diff options
Diffstat (limited to 'lisp')
1092 files changed, 66577 insertions, 50182 deletions
diff --git a/lisp/ChangeLog.12 b/lisp/ChangeLog.12 index 0c0349c9d99..1493825ebd9 100644 --- a/lisp/ChangeLog.12 +++ b/lisp/ChangeLog.12 @@ -6156,7 +6156,7 @@ * saveplace.el (load-save-place-alist-from-file): Use expanded name in both messages. -2006-09-16 Slawomir Nowaczyk <slawomir.nowaczyk.847@student.lu.se> +2006-09-16 Sławomir Nowaczyk <slawomir.nowaczyk.847@student.lu.se> * progmodes/python.el (python-preoutput-filter): Fix arg order to string-match. @@ -6540,7 +6540,7 @@ conf-space-keywords-override local. Call conf-space-mode-internal directly as well as via hook. -2006-09-09 Slawomir Nowaczyk <slawomir.nowaczyk.847@student.lu.se> (tiny change) +2006-09-09 Sławomir Nowaczyk <slawomir.nowaczyk.847@student.lu.se> (tiny change) * progmodes/python.el (python-font-lock-keywords): Add `self' and other quasi-keywords. @@ -12040,7 +12040,7 @@ * emacs-lisp/edebug.el (edebug-display): Use `edebug-sit-for-seconds' value instead of a literal constant (1) on more pauses. -2006-03-03 Slawomir Nowaczyk <slawomir.nowaczyk.847@student.lu.se> (tiny change) +2006-03-03 Sławomir Nowaczyk <slawomir.nowaczyk.847@student.lu.se> (tiny change) * textmodes/flyspell.el (flyspell-external-point-words): Be case-sensitive. @@ -17840,7 +17840,7 @@ * man.el (Man-highlight-references): Doc fix. Reformat code in a more Lisp-ish way. -2005-11-19 Slawomir Nowaczyk <slawomir.nowaczyk.847@student.lu.se> (tiny change) +2005-11-19 Sławomir Nowaczyk <slawomir.nowaczyk.847@student.lu.se> (tiny change) * ls-lisp.el (ls-lisp-format-file-size): Format file size with 9 digits, not 8, to avoid misalignment for files larger than 100MB. @@ -18028,7 +18028,7 @@ * cus-edit.el (face): Enclose %t in %{...%}. -2005-11-16 Hrvoje Niksic <hniksic@xemacs.org> +2005-11-16 Hrvoje Nikšić <hniksic@xemacs.org> * savehist.el (savehist-mode-hook): Re-add the var. (savehist-mode): Use it. @@ -18163,7 +18163,7 @@ Use the `variable-documentation' property to give the mode hook a docstring and expand that docstring. -2005-11-14 Hrvoje Niksic <hniksic@xemacs.org> +2005-11-14 Hrvoje Nikšić <hniksic@xemacs.org> * savehist.el (savehist-mode): Don't bother with `custom-set-minor-mode'. @@ -18983,7 +18983,7 @@ (savehist-mode) <defun>: Run the minor mode hook, set the custom state and emit a message if applicable. -2005-11-01 Hrvoje Niksic <hniksic@xemacs.org> +2005-11-01 Hrvoje Nikšić <hniksic@xemacs.org> * savehist.el: Sync up to version 19. (savehist-mode): New minor mode. @@ -19496,7 +19496,7 @@ * simple.el (completion-common-substring): Use `completion-common-substring' prior to `completion-base-size'. -2005-10-24 Hrvoje Niksic <hniksic@xemacs.org> +2005-10-24 Hrvoje Nikšić <hniksic@xemacs.org> * savehist.el: Require CL while compiling. (savehist-history-variables): Remove. @@ -20221,7 +20221,7 @@ (savehist-process-for-saving): Replace use of CL funs `subseq' and `delete-if-not'. -2005-10-16 Hrvoje Niksic <hniksic@xemacs.org> +2005-10-16 Hrvoje Nikšić <hniksic@xemacs.org> * savehist.el: Newer version. (savehist-autosave-interval, savehist-coding-system, savehist-timer) @@ -21480,7 +21480,7 @@ 2005-09-18 Michael Albinus <michael.albinus@gmx.de> * net/tramp.el (tramp-login-prompt-regexp): Expand regexp in order - to cover prompts like "login as:". Reported by Slawomir Nowaczyk + to cover prompts like "login as:". Reported by Sławomir Nowaczyk <slawomir.nowaczyk.847@student.lu.se>. 2005-09-18 Chong Yidong <cyd@stupidchicken.com> diff --git a/lisp/ChangeLog.15 b/lisp/ChangeLog.15 index b22661fe819..d8519a27206 100644 --- a/lisp/ChangeLog.15 +++ b/lisp/ChangeLog.15 @@ -4156,7 +4156,7 @@ coreutils. Reported by Klaus Reichl <Klaus.Reichl@thalesgroup.com>. -2010-11-13 Hrvoje Niksic <hniksic@xemacs.org> +2010-11-13 Hrvoje Nikšić <hniksic@xemacs.org> * simple.el (count-words-region): New function. diff --git a/lisp/ChangeLog.2 b/lisp/ChangeLog.2 index 4b9aa7fc4b6..e8675b9896e 100644 --- a/lisp/ChangeLog.2 +++ b/lisp/ChangeLog.2 @@ -1229,7 +1229,7 @@ 1987-05-13 Richard M. Stallman (rms@prep) * sendmail.el (mail-setup): New parameter mail-default-reply-to: - if non-nil, insert it as a Reply-to field. + if non-nil, insert it as a Reply-To field. * dired.el (dired-unflag): Doc fix. @@ -3924,7 +3924,7 @@ New key bindings for setting insert motion direction: C-c <, C-c >, C-c ^ and C-c . instead of M- chars. - * rmail.el (rmail-reply): When putting From into In-reply-to, + * rmail.el (rmail-reply): When putting From into In-Reply-To, stop at any newline. * mail-utils.el (mail-strip-quoted-names): diff --git a/lisp/ChangeLog.4 b/lisp/ChangeLog.4 index b8ae394d54d..74f09e5e380 100644 --- a/lisp/ChangeLog.4 +++ b/lisp/ChangeLog.4 @@ -3739,7 +3739,7 @@ 1994-01-10 Michael D. Ernst (mernst@monozygote) - * mailabbrev.el (mail-abbrev-mode-regexp): Add Reply-to. + * mailabbrev.el (mail-abbrev-mode-regexp): Add Reply-To. 1994-01-09 Roland McGrath (roland@churchy.gnu.ai.mit.edu) diff --git a/lisp/ChangeLog.5 b/lisp/ChangeLog.5 index ef6caa97042..749e7f68b6c 100644 --- a/lisp/ChangeLog.5 +++ b/lisp/ChangeLog.5 @@ -991,7 +991,7 @@ 1995-05-19 Kevin Rodgers <kevinr@ihs.com> (tiny change) * mailalias.el (expand-mail-aliases): Expand aliases in - From and Reply-to headers as well, plus the Resent- variants. + From and Reply-To headers as well, plus the Resent- variants. * sendmail.el (mail-mode): Clarify doc string. (mail-text): Ditto. diff --git a/lisp/ChangeLog.7 b/lisp/ChangeLog.7 index b3686af0d07..2fe98e8f00d 100644 --- a/lisp/ChangeLog.7 +++ b/lisp/ChangeLog.7 @@ -8142,7 +8142,7 @@ implementation) so that `locate-library' can find compressed files. (finder-commentary): Use it. -1997-11-15 Hrvoje Niksic <hniksic@srce.hr> +1997-11-15 Hrvoje Nikšić <hniksic@srce.hr> * cus-edit.el (custom-face-save): Save the face. @@ -9078,11 +9078,11 @@ * gnus.el: Gnus v5.4.60 is released. -1997-10-21 Hrvoje Niksic <hniksic@srce.hr> +1997-10-21 Hrvoje Nikšić <hniksic@srce.hr> * gnus-salt.el: Customized. -1997-10-21 Hrvoje Niksic <hniksic@srce.hr> +1997-10-21 Hrvoje Nikšić <hniksic@srce.hr> * gnus-salt.el (gnus-tree-show-summary): New function. (gnus-tree-mode-map): Use it. @@ -9098,7 +9098,7 @@ * gnus-sum.el (gnus-adjust-marked-articles): Improper lists. -1997-10-21 Hrvoje Niksic <hniksic@srce.hr> +1997-10-21 Hrvoje Nikšić <hniksic@srce.hr> * gnus-sum.el (gnus-summary-search-article): Inhibit updating tree buffer. @@ -9213,7 +9213,7 @@ * gnus-score.el (gnus-score-find-trace): Would bug out for file-less rules. -1997-10-21 Hrvoje Niksic <hniksic@srce.hr> +1997-10-21 Hrvoje Nikšić <hniksic@srce.hr> * gnus-xmas.el (gnus-xmas-group-startup-message): Cleanup. @@ -9264,7 +9264,7 @@ * gnus-art.el (gnus-header-button-alist): Check for URLs in the Subject. -1997-10-21 Hrvoje Niksic <hniksic@srce.hr> +1997-10-21 Hrvoje Nikšić <hniksic@srce.hr> * gnus-xmas.el: Cleanup. @@ -9715,7 +9715,7 @@ * gnus-art.el (gnus-read-save-file-name): Expand file name i save dir. -1997-10-21 Hrvoje Niksic <hniksic@srce.hr> +1997-10-21 Hrvoje Nikšić <hniksic@srce.hr> * gnus-art.el (gnus-signature-face): New face; use it. @@ -9724,12 +9724,12 @@ * gnus-picon.el (gnus-picons-insert-face-if-exists): Add picons to list. -1997-10-21 Hrvoje Niksic <hniksic@srce.hr> +1997-10-21 Hrvoje Nikšić <hniksic@srce.hr> * message.el (message-font-lock-keywords): Be a little bit more case-insensitive. -1997-10-21 Hrvoje Niksic <hniksic@srce.hr> +1997-10-21 Hrvoje Nikšić <hniksic@srce.hr> * message.el (message-insert-to): New argument FORCE. @@ -9748,7 +9748,7 @@ * gnus-ems.el: appt, not appt.el. -1997-10-21 Hrvoje Niksic <hniksic@srce.hr> +1997-10-21 Hrvoje Nikšić <hniksic@srce.hr> * gnus-xmas.el (gnus-xmas-summary-set-display-table): Don't nix out in Latin1. @@ -10150,7 +10150,7 @@ * vc-hooks.el (vc-find-cvs-master): Add missing `throw' for the case when TIMESTAMP is arbitrary text. -1997-09-30 Hrvoje Niksic <hniksic@srce.hr> +1997-09-30 Hrvoje Nikšić <hniksic@srce.hr> * wid-edit.el (widget-plist-member): Move from here to src/fns.c; translated into C for efficiency. @@ -10386,7 +10386,7 @@ * international/mule-util.el (truncate-string-to-width): Doc typo fix. -1997-09-14 Hrvoje Niksic <hniksic@srce.hr> +1997-09-14 Hrvoje Nikšić <hniksic@srce.hr> * arc-mode.el: Customized. @@ -17073,7 +17073,7 @@ * server.el (server-kill-buffer): Prevent infinite recursion. (server-kill-buffer-running): New variable. -1997-05-28 Hrvoje Niksic <hniksic@srce.hr> +1997-05-28 Hrvoje Nikšić <hniksic@srce.hr> * dired-aux.el: Customize. @@ -17337,7 +17337,7 @@ * libc.el: New file. -1997-05-22 Hrvoje Niksic <hniksic@srce.hr> +1997-05-22 Hrvoje Nikšić <hniksic@srce.hr> * terminal.el: Use defgroup and defcustom. * dired.el, dired-x.el: Likewise. @@ -18220,7 +18220,7 @@ * vc.el: Doc fixes. -1997-05-05 Hrvoje Niksic <hniksic@srce.hr> +1997-05-05 Hrvoje Nikšić <hniksic@srce.hr> * time.el, gud.el, metamail.el, simple.el: Customize. * window.el, frame.el, menu-bar.el, lisp.el, fill.el: Customize. @@ -18316,7 +18316,7 @@ * ispell.el (ispell-dictionary-alist-2): Specify syntax of ' in Danish. -1997-05-02 Hrvoje Niksic <hniksic@srce.hr> +1997-05-02 Hrvoje Nikšić <hniksic@srce.hr> * calendar.el: Customize. * appt.el, cal-china.el, cal-tex.el, diary-lib.el, solar.el: Likewise. @@ -18926,7 +18926,7 @@ * sh-script.el (sh-while-getopts): Don't add menu-enable property. -1997-04-15 Hrvoje Niksic <hniksic@srce.hr> +1997-04-15 Hrvoje Nikšić <hniksic@srce.hr> * saveplace.el: Add defgroup; use defcustom for user vars. * pascal.el, supercite.el: Likewise. @@ -19021,7 +19021,7 @@ * dired.el (dired-noselect): Avoid calling file-directory-p when the initial argument was syntactically a directory name. -1997-04-13 Hrvoje Niksic <hniksic@srce.hr> +1997-04-13 Hrvoje Nikšić <hniksic@srce.hr> * time-stamp.el: Add defgroup; use defcustom for user vars. * eldoc.el: Likewise. @@ -19214,7 +19214,7 @@ * Makefile (finder-inf.el, autoloads): New targets. (cus-load.el): Minor simplification. -1997-04-11 Hrvoje Niksic <hniksic@srce.hr> +1997-04-11 Hrvoje Nikšić <hniksic@srce.hr> * add-log.el, avoid.el, bookmark.el, cl-indent.el, cmacexp.el: * comint.el, completion.el, dabbrev.el, desktop.el, edebug.el: @@ -19291,7 +19291,7 @@ * cal-islam.el (diary-islamic-date): Use `date'. -1997-04-10 Hrvoje Niksic <hniksic@srce.hr> +1997-04-10 Hrvoje Nikšić <hniksic@srce.hr> * ispell.el: Use defcustom for user variables. @@ -21076,7 +21076,7 @@ 1996-12-17 Jonathan I. Kamens <jik@cam.ov.com> * rnewspost.el (news-mail-reply, news-reply): Include the message - ID in the In-reply-to line. + ID in the In-Reply-To line. 1996-12-16 Erik Naggum <erik@naggum.no> diff --git a/lisp/Makefile.in b/lisp/Makefile.in index e0abce49d3c..ee2c2091770 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -101,6 +101,10 @@ COMPILE_FIRST = \ $(lisp)/emacs-lisp/bytecomp.elc \ $(lisp)/emacs-lisp/autoload.elc +# Files to compile early in compile-main. Works around bug#25556. +MAIN_FIRST = ./emacs-lisp/eieio.el ./emacs-lisp/eieio-base.el \ + ./cedet/semantic/db.el + # Prevent any settings in the user environment causing problems. unexport EMACSDATA EMACSDOC EMACSPATH @@ -216,7 +220,7 @@ update-subdirs: $(srcdir)/../build-aux/update-subdirs $$file; \ done; -.PHONY: updates repo-update update-authors update-gnus-news +.PHONY: updates repo-update update-authors # Some modes of make-dist use this. updates: update-subdirs autoloads finder-data custom-deps @@ -229,17 +233,12 @@ updates: update-subdirs autoloads finder-data custom-deps # this directory's autoloads rule. repo-update: compile finder-data custom-deps -# Update etc/AUTHORS and etc/GNUS-NEWS. +# Update etc/AUTHORS update-authors: $(emacs) -L "$(top_srcdir)/admin" -l authors \ -f batch-update-authors "$(top_srcdir)/etc/AUTHORS" "$(top_srcdir)" -update-gnus-news: - $(emacs) -L "$(top_srcdir)/doc/misc" -l gnus-news -f batch-gnus-news \ - "$(top_srcdir)/doc/misc/gnus-news.texi" \ - "$(top_srcdir)/etc/GNUS-NEWS" - FORCE: .PHONY: FORCE @@ -317,14 +316,16 @@ compile-targets: $(TARGETS) # 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 - @(cd $(lisp) && \ + @(cd $(lisp) && \ els=`echo "${SUBDIRS_REL} " | sed -e 's|/\./|/|g' -e 's|/\. | |g' -e 's| |/*.el |g'`; \ - for el in $$els; do \ - test -f $$el || continue; \ - test ! -f $${el}c && GREP_OPTIONS= grep '^;.*no-byte-compile: t' $$el > /dev/null && continue; \ - echo "$${el}c"; \ - done | xargs $(XARGS_LIMIT) echo) | \ - while read chunk; do \ + for el in ${MAIN_FIRST} $$els; do \ + test -f $$el || continue; \ + test ! -f $${el}c && \ + GREP_OPTIONS= grep '^;.*[^a-zA-Z]no-byte-compile: *t' $$el > /dev/null && \ + continue; \ + echo "$${el}c"; \ + done | xargs $(XARGS_LIMIT) echo) | \ + while read chunk; do \ $(MAKE) compile-targets TARGETS="$$chunk"; \ done @@ -337,7 +338,7 @@ compile-clean: if test -f "$$el" || test ! -f "$${el}c"; then :; else \ echo rm "$${el}c"; \ rm "$${el}c"; \ - fi \ + fi; \ done .PHONY: gen-lisp leim semantic @@ -346,7 +347,9 @@ compile-clean: ## with ../src. See comments above for loaddefs. gen-lisp: leim semantic -leim: +# (re)compile titdic-cnv before recursing into `leim` since its used to +# generate some of the Quail source files from tables. +leim: $(lisp)/international/titdic-cnv.elc $(MAKE) -C ../leim all EMACS="$(EMACS)" semantic: @@ -450,18 +453,22 @@ $(CAL_DIR)/hol-loaddefs.el: $(CAL_SRC) $(CAL_DIR)/diary-loaddefs.el --eval "(setq generated-autoload-file (expand-file-name (unmsys--file-name \"$@\")))" \ -f batch-update-autoloads $(CAL_DIR) -.PHONY: bootstrap-clean distclean maintainer-clean +.PHONY: bootstrap-clean distclean maintainer-clean extraclean bootstrap-clean: find $(lisp) -name '*.elc' $(FIND_DELETE) rm -f $(AUTOGENEL) distclean: - -rm -f ./Makefile $(lisp)/loaddefs.el~ + -rm -f ./Makefile $(lisp)/loaddefs.el maintainer-clean: distclean bootstrap-clean rm -f TAGS +extraclean: bootstrap-clean distclean + -for file in $(LOADDEFS); do rm -f $${file}~; done + -rm -f $(lisp)/loaddefs.el~ + .PHONY: check-declare check-declare: diff --git a/lisp/abbrev.el b/lisp/abbrev.el index aebf65e0f78..9bd7e533d3e 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el @@ -56,9 +56,6 @@ define global abbrevs instead." (define-minor-mode abbrev-mode "Toggle Abbrev mode in the current buffer. -With a prefix argument ARG, enable Abbrev mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -Abbrev mode if ARG is omitted or nil. In Abbrev mode, inserting an abbreviation causes it to expand and be replaced by its expansion." @@ -68,6 +65,8 @@ be replaced by its expansion." (put 'abbrev-mode 'safe-local-variable 'booleanp) +(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) @@ -75,8 +74,6 @@ be replaced by its expansion." (define-key map "\C-c\C-c" 'edit-abbrevs-redefine) map) "Keymap used in `edit-abbrevs'.") -(define-obsolete-variable-alias 'edit-abbrevs-map - 'edit-abbrevs-mode-map "24.4") (defun kill-all-abbrevs () "Undefine all defined abbrevs." @@ -255,7 +252,8 @@ have been saved." (lambda (s1 s2) (string< (symbol-name s1) (symbol-name s2))))) - (insert-abbrev-table-description table nil)) + (if (abbrev--table-symbols table) + (insert-abbrev-table-description table nil))) (when (unencodable-char-position (point-min) (point-max) 'utf-8) (setq coding-system-for-write (if (> emacs-major-version 24) @@ -354,6 +352,7 @@ Expands the abbreviation after defining it." (let (name exp start end) (save-excursion (forward-word (1+ (- arg))) + (skip-syntax-backward "^w") (setq end (point)) (backward-word 1) (setq start (point) @@ -371,13 +370,16 @@ Expands the abbreviation after defining it." (defun abbrev-prefix-mark (&optional arg) "Mark current point as the beginning of an abbrev. -Abbrev to be expanded starts here rather than at beginning of word. -This way, you can expand an abbrev with a prefix: insert the prefix, -use this command, then insert the abbrev. This command inserts a -temporary hyphen after the prefix (until the intended abbrev -expansion occurs). -If the prefix is itself an abbrev, this command expands it, unless -ARG is non-nil. Interactively, ARG is the prefix argument." +The abbrev to be expanded starts here rather than at beginning of +word. This way, you can expand an abbrev with a prefix: insert +the prefix, use this command, then insert the abbrev. + +This command inserts a hyphen after the prefix, and if the abbrev +is subsequently expanded, this hyphen will be removed. + +If the prefix is itself an abbrev, this command expands it, +unless ARG is non-nil. Interactively, ARG is the prefix +argument." (interactive "P") (or arg (expand-abbrev)) (setq abbrev-start-location (point-marker) @@ -900,18 +902,22 @@ is not undone." (defun abbrev--write (sym) "Write the abbrev in a `read'able form. -Only writes the non-system abbrevs. Presumes that `standard-output' points to `current-buffer'." - (unless (or (null (symbol-value sym)) (abbrev-get sym :system)) - (insert " (") - (prin1 (symbol-name sym)) - (insert " ") - (prin1 (symbol-value sym)) - (insert " ") - (prin1 (symbol-function sym)) - (insert " ") - (prin1 (abbrev-get sym :count)) - (insert ")\n"))) + (insert " (") + (prin1 (symbol-name sym)) + (insert " ") + (prin1 (symbol-value sym)) + (insert " ") + (prin1 (symbol-function sym)) + (insert " :count ") + (prin1 (abbrev-get sym :count)) + (when (abbrev-get sym :case-fixed) + (insert " :case-fixed ") + (prin1 (abbrev-get sym :case-fixed))) + (when (abbrev-get sym :enable-function) + (insert " :enable-function ") + (prin1 (abbrev-get sym :enable-function))) + (insert ")\n")) (defun abbrev--describe (sym) (when (symbol-value sym) @@ -932,32 +938,43 @@ Presumes that `standard-output' points to `current-buffer'." "Insert before point a full description of abbrev table named NAME. NAME is a symbol whose value is an abbrev table. If optional 2nd arg READABLE is non-nil, a human-readable description -is inserted. Otherwise the description is an expression, -a call to `define-abbrev-table', which would -define the abbrev table NAME exactly as it is currently defined. +is inserted. -Abbrevs marked as \"system abbrevs\" are omitted." - (let ((table (symbol-value name)) - (symbols ())) - (mapatoms (lambda (sym) (if (symbol-value sym) (push sym symbols))) table) +If READABLE is nil, an expression is inserted. The expression is +a call to `define-abbrev-table' that when evaluated will define +the abbrev table NAME exactly as it is currently defined. +Abbrevs marked as \"system abbrevs\" are ignored." + (let ((symbols (abbrev--table-symbols name readable))) (setq symbols (sort symbols 'string-lessp)) (let ((standard-output (current-buffer))) (if readable - (progn - (insert "(") - (prin1 name) - (insert ")\n\n") - (mapc 'abbrev--describe symbols) - (insert "\n\n")) - (insert "(define-abbrev-table '") - (prin1 name) - (if (null symbols) - (insert " '())\n\n") - (insert "\n '(\n") - (mapc 'abbrev--write symbols) - (insert " ))\n\n"))) + (progn + (insert "(") + (prin1 name) + (insert ")\n\n") + (mapc 'abbrev--describe symbols) + (insert "\n\n")) + (insert "(define-abbrev-table '") + (prin1 name) + (if (null symbols) + (insert " '())\n\n") + (insert "\n '(\n") + (mapc 'abbrev--write symbols) + (insert " ))\n\n"))) nil))) +(defun abbrev--table-symbols (name &optional system) + "Return the user abbrev symbols in the abbrev table named NAME. +NAME is a symbol whose value is an abbrev table. System abbrevs +are omitted unless SYSTEM is non-nil." + (let ((table (symbol-value name)) + (symbols ())) + (mapatoms (lambda (sym) + (if (and (symbol-value sym) (or system (not (abbrev-get sym :system)))) + (push sym symbols))) + table) + symbols)) + (defun define-abbrev-table (tablename definitions &optional docstring &rest props) "Define TABLENAME (a symbol) as an abbrev table name. diff --git a/lisp/align.el b/lisp/align.el index 43918811b9a..443237b451b 100644 --- a/lisp/align.el +++ b/lisp/align.el @@ -399,7 +399,7 @@ The possible settings for `align-region-separate' are: (lambda (end reverse) (funcall (if reverse 're-search-backward 're-search-forward) - (concat "[^ \t\n\\\\]" + (concat "[^ \t\n\\]" (regexp-quote comment-start) "\\(.+\\)$") end t)))) (modes . align-open-comment-modes)) @@ -411,7 +411,7 @@ The possible settings for `align-region-separate' are: (c-variable-declaration (regexp . ,(concat "[*&0-9A-Za-z_]>?[&*]*\\(\\s-+[*&]*\\)" "[A-Za-z_][0-9A-Za-z:_]*\\s-*\\(\\()\\|" - "=[^=\n].*\\|(.*)\\|\\(\\[.*\\]\\)*\\)?" + "=[^=\n].*\\|(.*)\\|\\(\\[.*\\]\\)*\\)" "\\s-*[;,]\\|)\\s-*$\\)")) (group . 1) (modes . align-c++-modes) @@ -438,7 +438,7 @@ The possible settings for `align-region-separate' are: (tab-stop . nil)) (perl-assignment - (regexp . ,(concat "[^=!^&*-+<>/| \t\n]\\(\\s-*\\)=[~>]?" + (regexp . ,(concat "[^=!^&*+<>/| \t\n-]\\(\\s-*\\)=[~>]?" "\\(\\s-*\\)\\([^>= \t\n]\\|$\\)")) (group . (1 2)) (modes . align-perl-modes) @@ -452,7 +452,7 @@ The possible settings for `align-region-separate' are: (tab-stop . nil)) (make-assignment - (regexp . "^\\s-*\\w+\\(\\s-*\\):?=\\(\\s-*\\)\\([^\t\n \\\\]\\|$\\)") + (regexp . "^\\s-*\\w+\\(\\s-*\\):?=\\(\\s-*\\)\\([^\t\n \\]\\|$\\)") (group . (1 2)) (modes . '(makefile-mode)) (tab-stop . nil)) @@ -759,7 +759,7 @@ The following attributes are meaningful: (lambda (end reverse) (funcall (if reverse 're-search-backward 're-search-forward) - (concat "[^ \t\n\\\\]" + (concat "[^ \t\n\\]" (regexp-quote comment-start) "\\(.+\\)$") end t)))) (modes . align-open-comment-modes)) diff --git a/lisp/allout-widgets.el b/lisp/allout-widgets.el index a10a3f599af..e7da08d44e7 100644 --- a/lisp/allout-widgets.el +++ b/lisp/allout-widgets.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2005-2019 Free Software Foundation, Inc. ;; Author: Ken Manheimer <ken dot manheimer at gmail...> -;; Maintainer: Ken Manheimer <ken dot manheimer at gmail...> ;; Version: 1.0 ;; Created: Dec 2005 ;; Keywords: outlines @@ -70,12 +69,7 @@ (require 'allout) (require 'widget) (require 'wid-edit) - -(eval-when-compile - (progn - (require 'overlay) - (require 'cl) - )) +(eval-when-compile (require 'cl-lib)) ;;;_ : internal variables needed before user-customization variables ;;; In order to enable activation of allout-widgets-mode via customization, @@ -513,9 +507,6 @@ happens in the buffer.") ;;;###autoload (define-minor-mode allout-widgets-mode "Toggle Allout Widgets mode. -With a prefix argument ARG, enable Allout Widgets mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Allout Widgets mode is an extension of Allout mode that provides graphical decoration of outline structure. It is meant to @@ -768,8 +759,7 @@ Optional RECURSING is for internal use, to limit recursion." (if allout-widgets-time-decoration-activity (setq allout-widgets-last-decoration-timing - (list (allout-elapsed-time-seconds (current-time) - start-time) + (list (allout-elapsed-time-seconds nil start-time) allout-widgets-changes-record))) (setq allout-widgets-changes-record nil) @@ -964,7 +954,7 @@ posting threshold criteria." (when changes-pending (while changes-record (setq entry (pop changes-record)) - (case (car entry) + (pcase (car entry) (:exposed (push entry exposures)) (:added (push entry additions)) (:deleted (push entry deletions)) @@ -1382,34 +1372,34 @@ FROM and TO must be in increasing order, as must be the pairs in RANGES." ;; fresh: (setq ranges nil) - (assert (equal (funcall try 3 5) '(nil ((3 5))))) + (cl-assert (equal (funcall try 3 5) '(nil ((3 5))))) ;; add range at end: - (assert (equal (funcall try 10 12) '(nil ((3 5) (10 12))))) + (cl-assert (equal (funcall try 10 12) '(nil ((3 5) (10 12))))) ;; add range at beginning: - (assert (equal (funcall try 1 2) '(nil ((1 2) (3 5) (10 12))))) + (cl-assert (equal (funcall try 1 2) '(nil ((1 2) (3 5) (10 12))))) ;; insert range somewhere in the middle: - (assert (equal (funcall try 7 9) '(nil ((1 2) (3 5) (7 9) (10 12))))) + (cl-assert (equal (funcall try 7 9) '(nil ((1 2) (3 5) (7 9) (10 12))))) ;; consolidate some: - (assert (equal (funcall try 5 8) '(t ((1 2) (3 9) (10 12))))) + (cl-assert (equal (funcall try 5 8) '(t ((1 2) (3 9) (10 12))))) ;; add more: - (assert (equal (funcall try 15 17) '(nil ((1 2) (3 9) (10 12) (15 17))))) + (cl-assert (equal (funcall try 15 17) '(nil ((1 2) (3 9) (10 12) (15 17))))) ;; add more: - (assert (equal (funcall try 20 22) + (cl-assert (equal (funcall try 20 22) '(nil ((1 2) (3 9) (10 12) (15 17) (20 22))))) ;; encompass more: - (assert (equal (funcall try 4 11) '(t ((1 2) (3 12) (15 17) (20 22))))) + (cl-assert (equal (funcall try 4 11) '(t ((1 2) (3 12) (15 17) (20 22))))) ;; encompass all: - (assert (equal (funcall try 2 25) '(t ((1 25))))) + (cl-assert (equal (funcall try 2 25) '(t ((1 25))))) ;; fresh slate: (setq ranges nil) - (assert (equal (funcall try 20 25) '(nil ((20 25))))) - (assert (equal (funcall try 30 35) '(nil ((20 25) (30 35))))) - (assert (equal (funcall try 26 28) '(nil ((20 25) (26 28) (30 35))))) - (assert (equal (funcall try 15 20) '(t ((15 25) (26 28) (30 35))))) - (assert (equal (funcall try 10 30) '(t ((10 35))))) - (assert (equal (funcall try 5 6) '(nil ((5 6) (10 35))))) - (assert (equal (funcall try 2 100) '(t ((2 100))))) + (cl-assert (equal (funcall try 20 25) '(nil ((20 25))))) + (cl-assert (equal (funcall try 30 35) '(nil ((20 25) (30 35))))) + (cl-assert (equal (funcall try 26 28) '(nil ((20 25) (26 28) (30 35))))) + (cl-assert (equal (funcall try 15 20) '(t ((15 25) (26 28) (30 35))))) + (cl-assert (equal (funcall try 10 30) '(t ((10 35))))) + (cl-assert (equal (funcall try 5 6) '(nil ((5 6) (10 35))))) + (cl-assert (equal (funcall try 2 100) '(t ((2 100))))) (setq ranges nil) )) diff --git a/lisp/allout.el b/lisp/allout.el index 2a6401bcc3b..251f2f5900d 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1992-1994, 2001-2019 Free Software Foundation, Inc. ;; Author: Ken Manheimer <ken dot manheimer at gmail...> -;; Maintainer: Ken Manheimer <ken dot manheimer at gmail...> ;; Created: Dec 1991 -- first release to usenet ;; Version: 2.3 ;; Keywords: outlines, wp, languages, PGP, GnuPG @@ -79,12 +78,7 @@ ;;;_* Dependency loads (require 'overlay) -(eval-when-compile - ;; `cl' is required for `assert'. `assert' is not covered by a standard - ;; autoload, but it is a macro, so that eval-when-compile is sufficient - ;; to byte-compile it in, or to do the require when the buffer evalled. - (require 'cl) - ) +(eval-when-compile (require 'cl-lib)) ;;;_* USER CUSTOMIZATION VARIABLES: @@ -1506,41 +1500,6 @@ wrapped within allout's automatic `fill-prefix' setting.") (make-variable-buffer-local 'allout-outside-normal-auto-fill-function) ;;;_ = prevent redundant activation by desktop mode: (add-to-list 'desktop-minor-mode-handlers '(allout-mode . nil)) -;;;_ = allout-passphrase-verifier-string -(defvar allout-passphrase-verifier-string nil - "Setting used to test solicited encryption passphrases against the one -already associated with a file. - -It consists of an encrypted random string useful only to verify that a -passphrase entered by the user is effective for decryption. The passphrase -itself is *not* recorded in the file anywhere, and the encrypted contents -are random binary characters to avoid exposing greater susceptibility to -search attacks. - -The verifier string is retained as an Emacs file variable, as well as in -the Emacs buffer state, if file variable adjustments are enabled. See -`allout-enable-file-variable-adjustment' for details about that.") -(make-variable-buffer-local 'allout-passphrase-verifier-string) -(make-obsolete-variable 'allout-passphrase-verifier-string - "it is no longer used." "23.3") -;;;###autoload -(put 'allout-passphrase-verifier-string 'safe-local-variable 'stringp) -;;;_ = allout-passphrase-hint-string -(defvar allout-passphrase-hint-string "" - "Variable used to retain reminder string for file's encryption passphrase. - -See the description of `allout-passphrase-hint-handling' for details about how -the reminder is deployed. - -The hint is retained as an Emacs file variable, as well as in the Emacs buffer -state, if file variable adjustments are enabled. See -`allout-enable-file-variable-adjustment' for details about that.") -(make-variable-buffer-local 'allout-passphrase-hint-string) -(setq-default allout-passphrase-hint-string "") -(make-obsolete-variable 'allout-passphrase-hint-string - "it is no longer used." "23.3") -;;;###autoload -(put 'allout-passphrase-hint-string 'safe-local-variable 'stringp) ;;;_ = allout-after-save-decrypt (defvar allout-after-save-decrypt nil "Internal variable, is nil or has the value of two points: @@ -1687,7 +1646,7 @@ from what it did before, for backwards compatibility. MODE is the activation mode - see `allout-auto-activation' for valid values." (declare (obsolete allout-auto-activation "23.3")) - (custom-set-variables (list 'allout-auto-activation (format "%s" mode))) + (customize-set-variable 'allout-auto-activation (format "%s" mode)) (format "%s" mode)) ;;;_ > allout-setup-menubar () @@ -1728,9 +1687,6 @@ valid values." (define-minor-mode allout-mode ;;;_ . Doc string: "Toggle Allout outline mode. -With a prefix argument ARG, enable Allout outline mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. \\<allout-mode-map-value> Allout outline mode is a minor mode that provides extensive @@ -4389,7 +4345,7 @@ subtopics into siblings of the item." (let ((children-chart (allout-chart-subtree 1))) (if (listp (car children-chart)) ;; whoops: - (setq children-chart (allout-flatten children-chart))) + (setq children-chart (flatten-tree children-chart))) (save-excursion (dolist (child-point children-chart) (goto-char child-point) @@ -5826,7 +5782,7 @@ BULLET string, and a list of TEXT strings for the body." ; "\end{verbatim}" in text, ; it's special: (if (and body-content - (setq bop (string-match "\\end{verbatim}" curr-line))) + (setq bop (string-match "\\\\end{verbatim}" curr-line))) (setq curr-line (concat (substring curr-line 0 bop) ">" (substring curr-line bop)))) @@ -6160,13 +6116,13 @@ signal." (point-max)))) ;; determine key mode and, if keypair, recipients: (setq recipients - (case keypair-mode + (pcase keypair-mode - (decrypting nil) + ('decrypting nil) - (default (if encrypt-to (epg-list-keys epg-context encrypt-to))) + ('default (if encrypt-to (epg-list-keys epg-context encrypt-to))) - ((prompt prompt-save) + ((or 'prompt 'prompt-save) (save-window-excursion (epa-select-keys epg-context keypair-message))))) @@ -6585,14 +6541,7 @@ If BEG is bigger than END we return 0." (apply 'concat (mapcar (lambda (char) (if (= char ?%) "%%" (char-to-string char))) string))) -;;;_ : lists -;;;_ > allout-flatten (list) -(defun allout-flatten (list) - "Return a list of all atoms in list." - ;; classic. - (cond ((null list) nil) - ((atom (car list)) (cons (car list) (allout-flatten (cdr list)))) - (t (append (allout-flatten (car list)) (allout-flatten (cdr list)))))) +(define-obsolete-function-alias 'allout-flatten #'flatten-tree "27.1") ;;;_ : Compatibility: ;;;_ : xemacs undo-in-progress provision: (unless (boundp 'undo-in-progress) @@ -6831,6 +6780,7 @@ To ignore intangibility, bind `inhibit-point-motion-hooks' to t." (defvar allout-tests-locally-true nil "Fodder for allout resumptions tests -- defvar just for byte compiler.") (defun allout-test-resumptions () + ;; FIXME: Use ERT. "Exercise allout resumptions." ;; for each resumption case, we also test that the right local/global ;; scopes are affected during resumption effects: @@ -6839,48 +6789,48 @@ To ignore intangibility, bind `inhibit-point-motion-hooks' to t." (with-temp-buffer (allout-tests-obliterate-variable 'allout-tests-globally-unbound) (allout-add-resumptions '(allout-tests-globally-unbound t)) - (assert (not (default-boundp 'allout-tests-globally-unbound))) - (assert (local-variable-p 'allout-tests-globally-unbound (current-buffer))) - (assert (boundp 'allout-tests-globally-unbound)) - (assert (equal allout-tests-globally-unbound t)) + (cl-assert (not (default-boundp 'allout-tests-globally-unbound))) + (cl-assert (local-variable-p 'allout-tests-globally-unbound (current-buffer))) + (cl-assert (boundp 'allout-tests-globally-unbound)) + (cl-assert (equal allout-tests-globally-unbound t)) (allout-do-resumptions) - (assert (not (local-variable-p 'allout-tests-globally-unbound + (cl-assert (not (local-variable-p 'allout-tests-globally-unbound (current-buffer)))) - (assert (not (boundp 'allout-tests-globally-unbound)))) + (cl-assert (not (boundp 'allout-tests-globally-unbound)))) ;; ensure that variable with prior global value is resumed (with-temp-buffer (allout-tests-obliterate-variable 'allout-tests-globally-true) (setq allout-tests-globally-true t) (allout-add-resumptions '(allout-tests-globally-true nil)) - (assert (equal (default-value 'allout-tests-globally-true) t)) - (assert (local-variable-p 'allout-tests-globally-true (current-buffer))) - (assert (equal allout-tests-globally-true nil)) + (cl-assert (equal (default-value 'allout-tests-globally-true) t)) + (cl-assert (local-variable-p 'allout-tests-globally-true (current-buffer))) + (cl-assert (equal allout-tests-globally-true nil)) (allout-do-resumptions) - (assert (not (local-variable-p 'allout-tests-globally-true + (cl-assert (not (local-variable-p 'allout-tests-globally-true (current-buffer)))) - (assert (boundp 'allout-tests-globally-true)) - (assert (equal allout-tests-globally-true t))) + (cl-assert (boundp 'allout-tests-globally-true)) + (cl-assert (equal allout-tests-globally-true t))) ;; ensure that prior local value is resumed (with-temp-buffer (allout-tests-obliterate-variable 'allout-tests-locally-true) (set (make-local-variable 'allout-tests-locally-true) t) - (assert (not (default-boundp 'allout-tests-locally-true)) + (cl-assert (not (default-boundp 'allout-tests-locally-true)) nil (concat "Test setup mistake -- variable supposed to" " not have global binding, but it does.")) - (assert (local-variable-p 'allout-tests-locally-true (current-buffer)) + (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer)) nil (concat "Test setup mistake -- variable supposed to have" " local binding, but it lacks one.")) (allout-add-resumptions '(allout-tests-locally-true nil)) - (assert (not (default-boundp 'allout-tests-locally-true))) - (assert (local-variable-p 'allout-tests-locally-true (current-buffer))) - (assert (equal allout-tests-locally-true nil)) + (cl-assert (not (default-boundp 'allout-tests-locally-true))) + (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer))) + (cl-assert (equal allout-tests-locally-true nil)) (allout-do-resumptions) - (assert (boundp 'allout-tests-locally-true)) - (assert (local-variable-p 'allout-tests-locally-true (current-buffer))) - (assert (equal allout-tests-locally-true t)) - (assert (not (default-boundp 'allout-tests-locally-true)))) + (cl-assert (boundp 'allout-tests-locally-true)) + (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer))) + (cl-assert (equal allout-tests-locally-true t)) + (cl-assert (not (default-boundp 'allout-tests-locally-true)))) ;; ensure that last of multiple resumptions holds, for various scopes. (with-temp-buffer @@ -6896,27 +6846,27 @@ To ignore intangibility, bind `inhibit-point-motion-hooks' to t." '(allout-tests-globally-true 3) '(allout-tests-locally-true 4)) ;; reestablish many of the basic conditions are maintained after re-add: - (assert (not (default-boundp 'allout-tests-globally-unbound))) - (assert (local-variable-p 'allout-tests-globally-unbound (current-buffer))) - (assert (equal allout-tests-globally-unbound 2)) - (assert (default-boundp 'allout-tests-globally-true)) - (assert (local-variable-p 'allout-tests-globally-true (current-buffer))) - (assert (equal allout-tests-globally-true 3)) - (assert (not (default-boundp 'allout-tests-locally-true))) - (assert (local-variable-p 'allout-tests-locally-true (current-buffer))) - (assert (equal allout-tests-locally-true 4)) + (cl-assert (not (default-boundp 'allout-tests-globally-unbound))) + (cl-assert (local-variable-p 'allout-tests-globally-unbound (current-buffer))) + (cl-assert (equal allout-tests-globally-unbound 2)) + (cl-assert (default-boundp 'allout-tests-globally-true)) + (cl-assert (local-variable-p 'allout-tests-globally-true (current-buffer))) + (cl-assert (equal allout-tests-globally-true 3)) + (cl-assert (not (default-boundp 'allout-tests-locally-true))) + (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer))) + (cl-assert (equal allout-tests-locally-true 4)) (allout-do-resumptions) - (assert (not (local-variable-p 'allout-tests-globally-unbound + (cl-assert (not (local-variable-p 'allout-tests-globally-unbound (current-buffer)))) - (assert (not (boundp 'allout-tests-globally-unbound))) - (assert (not (local-variable-p 'allout-tests-globally-true + (cl-assert (not (boundp 'allout-tests-globally-unbound))) + (cl-assert (not (local-variable-p 'allout-tests-globally-true (current-buffer)))) - (assert (boundp 'allout-tests-globally-true)) - (assert (equal allout-tests-globally-true t)) - (assert (boundp 'allout-tests-locally-true)) - (assert (local-variable-p 'allout-tests-locally-true (current-buffer))) - (assert (equal allout-tests-locally-true t)) - (assert (not (default-boundp 'allout-tests-locally-true)))) + (cl-assert (boundp 'allout-tests-globally-true)) + (cl-assert (equal allout-tests-globally-true t)) + (cl-assert (boundp 'allout-tests-locally-true)) + (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer))) + (cl-assert (equal allout-tests-locally-true t)) + (cl-assert (not (default-boundp 'allout-tests-locally-true)))) ;; ensure that deliberately unbinding registered variables doesn't foul things (with-temp-buffer diff --git a/lisp/ansi-color.el b/lisp/ansi-color.el index 121a89a2d81..31bed6028cc 100644 --- a/lisp/ansi-color.el +++ b/lisp/ansi-color.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. ;; Author: Alex Schroeder <alex@gnu.org> -;; Maintainer: Alex Schroeder <alex@gnu.org> ;; Version: 3.4.2 ;; Keywords: comm processes terminals services @@ -182,7 +181,7 @@ in shell buffers. You set this variable by calling one of: :group 'ansi-colors :version "23.2") -(defvar ansi-color-apply-face-function 'ansi-color-apply-overlay-face +(defvar ansi-color-apply-face-function #'ansi-color-apply-overlay-face "Function for applying an Ansi Color face to text in a buffer. This function should accept three arguments: BEG, END, and FACE, and it should apply face FACE to the text between BEG and END.") @@ -415,15 +414,23 @@ this." ;; 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)) - (setq ansi-color-context-region (if codes (list codes))))))) + (setq ansi-color-context-region (if codes (list codes))))) + ;; Clean up our temporary markers. + (unless (eq start-marker (cadr ansi-color-context-region)) + (set-marker start-marker nil)) + (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. If FACE is nil, do nothing." (when face - (ansi-color-set-extent-face - (ansi-color-make-extent beg end) - face))) + (overlay-put (ansi-color-make-extent beg end) 'face face))) + +(defun ansi-color-apply-text-property-face (beg end face) + "Set the `font-lock-face' property to FACE in region BEG..END. +If FACE is nil, do nothing." + (when face + (put-text-property beg end 'font-lock-face face))) ;; This function helps you look for overlapping overlays. This is ;; useful in comint-buffers. Overlapping overlays should not happen! @@ -445,44 +452,32 @@ If FACE is nil, do nothing." ; (message "Reached %d." pos))) ; (setq pos (next-overlay-change pos))))) -;; Emacs/XEmacs compatibility layer - (defun ansi-color-make-face (property color) "Return a face with PROPERTY set to COLOR. PROPERTY can be either symbol `foreground' or symbol `background'. -For Emacs, we just return the cons cell (PROPERTY . COLOR). -For XEmacs, we create a temporary face and return it." - (if (featurep 'xemacs) - (let ((face (make-face (intern (concat color "-" (symbol-name property))) - "Temporary face created by ansi-color." - t))) - (set-face-property face property color) - face) - (cond ((eq property 'foreground) - (cons 'foreground-color color)) - ((eq property 'background) - (cons 'background-color color)) - (t - (cons property color))))) - -(defun ansi-color-make-extent (from to &optional object) - "Make an extent for the range [FROM, TO) in OBJECT. - -OBJECT defaults to the current buffer. XEmacs uses `make-extent', Emacs -uses `make-overlay'. XEmacs can use a buffer or a string for OBJECT, -Emacs requires OBJECT to be a buffer." - (if (fboundp 'make-extent) - (make-extent from to object) - ;; In Emacs, the overlay might end at the process-mark in comint - ;; buffers. In that case, new text will be inserted before the - ;; process-mark, ie. inside the overlay (using insert-before-marks). - ;; In order to avoid this, we use the `insert-behind-hooks' overlay - ;; property to make sure it works. - (let ((overlay (make-overlay from to object))) - (overlay-put overlay 'modification-hooks '(ansi-color-freeze-overlay)) - (overlay-put overlay 'insert-behind-hooks '(ansi-color-freeze-overlay)) - overlay))) +For Emacs, we just return the cons cell (PROPERTY . COLOR)." + (cond ((eq property 'foreground) + (cons 'foreground-color color)) + ((eq property 'background) + (cons 'background-color color)) + (t + (cons property color)))) + +(defun ansi-color-make-extent (from to &optional buffer) + "Make an extent for the range [FROM, TO) in BUFFER. + +BUFFER defaults to the current buffer." + ;; The overlay might end at the process-mark in comint + ;; buffers. In that case, new text will be inserted before the + ;; process-mark, ie. inside the overlay (using insert-before-marks). + ;; In order to avoid this, we use the `insert-behind-hooks' overlay + ;; property to make sure it works. + (let ((overlay (make-overlay from to buffer))) + (overlay-put overlay 'evaporate t) + (overlay-put overlay 'modification-hooks '(ansi-color-freeze-overlay)) + (overlay-put overlay 'insert-behind-hooks '(ansi-color-freeze-overlay)) + overlay)) (defun ansi-color-freeze-overlay (overlay is-after begin end &optional len) "Prevent OVERLAY from being extended. @@ -496,11 +491,9 @@ property." (move-overlay overlay (overlay-start overlay) begin))) (defun ansi-color-set-extent-face (extent face) - "Set the `face' property of EXTENT to FACE. -XEmacs uses `set-extent-face', Emacs uses `overlay-put'." - (if (featurep 'xemacs) - (set-extent-face extent face) - (overlay-put extent 'face face))) + "Set the `face' property of EXTENT to FACE." + (declare (obsolete overlay-put "27.1")) + (overlay-put extent 'face face)) ;; Helper functions diff --git a/lisp/apropos.el b/lisp/apropos.el index e27ff76c119..1b86f5bcde3 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -681,19 +681,19 @@ the output includes key-bindings of commands." (re (concat "\\(?:\\`\\|[\\/]\\)" (regexp-quote file) "\\(\\.\\|\\'\\)"))) (while (and lh (null lh-entry)) - (if (and (caar lh) (string-match re (caar lh))) + (if (and (stringp (caar lh)) (string-match re (caar lh))) (setq lh-entry (car lh)) (setq lh (cdr lh))))) (unless lh-entry (error "Unknown library `%s'" file))) (dolist (x (cdr lh-entry)) (pcase (car-safe x) ;; (autoload (push (cdr x) autoloads)) - (`require (push (cdr x) requires)) - (`provide (push (cdr x) provides)) - (`t nil) ; Skip "was an autoload" entries. + ('require (push (cdr x) requires)) + ('provide (push (cdr x) provides)) + ('t nil) ; Skip "was an autoload" entries. ;; FIXME: Print information about each individual method: both ;; its docstring and specializers (bug#21422). - (`cl-defmethod (push (cadr x) provides)) + ('cl-defmethod (push (cadr x) provides)) (_ (push (or (cdr-safe x) x) symbols)))) (let ((apropos-pattern "")) ;Dummy binding for apropos-symbols-internal. (apropos-symbols-internal diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index 0e4ee525db1..7f435f17a17 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -417,70 +417,66 @@ file. Archive and member name will be added." (substitute-key-definition 'advertised-undo 'archive-undo map global-map) (substitute-key-definition 'undo 'archive-undo map global-map)) - (define-key map - (if (featurep 'xemacs) 'button2 [mouse-2]) 'archive-extract) - - (if (featurep 'xemacs) - () ; out of luck - - (define-key map [menu-bar immediate] - (cons "Immediate" (make-sparse-keymap "Immediate"))) - (define-key map [menu-bar immediate alternate] - '(menu-item "Alternate Display" archive-alternate-display - :enable (boundp (archive-name "alternate-display")) - :help "Toggle alternate file info display")) - (define-key map [menu-bar immediate view] - '(menu-item "View This File" archive-view - :help "Display file at cursor in View Mode")) - (define-key map [menu-bar immediate display] - '(menu-item "Display in Other Window" archive-display-other-window - :help "Display file at cursor in another window")) - (define-key map [menu-bar immediate find-file-other-window] - '(menu-item "Find in Other Window" archive-extract-other-window - :help "Edit file at cursor in another window")) - (define-key map [menu-bar immediate find-file] - '(menu-item "Find This File" archive-extract - :help "Extract file at cursor and edit it")) - - (define-key map [menu-bar mark] - (cons "Mark" (make-sparse-keymap "Mark"))) - (define-key map [menu-bar mark unmark-all] - '(menu-item "Unmark All" archive-unmark-all-files - :help "Unmark all marked files")) - (define-key map [menu-bar mark deletion] - '(menu-item "Flag" archive-flag-deleted - :help "Flag file at cursor for deletion")) - (define-key map [menu-bar mark unmark] - '(menu-item "Unflag" archive-unflag - :help "Unmark file at cursor")) - (define-key map [menu-bar mark mark] - '(menu-item "Mark" archive-mark - :help "Mark file at cursor")) - - (define-key map [menu-bar operate] - (cons "Operate" (make-sparse-keymap "Operate"))) - (define-key map [menu-bar operate chown] - '(menu-item "Change Owner..." archive-chown-entry - :enable (fboundp (archive-name "chown-entry")) - :help "Change owner of marked files")) - (define-key map [menu-bar operate chgrp] - '(menu-item "Change Group..." archive-chgrp-entry - :enable (fboundp (archive-name "chgrp-entry")) - :help "Change group ownership of marked files")) - (define-key map [menu-bar operate chmod] - '(menu-item "Change Mode..." archive-chmod-entry - :enable (fboundp (archive-name "chmod-entry")) - :help "Change mode (permissions) of marked files")) - (define-key map [menu-bar operate rename] - '(menu-item "Rename to..." archive-rename-entry - :enable (fboundp (archive-name "rename-entry")) - :help "Rename marked files")) - ;;(define-key map [menu-bar operate copy] - ;; '(menu-item "Copy to..." archive-copy)) - (define-key map [menu-bar operate expunge] - '(menu-item "Expunge Marked Files" archive-expunge - :help "Delete all flagged files from archive")) - map)) + (define-key map [mouse-2] 'archive-extract) + + (define-key map [menu-bar immediate] + (cons "Immediate" (make-sparse-keymap "Immediate"))) + (define-key map [menu-bar immediate alternate] + '(menu-item "Alternate Display" archive-alternate-display + :enable (boundp (archive-name "alternate-display")) + :help "Toggle alternate file info display")) + (define-key map [menu-bar immediate view] + '(menu-item "View This File" archive-view + :help "Display file at cursor in View Mode")) + (define-key map [menu-bar immediate display] + '(menu-item "Display in Other Window" archive-display-other-window + :help "Display file at cursor in another window")) + (define-key map [menu-bar immediate find-file-other-window] + '(menu-item "Find in Other Window" archive-extract-other-window + :help "Edit file at cursor in another window")) + (define-key map [menu-bar immediate find-file] + '(menu-item "Find This File" archive-extract + :help "Extract file at cursor and edit it")) + + (define-key map [menu-bar mark] + (cons "Mark" (make-sparse-keymap "Mark"))) + (define-key map [menu-bar mark unmark-all] + '(menu-item "Unmark All" archive-unmark-all-files + :help "Unmark all marked files")) + (define-key map [menu-bar mark deletion] + '(menu-item "Flag" archive-flag-deleted + :help "Flag file at cursor for deletion")) + (define-key map [menu-bar mark unmark] + '(menu-item "Unflag" archive-unflag + :help "Unmark file at cursor")) + (define-key map [menu-bar mark mark] + '(menu-item "Mark" archive-mark + :help "Mark file at cursor")) + + (define-key map [menu-bar operate] + (cons "Operate" (make-sparse-keymap "Operate"))) + (define-key map [menu-bar operate chown] + '(menu-item "Change Owner..." archive-chown-entry + :enable (fboundp (archive-name "chown-entry")) + :help "Change owner of marked files")) + (define-key map [menu-bar operate chgrp] + '(menu-item "Change Group..." archive-chgrp-entry + :enable (fboundp (archive-name "chgrp-entry")) + :help "Change group ownership of marked files")) + (define-key map [menu-bar operate chmod] + '(menu-item "Change Mode..." archive-chmod-entry + :enable (fboundp (archive-name "chmod-entry")) + :help "Change mode (permissions) of marked files")) + (define-key map [menu-bar operate rename] + '(menu-item "Rename to..." archive-rename-entry + :enable (fboundp (archive-name "rename-entry")) + :help "Rename marked files")) + ;;(define-key map [menu-bar operate copy] + ;; '(menu-item "Copy to..." archive-copy)) + (define-key map [menu-bar operate expunge] + '(menu-item "Expunge Marked Files" archive-expunge + :help "Delete all flagged files from archive")) + map) "Local keymap for archive mode listings.") (defvar archive-file-name-indent nil "Column where file names start.") @@ -516,36 +512,30 @@ Each descriptor is a vector of the form ;; ------------------------------------------------------------------------- ;;; Section: Support functions. -(eval-when-compile - (defsubst byte-after (pos) - "Like char-after but an eight-bit char is converted to unibyte." - (multibyte-char-to-unibyte (char-after pos))) - (defsubst insert-unibyte (&rest args) - "Like insert but don't make unibyte string and eight-bit char multibyte." - (dolist (elt args) - (if (integerp elt) - (insert (if (< elt 128) elt (decode-char 'eight-bit elt))) - (insert (string-to-multibyte elt))))) - ) +(defun arc-insert-unibyte (&rest args) + "Like insert but don't make unibyte string and eight-bit char multibyte." + (dolist (elt args) + (if (integerp elt) + (insert (if (< elt 128) elt (decode-char 'eight-bit elt))) + (insert elt)))) (defsubst archive-name (suffix) (intern (concat "archive-" (symbol-name archive-subtype) "-" suffix))) -(defun archive-l-e (str &optional len float) +(defun archive-l-e (str &optional len) "Convert little endian string/vector STR to integer. Alternatively, STR may be a buffer position in the current buffer -in which case a second argument, length LEN, should be supplied. -FLOAT, if non-nil, means generate and return a float instead of an integer -\(use this for numbers that can overflow the Emacs integer)." +in which case a second argument, length LEN, should be supplied." (if (stringp str) (setq len (length str)) (setq str (buffer-substring str (+ str len)))) - (setq str (string-as-unibyte str)) + (if (multibyte-string-p str) + (setq str (encode-coding-string str 'utf-8-emacs-unix))) (let ((result 0) (i 0)) (while (< i len) (setq i (1+ i) - result (+ (if float (* result 256.0) (ash result 8)) + result (+ (ash result 8) (aref str (- len i))))) result)) @@ -583,7 +573,7 @@ the mode is invalid. If ERROR is nil then nil will be returned." (len (length newmode)) (i 1)) (while (< i len) - (setq result (+ (lsh result 3) (aref newmode i) (- ?0)) + (setq result (+ (ash result 3) (aref newmode i) (- ?0)) i (1+ i))) (logior (logand oldmode 65024) result))) ((string-match "^\\([agou]+\\)\\([---+=]\\)\\([rwxst]+\\)$" newmode) @@ -639,7 +629,7 @@ the mode is invalid. If ERROR is nil then nil will be returned." (defun archive-unixdate (low high) "Stringify Unix (LOW HIGH) date." - (let* ((time (cons high low)) + (let* ((time (list high low)) (str (current-time-string time))) (format "%s-%s-%s" (substring str 8 10) @@ -648,8 +638,7 @@ the mode is invalid. If ERROR is nil then nil will be returned." (defun archive-unixtime (low high) "Stringify Unix (LOW HIGH) time." - (let ((str (current-time-string (cons high low)))) - (substring str 11 19))) + (format-time-string "%H:%M:%S" (list high low))) (defun archive-get-lineno () (if (>= (point) archive-file-list-start) @@ -748,8 +737,7 @@ archive. (or file-name-coding-system default-file-name-coding-system locale-coding-system)) - (if (default-value 'enable-multibyte-characters) - (set-buffer-multibyte 'to)) + (set-buffer-multibyte 'to) (archive-summarize nil) (setq buffer-read-only t) (when (and archive-visit-single-files @@ -807,7 +795,7 @@ is visible (and the real data of the buffer is hidden). Optional argument SHUT-UP, if non-nil, means don't print messages when parsing the archive." (widen) - (let ((buffer-file-truename nil) ; avoid changing dir mtime by lock_file + (let ((create-lockfiles nil) ; avoid changing dir mtime by lock_file (inhibit-read-only t)) (setq archive-proper-file-start (copy-marker (point-min) t)) (set (make-local-variable 'change-major-mode-hook) 'archive-desummarize) @@ -846,13 +834,11 @@ when parsing the archive." ;; Using `concat' here copies the text also, so we can add ;; properties without problems. (let ((text (concat (aref fil 0) "\n"))) - (if (featurep 'xemacs) - () ; out of luck - (add-text-properties - (aref fil 1) (aref fil 2) - '(mouse-face highlight - help-echo "mouse-2: extract this file into a buffer") - text)) + (add-text-properties + (aref fil 1) (aref fil 2) + '(mouse-face highlight + help-echo "mouse-2: extract this file into a buffer") + text) text)) files))) (setq archive-file-list-end (point-marker))) @@ -972,8 +958,8 @@ using `make-temp-file', and the generated name is returned." (jka-compr-inhibit t)) (write-region (point-min) (point-max) tmpfile nil 'quiet)) (erase-buffer) - (let ((coding-system-for-read 'no-conversion)) - (insert-file-contents tmpfile))) + (set-buffer-multibyte t) + (insert-file-contents tmpfile)) (delete-file tmpfile))))) (defun archive-file-name-handler (op &rest args) @@ -1011,8 +997,6 @@ using `make-temp-file', and the generated name is returned." (kill-local-variable 'buffer-file-coding-system) (after-insert-file-set-coding (- (point-max) (point-min)))))) -(define-obsolete-function-alias 'archive-mouse-extract 'archive-extract "22.1") - (defun archive-extract (&optional other-window-p event) "In archive mode, extract this entry of the archive into its own buffer." (interactive (list nil last-input-event)) @@ -1064,7 +1048,9 @@ using `make-temp-file', and the generated name is returned." ;; We read an archive member by no-conversion at ;; first, then decode appropriately by calling ;; archive-set-buffer-as-visiting-file later. - (coding-system-for-read 'no-conversion)) + (coding-system-for-read 'no-conversion) + ;; Avoid changing dir mtime by lock_file + (create-lockfiles nil)) (condition-case err (if (fboundp extractor) (funcall extractor archive ename) @@ -1496,20 +1482,19 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." files visual) (while (and (< (+ p 29) (point-max)) - (= (byte-after p) ?\C-z) - (> (byte-after (1+ p)) 0)) + (= (get-byte p) ?\C-z) + (> (get-byte (1+ p)) 0)) (let* ((namefld (buffer-substring (+ p 2) (+ p 2 13))) (fnlen (or (string-match "\0" namefld) 13)) (efnname (decode-coding-string (substring namefld 0 fnlen) archive-file-name-coding-system)) - ;; Convert to float to avoid overflow for very large files. - (csize (archive-l-e (+ p 15) 4 'float)) + (csize (archive-l-e (+ p 15) 4)) (moddate (archive-l-e (+ p 19) 2)) (modtime (archive-l-e (+ p 21) 2)) - (ucsize (archive-l-e (+ p 25) 4 'float)) + (ucsize (archive-l-e (+ p 25) 4)) (fiddle (string= efnname (upcase efnname))) (ifnname (if fiddle (downcase efnname) efnname)) - (text (format " %8.0f %-11s %-8s %s" + (text (format " %8d %-11s %-8s %s" ucsize (archive-dosdate moddate) (archive-dostime modtime) @@ -1522,11 +1507,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." visual) files (cons (vector efnname ifnname fiddle nil (1- p)) files) - ;; p needs to stay an integer, since we use it in char-after - ;; above. Passing through `round' limits the compressed size - ;; to most-positive-fixnum, but if the compressed size exceeds - ;; that, we cannot visit the archive anyway. - p (+ p 29 (round csize))))) + p (+ p 29 csize)))) (goto-char (point-min)) (let ((dash (concat "- -------- ----------- -------- " (make-string maxlen ?-) @@ -1535,7 +1516,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." dash) (archive-summarize-files (nreverse visual)) (insert dash - (format " %8.0f %d file%s" + (format " %8d %d file%s" totalsize (length files) (if (= 1 (length files)) "" "s")) @@ -1543,7 +1524,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (apply #'vector (nreverse files)))) (defun archive-arc-rename-entry (newname descr) - (if (string-match "[:\\\\/]" newname) + (if (string-match "[:\\/]" newname) (error "File names in arc files must not contain a directory component")) (if (> (length newname) 12) (error "File names in arc files are limited to 12 characters")) @@ -1555,7 +1536,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (widen) (goto-char (+ archive-proper-file-start (aref descr 4) 2)) (delete-char 13) - (insert-unibyte name))))) + (arc-insert-unibyte name))))) ;; ------------------------------------------------------------------------- ;;; Section: Lzh Archives @@ -1567,14 +1548,13 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." visual) (while (progn (goto-char p) ;beginning of a base header. (looking-at "\\(.\\|\n\\)\\(.\\|\n\\)-l[hz][0-9ds]-")) - (let* ((hsize (byte-after p)) ;size of the base header (level 0 and 1) - ;; Convert to float to avoid overflow for very large files. - (csize (archive-l-e (+ p 7) 4 'float)) ;size of a compressed file to follow (level 0 and 2), + (let* ((hsize (get-byte p)) ;size of the base header (level 0 and 1) + (csize (archive-l-e (+ p 7) 4)) ;size of a compressed file to follow (level 0 and 2), ;size of extended headers + the compressed file to follow (level 1). - (ucsize (archive-l-e (+ p 11) 4 'float)) ;size of an uncompressed file. + (ucsize (archive-l-e (+ p 11) 4)) ;size of an uncompressed file. (time1 (archive-l-e (+ p 15) 2)) ;date/time (MSDOS format in level 0, 1 headers (time2 (archive-l-e (+ p 17) 2)) ;and UNIX format in level 2 header.) - (hdrlvl (byte-after (+ p 20))) ;header level + (hdrlvl (get-byte (+ p 20))) ;header level thsize ;total header size (base + extensions) fnlen efnname osid fiddle ifnname width p2 neh ;beginning of next extension header (level 1 and 2) @@ -1582,7 +1562,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." gname uname modtime moddate) (if (= hdrlvl 3) (error "can't handle lzh level 3 header type")) (when (or (= hdrlvl 0) (= hdrlvl 1)) - (setq fnlen (byte-after (+ p 21))) ;filename length + (setq fnlen (get-byte (+ p 21))) ;filename length (setq efnname (let ((str (buffer-substring (+ p 22) (+ p 22 fnlen)))) ;filename from offset 22 (decode-coding-string str archive-file-name-coding-system))) @@ -1593,19 +1573,19 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (setq neh (+ p 24)))) ;specific to level 2 header (if neh ;if level 1 or 2 we expect extension headers to follow (let* ((ehsize (archive-l-e neh 2)) ;size of the extension header - (etype (byte-after (+ neh 2)))) ;extension type + (etype (get-byte (+ neh 2)))) ;extension type (while (not (= ehsize 0)) (cond ((= etype 1) ;file name (let ((i (+ neh 3))) (while (< i (+ neh ehsize)) - (setq efnname (concat efnname (char-to-string (byte-after i)))) + (setq efnname (concat efnname (char-to-string (get-byte i)))) (setq i (1+ i))))) ((= etype 2) ;directory name (let ((i (+ neh 3))) (while (< i (+ neh ehsize)) (setq dir (concat dir - (if (= (byte-after i) + (if (= (get-byte i) 255) "/" (char-to-string @@ -1629,7 +1609,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." ) (setq neh (+ neh ehsize)) (setq ehsize (archive-l-e neh 2)) - (setq etype (byte-after (+ neh 2)))) + (setq etype (get-byte (+ neh 2)))) ;;get total header size for level 1 and 2 headers (setq thsize (- neh p)))) (if (= hdrlvl 0) ;total header size @@ -1661,12 +1641,12 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (archive-unixtime time1 time2) (archive-dostime time1))) (setq text (if archive-alternate-display - (format " %8.0f %5S %5S %s" + (format " %8d %5S %5S %s" ucsize (or uid "?") (or gid "?") ifnname) - (format " %10s %8.0f %-11s %-8s %s" + (format " %10s %8d %-11s %-8s %s" modestr ucsize moddate @@ -1681,13 +1661,9 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." files (cons (vector prname ifnname fiddle mode (1- p)) files)) (cond ((= hdrlvl 1) - ;; p needs to stay an integer, since we use it in goto-char - ;; above. Passing through `round' limits the compressed size - ;; to most-positive-fixnum, but if the compressed size exceeds - ;; that, we cannot visit the archive anyway. - (setq p (+ p hsize 2 (round csize)))) + (setq p (+ p hsize 2 csize))) ((or (= hdrlvl 2) (= hdrlvl 0)) - (setq p (+ p thsize 2 (round csize))))) + (setq p (+ p thsize 2 csize)))) )) (goto-char (point-min)) (let ((dash (concat (if archive-alternate-display @@ -1720,7 +1696,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (let ((sum 0)) (while (> count 0) (setq count (1- count) - sum (+ sum (byte-after p)) + sum (+ sum (get-byte p)) p (1+ p))) (logand sum 255))) @@ -1729,8 +1705,8 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (save-excursion (widen) (let* ((p (+ archive-proper-file-start (aref descr 4))) - (oldhsize (byte-after p)) - (oldfnlen (byte-after (+ p 21))) + (oldhsize (get-byte p)) + (oldfnlen (get-byte (+ p 21))) (newfnlen (length newname)) (newhsize (+ oldhsize newfnlen (- oldfnlen))) (inhibit-read-only t)) @@ -1738,10 +1714,10 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (error "The file name is too long")) (goto-char (+ p 21)) (delete-char (1+ oldfnlen)) - (insert-unibyte newfnlen newname) + (arc-insert-unibyte newfnlen newname) (goto-char p) (delete-char 2) - (insert-unibyte newhsize (archive-lzh-resum p newhsize)))))) + (arc-insert-unibyte newhsize (archive-lzh-resum p newhsize)))))) (defun archive-lzh-ogm (newval files errtxt ofs) (save-excursion @@ -1749,10 +1725,10 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (widen) (dolist (fil files) (let* ((p (+ archive-proper-file-start (aref fil 4))) - (hsize (byte-after p)) - (fnlen (byte-after (+ p 21))) + (hsize (get-byte p)) + (fnlen (get-byte (+ p 21))) (p2 (+ p 22 fnlen)) - (creator (if (>= (- hsize fnlen) 24) (byte-after (+ p2 2)) 0)) + (creator (if (>= (- hsize fnlen) 24) (get-byte (+ p2 2)) 0)) (inhibit-read-only t)) (if (= creator ?U) (progn @@ -1760,10 +1736,10 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (setq newval (funcall newval (archive-l-e (+ p2 ofs) 2)))) (goto-char (+ p2 ofs)) (delete-char 2) - (insert-unibyte (logand newval 255) (lsh newval -8)) + (arc-insert-unibyte (logand newval 255) (ash newval -8)) (goto-char (1+ p)) (delete-char 1) - (insert-unibyte (archive-lzh-resum (1+ p) hsize))) + (arc-insert-unibyte (archive-lzh-resum (1+ p) hsize))) (message "Member %s does not have %s field" (aref fil 1) errtxt))))))) @@ -1825,32 +1801,21 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." ;; ;; First, find the Zip64 end-of-central-directory locator. (search-backward "PK\006\007") - ;; Pay attention: the offset of Zip64 end-of-central-directory - ;; is a 64-bit field, so it could overflow the Emacs integer - ;; even on a 64-bit host, let alone 32-bit one. But since we've - ;; already read the zip file into a buffer, and this is a byte - ;; offset into the file we've read, it must be short enough, so - ;; such an overflow can never happen, and we can safely read - ;; these 8 bytes into an Emacs integer. Moreover, on host with - ;; 32-bit Emacs integer we can only read 4 bytes, since they are - ;; stored in little-endian byte order. - (setq emacs-int-has-32bits (<= most-positive-fixnum #x1fffffff)) (setq p (+ (point-min) - (archive-l-e (+ (point) 8) (if emacs-int-has-32bits 4 8)))) + (archive-l-e (+ (point) 8) 8))) (goto-char p) ;; We should be at Zip64 end-of-central-directory record now. (or (string= "PK\006\006" (buffer-substring p (+ p 4))) (error "Unrecognized ZIP file format")) ;; Offset to central directory: - (setq p (archive-l-e (+ p 48) (if emacs-int-has-32bits 4 8)))) + (setq p (archive-l-e (+ p 48) 8))) (setq p (+ p (point-min))) (while (string= "PK\001\002" (buffer-substring p (+ p 4))) - (let* ((creator (byte-after (+ p 5))) + (let* ((creator (get-byte (+ p 5))) ;; (method (archive-l-e (+ p 10) 2)) (modtime (archive-l-e (+ p 12) 2)) (moddate (archive-l-e (+ p 14) 2)) - ;; Convert to float to avoid overflow for very large files. - (ucsize (archive-l-e (+ p 24) 4 'float)) + (ucsize (archive-l-e (+ p 24) 4)) (fnlen (archive-l-e (+ p 28) 2)) (exlen (archive-l-e (+ p 30) 2)) (fclen (archive-l-e (+ p 32) 2)) @@ -1866,7 +1831,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (logior ?\444 (if isdir (logior 16384 ?\111) 0) (if (zerop - (logand 1 (byte-after (+ p 38)))) + (logand 1 (get-byte (+ p 38)))) ?\222 0))) (t nil))) (modestr (if mode (archive-int-to-mode mode) "??????????")) @@ -1875,7 +1840,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (string= (upcase efnname) efnname))) (ifnname (if fiddle (downcase efnname) efnname)) (width (string-width ifnname)) - (text (format " %10s %8.0f %-11s %-8s %s" + (text (format " %10s %8d %-11s %-8s %s" modestr ucsize (archive-dosdate moddate) @@ -1901,7 +1866,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." dash) (archive-summarize-files (nreverse visual)) (insert dash - (format " %8.0f %d file%s" + (format " %8d %d file%s" totalsize (length files) (if (= 1 (length files)) "" "s")) @@ -1943,18 +1908,19 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (widen) (dolist (fil files) (let* ((p (+ archive-proper-file-start (car (aref fil 4)))) - (creator (byte-after (+ p 5))) + (creator (get-byte (+ p 5))) (oldmode (aref fil 3)) (newval (archive-calc-mode oldmode newmode t)) (inhibit-read-only t)) (cond ((memq creator '(2 3)) ; Unix (goto-char (+ p 40)) (delete-char 2) - (insert-unibyte (logand newval 255) (lsh newval -8))) + (arc-insert-unibyte (logand newval 255) (ash newval -8))) ((memq creator '(0 5 6 7 10 11 15)) ; Dos etc. (goto-char (+ p 38)) - (insert-unibyte (logior (logand (byte-after (point)) 254) - (logand (logxor 1 (lsh newval -7)) 1))) + (arc-insert-unibyte + (logior (logand (get-byte (point)) 254) + (logand (logxor 1 (ash newval -7)) 1))) (delete-char 1)) (t (message "Don't know how to change mode for this member")))) )))) @@ -1972,12 +1938,11 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (let* ((next (1+ (archive-l-e (+ p 6) 4))) (moddate (archive-l-e (+ p 14) 2)) (modtime (archive-l-e (+ p 16) 2)) - ;; Convert to float to avoid overflow for very large files. - (ucsize (archive-l-e (+ p 20) 4 'float)) + (ucsize (archive-l-e (+ p 20) 4)) (namefld (buffer-substring (+ p 38) (+ p 38 13))) - (dirtype (byte-after (+ p 4))) - (lfnlen (if (= dirtype 2) (byte-after (+ p 56)) 0)) - (ldirlen (if (= dirtype 2) (byte-after (+ p 57)) 0)) + (dirtype (get-byte (+ p 4))) + (lfnlen (if (= dirtype 2) (get-byte (+ p 56)) 0)) + (ldirlen (if (= dirtype 2) (get-byte (+ p 57)) 0)) (fnlen (or (string-match "\0" namefld) 13)) (efnname (let ((str (concat @@ -1996,7 +1961,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (fiddle (and (= lfnlen 0) (string= efnname (upcase efnname)))) (ifnname (if fiddle (downcase efnname) efnname)) (width (string-width ifnname)) - (text (format " %8.0f %-11s %-8s %s" + (text (format " %8d %-11s %-8s %s" ucsize (archive-dosdate moddate) (archive-dostime modtime) @@ -2018,7 +1983,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." dash) (archive-summarize-files (nreverse visual)) (insert dash - (format " %8.0f %d file%s" + (format " %8d %d file%s" totalsize (length files) (if (= 1 (length files)) "" "s")) @@ -2042,14 +2007,14 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (call-process "lsar" nil t nil "-l" (or file copy)) (if copy (delete-file copy)) (goto-char (point-min)) - (re-search-forward "^\\(\s+=+\s?+\\)+\n") - (while (looking-at (concat "^\s+[0-9.]+\s+-+\s+" ; Flags - "\\([0-9-]+\\)\s+" ; Size - "\\([0-9.%]+\\)\s+" ; Ratio - "\\([0-9a-zA-Z]+\\)\s+" ; Mode - "\\([0-9-]+\\)\s+" ; Date - "\\([0-9:]+\\)\s+" ; Time - "\\(.*\\)\n" ; Name + (re-search-forward "^\\(\s+=+\s*\\)+\n") + (while (looking-at (concat "^\s+[0-9.]+\s+D?-+\s+" ; Flags + "\\([0-9-]+\\)\s+" ; Size + "\\([-0-9.%]+\\)\s+" ; Ratio + "\\([0-9a-zA-Z]+\\)\s+" ; Mode + "\\([0-9-]+\\)\s+" ; Date + "\\([0-9:]+\\)\s+" ; Time + "\\(.*\\)\n" ; Name )) (goto-char (match-end 0)) (let ((name (match-string 6)) @@ -2091,7 +2056,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." ;; The code below assumes the name is relative and may do undesirable ;; things otherwise. (error "Can't extract files with non-relative names") - (archive-extract-by-file archive name `("unar" "-no-directory" "-o") "Successfully extracted"))) + (archive-extract-by-file archive name '("unar" "-no-directory" "-o") "Successfully extracted"))) ;;; Section: Rar self-extracting .exe archives. @@ -2212,8 +2177,6 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (while (looking-at archive-ar-file-header-re) (let ((name (match-string 1)) extname - ;; Emacs will automatically use float here because those - ;; timestamps don't fit in our ints. (time (string-to-number (match-string 2))) (user (match-string 3)) (group (match-string 4)) diff --git a/lisp/auth-source-pass.el b/lisp/auth-source-pass.el index bd90045b38d..f16d9108903 100644 --- a/lisp/auth-source-pass.el +++ b/lisp/auth-source-pass.el @@ -4,10 +4,11 @@ ;; Author: Damien Cassou <damien@cassou.me>, ;; Nicolas Petton <nicolas@petton.fr> -;; Version: 2.0.0 -;; Package-Requires: ((emacs "24.4") +;; Keith Amidon <camalot@picnicpark.org> +;; Version: 5.0.0 +;; Package-Requires: ((emacs "25")) +;; Url: https://github.com/DamienCassou/auth-password-store ;; Created: 07 Jun 2015 -;; Keywords: pass password-store auth-source username password login ;; This file is part of GNU Emacs. @@ -38,6 +39,22 @@ (require 'auth-source) (require 'url-parse) +(defgroup auth-source-pass nil + "password-store integration within auth-source." + :prefix "auth-source-pass-" + :group 'auth-source + :version "27.1") + +(defcustom auth-source-pass-filename "~/.password-store" + "Filename of the password-store folder." + :type 'directory + :version "27.1") + +(defcustom auth-source-pass-port-separator ":" + "Separator string between host and port in entry filename." + :type 'string + :version "27.1") + (cl-defun auth-source-pass-search (&rest spec &key backend type host user port &allow-other-keys) @@ -45,20 +62,29 @@ See `auth-source-search' for details on SPEC." (cl-assert (or (null type) (eq type (oref backend type))) t "Invalid password-store search: %s %s") - (when (listp host) + (when (consp host) + (warn "auth-source-pass ignores all but first host in spec.") ;; Take the first non-nil item of the list of hosts (setq host (seq-find #'identity host))) - (list (auth-source-pass--build-result host port user))) + (cond ((eq host t) + (warn "auth-source-pass does not handle host wildcards.") + nil) + ((null host) + ;; Do not build a result, as none will match when HOST is nil + nil) + (t + (when-let ((result (auth-source-pass--build-result host port user))) + (list result))))) (defun auth-source-pass--build-result (host port user) "Build auth-source-pass entry matching HOST, PORT and USER." - (let ((entry (auth-source-pass--find-match host user))) - (when entry + (let ((entry-data (auth-source-pass--find-match host user port))) + (when entry-data (let ((retval (list :host host - :port (or (auth-source-pass-get "port" entry) port) - :user (or (auth-source-pass-get "user" entry) user) - :secret (lambda () (auth-source-pass-get 'secret entry))))) + :port (or (auth-source-pass--get-attr "port" entry-data) port) + :user (or (auth-source-pass--get-attr "user" entry-data) user) + :secret (lambda () (auth-source-pass--get-attr 'secret entry-data))))) (auth-source-pass--do-debug "return %s as final result (plus hidden password)" (seq-subseq retval 0 -2)) ;; remove password retval)))) @@ -73,7 +99,7 @@ See `auth-source-search' for details on SPEC." (defvar auth-source-pass-backend (auth-source-backend - (format "Password store") + (when (<= emacs-major-version 25) "password-store") :source "." ;; not used :type 'password-store :search-function #'auth-source-pass-search) @@ -84,9 +110,12 @@ See `auth-source-search' for details on SPEC." (when (eq entry 'password-store) (auth-source-backend-parse-parameters entry auth-source-pass-backend))) -(add-hook 'auth-source-backend-parser-functions #'auth-source-pass-backend-parse) +(if (boundp 'auth-source-backend-parser-functions) + (add-hook 'auth-source-backend-parser-functions #'auth-source-pass-backend-parse) + (advice-add 'auth-source-backend-parse :before-until #'auth-source-pass-backend-parse)) +;;;###autoload (defun auth-source-pass-get (key entry) "Return the value associated to KEY in the password-store entry ENTRY. @@ -100,16 +129,25 @@ secret key1: value1 key2: value2" (let ((data (auth-source-pass-parse-entry entry))) - (or (cdr (assoc key data)) - (and (string= key "user") - (cdr (assoc "username" data)))))) + (auth-source-pass--get-attr key data))) + +(defun auth-source-pass--get-attr (key entry-data) + "Return value associated with KEY in an ENTRY-DATA. + +ENTRY-DATA is the data from a parsed password-store entry. +The key used to retrieve the password is the symbol `secret'. + +See `auth-source-pass-get'." + (or (cdr (assoc key entry-data)) + (and (string= key "user") + (cdr (assoc "username" entry-data))))) (defun auth-source-pass--read-entry (entry) "Return a string with the file content of ENTRY." (with-temp-buffer (insert-file-contents (expand-file-name (format "%s.gpg" entry) - "~/.password-store")) + auth-source-pass-filename)) (buffer-substring-no-properties (point-min) (point-max)))) (defun auth-source-pass-parse-entry (entry) @@ -124,12 +162,12 @@ ENTRY is the name of a password-store entry." (defun auth-source-pass--parse-secret (contents) "Parse the password-store data in the string CONTENTS and return its secret. The secret is the first line of CONTENTS." - (car (split-string contents "\\\n" t))) + (car (split-string contents "\n" t))) (defun auth-source-pass--parse-data (contents) "Parse the password-store data in the string CONTENTS and return an alist. CONTENTS is the contents of a password-store formatted file." - (let ((lines (split-string contents "\\\n" t "\\\s"))) + (let ((lines (split-string contents "\n" t "[ \t]+"))) (seq-remove #'null (mapcar (lambda (line) (let ((pair (mapcar (lambda (s) (string-trim s)) @@ -139,115 +177,135 @@ CONTENTS is the contents of a password-store formatted file." (mapconcat #'identity (cdr pair) ":"))))) (cdr lines))))) -(defun auth-source-pass--user-match-p (entry user) - "Return true iff ENTRY match USER." - (or (null user) - (string= user (auth-source-pass-get "user" entry)))) - -(defun auth-source-pass--hostname (host) - "Extract hostname from HOST." - (let ((url (url-generic-parse-url host))) - (or (url-host url) host))) - -(defun auth-source-pass--hostname-with-user (host) - "Extract hostname and user from HOST." - (let* ((url (url-generic-parse-url host)) - (user (url-user url)) - (hostname (url-host url))) - (cond - ((and user hostname) (format "%s@%s" user hostname)) - (hostname hostname) - (t host)))) - (defun auth-source-pass--do-debug (&rest msg) "Call `auth-source-do-debug` with MSG and a prefix." (apply #'auth-source-do-debug - (cons (concat "auth-source-password-store: " (car msg)) + (cons (concat "auth-source-pass: " (car msg)) (cdr msg)))) -(defun auth-source-pass--select-one-entry (entries user) - "Select one entry from ENTRIES by searching for a field matching USER." - (let ((number (length entries)) - (entry-with-user - (and user - (seq-find (lambda (entry) - (string-equal (auth-source-pass-get "user" entry) user)) - entries)))) - (auth-source-pass--do-debug "found %s matches: %s" number - (mapconcat #'identity entries ", ")) - (if entry-with-user - (progn - (auth-source-pass--do-debug "return %s as it contains matching user field" - entry-with-user) - entry-with-user) - (auth-source-pass--do-debug "return %s as it is the first one" (car entries)) - (car entries)))) - -(defun auth-source-pass--entry-valid-p (entry) - "Return t iff ENTRY can be opened. -Also displays a warning if not. This function is slow, don't call it too -often." - (if (auth-source-pass-parse-entry entry) - t - (auth-source-pass--do-debug "entry '%s' is not valid" entry) - nil)) - ;; TODO: add tests for that when `assess-with-filesystem' is included ;; in Emacs (defun auth-source-pass-entries () "Return a list of all password store entries." - (let ((store-dir (expand-file-name "~/.password-store/"))) + (let ((store-dir (expand-file-name auth-source-pass-filename))) (mapcar (lambda (file) (file-name-sans-extension (file-relative-name file store-dir))) - (directory-files-recursively store-dir "\.gpg$")))) - -(defun auth-source-pass--find-all-by-entry-name (entryname user) - "Search the store for all entries either matching ENTRYNAME/USER or ENTRYNAME. -Only return valid entries as of `auth-source-pass--entry-valid-p'." - (seq-filter (lambda (entry) - (and - (or - (let ((components-host-user - (member entryname (split-string entry "/")))) - (and (= (length components-host-user) 2) - (string-equal user (cadr components-host-user)))) - (string-equal entryname (file-name-nondirectory entry))) - (auth-source-pass--entry-valid-p entry))) - (auth-source-pass-entries))) - -(defun auth-source-pass--find-one-by-entry-name (entryname user) - "Search the store for an entry matching ENTRYNAME. + (directory-files-recursively store-dir "\\.gpg$")))) + +(defun auth-source-pass--find-match (host user port) + "Return password-store entry data matching HOST, USER and PORT. + +Disambiguate between user provided inside HOST (e.g., user@server.com) and +inside USER by giving priority to USER. Same for PORT." + (apply #'auth-source-pass--find-match-unambiguous (auth-source-pass--disambiguate host user port))) + +(defun auth-source-pass--disambiguate (host &optional user port) + "Return (HOST USER PORT) after disambiguation. +Disambiguate between having user provided inside HOST (e.g., +user@server.com) and inside USER by giving priority to USER. +Same for PORT." + (let* ((url (url-generic-parse-url (if (string-match-p ".*://" host) + host + (format "https://%s" host))))) + (list + (or (url-host url) host) + (or user (url-user url)) + ;; url-port returns 443 (because of the https:// above) by default + (or port (number-to-string (url-port url)))))) + +(defun auth-source-pass--find-match-unambiguous (hostname user port) + "Return password-store entry data matching HOSTNAME, USER and PORT. +If many matches are found, return the first one. If no match is found, +return nil. + +HOSTNAME should not contain any username or port number." + (let ((all-entries (auth-source-pass-entries)) + (suffixes (auth-source-pass--generate-entry-suffixes hostname user port))) + (auth-source-pass--do-debug "searching for entries matching hostname=%S, user=%S, port=%S" + hostname (or user "") (or port "")) + (auth-source-pass--do-debug "corresponding suffixes to search for: %S" suffixes) + (catch 'auth-source-pass-break + (dolist (suffix suffixes) + (let* ((matching-entries (auth-source-pass--entries-matching-suffix suffix all-entries)) + (best-entry-data (auth-source-pass--select-from-entries matching-entries user))) + (pcase (length matching-entries) + (0 (auth-source-pass--do-debug "found no entries matching %S" suffix)) + (1 (auth-source-pass--do-debug "found 1 entry matching %S: %S" + suffix + (car matching-entries))) + (_ (auth-source-pass--do-debug "found %s entries matching %S: %S" + (length matching-entries) + suffix + matching-entries))) + (when best-entry-data + (throw 'auth-source-pass-break best-entry-data))))))) + +(defun auth-source-pass--select-from-entries (entries user) + "Return best matching password-store entry data from ENTRIES. + If USER is non nil, give precedence to entries containing a user field matching USER." - (auth-source-pass--do-debug "searching for '%s' in entry names (user: %s)" - entryname - user) - (let ((matching-entries (auth-source-pass--find-all-by-entry-name entryname user))) - (pcase (length matching-entries) - (0 (auth-source-pass--do-debug "no match found") - nil) - (1 (auth-source-pass--do-debug "found 1 match: %s" (car matching-entries)) - (car matching-entries)) - (_ (auth-source-pass--select-one-entry matching-entries user))))) - -(defun auth-source-pass--find-match (host user) - "Return a password-store entry name matching HOST and USER. -If many matches are found, return the first one. If no match is -found, return nil." - (or - (if (url-user (url-generic-parse-url host)) - ;; if HOST contains a user (e.g., "user@host.com"), <HOST> - (auth-source-pass--find-one-by-entry-name (auth-source-pass--hostname-with-user host) user) - ;; otherwise, if USER is provided, search for <USER>@<HOST> - (when (stringp user) - (auth-source-pass--find-one-by-entry-name (concat user "@" (auth-source-pass--hostname host)) user))) - ;; if that didn't work, search for HOST without it's user component if any - (auth-source-pass--find-one-by-entry-name (auth-source-pass--hostname host) user) - ;; if that didn't work, remove subdomain: foo.bar.com -> bar.com - (let ((components (split-string host "\\."))) - (when (= (length components) 3) - ;; start from scratch - (auth-source-pass--find-match (mapconcat 'identity (cdr components) ".") user))))) + (let (fallback) + (catch 'auth-source-pass-break + (dolist (entry entries fallback) + (let ((entry-data (auth-source-pass-parse-entry entry))) + (when (and entry-data (not fallback)) + (setq fallback entry-data) + (when (or (not user) (equal (auth-source-pass--get-attr "user" entry-data) user)) + (throw 'auth-source-pass-break entry-data)))))))) + +(defun auth-source-pass--entries-matching-suffix (suffix entries) + "Return entries matching SUFFIX. +If ENTRIES is nil, use the result of calling `auth-source-pass-entries' instead." + (cl-remove-if-not + (lambda (entry) (string-match-p + (format "\\(^\\|/\\)%s$" (regexp-quote suffix)) + entry)) + (or entries (auth-source-pass-entries)))) + +(defun auth-source-pass--generate-entry-suffixes (hostname user port) + "Return a list of possible entry path suffixes in the password-store. + +Based on the supported pathname patterns for HOSTNAME, USER, & +PORT, return a list of possible suffixes for matching entries in +the password-store." + (let ((domains (auth-source-pass--domains (split-string hostname "\\.")))) + (seq-mapcat (lambda (n) + (auth-source-pass--name-port-user-suffixes n user port)) + domains))) + +(defun auth-source-pass--domains (name-components) + "Return a list of possible domain names matching the hostname. + +This function takes a list of NAME-COMPONENTS, the strings +separated by periods in the hostname, and returns a list of full +domain names containing the trailing sequences of those +components, from longest to shortest." + (cl-maplist (lambda (components) (mapconcat #'identity components ".")) + name-components)) + +(defun auth-source-pass--name-port-user-suffixes (name user port) + "Return a list of possible path suffixes for NAME, USER, & PORT. + +The resulting list is ordered from most specifc to least +specific, with paths matching all of NAME, USER, & PORT first, +then NAME & USER, then NAME & PORT, then just NAME." + (seq-mapcat + #'identity + (list + (when (and user port) + (list + (format "%s@%s%s%s" user name auth-source-pass-port-separator port) + (format "%s%s%s/%s" name auth-source-pass-port-separator port user))) + (when user + (list + (format "%s@%s" user name) + (format "%s/%s" name user))) + (when port + (list + (format "%s%s%s" name auth-source-pass-port-separator port))) + (list + (format "%s" name))))) (provide 'auth-source-pass) ;;; auth-source-pass.el ends here diff --git a/lisp/auth-source.el b/lisp/auth-source.el index 33a9b510f4e..74c44916992 100644 --- a/lisp/auth-source.el +++ b/lisp/auth-source.el @@ -39,6 +39,7 @@ ;;; Code: +(require 'json) (require 'password-cache) (eval-when-compile (require 'cl-lib)) @@ -82,7 +83,6 @@ expiring. Overrides `password-cache-expiry' through a let-binding." :version "24.1" - :group 'auth-source :type '(choice (const :tag "Never" nil) (const :tag "All Day" 86400) (const :tag "2 Hours" 7200) @@ -138,7 +138,6 @@ let-binding." (smtp "smtp" "25")) "List of authentication protocols and their names" - :group 'auth-source :version "23.2" ;; No Gnus :type '(repeat :tag "Authentication Protocols" (cons :tag "Protocol Entry" @@ -167,9 +166,8 @@ let-binding." (defcustom auth-source-save-behavior 'ask "If set, auth-source will respect it for save behavior." - :group 'auth-source :version "23.2" ;; No Gnus - :type `(choice + :type '(choice :tag "auth-source new token save behavior" (const :tag "Always save" t) (const :tag "Never save" nil) @@ -182,7 +180,6 @@ let-binding." "Set this to tell auth-source when to create GPG password tokens in netrc files. It's either an alist or `never'. Note that if EPA/EPG is not available, this should NOT be used." - :group 'auth-source :version "23.2" ;; No Gnus :type `(choice (const :tag "Always use GPG password tokens" (t gpg)) @@ -202,9 +199,8 @@ Note that if EPA/EPG is not available, this should NOT be used." (defcustom auth-source-do-cache t "Whether auth-source should cache information with `password-cache'." - :group 'auth-source :version "23.2" ;; No Gnus - :type `boolean) + :type 'boolean) (defcustom auth-source-debug nil "Whether auth-source should log debug messages. @@ -217,9 +213,8 @@ for passwords). If the value is a function, debug messages are logged by calling that function using the same arguments as `message'." - :group 'auth-source :version "23.2" ;; No Gnus - :type `(choice + :type '(choice :tag "auth-source debugging mode" (const :tag "Log using `message' to the *Messages* buffer" t) (const :tag "Log all trivia with `message' to the *Messages* buffer" @@ -240,8 +235,7 @@ for details. It's best to customize this with `\\[customize-variable]' because the choices can get pretty complex." - :group 'auth-source - :version "26.1" ;; No Gnus + :version "26.1" ; neither new nor changed default :type `(repeat :tag "Authentication Sources" (choice (string :tag "Just a file") @@ -310,7 +304,6 @@ can get pretty complex." (defcustom auth-source-gpg-encrypt-to t "List of recipient keys that `authinfo.gpg' encrypted to. If the value is not a list, symmetric encryption will be used." - :group 'auth-source :version "24.1" ;; No Gnus :type '(choice (const :tag "Symmetric encryption" t) (repeat :tag "Recipient public keys" @@ -362,10 +355,9 @@ soon as a function returns non-nil.") (defun auth-source-backend-parse (entry) "Create an auth-source-backend from an ENTRY in `auth-sources'." - (let (backend) - (cl-dolist (f auth-source-backend-parser-functions) - (when (setq backend (funcall f entry)) - (cl-return))) + (let ((backend + (run-hook-with-args-until-success 'auth-source-backend-parser-functions + entry))) (unless backend ;; none of the parsers worked @@ -380,27 +372,42 @@ soon as a function returns non-nil.") ;; take just a file name use it as a netrc/plist file ;; matching any user, host, and protocol (when (stringp entry) - (setq entry `(:source ,entry))) - (cond - ;; a file name with parameters - ((stringp (plist-get entry :source)) - (if (equal (file-name-extension (plist-get entry :source)) "plist") + (setq entry (list :source entry))) + (let* ((source (plist-get entry :source)) + (source-without-gpg + (if (and (stringp source) + (equal (file-name-extension source) "gpg")) + (file-name-sans-extension source) + (or source ""))) + (extension (or (and (stringp source-without-gpg) + (file-name-extension source-without-gpg)) + ""))) + (when (stringp source) + (cond + ((equal extension "plist") (auth-source-backend - (plist-get entry :source) - :source (plist-get entry :source) + source + :source source :type 'plstore :search-function #'auth-source-plstore-search :create-function #'auth-source-plstore-create - :data (plstore-open (plist-get entry :source))) - (auth-source-backend - (plist-get entry :source) - :source (plist-get entry :source) - :type 'netrc - :search-function #'auth-source-netrc-search - :create-function #'auth-source-netrc-create))))) + :data (plstore-open source))) + ((member-ignore-case extension '("json")) + (auth-source-backend + source + :source source + :type 'json + :search-function #'auth-source-json-search)) + (t + (auth-source-backend + source + :source source + :type 'netrc + :search-function #'auth-source-netrc-search + :create-function #'auth-source-netrc-create)))))) ;; Note this function should be last in the parser functions, so we add it first -(add-hook 'auth-source-backend-parser-functions 'auth-source-backends-parser-file) +(add-hook 'auth-source-backend-parser-functions #'auth-source-backends-parser-file) (defun auth-source-backends-parser-macos-keychain (entry) ;; take macos-keychain-{internet,generic}:XYZ and use it as macOS @@ -447,7 +454,7 @@ soon as a function returns non-nil.") :search-function #'auth-source-macos-keychain-search :create-function #'auth-source-macos-keychain-create))))) -(add-hook 'auth-source-backend-parser-functions 'auth-source-backends-parser-macos-keychain) +(add-hook 'auth-source-backend-parser-functions #'auth-source-backends-parser-macos-keychain) (defun auth-source-backends-parser-secrets (entry) ;; take secrets:XYZ and use it as Secrets API collection "XYZ" @@ -494,7 +501,7 @@ soon as a function returns non-nil.") :source "" :type 'ignore)))))) -(add-hook 'auth-source-backend-parser-functions 'auth-source-backends-parser-secrets) +(add-hook 'auth-source-backend-parser-functions #'auth-source-backends-parser-secrets) (defun auth-source-backend-parse-parameters (entry backend) "Fills in the extra auth-source-backend parameters of ENTRY. @@ -512,7 +519,7 @@ parameters." (oset backend port val))) backend) -;; (mapcar 'auth-source-backend-parse auth-sources) +;; (mapcar #'auth-source-backend-parse auth-sources) (cl-defun auth-source-search (&rest spec &key max require create delete @@ -940,7 +947,8 @@ Note that the MAX parameter is used so we can exit the parse early." (if (and (functionp cached-secrets) (equal cached-mtime - (nth 5 (file-attributes file)))) + (file-attribute-modification-time + (file-attributes file)))) (progn (auth-source-do-trivia "auth-source-netrc-parse: using CACHED file data for %s" @@ -952,7 +960,8 @@ Note that the MAX parameter is used so we can exit the parse early." ;; (note for the irony-impaired: they are just obfuscated) (auth-source--aput auth-source-netrc-cache file - (list :mtime (nth 5 (file-attributes file)) + (list :mtime (file-attribute-modification-time + (file-attributes file)) :secret (let ((v (mapcar #'1+ (buffer-string)))) (lambda () (apply #'string (mapcar #'1- v))))))) (goto-char (point-min)) @@ -1302,9 +1311,7 @@ See `auth-source-search' for details on SPEC." (string-match (car item) file)) (setq ret (cdr item)) (setq check nil))) - ;; FIXME: `ret' unused. - ;; Should we return it here? - )) + ret)) (t 'never))) (plain (or (eval default) (read-passwd prompt)))) ;; ask if we don't know what to do (in which case @@ -1485,13 +1492,13 @@ Here's an example that looks for the first item in the `Login' Secrets collection: (let ((auth-sources \\='(\"secrets:Login\"))) - (auth-source-search :max 1) + (auth-source-search :max 1)) Here's another that looks for the first item in the `Login' Secrets collection whose label contains `gnus': (let ((auth-sources \\='(\"secrets:Login\"))) - (auth-source-search :max 1 :label \"gnus\") + (auth-source-search :max 1 :label \"gnus\")) And this one looks for the first item in the `Login' Secrets collection that's a Google Chrome entry for the git.gnus.org site @@ -1502,9 +1509,6 @@ authentication tokens: " ;; TODO - (cl-assert (not create) nil - "The Secrets API auth-source backend doesn't support creation yet") - ;; TODO ;; (secrets-delete-item coll elt) (cl-assert (not delete) nil "The Secrets API auth-source backend doesn't support deletion yet") @@ -1564,12 +1568,204 @@ authentication tokens: returned-keys)) plist)) items))) + (cond + ;; if we need to create an entry AND none were found to match + ((and create + (not items)) + + ;; create based on the spec and record the value + (setq items (or + ;; if the user did not want to create the entry + ;; in the file, it will be returned + (apply (slot-value backend 'create-function) spec) + ;; if not, we do the search again without :create + ;; to get the updated data. + + ;; the result will be returned, even if the search fails + (apply #'auth-source-secrets-search + (plist-put spec :create nil)))))) items)) -(defun auth-source-secrets-create (&rest spec) - ;; TODO - ;; (apply 'secrets-create-item (auth-get-source entry) name passwd spec) - (debug spec)) +(cl-defun auth-source-secrets-create (&rest spec + &key backend host port create + &allow-other-keys) + (let* ((base-required '(host user port secret label)) + ;; 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)) + (current-data (car (auth-source-search :max 1 + :host host + :port port))) + (required (append base-required create-extra)) + (collection (oref backend source)) + ;; `args' are the arguments for `secrets-create-item'. + args + ;; `valist' is an alist + valist + ;; `artificial' will be returned if no creation is needed + artificial) + + ;; only for base required elements (defined as function parameters): + ;; fill in the valist with whatever data we may have from the search + ;; we complete the first value if it's a list and use the value otherwise + (dolist (br base-required) + (let ((val (plist-get spec (auth-source--symbol-keyword br)))) + (when val + (let ((br-choice (cond + ;; all-accepting choice (predicate is t) + ((eq t val) nil) + ;; just the value otherwise + (t val)))) + (when br-choice + (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)))) + (when (memq k keys) + (auth-source--aput valist er (plist-get spec k))))) + + ;; for each required element + (dolist (r required) + (let* ((data (auth-source--aget valist r)) + ;; take the first element if the data is a list + (data (or (auth-source-netrc-element-or-first data) + (plist-get current-data + (auth-source--symbol-keyword r)))) + ;; this is the default to be offered + (given-default (auth-source--aget + auth-source-creation-defaults r)) + ;; the default supplementals are simple: + ;; for the user, try `given-default' and then (user-login-name); + ;; for the label, try `given-default' and then user@host; + ;; otherwise take `given-default' + (default (cond + ((and (not given-default) (eq r 'user)) + (user-login-name)) + ((and (not given-default) (eq r 'label)) + (format "%s@%s" + (or (auth-source-netrc-element-or-first + (auth-source--aget valist 'user)) + (plist-get artificial :user)) + (or (auth-source-netrc-element-or-first + (auth-source--aget valist 'host)) + (plist-get artificial :host)))) + (t given-default))) + (printable-defaults (list + (cons 'user + (or + (auth-source-netrc-element-or-first + (auth-source--aget valist 'user)) + (plist-get artificial :user) + "[any user]")) + (cons 'host + (or + (auth-source-netrc-element-or-first + (auth-source--aget valist 'host)) + (plist-get artificial :host) + "[any host]")) + (cons 'port + (or + (auth-source-netrc-element-or-first + (auth-source--aget valist 'port)) + (plist-get artificial :port) + "[any port]")) + (cons 'label + (or + (auth-source-netrc-element-or-first + (auth-source--aget valist 'label)) + (plist-get artificial :label) + "[any label]")))) + (prompt (or (auth-source--aget auth-source-creation-prompts r) + (cl-case r + (secret "%p password for %u@%h: ") + (user "%p user name for %h: ") + (host "%p host name for user %u: ") + (port "%p port for %u@%h: ") + (label "Enter label for %u@%h: ")) + (format "Enter %s (%%u@%%h:%%p): " r))) + (prompt (auth-source-format-prompt + prompt + `((?u ,(auth-source--aget printable-defaults 'user)) + (?h ,(auth-source--aget printable-defaults 'host)) + (?p ,(auth-source--aget printable-defaults 'port)))))) + + ;; Store the data, prompting for the password if needed. + (setq data (or data + (if (eq r 'secret) + (or (eval default) (read-passwd prompt)) + (if (stringp default) + (read-string (if (string-match ": *\\'" prompt) + (concat (substring prompt 0 (match-beginning 0)) + " (default " default "): ") + (concat prompt "(default " default ") ")) + nil nil default) + (eval default))))) + + (when data + (setq artificial (plist-put artificial + (auth-source--symbol-keyword r) + (if (eq r 'secret) + (let ((data data)) + (lambda () data)) + data)))) + + ;; When r is not an empty string... + (when (and (stringp data) + (< 0 (length data)) + (not (member r '(secret label)))) + ;; append the key (the symbol name of r) + ;; and the value in r + (setq args (append args (list (auth-source--symbol-keyword r) data)))))) + + (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))) + (lambda () + (auth-source-secrets-saver collection item secret args)))) + + (list artificial))) + +(defun auth-source-secrets-saver (collection item secret args) + "Wrapper around `secrets-create-item', prompting along the way. +Respects `auth-source-save-behavior'." + (let ((prompt (format "Save auth info to secrets collection %s? " collection)) + (done (not (eq auth-source-save-behavior 'ask))) + (doit (eq auth-source-save-behavior t)) + (bufname "*auth-source Help*") + k) + (while (not done) + (setq k (auth-source-read-char-choice prompt '(?y ?n ?N ??))) + (cl-case k + (?y (setq done t doit t)) + (?? (save-excursion + (with-output-to-temp-buffer bufname + (princ + (concat "(y)es, save\n" + "(n)o but use the info\n" + "(N)o and don't ask to save again\n" + "(?) for help as you can see.\n")) + ;; Why? Doesn't with-output-to-temp-buffer already do + ;; the exact same thing anyway? --Stef + (set-buffer standard-output) + (help-mode)))) + (?n (setq done t doit nil)) + (?N (setq done t doit nil) + (customize-save-variable 'auth-source-save-behavior nil)) + (t nil))) + + (when doit + (progn + (auth-source-do-debug + "secrets-create-item: wrote 1 new item to %s" collection) + (message "Saved new authentication information to %s" collection) + (apply 'secrets-create-item collection item secret args))))) ;;; Backend specific parsing: Mac OS Keychain (using /usr/bin/security) backend @@ -1970,6 +2166,77 @@ entries for git.gnus.org: (plstore-get-file (oref backend data)))) (plstore-save (oref backend data))))) +;;; Backend specific parsing: JSON backend +;; (auth-source-search :max 1 :machine "imap.gmail.com") +;; (auth-source-search :max 1 :host '("my-gmail" "imap.gmail.com") :port '(993 "imaps" "imap" "993" "143") :user nil :require '(:user :secret)) + +(defun auth-source-json-check (host user port require item) + (and item + (auth-source-search-collection + (or host t) + (or + (plist-get item :machine) + (plist-get item :host) + t)) + (auth-source-search-collection + (or user t) + (or + (plist-get item :login) + (plist-get item :account) + (plist-get item :user) + t)) + (auth-source-search-collection + (or port t) + (or + (plist-get item :port) + (plist-get item :protocol) + t)) + (or + ;; the required list of keys is nil, or + (null require) + ;; every element of require is in + (cl-loop for req in require + always (plist-get item req))))) + +(cl-defun auth-source-json-search (&rest spec + &key backend require + type max host user port + &allow-other-keys) + "Given a property list SPEC, return search matches from the :backend. +See `auth-source-search' for details on SPEC." + ;; just in case, check that the type is correct (null or same as the backend) + (cl-assert (or (null type) (eq type (oref backend type))) + t "Invalid JSON search: %s %s") + + ;; Hide the secrets early to avoid accidental exposure. + (let* ((jdata + (mapcar (lambda (entry) + (let (ret) + (while entry + (let* ((item (pop entry)) + (k (auth-source--symbol-keyword (car item))) + (v (cdr item))) + (setq k (cond ((memq k '(:machine)) :host) + ((memq k '(:login :account)) :user) + ((memq k '(:protocol)) :port) + ((memq k '(:password)) :secret) + (t k))) + ;; send back the secret in a function (lexical binding) + (when (eq k :secret) + (setq v (let ((lexv v)) + (lambda () lexv)))) + (setq ret (plist-put ret k v)))) + ret)) + (json-read-file (oref backend source)))) + (max (or max 5000)) ; sanity check: default to stop at 5K + all) + (dolist (item jdata) + (when (and item + (> max (length all)) + (auth-source-json-check host user port require item)) + (push item all))) + (nreverse all))) + ;;; older API ;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz") diff --git a/lisp/autoarg.el b/lisp/autoarg.el index d344d273538..97e9d6be9cc 100644 --- a/lisp/autoarg.el +++ b/lisp/autoarg.el @@ -90,9 +90,6 @@ ;;;###autoload (define-minor-mode autoarg-mode "Toggle Autoarg mode, a global minor mode. -With a prefix argument ARG, enable Autoarg mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. \\<autoarg-mode-map> In Autoarg mode, digits are bound to `digit-argument', i.e. they @@ -116,9 +113,6 @@ then invokes the normal binding of \\[autoarg-terminate]. ;;;###autoload (define-minor-mode autoarg-kp-mode "Toggle Autoarg-KP mode, a global minor mode. -With a prefix argument ARG, enable Autoarg-KP mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. \\<autoarg-kp-mode-map> This is similar to `autoarg-mode' but rebinds the keypad keys diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el index 1e606dde208..a77ca091d29 100644 --- a/lisp/autoinsert.el +++ b/lisp/autoinsert.el @@ -1,4 +1,4 @@ -;;; autoinsert.el --- automatic mode-dependent insertion of text into new files +;;; autoinsert.el --- automatic mode-dependent insertion of text into new files -*- lexical-binding: t -*- ;; Copyright (C) 1985-1987, 1994-1995, 1998, 2000-2019 Free Software ;; Foundation, Inc. @@ -49,6 +49,8 @@ ;;; Code: +(require 'seq) + (defgroup auto-insert nil "Automatic mode-dependent insertion of text into new files." :prefix "auto-insert-" @@ -72,22 +74,19 @@ With \\[auto-insert], this is always treated as if it were t." :type '(choice (const :tag "Insert if possible" t) (const :tag "Do nothing" nil) (other :tag "insert if possible, mark as unmodified." - not-modified)) - :group 'auto-insert) + not-modified))) (defcustom auto-insert-query 'function "Non-nil means ask user before auto-inserting. When this is `function', only ask when called non-interactively." :type '(choice (const :tag "Don't ask" nil) (const :tag "Ask if called non-interactively" function) - (other :tag "Ask" t)) - :group 'auto-insert) + (other :tag "Ask" t))) (defcustom auto-insert-prompt "Perform %s auto-insertion? " "Prompt to use when querying whether to auto-insert. If this contains a %s, that will be replaced by the matching rule." - :type 'string - :group 'auto-insert) + :type 'string) (defcustom auto-insert-alist @@ -141,14 +140,14 @@ If this contains a %s, that will be replaced by the matching rule." " .\\\" You may distribute this file under the terms of the GNU Free .\\\" Documentation License. -.TH " (file-name-base) +.TH " (file-name-base (buffer-file-name)) " " (file-name-extension (buffer-file-name)) " " (format-time-string "%Y-%m-%d ") "\n.SH NAME\n" - (file-name-base) + (file-name-base (buffer-file-name)) " \\- " str "\n.SH SYNOPSIS -.B " (file-name-base) +.B " (file-name-base (buffer-file-name)) "\n" _ " @@ -211,7 +210,7 @@ If this contains a %s, that will be replaced by the matching rule." \(provide '" - (file-name-base) + (file-name-base (buffer-file-name)) ") \;;; " (file-name-nondirectory (buffer-file-name)) " ends here\n") (("\\.texi\\(nfo\\)?\\'" . "Texinfo file skeleton") @@ -219,7 +218,7 @@ If this contains a %s, that will be replaced by the matching rule." "\\input texinfo @c -*-texinfo-*- @c %**start of header @setfilename " - (file-name-base) ".info\n" + (file-name-base (buffer-file-name)) ".info\n" "@settitle " str " @c %**end of header @copying\n" @@ -316,8 +315,7 @@ described above, e.g. [\"header.insert\" date-and-author-update]." ;; There's no custom equivalent of "repeat" for vectors. :value-type (choice file function (sexp :tag "Skeleton or vector"))) - :version "25.1" - :group 'auto-insert) + :version "25.1") ;; Establish a default value for auto-insert-directory @@ -325,8 +323,7 @@ described above, e.g. [\"header.insert\" date-and-author-update]." "Directory from which auto-inserted files are taken. The value must be an absolute directory name; thus, on a GNU or Unix system, it must end in a slash." - :type 'directory - :group 'auto-insert) + :type 'directory) ;;;###autoload @@ -338,23 +335,23 @@ Matches the visited file name against the elements of `auto-insert-alist'." (or (eq this-command 'auto-insert) (and auto-insert (bobp) (eobp))) - (let ((alist auto-insert-alist) - case-fold-search cond desc action) - (goto-char 1) - ;; find first matching alist entry - (while alist - (if (atom (setq cond (car (car alist)))) - (setq desc cond) - (setq desc (cdr cond) - cond (car cond))) - (if (if (symbolp cond) - (derived-mode-p cond) - (and buffer-file-name - (string-match cond buffer-file-name))) - (setq action (cdr (car alist)) - alist nil) - (setq alist (cdr alist)))) - + (let* ((case-fold-search nil) + (desc nil) + ;; Find first matching alist entry. + (action + (seq-some + (pcase-lambda (`(,cond . ,action)) + (if (atom cond) + (setq desc cond) + (setq desc (cdr cond) + cond (car cond))) + (when (if (symbolp cond) + (derived-mode-p cond) + (and buffer-file-name + (string-match cond buffer-file-name))) + action)) + auto-insert-alist))) + (goto-char 1) ;; Now, if we found something, do it (and action (or (not (stringp action)) @@ -412,9 +409,6 @@ or if CONDITION had no actions, after all other CONDITIONs." ;;;###autoload (define-minor-mode auto-insert-mode "Toggle Auto-insert mode, a global minor mode. -With a prefix argument ARG, enable Auto-insert mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. 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." diff --git a/lisp/autorevert.el b/lisp/autorevert.el index 58c5dba3160..6cdc1d3a297 100644 --- a/lisp/autorevert.el +++ b/lisp/autorevert.el @@ -107,7 +107,7 @@ ;; Dependencies: -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) (require 'timer) (require 'filenotify) @@ -126,8 +126,6 @@ Global Auto-Revert Mode does so in all buffers." ;; Variables: -;;; What's this?: ;; Autoload for the benefit of `make-mode-line-mouse-sensitive'. -;;; What's this?: ;;;###autoload (defvar auto-revert-mode nil "Non-nil when Auto-Revert Mode is active. Never set this variable directly, use the command `auto-revert-mode' instead.") @@ -268,7 +266,10 @@ buffers. CPU usage depends on the version control system." (defvar-local global-auto-revert-ignore-buffer nil "When non-nil, Global Auto-Revert Mode will not revert this buffer. -This variable becomes buffer local when set in any fashion.") +This variable can also be a predicate function, in which case +it'll be called with one parameter (the buffer in question), and +it should return non-nil to make Global Auto-Revert Mode not +revert this buffer.") (defcustom auto-revert-remote-files nil "If non-nil remote files are also reverted." @@ -302,6 +303,27 @@ You should set this variable through Custom." :type 'regexp :version "24.4") +(defcustom auto-revert-avoid-polling nil + "Non-nil to avoid polling files when notification is available. + +Set this variable to a non-nil value to save power by avoiding +polling when possible. Files on file-systems that do not support +change notifications must match `auto-revert-notify-exclude-dir-regexp' +for Auto-Revert to work properly in this case. This typically +includes files on network file systems on Unix-like machines, +when those files are modified from another computer. + +When nil, buffers in Auto-Revert Mode will always be polled for +changes to their files on disk every `auto-revert-interval' +seconds, in addition to using notification for those files." + :group 'auto-revert + :type 'boolean + :set (lambda (variable value) + (set-default variable value) + (when (fboundp 'auto-revert-set-timer) + (auto-revert-set-timer))) + :version "27.1") + ;; Internal variables: (defvar auto-revert-buffer-list () @@ -313,6 +335,9 @@ buffers to this list. The timer function `auto-revert-buffers' is responsible for purging the list of old buffers.") +(defvar-local auto-revert--global-mode nil + "Non-nil if buffer is handled by Global Auto-Revert mode.") + (defvar auto-revert-remaining-buffers () "Buffers not checked when user input stopped execution.") @@ -321,17 +346,19 @@ the list of old buffers.") (defun auto-revert-find-file-function () (setq-local auto-revert-tail-pos - (nth 7 (file-attributes buffer-file-name)))) + (file-attribute-size (file-attributes buffer-file-name)))) (add-hook 'find-file-hook #'auto-revert-find-file-function) +(add-hook 'after-set-visited-file-name-hook + #'auto-revert-set-visited-file-name) -(defvar auto-revert-notify-watch-descriptor-hash-list +(defvar auto-revert--buffers-by-watch-descriptor (make-hash-table :test 'equal) - "A hash table collecting all file watch descriptors. -Hash key is a watch descriptor, hash value is a list of buffers -which are related to files being watched and carrying the same -default directory.") + "A hash table mapping notification descriptors to lists of buffers. +The buffers use that descriptor for auto-revert notifications. +The key is equal to `auto-revert-notify-watch-descriptor' in each +buffer.") (defvar-local auto-revert-notify-watch-descriptor nil "The file watch descriptor active for the current buffer.") @@ -341,19 +368,20 @@ default directory.") "Non-nil when file has been modified on the file system. This has been reported by a file notification event.") +(defvar auto-revert-debug nil + "Use for debug messages.") + ;; Functions: -(defun auto-revert-remove-current-buffer () - "Remove dead buffer from `auto-revert-buffer-list'." +(defun auto-revert-remove-current-buffer (&optional buffer) + "Remove BUFFER from `auto-revert-buffer-list'. +BUFFER defaults to `current-buffer'." (setq auto-revert-buffer-list - (delq (current-buffer) auto-revert-buffer-list))) + (delq (or buffer (current-buffer)) auto-revert-buffer-list))) ;;;###autoload (define-minor-mode auto-revert-mode "Toggle reverting buffer when the file changes (Auto-Revert Mode). -With a prefix argument ARG, enable Auto-Revert Mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Auto-Revert Mode is a minor mode that affects only the current buffer. When enabled, it reverts the buffer when the file on @@ -373,7 +401,7 @@ without being changed in the part that is already in the buffer." 'kill-buffer-hook #'auto-revert-remove-current-buffer nil t)) - (when auto-revert-use-notify (auto-revert-notify-rm-watch)) + (when auto-revert-notify-watch-descriptor (auto-revert-notify-rm-watch)) (auto-revert-remove-current-buffer)) (auto-revert-set-timer) (when auto-revert-mode @@ -393,9 +421,6 @@ This function is designed to be added to hooks, for example: ;;;###autoload (define-minor-mode auto-revert-tail-mode "Toggle reverting tail of buffer when the file grows. -With a prefix argument ARG, enable Auto-Revert Tail Mode if ARG -is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. When Auto-Revert Tail Mode is enabled, the tail of the file is constantly followed, as with the shell command `tail -f'. This @@ -440,7 +465,8 @@ Perform a full revert? ") (add-hook 'before-save-hook (lambda () (auto-revert-tail-mode 0)) nil t) (or (local-variable-p 'auto-revert-tail-pos) ; don't lose prior position (setq-local auto-revert-tail-pos - (nth 7 (file-attributes buffer-file-name)))) + (file-attribute-size + (file-attributes buffer-file-name)))) ;; let auto-revert-mode set up the mechanism for us if it isn't already (or auto-revert-mode (let ((auto-revert-tail-mode t)) @@ -460,9 +486,6 @@ This function is designed to be added to hooks, for example: ;;;###autoload (define-minor-mode global-auto-revert-mode "Toggle Global Auto-Revert Mode. -With a prefix argument ARG, enable Global Auto-Revert Mode if ARG -is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. Global Auto-Revert Mode is a global minor mode that reverts any buffer associated with a file when the file changes on disk. Use @@ -483,11 +506,110 @@ specifies in the mode line." :global t :group 'auto-revert :lighter global-auto-revert-mode-text (auto-revert-set-timer) (if global-auto-revert-mode - (auto-revert-buffers) + ;; Turn global-auto-revert-mode ON. + (progn + (dolist (buf (buffer-list)) + (with-current-buffer buf + (auto-revert--global-add-current-buffer))) + ;; Make sure future buffers are added as well. + (add-hook 'find-file-hook #'auto-revert--global-adopt-current-buffer) + ;; To track non-file buffers, we need to listen in to buffer + ;; creation in general. Listening to major-mode changes is + ;; suitable, since we then know whether it's a mode that is tracked. + (when global-auto-revert-non-file-buffers + (add-hook 'after-change-major-mode-hook + #'auto-revert--global-adopt-current-buffer)) + (auto-revert-buffers)) + ;; Turn global-auto-revert-mode OFF. + (remove-hook 'after-change-major-mode-hook + #'auto-revert--global-adopt-current-buffer) + (remove-hook 'find-file-hook #'auto-revert--global-adopt-current-buffer) (dolist (buf (buffer-list)) (with-current-buffer buf - (when auto-revert-use-notify - (auto-revert-notify-rm-watch)))))) + (when auto-revert--global-mode + (setq auto-revert--global-mode nil) + (when (and auto-revert-notify-watch-descriptor + (not (or auto-revert-mode auto-revert-tail-mode))) + (auto-revert-notify-rm-watch))))))) + +(defun auto-revert--global-add-current-buffer () + "Set current buffer to be tracked by Global Auto-Revert if appropriate." + (when (and (not auto-revert--global-mode) + (or buffer-file-name + (and global-auto-revert-non-file-buffers + (not (string-prefix-p " " (buffer-name))) + ;; Any non-file buffer must have a custom + ;; `buffer-stale-function' to be tracked, since + ;; we wouldn't know when to revert it otherwise. + (not (eq buffer-stale-function + #'buffer-stale--default-function)))) + (not (memq 'major-mode global-auto-revert-ignore-modes)) + (or (null global-auto-revert-ignore-buffer) + (if (functionp global-auto-revert-ignore-buffer) + (not (funcall global-auto-revert-ignore-buffer + (current-buffer))) + nil))) + (setq auto-revert--global-mode t))) + +(defun auto-revert--global-adopt-current-buffer () + "Consider tracking current buffer in a running Global Auto-Revert mode." + (auto-revert--global-add-current-buffer) + (auto-revert-set-timer)) + +(defun auto-revert-set-visited-file-name () + "Update Auto-Revert management of the current buffer. +Called after `set-visited-file-name'." + (when auto-revert-notify-watch-descriptor + ;; Remove any existing notifier so that we don't track the wrong + ;; file in case the file name was changed. + (auto-revert-notify-rm-watch)) + (cond (global-auto-revert-mode + (auto-revert--global-adopt-current-buffer)) + ((or auto-revert-mode auto-revert-tail-mode) + (auto-revert-set-timer)))) + +(defun auto-revert--polled-buffers () + "List of buffers that need to be polled." + (cond (global-auto-revert-mode + (mapcan (lambda (buffer) + (and (not (and auto-revert-avoid-polling + (buffer-local-value + 'auto-revert-notify-watch-descriptor + buffer))) + (or (buffer-local-value + 'auto-revert--global-mode buffer) + (buffer-local-value 'auto-revert-mode buffer) + (buffer-local-value 'auto-revert-tail-mode buffer)) + (list buffer))) + (buffer-list))) + (auto-revert-avoid-polling + (mapcan (lambda (buffer) + (and (not (buffer-local-value + 'auto-revert-notify-watch-descriptor buffer)) + (list buffer))) + auto-revert-buffer-list)) + (t auto-revert-buffer-list))) + +;; Same as above in a boolean context, but cheaper. +(defun auto-revert--need-polling-p () + "Whether periodic polling is required." + (cond (global-auto-revert-mode + (or (not auto-revert-avoid-polling) + (cl-some + (lambda (buffer) + (and (not (buffer-local-value + 'auto-revert-notify-watch-descriptor buffer)) + (or (buffer-local-value 'auto-revert--global-mode buffer) + (buffer-local-value 'auto-revert-mode buffer) + (buffer-local-value 'auto-revert-tail-mode buffer)))) + (buffer-list)))) + (auto-revert-avoid-polling + (not (cl-every + (lambda (buffer) + (buffer-local-value + 'auto-revert-notify-watch-descriptor buffer)) + auto-revert-buffer-list))) + (t auto-revert-buffer-list))) (defun auto-revert-set-timer () "Restart or cancel the timer used by Auto-Revert Mode. @@ -499,87 +621,86 @@ will use an up-to-date value of `auto-revert-interval'" (if (timerp auto-revert-timer) (cancel-timer auto-revert-timer)) (setq auto-revert-timer - (if (or global-auto-revert-mode auto-revert-buffer-list) - (run-with-timer auto-revert-interval - auto-revert-interval - 'auto-revert-buffers)))) + (and (auto-revert--need-polling-p) + (run-with-timer auto-revert-interval + auto-revert-interval + 'auto-revert-buffers)))) (defun auto-revert-notify-rm-watch () "Disable file notification for current buffer's associated file." - (when auto-revert-notify-watch-descriptor - (maphash - (lambda (key value) - (when (equal key auto-revert-notify-watch-descriptor) - (setq value (delete (current-buffer) value)) - (if value - (puthash key value auto-revert-notify-watch-descriptor-hash-list) - (remhash key auto-revert-notify-watch-descriptor-hash-list) - (ignore-errors - (file-notify-rm-watch auto-revert-notify-watch-descriptor))))) - auto-revert-notify-watch-descriptor-hash-list) - (remove-hook 'kill-buffer-hook #'auto-revert-notify-rm-watch)) + (let ((desc auto-revert-notify-watch-descriptor) + (table auto-revert--buffers-by-watch-descriptor)) + (when desc + (let ((buffers (delq (current-buffer) (gethash desc table)))) + (if buffers + (puthash desc buffers table) + (remhash desc table))) + (ignore-errors + (file-notify-rm-watch desc)) + (remove-hook 'kill-buffer-hook #'auto-revert-notify-rm-watch t))) (setq auto-revert-notify-watch-descriptor nil auto-revert-notify-modified-p nil)) (defun auto-revert-notify-add-watch () "Enable file notification for current buffer's associated file." - ;; We can assume that `buffer-file-name' and - ;; `auto-revert-use-notify' are non-nil. - (if (or (string-match auto-revert-notify-exclude-dir-regexp - (expand-file-name default-directory)) - (file-symlink-p (or buffer-file-name default-directory))) - - ;; Fallback to file checks. - (setq-local auto-revert-use-notify nil) - - (when (not auto-revert-notify-watch-descriptor) - (setq auto-revert-notify-watch-descriptor - (ignore-errors - (if buffer-file-name - (file-notify-add-watch - (expand-file-name buffer-file-name default-directory) - '(change attribute-change) - 'auto-revert-notify-handler) + ;; We can assume that `auto-revert-notify-watch-descriptor' is nil. + (unless (or auto-revert-notify-watch-descriptor + (string-match auto-revert-notify-exclude-dir-regexp + (expand-file-name default-directory)) + (file-symlink-p (or buffer-file-name default-directory))) + ;; Check, whether this has been activated already. + (let ((file (if buffer-file-name + (expand-file-name buffer-file-name default-directory) + (expand-file-name default-directory)))) + (maphash + (lambda (key _value) + (when (and + (file-notify-valid-p key) + (equal (file-notify--watch-absolute-filename + (gethash key file-notify-descriptors)) + (directory-file-name file)) + (equal (file-notify--watch-callback + (gethash key file-notify-descriptors)) + 'auto-revert-notify-handler)) + (setq auto-revert-notify-watch-descriptor key))) + auto-revert--buffers-by-watch-descriptor) + ;; Create a new watch if needed. + (unless auto-revert-notify-watch-descriptor + (setq auto-revert-notify-watch-descriptor + (ignore-errors (file-notify-add-watch - (expand-file-name default-directory) - '(change) - 'auto-revert-notify-handler)))) - (if auto-revert-notify-watch-descriptor - (progn - (puthash - auto-revert-notify-watch-descriptor - (cons (current-buffer) - (gethash auto-revert-notify-watch-descriptor - auto-revert-notify-watch-descriptor-hash-list)) - auto-revert-notify-watch-descriptor-hash-list) - (add-hook 'kill-buffer-hook - #'auto-revert-notify-rm-watch nil t)) - ;; Fallback to file checks. - (setq-local auto-revert-use-notify nil))))) + file + (if buffer-file-name '(change attribute-change) '(change)) + 'auto-revert-notify-handler)))) + (when auto-revert-notify-watch-descriptor + (setq auto-revert-notify-modified-p t) + (puthash + auto-revert-notify-watch-descriptor + (cons (current-buffer) + (gethash auto-revert-notify-watch-descriptor + auto-revert--buffers-by-watch-descriptor)) + auto-revert--buffers-by-watch-descriptor) + (add-hook 'kill-buffer-hook #'auto-revert-notify-rm-watch nil t))))) ;; If we have file notifications, we want to update the auto-revert buffers ;; immediately when a notification occurs. Since file updates can happen very ;; often, we want to skip some revert operations so that we don't spend all our ;; time reverting the buffer. ;; -;; We do this by reverting immediately in response to the first in a flurry of -;; notifications. We suppress subsequent notifications until the next time -;; `auto-revert-buffers' is called (this happens on a timer with a period set by -;; `auto-revert-interval'). -(defvar auto-revert-buffers-counter 1 - "Incremented each time `auto-revert-buffers' is called") -(defvar-local auto-revert-buffers-counter-lockedout 0 - "Buffer-local value to indicate whether we should immediately -update the buffer on a notification event or not. If - - (= auto-revert-buffers-counter-lockedout - auto-revert-buffers-counter) - -then the updates are locked out, and we wait until the next call -of `auto-revert-buffers' to revert the buffer. If no lockout is -present, then we revert immediately and set the lockout, so that -no more reverts are possible until the next call of -`auto-revert-buffers'") +;; We do this by reverting immediately in response to the first in a +;; flurry of notifications. Any notifications during the following +;; `auto-revert-lockout-interval' seconds are noted but not acted upon +;; until the end of that interval. + +(defconst auto-revert--lockout-interval 2.5 + "Duration, in seconds, of the Auto-Revert Mode notification lockout. +This is the quiescence after each notification of a file being +changed during which no automatic reverting takes place, to +prevent many updates in rapid succession from overwhelming the +system.") + +(defvar-local auto-revert--lockout-timer nil + "Timer awaiting the end of the notification lockout interval, or nil.") (defun auto-revert-notify-handler (event) "Handle an EVENT returned from file notification." @@ -589,30 +710,31 @@ no more reverts are possible until the next call of (file (nth 2 event)) (file1 (nth 3 event)) ;; Target of `renamed'. (buffers (gethash descriptor - auto-revert-notify-watch-descriptor-hash-list))) + auto-revert--buffers-by-watch-descriptor))) ;; Check, that event is meant for us. (cl-assert descriptor) ;; Since we watch a directory, a file name must be returned. (cl-assert (stringp file)) (when (eq action 'renamed) (cl-assert (stringp file1))) + (when auto-revert-debug + (message "auto-revert-notify-handler %S" event)) (if (eq action 'stopped) ;; File notification has stopped. Continue with polling. - (cl-dolist (buffer - (if global-auto-revert-mode - (buffer-list) auto-revert-buffer-list)) + (cl-dolist (buffer buffers) (with-current-buffer buffer - (when (and (equal descriptor auto-revert-notify-watch-descriptor) - (or - ;; A buffer associated with a file. - (and (stringp buffer-file-name) - (string-equal - (file-name-nondirectory file) - (file-name-nondirectory buffer-file-name))) - ;; A buffer w/o a file, like dired. - (null buffer-file-name))) + (when (or + ;; A buffer associated with a file. + (and (stringp buffer-file-name) + (string-equal + (file-name-nondirectory file) + (file-name-nondirectory buffer-file-name))) + ;; A buffer w/o a file, like dired. + (null buffer-file-name)) (auto-revert-notify-rm-watch) - (setq-local auto-revert-use-notify nil)))) + ;; Restart the timer if it wasn't running. + (unless auto-revert-timer) + (auto-revert-set-timer)))) ;; Loop over all buffers, in order to find the intended one. (cl-dolist (buffer buffers) @@ -638,24 +760,27 @@ no more reverts are possible until the next call of (setq auto-revert-notify-modified-p t) ;; Revert the buffer now if we're not locked out. - (when (/= auto-revert-buffers-counter-lockedout - auto-revert-buffers-counter) + (unless auto-revert--lockout-timer (auto-revert-handler) - (setq auto-revert-buffers-counter-lockedout - auto-revert-buffers-counter)) - - ;; No need to check other buffers. - (cl-return))))))))) + (setq auto-revert--lockout-timer + (run-with-timer + auto-revert--lockout-interval nil + #'auto-revert--end-lockout buffer))))))))))) + +(defun auto-revert--end-lockout (buffer) + "End the lockout period after a notification. +If the buffer needs to be reverted, do it now." + (when (buffer-live-p buffer) + (with-current-buffer buffer + (setq auto-revert--lockout-timer nil) + (when auto-revert-notify-modified-p + (auto-revert-handler))))) (defun auto-revert-active-p () - "Check if auto-revert is active (in current buffer or globally)." + "Check if auto-revert is active in current buffer." (or auto-revert-mode auto-revert-tail-mode - (and - global-auto-revert-mode - (not global-auto-revert-ignore-buffer) - (not (memq major-mode - global-auto-revert-ignore-modes))))) + auto-revert--global-mode)) (defun auto-revert-handler () "Revert current buffer, if appropriate. @@ -669,14 +794,14 @@ This is an internal function used by Auto-Revert Mode." (if buffer-file-name (and (or auto-revert-remote-files (not (file-remote-p buffer-file-name))) - (or (not auto-revert-use-notify) + (or (not auto-revert-notify-watch-descriptor) auto-revert-notify-modified-p) (if auto-revert-tail-mode (and (file-readable-p buffer-file-name) (/= auto-revert-tail-pos (setq size - (nth 7 (file-attributes - buffer-file-name))))) + (file-attribute-size + (file-attributes buffer-file-name))))) (funcall (or buffer-stale-function #'buffer-stale--default-function) t))) @@ -719,7 +844,8 @@ This is an internal function used by Auto-Revert Mode." ;; `preserve-modes' avoids changing the (minor) modes. But we do ;; want to reset the mode for VC, so we do it manually. (when (or revert auto-revert-check-vc-info) - (vc-refresh-state)))) + (let ((revert-buffer-in-progress-p t)) + (vc-refresh-state))))) (defun auto-revert-tail-handler (size) (let ((modified (buffer-modified-p)) @@ -767,14 +893,21 @@ This function is also responsible for removing buffers no longer in Auto-Revert Mode from `auto-revert-buffer-list', and for canceling the timer when no buffers need to be checked." - (setq auto-revert-buffers-counter - (1+ auto-revert-buffers-counter)) - (save-match-data - (let ((bufs (if global-auto-revert-mode - (buffer-list) - auto-revert-buffer-list)) + (let ((bufs (auto-revert--polled-buffers)) remaining new) + ;; Buffers with remote contents shall be reverted only if the + ;; connection is established already. + (setq bufs (delq nil + (mapcar + (lambda (buf) + (and (buffer-live-p buf) + (with-current-buffer buf + (and + (or (not (file-remote-p default-directory)) + (file-remote-p default-directory nil t)) + buf)))) + bufs))) ;; Partition `bufs' into two halves depending on whether or not ;; the buffers are in `auto-revert-remaining-buffers'. The two ;; halves are then re-joined with the "remaining" buffers at the @@ -790,29 +923,31 @@ the timer when no buffers need to be checked." (not (and auto-revert-stop-on-user-input (input-pending-p)))) (let ((buf (car bufs))) - (with-current-buffer buf - (if (buffer-live-p buf) - (progn - ;; Test if someone has turned off Auto-Revert Mode - ;; in a non-standard way, for example by changing - ;; major mode. - (if (and (not auto-revert-mode) - (not auto-revert-tail-mode) - (memq buf auto-revert-buffer-list)) - (auto-revert-remove-current-buffer)) - (when (auto-revert-active-p) - ;; Enable file notification. - (when (and auto-revert-use-notify - (not auto-revert-notify-watch-descriptor)) - (auto-revert-notify-add-watch)) - (auto-revert-handler))) + (if (not (buffer-live-p buf)) ;; Remove dead buffer from `auto-revert-buffer-list'. - (auto-revert-remove-current-buffer)))) + (auto-revert-remove-current-buffer buf) + (with-current-buffer buf + ;; Test if someone has turned off Auto-Revert Mode + ;; in a non-standard way, for example by changing + ;; major mode. + (if (and (not auto-revert-mode) + (not auto-revert-tail-mode) + (memq buf auto-revert-buffer-list)) + (auto-revert-remove-current-buffer)) + (when (auto-revert-active-p) + ;; Enable file notification. + ;; Don't bother creating a notifier for non-file buffers + ;; unless it explicitly indicates that this works. + (when (and auto-revert-use-notify + (not auto-revert-notify-watch-descriptor) + (or buffer-file-name + buffer-auto-revert-by-notification)) + (auto-revert-notify-add-watch)) + (auto-revert-handler))))) (setq bufs (cdr bufs))) (setq auto-revert-remaining-buffers bufs) ;; Check if we should cancel the timer. - (when (and (not global-auto-revert-mode) - (null auto-revert-buffer-list)) + (unless (auto-revert--need-polling-p) (if (timerp auto-revert-timer) (cancel-timer auto-revert-timer)) (setq auto-revert-timer nil))))) diff --git a/lisp/avoid.el b/lisp/avoid.el index 0ad1b0ba535..7d69fa2a247 100644 --- a/lisp/avoid.el +++ b/lisp/avoid.el @@ -205,8 +205,8 @@ If you want the mouse banished to a different corner set 'frame-or-window mouse-avoidance-banish-position 'eq)) (list-values (pcase fra-or-win - (`frame (list 0 0 (frame-width) (frame-height))) - (`window (window-edges)))) + ('frame (list 0 0 (frame-width) (frame-height))) + ('window (window-edges)))) (alist (cl-loop for v in list-values for k in '(left top right bottom) collect (cons k v))) @@ -223,11 +223,11 @@ If you want the mouse banished to a different corner set 'top-or-bottom-pos mouse-avoidance-banish-position #'eq)) (side-fn (pcase side - (`left '+) - (`right '-))) + ('left '+) + ('right '-))) (top-or-bottom-fn (pcase top-or-bottom - (`top '+) - (`bottom '-)))) + ('top '+) + ('bottom '-)))) (cons (funcall side-fn ; -/+ (assoc-default side alist 'eq) ; right or left side-dist) ; distance from side diff --git a/lisp/battery.el b/lisp/battery.el index e23dab4c91a..7037d07dcf0 100644 --- a/lisp/battery.el +++ b/lisp/battery.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1997-1998, 2000-2019 Free Software Foundation, Inc. -;; Author: Ralph Schleicher <rs@nunatak.allgaeu.org> +;; Author: Ralph Schleicher <rs@ralph-schleicher.de> ;; Keywords: hardware ;; This file is part of GNU Emacs. @@ -175,9 +175,6 @@ The text being displayed in the echo area is controlled by the variables ;;;###autoload (define-minor-mode display-battery-mode "Toggle battery status display in mode line (Display Battery mode). -With a prefix argument ARG, enable Display Battery mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. The text displayed in the mode line is controlled by `battery-mode-line-format' and `battery-status-function'. @@ -378,12 +375,12 @@ The following %-sequences are provided: last-full-capacity design-capacity)) (and capacity rate (setq minutes (if (zerop rate) 0 - (floor (* (/ (float (if (string= charging-state - "charging") - (- full-capacity capacity) - capacity)) - rate) - 60))) + (floor (* (if (string= charging-state + "charging") + (- full-capacity capacity) + capacity) + 60) + rate)) hours (/ minutes 60))) (list (cons ?c (or (and capacity (number-to-string capacity)) "N/A")) (cons ?L (or (battery-search-for-one-match-in-files @@ -417,8 +414,7 @@ The following %-sequences are provided: (cons ?p (or (and full-capacity capacity (> full-capacity 0) (number-to-string - (floor (/ capacity - (/ (float full-capacity) 100))))) + (floor (* 100 capacity) full-capacity))) "N/A"))))) @@ -474,9 +470,9 @@ The following %-sequences are provided: "POWER_SUPPLY_\\(CURRENT\\|POWER\\)_NOW=\\([0-9]*\\)$" nil t) (cl-incf power-now - (* (float (string-to-number (match-string 2))) + (* (string-to-number (match-string 2)) (if (eq (char-after (match-beginning 1)) ?C) - voltage-now 1.0)))) + voltage-now 1)))) (goto-char (point-min)) (when (re-search-forward "POWER_SUPPLY_TEMP=\\([0-9]*\\)$" nil t) (setq temperature (match-string 1))) @@ -588,9 +584,7 @@ The following %-sequences are provided: (when seconds (setq minutes (/ seconds 60) hours (/ minutes 60) - remaining-time - (format "%d:%02d" (truncate hours) - (- (truncate minutes) (* 60 (truncate hours)))))) + remaining-time (format "%d:%02d" hours (mod minutes 60)))) (list (cons ?c (or (and energy (number-to-string (round (* 1000 energy)))) "N/A")) @@ -623,46 +617,71 @@ The following %-sequences are provided: %h Remaining battery charge time in hours %t Remaining battery charge time in the form `h:min'" (let* ((os-name (car (split-string - (shell-command-to-string "/usr/bin/uname")))) - (apm-flag (if (equal os-name "OpenBSD") "P" "s")) - (apm-cmd (concat "/usr/sbin/apm -ablm" apm-flag)) - (apm-output (split-string (shell-command-to-string apm-cmd))) - ;; Battery status - (battery-status - (let ((stat (string-to-number (nth 0 apm-output)))) - (cond ((eq stat 0) '("high" . "")) - ((eq stat 1) '("low" . "-")) - ((eq stat 2) '("critical" . "!")) - ((eq stat 3) '("charging" . "+")) - ((eq stat 4) '("absent" . nil))))) - ;; Battery percentage - (battery-percentage (nth 1 apm-output)) - ;; Battery life - (battery-life (nth 2 apm-output)) - ;; AC status - (line-status - (let ((ac (string-to-number (nth 3 apm-output)))) - (cond ((eq ac 0) "disconnected") - ((eq ac 1) "connected") - ((eq ac 2) "backup power")))) - ;; Advanced power savings mode - (apm-mode - (let ((apm (string-to-number (nth 4 apm-output)))) - (if (string= os-name "OpenBSD") - (cond ((eq apm 0) "manual") - ((eq apm 1) "automatic") - ((eq apm 2) "cool running")) - (if (eq apm 1) "on" "off")))) + ;; FIXME: Can't we use something like `system-type'? + (shell-command-to-string "/usr/bin/uname")))) + (apm-flag (pcase os-name + ("OpenBSD" "mP") + ("FreeBSD" "st") + (_ "ms"))) + (apm-cmd (concat "/usr/sbin/apm -abl" apm-flag)) + (apm-output (split-string (shell-command-to-string apm-cmd))) + (indices (pcase os-name + ;; FreeBSD's manpage documents that multiple + ;; outputs are ordered by "the order in which + ;; they're listed in the manpage", which is alphabetical + ;; and is also the order in which we pass them. + ("FreeBSD" '((ac . 0) + (battery-status . 1) + (battery-percent . 2) + (apm-mode . 3) + (battery-life . 4))) + ;; For NetBSD and OpenBSD, the manpage doesn't document + ;; the order. The previous code used this order, so let's + ;; assume it's right. + (_ '((ac . 3) + (battery-status . 0) + (battery-percent . 1) + (apm-mode . 4) + (battery-life . 2))))) + ;; Battery status + (battery-status + (pcase (string-to-number + (nth (alist-get 'battery-status indices) apm-output)) + (0 '("high" . "")) + (1 '("low" . "-")) + (2 '("critical" . "!")) + (3 '("charging" . "+")) + (4 '("absent" . nil)))) + ;; Battery percentage + (battery-percentage + (nth (alist-get 'battery-percent indices) apm-output)) + ;; Battery life + (battery-life (nth (alist-get 'battery-life indices) apm-output)) + ;; AC status + (line-status + (pcase (string-to-number (nth (alist-get 'ac indices) apm-output)) + (0 "disconnected") + (1 "connected") + (2 "backup power"))) + ;; Advanced power savings mode + (apm-mode + (let ((apm (string-to-number + (nth (alist-get 'apm-mode indices) apm-output)))) + (if (string= os-name "OpenBSD") + (pcase apm + (0 "manual") + (1 "automatic") + (2 "cool running")) + (if (eql apm 1) "on" "off")))) seconds minutes hours remaining-time) (unless (member battery-life '("unknown" "-1")) (if (member os-name '("OpenBSD" "NetBSD")) (setq minutes (string-to-number battery-life) seconds (* 60 minutes)) (setq seconds (string-to-number battery-life) - minutes (truncate (/ seconds 60)))) - (setq hours (truncate (/ minutes 60)) - remaining-time (format "%d:%02d" hours - (- minutes (* 60 hours))))) + minutes (truncate seconds 60))) + (setq hours (truncate minutes 60) + remaining-time (format "%d:%02d" hours (mod minutes 60)))) (list (cons ?L (or line-status "N/A")) (cons ?B (or (car battery-status) "N/A")) (cons ?b (or (cdr battery-status) "N/A")) diff --git a/lisp/bindings.el b/lisp/bindings.el index 210cf59e4f7..0be14587981 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -124,17 +124,61 @@ corresponding to the mode line clicked." ;;; Mode line contents -(defcustom mode-line-default-help-echo - "mouse-1: Select (drag to resize)\n\ -mouse-2: Make current window occupy the whole frame\n\ -mouse-3: Remove current window from display" +(defun mode-line-default-help-echo (window) + "Return default help echo text for WINDOW's mode line." + (let* ((frame (window-frame window)) + (line-1a + ;; Show text to select window only if the window is not + ;; selected. + (not (eq window (frame-selected-window frame)))) + (line-1b + ;; Show text to drag mode line if either the window is not + ;; at the bottom of its frame or the minibuffer window of + ;; this frame can be resized. This matches a corresponding + ;; check in `mouse-drag-mode-line'. + (or (not (window-at-side-p window 'bottom)) + (let ((mini-window (minibuffer-window frame))) + (and (eq frame (window-frame mini-window)) + (or (minibuffer-window-active-p mini-window) + (not resize-mini-windows)))))) + (line-2 + ;; Show text make window occupy the whole frame + ;; only if it doesn't already do that. + (not (eq window (frame-root-window frame)))) + (line-3 + ;; Show text to delete window only if that's possible. + (not (eq window (frame-root-window frame))))) + (when (or line-1a line-1b line-2 line-3) + (concat + (when (or line-1a line-1b) + (concat + "mouse-1: " + (when line-1a "Select window") + (when line-1b + (if line-1a " (drag to resize)" "Drag to resize")) + (when (or line-2 line-3) "\n"))) + (when line-2 + (concat + "mouse-2: Make window occupy whole frame" + (when line-3 "\n"))) + (when line-3 + "mouse-3: Remove window from frame"))))) + +(defcustom mode-line-default-help-echo #'mode-line-default-help-echo "Default help text for the mode line. If the value is a string, it specifies the tooltip or echo area message to display when the mouse is moved over the mode line. -If the text at the mouse position has a `help-echo' text -property, that overrides this variable." - :type '(choice (const :tag "No help" :value nil) string) - :version "24.3" +If the value is a function, call that function with one argument +- the window whose mode line to display. If the text at the +mouse position has a `help-echo' text property, that overrides +this variable." + :type '(choice + (const :tag "No help" :value nil) + function + (string :value "mouse-1: Select (drag to resize)\n\ +mouse-2: Make current window occupy the whole frame\n\ +mouse-3: Remove current window from display")) + :version "27.1" :group 'mode-line) (defvar mode-line-front-space '(:eval (if (display-graphic-p) " " "-")) @@ -373,7 +417,7 @@ zero, otherwise they start from one." This option specifies both the field width and the type of offset displayed in `mode-line-position', a component of the default `mode-line-format'." - :type `(radio + :type '(radio (const :tag "nil: No offset is displayed" nil) (const :tag "\"%o\": Proportion of \"travel\" of the window through the buffer" (-3 "%o")) @@ -600,6 +644,11 @@ Switch to the most recently selected buffer other than the current one." (let ((indicator (car (nth 4 (car (cdr event)))))) (describe-minor-mode-from-indicator indicator))) +(defvar mode-line-defining-kbd-macro (propertize " Def" 'face 'font-lock-warning-face) + "String displayed in the mode line in keyboard macro recording mode.") +;;;###autoload +(put 'mode-line-defining-kbd-macro 'risky-local-variable t) + (defvar minor-mode-alist nil "\ Alist saying how to show minor modes in the mode line. Each element looks like (VARIABLE STRING); @@ -609,13 +658,14 @@ Actually, STRING need not be a string; any mode-line construct is okay. See `mode-line-format'.") ;;;###autoload (put 'minor-mode-alist 'risky-local-variable t) -;; Don't use purecopy here--some people want to change these strings. +;; Don't use purecopy here--some people want to change these strings, +;; also string properties are lost when put into pure space. (setq minor-mode-alist '((abbrev-mode " Abbrev") (overwrite-mode overwrite-mode) (auto-fill-function " Fill") ;; not really a minor mode... - (defining-kbd-macro " Def"))) + (defining-kbd-macro mode-line-defining-kbd-macro))) ;; These variables are used by autoloadable packages. ;; They are defined here so that they do not get overridden @@ -680,11 +730,11 @@ okay. See `mode-line-format'.") ;; FIXME: Maybe beginning-of-line, beginning-of-buffer, end-of-line, ;; end-of-buffer, end-of-file, buffer-read-only, and ;; file-supersession should all be user-errors! - `(beginning-of-line beginning-of-buffer end-of-line - end-of-buffer end-of-file buffer-read-only - file-supersession mark-inactive - user-error ;; That's the main one! - )) + '(beginning-of-line beginning-of-buffer end-of-line + end-of-buffer end-of-file buffer-read-only + file-supersession mark-inactive + user-error ;; That's the main one! + )) (make-variable-buffer-local 'indent-tabs-mode) @@ -702,7 +752,7 @@ okay. See `mode-line-format'.") buffer-file-format buffer-auto-save-file-format buffer-display-count buffer-display-time enable-multibyte-characters - buffer-file-coding-system)) + buffer-file-coding-system truncate-lines)) ;; We have base64, md5 and sha1 functions built in now. (provide 'base64) @@ -985,6 +1035,13 @@ if `inhibit-field-text-motion' is non-nil." (define-key search-map "hu" 'unhighlight-regexp) (define-key search-map "hf" 'hi-lock-find-patterns) (define-key search-map "hw" 'hi-lock-write-interactive-patterns) +(put 'highlight-regexp :advertised-binding [?\M-s ?h ?r]) +(put 'highlight-phrase :advertised-binding [?\M-s ?h ?p]) +(put 'highlight-lines-matching-regexp :advertised-binding [?\M-s ?h ?l]) +(put 'highlight-symbol-at-point :advertised-binding [?\M-s ?h ?.]) +(put 'unhighlight-regexp :advertised-binding [?\M-s ?h ?u]) +(put 'hi-lock-find-patterns :advertised-binding [?\M-s ?h ?f]) +(put 'hi-lock-write-interactive-patterns :advertised-binding [?\M-s ?h ?w]) ;;(defun function-key-error () ;; (interactive) @@ -1178,8 +1235,8 @@ if `inhibit-field-text-motion' is non-nil." (define-key ctl-x-map "\C-t" 'transpose-lines) (define-key esc-map ";" 'comment-dwim) -(define-key esc-map "j" 'indent-new-comment-line) -(define-key esc-map "\C-j" 'indent-new-comment-line) +(define-key esc-map "j" 'default-indent-new-line) +(define-key esc-map "\C-j" 'default-indent-new-line) (define-key ctl-x-map ";" 'comment-set-column) (define-key ctl-x-map [?\C-\;] 'comment-line) (define-key ctl-x-map "f" 'set-fill-column) diff --git a/lisp/bookmark.el b/lisp/bookmark.el index 0bc2688537e..f564cd6b431 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -1,11 +1,10 @@ -;;; bookmark.el --- set bookmarks, maybe annotate them, jump to them later +;;; bookmark.el --- set bookmarks, maybe annotate them, jump to them later -*- lexical-binding: t -*- ;; Copyright (C) 1993-1997, 2001-2019 Free Software Foundation, Inc. ;; Author: Karl Fogel <kfogel@red-bean.com> -;; Maintainer: Karl Fogel <kfogel@red-bean.com> ;; Created: July, 1993 -;; Keywords: bookmarks, placeholders, annotations +;; Keywords: convenience ;; This file is part of GNU Emacs. @@ -33,13 +32,11 @@ ;;; Code: (require 'pp) +(require 'text-property-search) (eval-when-compile (require 'cl-lib)) ;;; Misc comments: ;; -;; If variable bookmark-use-annotations is non-nil, an annotation is -;; queried for when setting a bookmark. -;; ;; The bookmark list is sorted lexically by default, but you can turn ;; this off by setting bookmark-sort-flag to nil. If it is nil, then ;; the list will be presented in the order it is recorded @@ -53,9 +50,8 @@ (defcustom bookmark-use-annotations nil - "If non-nil, saving a bookmark queries for an annotation in a buffer." - :type 'boolean - :group 'bookmark) + "If non-nil, setting a bookmark queries for an annotation in a buffer." + :type 'boolean) (defcustom bookmark-save-flag t @@ -75,28 +71,30 @@ behavior.) To specify the file in which to save them, modify the variable `bookmark-default-file'." - :type '(choice (const nil) integer (other t)) - :group 'bookmark) + :type '(choice (const nil) integer (other t))) -(defconst bookmark-old-default-file "~/.emacs-bkmrks" - "The `.emacs.bmk' file used to be called this name.") - - -;; defvared to avoid a compilation warning: -(defvar bookmark-file nil - "Old name for `bookmark-default-file'.") - +(define-obsolete-variable-alias 'bookmark-old-default-file + 'bookmark-default-file "27.1") +(define-obsolete-variable-alias 'bookmark-file 'bookmark-default-file "27.1") (defcustom bookmark-default-file - (if bookmark-file - ;; In case user set `bookmark-file' in her .emacs: - bookmark-file - (locate-user-emacs-file "bookmarks" ".emacs.bmk")) + (locate-user-emacs-file "bookmarks" ".emacs.bmk") "File in which to save bookmarks by default." - :type 'file + ;; The current default file is defined via the internal variable + ;; `bookmark-bookmarks-timestamp'. This does not affect the value + ;; of `bookmark-default-file'. + :type 'file) + +(defcustom bookmark-watch-bookmark-file t + "If non-nil watch the default bookmark file. +If this file has changed on disk since it was last loaded, query the user +whether to load it again. If the value is `silent' reload without querying. +This file defaults to `bookmark-default-file'. But during an Emacs session, +`bookmark-load' and `bookmark-save' can redefine the current default file." + :version "27.1" + :type 'boolean :group 'bookmark) - (defcustom bookmark-version-control 'nospecial "Whether or not to make numbered backups of the bookmark file. It can have four values: t, nil, `never', or `nospecial'. @@ -106,88 +104,75 @@ just use the value of `version-control'." :type '(choice (const :tag "If existing" nil) (const :tag "Never" never) (const :tag "Use value of option `version-control'" nospecial) - (other :tag "Always" t)) - :group 'bookmark) + (other :tag "Always" t))) (defcustom bookmark-completion-ignore-case t "Non-nil means bookmark functions ignore case in completion." - :type 'boolean - :group 'bookmark) + :type 'boolean) (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 - :group 'bookmark) + :type 'boolean) (defcustom bookmark-automatically-show-annotations t "Non-nil means show annotations when jumping to a bookmark." - :type 'boolean - :group 'bookmark) + :type 'boolean) + +(defconst bookmark-bmenu-buffer "*Bookmark List*" + "Name of buffer used for Bookmark List.") (defcustom bookmark-bmenu-use-header-line t "Non-nil means to use an immovable header line. This is as opposed to inline text at the top of the buffer." :version "24.4" - :type 'boolean - :group 'bookmark) + :type 'boolean) (defconst bookmark-bmenu-inline-header-height 2 - "Number of lines used for the *Bookmark List* header -\(only significant when `bookmark-bmenu-use-header-line' is nil).") + "Number of lines used for the *Bookmark List* header. +\(This is only significant when `bookmark-bmenu-use-header-line' +is nil.)") (defconst bookmark-bmenu-marks-width 2 - "Number of columns (chars) used for the *Bookmark List* marks column, -including the annotations column.") + "Number of columns (chars) used for the *Bookmark List* marks column. +This includes the annotations column.") (defcustom bookmark-bmenu-file-column 30 "Column at which to display filenames in a buffer listing bookmarks. You can toggle whether files are shown with \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-toggle-filenames]." - :type 'integer - :group 'bookmark) + :type 'integer) (defcustom bookmark-bmenu-toggle-filenames t "Non-nil means show filenames when listing bookmarks. A non-nil value may result in truncated bookmark names." - :type 'boolean - :group 'bookmark) + :type 'boolean) (defface bookmark-menu-bookmark '((t (:weight bold))) - "Face used to highlight bookmark names in bookmark menu buffers." - :group 'bookmark) + "Face used to highlight bookmark names in bookmark menu buffers.") (defcustom bookmark-menu-length 70 "Maximum length of a bookmark name displayed on a popup menu." - :type 'integer - :group 'bookmark) + :type 'integer) ;; FIXME: Is it really worth a customization option? (defcustom bookmark-search-delay 0.2 "Time before `bookmark-bmenu-search' updates the display." - :group 'bookmark :type 'number) (defface bookmark-menu-heading '((t (:inherit font-lock-type-face))) "Face used to highlight the heading in bookmark menu buffers." - :group 'bookmark :version "22.1") ;;; No user-serviceable parts beyond this point. -;; Added for lucid emacs compatibility, db -(or (fboundp 'defalias) (fset 'defalias 'fset)) - -;; suggested for lucid compatibility by david hughes: -(or (fboundp 'frame-height) (defalias 'frame-height 'screen-height)) - ;;; Keymap stuff: @@ -209,6 +194,7 @@ A non-nil value may result in truncated bookmark names." (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 @@ -221,7 +207,7 @@ A non-nil value may result in truncated bookmark names." "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 `bookmark-map'. All interactive bookmark +key of your choice to variable `bookmark-map'. All interactive bookmark functions have a binding in this keymap.") ;;;###autoload (fset 'bookmark-map bookmark-map) @@ -233,45 +219,54 @@ functions have a binding in this keymap.") Bookmark functions update the value automatically. You probably do NOT want to change the value yourself. -The value is an alist with entries of the form +The value is an alist with bookmarks of the form (BOOKMARK-NAME . PARAM-ALIST) or the deprecated form (BOOKMARK-NAME PARAM-ALIST). - BOOKMARK-NAME is the name you gave to the bookmark when creating it. - - PARAM-ALIST is an alist of bookmark information. The order of the - entries in PARAM-ALIST is not important. The possible entries are - described below. An entry with a key but null value means the entry - is not used. - - (filename . FILENAME) - (position . POS) - (front-context-string . STR-AFTER-POS) - (rear-context-string . STR-BEFORE-POS) - (handler . HANDLER) - (annotation . ANNOTATION) - - FILENAME names the bookmarked file. - POS is the bookmarked buffer position. - STR-AFTER-POS is buffer text that immediately follows POS. - STR-BEFORE-POS is buffer text that immediately precedes POS. - ANNOTATION is a string that describes the bookmark. - See options `bookmark-use-annotations' and - `bookmark-automatically-show-annotations'. - HANDLER is a function that provides the bookmark-jump behavior for a - specific kind of bookmark. This is the case for Info bookmarks, - for instance. HANDLER must accept a bookmark as its single argument.") - -(defvar bookmarks-already-loaded nil - "Non-nil if and only if bookmarks have been loaded from `bookmark-default-file'.") +BOOKMARK-NAME is the name you gave to the bookmark when creating it. + +PARAM-ALIST is an alist of bookmark information. The order of the +entries in PARAM-ALIST is not important. The default entries are +described below. An entry with a key but null value means the entry +is not used. + + (filename . FILENAME) + (buf . BUFFER-OR-NAME) + (position . POS) + (front-context-string . STR-AFTER-POS) + (rear-context-string . STR-BEFORE-POS) + (handler . HANDLER) + (annotation . ANNOTATION) + +FILENAME names the bookmarked file. +BUFFER-OR-NAME is a buffer or the name of a buffer that is used + if FILENAME is not defined or it refers to a non-existent file. +POS is the bookmarked buffer position. +STR-AFTER-POS is buffer text that immediately follows POS. +STR-BEFORE-POS is buffer text that immediately precedes POS. +ANNOTATION is a string that describes the bookmark. + See options `bookmark-use-annotations' and + `bookmark-automatically-show-annotations'. +HANDLER is a function that provides the bookmark-jump behavior for a +specific kind of bookmark instead of the default `bookmark-default-handler'. +This is the case for Info bookmarks, for instance. HANDLER must accept +a bookmark as its single argument. + +A function `bookmark-make-record-function' may define additional entries +in PARAM-LIST that can be used by HANDLER.") + +(define-obsolete-variable-alias 'bookmarks-already-loaded + 'bookmark-bookmarks-timestamp "27.1") +(defvar bookmark-bookmarks-timestamp nil + "Timestamp of current default bookmark file. +The value is actually (FILE . MODTIME), where FILE is a bookmark file that +defaults to `bookmark-default-file' and MODTIME is its modification time.") (defvar bookmark-file-coding-system nil "The coding-system of the last loaded or saved bookmark file.") -;; more stuff added by db. - (defvar bookmark-current-bookmark nil "Name of bookmark most recently used in the current file. It is buffer local, used to make moving a bookmark forward @@ -301,7 +296,9 @@ This point is in `bookmark-current-buffer'.") (defvar bookmark-quit-flag nil - "Non nil make `bookmark-bmenu-search' quit immediately.") + "Non-nil means `bookmark-bmenu-search' quits immediately.") +(make-obsolete-variable 'bookmark-quit-flag "no longer used" "27.1") + ;; Helper functions and macros. @@ -318,8 +315,8 @@ This point is in `bookmark-current-buffer'.") ;; Everyone else should go through them. (defun bookmark-name-from-full-record (bookmark-record) - "Return the name of BOOKMARK-RECORD. BOOKMARK-RECORD is, e.g., -one element from `bookmark-alist'." + "Return the name of BOOKMARK-RECORD. +BOOKMARK-RECORD is, e.g., one element from `bookmark-alist'." (car bookmark-record)) @@ -346,8 +343,8 @@ is already a bookmark record, just return it." (defun bookmark-get-bookmark-record (bookmark-name-or-record) - "Return the record portion of the entry for BOOKMARK-NAME-OR-RECORD in -`bookmark-alist' (that is, all information but the name)." + "Return the record portion of BOOKMARK-NAME-OR-RECORD in `bookmark-alist'. +In other words, return all information but the name." (let ((alist (cdr (bookmark-get-bookmark bookmark-name-or-record)))) ;; The bookmark objects can either look like (NAME ALIST) or ;; (NAME . ALIST), so we have to distinguish the two here. @@ -507,10 +504,7 @@ exists in `bookmark-alist', record the new bookmark without throwing away the old one." (bookmark-maybe-load-default-file) (let ((stripped-name (copy-sequence name))) - (or (featurep 'xemacs) - ;; XEmacs's `set-text-properties' doesn't work on - ;; free-standing strings, apparently. - (set-text-properties 0 (length stripped-name) nil stripped-name)) + (set-text-properties 0 (length stripped-name) nil stripped-name) (if (and (not no-overwrite) (bookmark-get-bookmark stripped-name 'noerror)) ;; already existing bookmark under that name and @@ -660,7 +654,9 @@ affect point." (forward-char -1) (read (current-buffer))) ;; Else no hope of getting information here. - (error "Not bookmark format"))))) + (if buffer-file-name + (error "File not in bookmark format: %s" buffer-file-name) + (error "Buffer not in bookmark format: %s" (buffer-name))))))) (defun bookmark-upgrade-version-0-alist (old-list) @@ -687,18 +683,17 @@ affect point." (defun bookmark-upgrade-file-format-from-0 () "Upgrade a bookmark file of format 0 (the original format) to format 1. This expects to be called from `point-min' in a bookmark file." - (message "Upgrading bookmark format from 0 to %d..." - bookmark-file-format-version) - (let* ((old-list (bookmark-alist-from-buffer)) + (let* ((reporter (make-progress-reporter + (format "Upgrading bookmark format from 0 to %d..." + bookmark-file-format-version))) + (old-list (bookmark-alist-from-buffer)) (new-list (bookmark-upgrade-version-0-alist old-list))) (delete-region (point-min) (point-max)) (bookmark-insert-file-format-version-stamp buffer-file-coding-system) (pp new-list (current-buffer)) - (save-buffer)) - (goto-char (point-min)) - (message "Upgrading bookmark format from 0 to %d...done" - bookmark-file-format-version) - ) + (save-buffer) + (goto-char (point-min)) + (progress-reporter-done reporter))) (defun bookmark-grok-file-format-version () @@ -735,7 +730,7 @@ CODING is the symbol of the coding-system in which the file is encoded." (if (memq (coding-system-base coding) '(undecided prefer-utf-8)) (setq coding 'utf-8-emacs)) (insert - (format ";;;; Emacs Bookmark Format Version %d ;;;; -*- coding: %S -*- \n" + (format ";;;; Emacs Bookmark Format Version %d ;;;; -*- coding: %S -*-\n" bookmark-file-format-version (coding-system-base coding))) (insert ";;; This format is meant to be slightly human-readable;\n" ";;; nevertheless, you probably don't want to edit it.\n" @@ -746,16 +741,10 @@ CODING is the symbol of the coding-system in which the file is encoded." ;;; end file-format stuff -;;; Generic helpers. - -(defun bookmark-maybe-message (fmt &rest args) - "Apply `message' to FMT and ARGS, but only if the display is fast enough." - (if (>= baud-rate 9600) - (apply 'message fmt args))) - - ;;; Core code: +(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) @@ -763,19 +752,23 @@ CODING is the symbol of the coding-system in which the file is encoded." map)) (defun bookmark-set-internal (prompt name overwrite-or-push) - "Interactively set a bookmark named NAME at the current location. - -Begin the interactive prompt with PROMPT, followed by a space, a -generated default name in parentheses, a colon and a space. - -If OVERWRITE-OR-PUSH is nil, then error if there is already a -bookmark named NAME; if `overwrite', then replace any existing -bookmark if there is one; if `push' then push the new bookmark -onto the bookmark alist. The `push' behavior means that among -bookmarks named NAME, this most recently set one becomes the one in -effect, but the others are still there, in order, if the topmost one -is ever deleted." - (interactive (list nil current-prefix-arg)) + "Set a bookmark using specified NAME or prompting with PROMPT. +The bookmark is set at the current location. + +If NAME is non-nil, use it as the name of the new bookmark. In +this case, the value of PROMPT is ignored. + +Otherwise, prompt the user for the bookmark name. Begin the +interactive prompt with PROMPT, followed by a space, a generated +default name in parentheses, a colon and a space. + +OVERWRITE-OR-PUSH controls what happens if there is already a +bookmark with the same name: nil means signal an error; +`overwrite' means replace any existing bookmark; `push' means +push the new bookmark onto the bookmark alist. The `push' +behavior means that among bookmarks with the same name, this most +recently set one becomes the one in effect, but the others are +still there, in order, if the topmost one is ever deleted." (unwind-protect (let* ((record (bookmark-make-record)) ;; `defaults' is a transient element of the @@ -803,7 +796,7 @@ is ever deleted." (let ((str (or name (read-from-minibuffer - (format "%s (default \"%s\"): " prompt default) + (format "%s (default %s): " prompt default) nil bookmark-minibuffer-read-name-map nil nil defaults)))) @@ -812,7 +805,7 @@ is ever deleted." (cond ((eq overwrite-or-push nil) (if (bookmark-get-bookmark str t) - (error "A bookmark named \"%s\" already exists." str) + (error "A bookmark named \"%s\" already exists" str) (bookmark-store str (cdr record) nil))) ((eq overwrite-or-push 'overwrite) (bookmark-store str (cdr record) nil)) @@ -900,13 +893,13 @@ Does not affect the kill ring." (when (and newline-too (= (following-char) ?\n)) (delete-char 1)))) - -;; Defvars to avoid compilation warnings: (defvar bookmark-annotation-name nil - "Variable holding the name of the bookmark. -This is used in `bookmark-edit-annotation' to record the bookmark -whose annotation is being edited.") + "Name of bookmark under edit in `bookmark-edit-annotation-mode'.") +(make-variable-buffer-local 'bookmark-annotation-name) +(defvar bookmark--annotation-from-bookmark-list nil + "If non-nil, `bookmark-edit-annotation-mode' should return to bookmark list.") +(make-variable-buffer-local 'bookmark--annotation-from-bookmark-list) (defun bookmark-default-annotation-text (bookmark-name) "Return default annotation text for BOOKMARK-NAME. @@ -937,6 +930,9 @@ It takes one argument, the name of the bookmark, as a string.") "Keymap for editing an annotation of a bookmark.") (defun bookmark-insert-annotation (bookmark-name-or-record) + "Insert annotation for BOOKMARK-NAME-OR-RECORD at point." + (when (not (bookmark-get-bookmark bookmark-name-or-record t)) + (error "Invalid bookmark: %s" bookmark-name-or-record)) (insert (funcall bookmark-edit-annotation-text-func bookmark-name-or-record)) (let ((annotation (bookmark-get-annotation bookmark-name-or-record))) (if (and annotation (not (string-equal annotation ""))) @@ -945,7 +941,7 @@ It takes one argument, the name of the bookmark, as a string.") (define-derived-mode bookmark-edit-annotation-mode text-mode "Edit Bookmark Annotation" "Mode for editing the annotation of bookmarks. -When you have finished composing, type \\[bookmark-send-annotation]. +When you have finished composing, type \\[bookmark-send-edited-annotation]. \\{bookmark-edit-annotation-mode-map}") @@ -963,21 +959,31 @@ Lines beginning with `#' are ignored." (forward-line 1))) ;; Take no chances with text properties. (let ((annotation (buffer-substring-no-properties (point-min) (point-max))) - (bookmark-name bookmark-annotation-name)) + (bookmark-name bookmark-annotation-name) + (from-bookmark-list bookmark--annotation-from-bookmark-list) + (old-buffer (current-buffer))) (bookmark-set-annotation bookmark-name annotation) (setq bookmark-alist-modification-count (1+ bookmark-alist-modification-count)) - (bookmark-bmenu-surreptitiously-rebuild-list)) - (kill-buffer (current-buffer))) + (message "Annotation updated for \"%s\"" bookmark-name) + (quit-window) + (bookmark-bmenu-surreptitiously-rebuild-list) + (when from-bookmark-list + (pop-to-buffer (get-buffer bookmark-bmenu-buffer)) + (goto-char (point-min)) + (text-property-search-forward 'bookmark-name-prop bookmark-name)) + (kill-buffer old-buffer))) -(defun bookmark-edit-annotation (bookmark-name-or-record) - "Pop up a buffer for editing bookmark BOOKMARK-NAME-OR-RECORD's annotation." +(defun bookmark-edit-annotation (bookmark-name-or-record &optional from-bookmark-list) + "Pop up a buffer for editing bookmark BOOKMARK-NAME-OR-RECORD's annotation. +If optional argument FROM-BOOKMARK-LIST is non-nil, return to the +bookmark list when editing is done." (pop-to-buffer (generate-new-buffer-name "*Bookmark Annotation Compose*")) (bookmark-insert-annotation bookmark-name-or-record) (bookmark-edit-annotation-mode) - (set (make-local-variable 'bookmark-annotation-name) - bookmark-name-or-record)) + (setq bookmark--annotation-from-bookmark-list from-bookmark-list) + (setq bookmark-annotation-name bookmark-name-or-record)) (defun bookmark-buffer-name () @@ -1033,23 +1039,19 @@ it to the name of the bookmark currently being set, advancing (defun bookmark-maybe-load-default-file () "If bookmarks have not been loaded from the default place, load them." - (and (not bookmarks-already-loaded) - (null bookmark-alist) - (prog2 - (and - ;; Possibly the old bookmark file, "~/.emacs-bkmrks", needs - ;; to be renamed. - (file-exists-p bookmark-old-default-file) - (not (file-exists-p bookmark-default-file)) - (rename-file bookmark-old-default-file - bookmark-default-file)) - ;; return t so the `and' will continue... - t) - - (file-readable-p bookmark-default-file) - (bookmark-load bookmark-default-file t t) - (setq bookmarks-already-loaded t))) - + (cond ((and (not bookmark-bookmarks-timestamp) + (null bookmark-alist) + (file-readable-p bookmark-default-file) + (bookmark-load bookmark-default-file t t))) + ((and bookmark-watch-bookmark-file + (not (equal (nth 5 (file-attributes + (car bookmark-bookmarks-timestamp))) + (cdr bookmark-bookmarks-timestamp))) + (or (eq 'silent bookmark-watch-bookmark-file) + (yes-or-no-p + (format "Bookmarks %s changed on disk. Reload? " + (car bookmark-bookmarks-timestamp))))) + (bookmark-load (car bookmark-bookmarks-timestamp) t t)))) (defun bookmark-maybe-sort-alist () "Return `bookmark-alist' for display. @@ -1066,8 +1068,8 @@ If `bookmark-sort-flag' is non-nil, then return a sorted copy of the alist." Useful for example to unhide text in `outline-mode'.") (defun bookmark--jump-via (bookmark-name-or-record display-function) - "Handle BOOKMARK-NAME-OR-RECORD, then call DISPLAY-FUNCTION with -current buffer as argument. + "Handle BOOKMARK-NAME-OR-RECORD, then call DISPLAY-FUNCTION. +DISPLAY-FUNCTION is called with the current buffer as argument. After calling DISPLAY-FUNCTION, set window point to the point specified by BOOKMARK-NAME-OR-RECORD, if necessary, run `bookmark-after-jump-hook', @@ -1125,6 +1127,14 @@ DISPLAY-FUNC would be `switch-to-buffer-other-window'." bookmark-current-bookmark))) (bookmark-jump bookmark 'switch-to-buffer-other-window)) +;;;###autoload +(defun bookmark-jump-other-frame (bookmark) + "Jump to BOOKMARK in another frame. See `bookmark-jump' for more." + (interactive + (list (bookmark-completing-read "Jump to bookmark (in another frame)" + bookmark-current-bookmark))) + (let ((pop-up-frames t)) + (bookmark-jump-other-window bookmark))) (defun bookmark-jump-noselect (bookmark) "Return the location pointed to by BOOKMARK (see `bookmark-jump'). @@ -1186,7 +1196,8 @@ then offer interactively to relocate BOOKMARK-NAME-OR-RECORD." (setq bookmark-current-bookmark bookmark-name-or-record)) nil) -(define-error 'bookmark-errors nil) +(define-error 'bookmark-errors + "Bookmark error") (define-error 'bookmark-error-no-filename "Bookmark has no associated file (or directory)" 'bookmark-errors) @@ -1203,7 +1214,7 @@ Changes current buffer and point and returns nil, or signals a `file-error'." (cond ((and file (file-readable-p file) (not (buffer-live-p buf))) (find-file-noselect file)) - ;; No file found. See if buffer BUF have been created. + ;; No file found. See if buffer BUF has been created. ((and buf (get-buffer buf))) (t ;; If not, raise error. (signal 'bookmark-error-no-filename (list 'stringp file))))) @@ -1382,87 +1393,89 @@ is greater than `bookmark-alist-modification-count'." ;;;###autoload -(defun bookmark-save (&optional parg file) - "Save currently defined bookmarks. -Saves by default in the file defined by the variable -`bookmark-default-file'. With a prefix arg, save it in file FILE -\(second argument). - -If you are calling this from Lisp, the two arguments are PARG and -FILE, and if you just want it to write to the default file, then -pass no arguments. Or pass in nil and FILE, and it will save in FILE -instead. If you pass in one argument, and it is non-nil, then the -user will be interactively queried for a file to save in. +(defun bookmark-save (&optional parg file make-default) + "Save currently defined bookmarks in FILE. +FILE defaults to `bookmark-default-file'. +With prefix PARG, query user for a file to save in. +If MAKE-DEFAULT is non-nil (interactively with prefix C-u C-u) +the file we save in becomes the new default in the current Emacs +session (without affecting the value of `bookmark-default-file'.). When you want to load in the bookmarks from a file, use `bookmark-load', \\[bookmark-load]. That function will prompt you for a file, defaulting to the file defined by variable `bookmark-default-file'." - (interactive "P") + (interactive + (list current-prefix-arg nil (equal '(16) current-prefix-arg))) (bookmark-maybe-load-default-file) - (cond - ((and (null parg) (null file)) - ;;whether interactive or not, write to default file - (bookmark-write-file bookmark-default-file)) - ((and (null parg) file) - ;;whether interactive or not, write to given file - (bookmark-write-file file)) - ((and parg (not file)) - ;;have been called interactively w/ prefix arg - (let ((file (read-file-name "File to save bookmarks in: "))) - (bookmark-write-file file))) - (t ; someone called us with prefix-arg *and* a file, so just write to file - (bookmark-write-file file))) - ;; signal that we have synced the bookmark file by setting this to - ;; 0. If there was an error at any point before, it will not get - ;; set, which is what we want. - (setq bookmark-alist-modification-count 0)) - + (unless file + (setq file + (let ((default (or (car bookmark-bookmarks-timestamp) + bookmark-default-file))) + (if parg + ;; This should be part of the `interactive' spec. + (read-file-name (format "File to save bookmarks in: (%s) " + default) + (file-name-directory default) default) + default)))) + (bookmark-write-file file) + ;; Signal that we have synced the bookmark file by setting this to 0. + ;; If there was an error at any point before, it will not get set, + ;; which is what we want. + (setq bookmark-alist-modification-count 0) + (if make-default + (let ((default (expand-file-name file))) + (setq bookmark-bookmarks-timestamp + (cons default (nth 5 (file-attributes default))))) + (let ((default (car bookmark-bookmarks-timestamp))) + (if (string= default (expand-file-name file)) + (setq bookmark-bookmarks-timestamp + (cons default (nth 5 (file-attributes default)))))))) (defun bookmark-write-file (file) "Write `bookmark-alist' to FILE." - (bookmark-maybe-message "Saving bookmarks to file %s..." file) - (with-current-buffer (get-buffer-create " *Bookmarks*") - (goto-char (point-min)) - (delete-region (point-min) (point-max)) - (let ((coding-system-for-write - (or coding-system-for-write - bookmark-file-coding-system 'utf-8-emacs)) - (print-length nil) - (print-level nil) - ;; See bug #12503 for why we bind `print-circle'. Users - ;; can define their own bookmark types, which can result in - ;; arbitrary Lisp objects being stored in bookmark records, - ;; and some users create objects containing circularities. - (print-circle t)) - (insert "(") - ;; Rather than a single call to `pp' we make one per bookmark. - ;; Apparently `pp' has a poor algorithmic complexity, so this - ;; scales a lot better. bug#4485. - (dolist (i bookmark-alist) (pp i (current-buffer))) - (insert ")") - ;; Make sure the specified encoding can safely encode the - ;; bookmarks. If it cannot, suggest utf-8-emacs as default. - (with-coding-priority '(utf-8-emacs) - (setq coding-system-for-write - (select-safe-coding-system (point-min) (point-max) - (list t coding-system-for-write)))) + (let ((reporter (make-progress-reporter + (format "Saving bookmarks to file %s..." file)))) + (with-current-buffer (get-buffer-create " *Bookmarks*") (goto-char (point-min)) - (bookmark-insert-file-format-version-stamp coding-system-for-write) - (let ((version-control - (cond - ((null bookmark-version-control) nil) - ((eq 'never bookmark-version-control) 'never) - ((eq 'nospecial bookmark-version-control) version-control) - (t t)))) - (condition-case nil - (write-region (point-min) (point-max) file) - (file-error (message "Can't write %s" file))) - (setq bookmark-file-coding-system coding-system-for-write) - (kill-buffer (current-buffer)) - (bookmark-maybe-message - "Saving bookmarks to file %s...done" file))))) + (delete-region (point-min) (point-max)) + (let ((coding-system-for-write + (or coding-system-for-write + bookmark-file-coding-system 'utf-8-emacs)) + (print-length nil) + (print-level nil) + ;; See bug #12503 for why we bind `print-circle'. Users + ;; can define their own bookmark types, which can result in + ;; arbitrary Lisp objects being stored in bookmark records, + ;; and some users create objects containing circularities. + (print-circle t)) + (insert "(") + ;; Rather than a single call to `pp' we make one per bookmark. + ;; Apparently `pp' has a poor algorithmic complexity, so this + ;; scales a lot better. bug#4485. + (dolist (i bookmark-alist) (pp i (current-buffer))) + (insert ")\n") + ;; Make sure the specified encoding can safely encode the + ;; bookmarks. If it cannot, suggest utf-8-emacs as default. + (with-coding-priority '(utf-8-emacs) + (setq coding-system-for-write + (select-safe-coding-system (point-min) (point-max) + (list t coding-system-for-write)))) + (goto-char (point-min)) + (bookmark-insert-file-format-version-stamp coding-system-for-write) + (let ((version-control + (cond + ((null bookmark-version-control) nil) + ((eq 'never bookmark-version-control) 'never) + ((eq 'nospecial bookmark-version-control) version-control) + (t t)))) + (condition-case nil + (write-region (point-min) (point-max) file) + (file-error (message "Can't write %s" file))) + (setq bookmark-file-coding-system coding-system-for-write) + (kill-buffer (current-buffer)) + (progress-reporter-done reporter)))))) (defun bookmark-import-new-list (new-list) @@ -1491,12 +1504,13 @@ This is a helper for `bookmark-import-new-list'." ;;;###autoload -(defun bookmark-load (file &optional overwrite no-msg) +(defun bookmark-load (file &optional overwrite no-msg default) "Load bookmarks from FILE (which must be in bookmark format). -Appends loaded bookmarks to the front of the list of bookmarks. If -optional second argument OVERWRITE is non-nil, existing bookmarks are -destroyed. Optional third arg NO-MSG means don't display any messages -while loading. +Appends loaded bookmarks to the front of the list of bookmarks. +If argument OVERWRITE is non-nil, existing bookmarks are destroyed. +Optional third arg NO-MSG means don't display any messages while loading. +If DEFAULT is non-nil make FILE the new bookmark file to watch. +Interactively, a prefix arg makes OVERWRITE and DEFAULT non-nil. If you load a file that doesn't contain a proper bookmark alist, you will corrupt Emacs's bookmark list. Generally, you should only load @@ -1509,51 +1523,55 @@ If you load a file containing bookmarks with the same names as bookmarks already present in your Emacs, the new bookmarks will get unique numeric suffixes \"<2>\", \"<3>\", etc." (interactive - (list (read-file-name - (format "Load bookmarks from: (%s) " - bookmark-default-file) - ;;Default might not be used often, - ;;but there's no better default, and - ;;I guess it's better than none at all. - "~/" bookmark-default-file 'confirm))) - (setq file (abbreviate-file-name (expand-file-name file))) - (if (not (file-readable-p file)) - (error "Cannot read bookmark file %s" file) - (if (null no-msg) - (bookmark-maybe-message "Loading bookmarks from %s..." file)) - (with-current-buffer (let ((enable-local-variables nil)) - (find-file-noselect file)) - (goto-char (point-min)) - (bookmark-maybe-upgrade-file-format) - (let ((blist (bookmark-alist-from-buffer))) - (if (listp blist) - (progn - (if overwrite - (progn - (setq bookmark-alist blist) - (setq bookmark-alist-modification-count 0)) - ;; else - (bookmark-import-new-list blist) - (setq bookmark-alist-modification-count - (1+ bookmark-alist-modification-count))) - (if (string-equal - (abbreviate-file-name - (expand-file-name bookmark-default-file)) - file) - (setq bookmarks-already-loaded t)) - (bookmark-bmenu-surreptitiously-rebuild-list) - (setq bookmark-file-coding-system buffer-file-coding-system)) - (error "Invalid bookmark list in %s" file))) - (kill-buffer (current-buffer))) - (if (null no-msg) - (bookmark-maybe-message "Loading bookmarks from %s...done" file)))) - + (let ((default (abbreviate-file-name + (or (car bookmark-bookmarks-timestamp) + (expand-file-name bookmark-default-file)))) + (prefix current-prefix-arg)) + (list (read-file-name (format "Load bookmarks from: (%s) " default) + (file-name-directory default) default 'confirm) + prefix nil prefix))) + (let* ((file (expand-file-name file)) + (afile (abbreviate-file-name file))) + (unless (file-readable-p file) + (user-error "Cannot read bookmark file %s" afile)) + (let ((reporter + (unless no-msg + (make-progress-reporter + (format "Loading bookmarks from %s..." file))))) + (with-current-buffer (let (enable-local-variables) + (find-file-noselect file)) + (goto-char (point-min)) + (bookmark-maybe-upgrade-file-format) + (let ((blist (bookmark-alist-from-buffer))) + (unless (listp blist) + (error "Invalid bookmark list in %s" file)) + ;; RW: Upon loading the bookmarks, we could add to each bookmark + ;; in `bookmark-alist' an extra key `bookmark-file', so that + ;; upon reloading the bookmarks with OVERWRITE non-nil, + ;; we overwrite only those bookmarks for which the key `bookmark-file' + ;; matches FILE. `bookmark-save' can ignore this key. + ;; Would this be a useful option? + (if overwrite + (setq bookmark-alist blist + bookmark-alist-modification-count 0) + (bookmark-import-new-list blist) + (setq bookmark-alist-modification-count + (1+ bookmark-alist-modification-count))) + (if (or default + (string= file (or (car bookmark-bookmarks-timestamp) + (expand-file-name bookmark-default-file)))) + (setq bookmark-bookmarks-timestamp + (cons file (nth 5 (file-attributes file))))) + (bookmark-bmenu-surreptitiously-rebuild-list) + (setq bookmark-file-coding-system buffer-file-coding-system)) + (kill-buffer (current-buffer))) + (unless no-msg + (progress-reporter-done reporter))))) -;;; Code supporting the dired-like bookmark menu. +;;; Code supporting the dired-like bookmark list. ;; Prefix is "bookmark-bmenu" for "buffer-menu": - (defvar bookmark-bmenu-hidden-bookmarks ()) @@ -1562,6 +1580,7 @@ unique numeric suffixes \"<2>\", \"<3>\", etc." (set-keymap-parent map special-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) @@ -1571,6 +1590,7 @@ unique numeric suffixes \"<2>\", \"<3>\", etc." (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) @@ -1592,6 +1612,34 @@ unique numeric suffixes \"<2>\", \"<3>\", etc." (define-key map [mouse-2] 'bookmark-bmenu-other-window-with-mouse) map)) +(easy-menu-define + bookmark-menu bookmark-bmenu-mode-map "Bookmark Menu" + '("Bookmark" + ["Select Bookmark in This Window" bookmark-bmenu-this-window t] + ["Select Bookmark in Full-Frame Window" bookmark-bmenu-1-window t] + ["Select Bookmark in Other Window" bookmark-bmenu-other-window t] + ["Select Bookmark in Other Frame" bookmark-bmenu-other-frame t] + ["Select Marked Bookmarks" bookmark-bmenu-select t] + "---" + ["Mark Bookmark" bookmark-bmenu-mark t] + ["Unmark Bookmark" bookmark-bmenu-unmark t] + ["Unmark Backwards" bookmark-bmenu-backup-unmark t] + ["Toggle Display of Filenames" bookmark-bmenu-toggle-filenames t] + ["Display Location of Bookmark" bookmark-bmenu-locate t] + "---" + ("Edit Bookmarks" + ["Rename Bookmark" bookmark-bmenu-rename t] + ["Relocate Bookmark's File" bookmark-bmenu-relocate t] + ["Mark Bookmark for Deletion" bookmark-bmenu-delete t] + ["Delete Marked Bookmarks" bookmark-bmenu-execute-deletions t]) + ("Annotations" + ["Show Annotation for Current Bookmark" bookmark-bmenu-show-annotation t] + ["Show Annotations for All Bookmarks" bookmark-bmenu-show-all-annotations t] + ["Edit Annotation for Current Bookmark." bookmark-bmenu-edit-annotation t]) + "---" + ["Save Bookmarks" bookmark-bmenu-save t] + ["Load Bookmarks" bookmark-bmenu-load t])) + ;; Bookmark Buffer Menu mode is suitable only for specially formatted ;; data. (put 'bookmark-bmenu-mode 'mode-class 'special) @@ -1607,7 +1655,7 @@ unique numeric suffixes \"<2>\", \"<3>\", etc." (defun bookmark-bmenu-surreptitiously-rebuild-list () "Rebuild the Bookmark List if it exists. Don't affect the buffer ring order." - (if (get-buffer "*Bookmark List*") + (if (get-buffer bookmark-bmenu-buffer) (save-excursion (save-window-excursion (bookmark-bmenu-list))))) @@ -1621,7 +1669,7 @@ The leftmost column displays a D if the bookmark is flagged for deletion, or > if it is flagged for displaying." (interactive) (bookmark-maybe-load-default-file) - (let ((buf (get-buffer-create "*Bookmark List*"))) + (let ((buf (get-buffer-create bookmark-bmenu-buffer))) (if (called-interactively-p 'interactive) (switch-to-buffer buf) (set-buffer buf))) @@ -1666,8 +1714,10 @@ deletion, or > if it is flagged for displaying." ;;;###autoload (defalias 'edit-bookmarks 'bookmark-bmenu-list) +;; FIXME: This could also display the current default bookmark file +;; according to `bookmark-bookmarks-timestamp'. (defun bookmark-bmenu-set-header () - "Sets the immutable header line." + "Set the immutable header line." (let ((header (concat "%% " "Bookmark"))) (when bookmark-bmenu-toggle-filenames (setq header (concat header @@ -1703,6 +1753,7 @@ Bookmark names preceded by a \"*\" have annotations. \\[bookmark-bmenu-this-window] -- select this bookmark in place of the bookmark menu buffer. \\[bookmark-bmenu-other-window] -- select this bookmark in another window, so the bookmark menu bookmark remains visible in its window. +\\[bookmark-bmenu-other-frame] -- select this bookmark in another frame. \\[bookmark-bmenu-switch-other-window] -- switch the other window to this bookmark. \\[bookmark-bmenu-rename] -- rename this bookmark (prompts for new name). \\[bookmark-bmenu-relocate] -- relocate this bookmark's file (prompts for new file). @@ -1826,16 +1877,19 @@ last full line, move to the last full line. The return value is undefined." (defun bookmark-show-annotation (bookmark-name-or-record) - "Display the annotation for BOOKMARK-NAME-OR-RECORD in a buffer, -if an annotation exists." + "Display the annotation for BOOKMARK-NAME-OR-RECORD in a buffer. +If the annotation does not exist, do nothing." (let ((annotation (bookmark-get-annotation bookmark-name-or-record))) (when (and annotation (not (string-equal annotation ""))) (save-excursion (let ((old-buf (current-buffer))) (pop-to-buffer (get-buffer-create "*Bookmark Annotation*") t) - (delete-region (point-min) (point-max)) - (insert annotation) - (goto-char (point-min)) + (let (buffer-read-only) + (erase-buffer) + (insert annotation) + (goto-char (point-min)) + (set-buffer-modified-p nil)) + (setq buffer-read-only t) (switch-to-buffer-other-window old-buf)))))) @@ -1843,22 +1897,25 @@ if an annotation exists." "Display the annotations for all bookmarks in a buffer." (save-selected-window (pop-to-buffer (get-buffer-create "*Bookmark Annotation*") t) - (delete-region (point-min) (point-max)) - (dolist (full-record (bookmark-maybe-sort-alist)) - (let* ((name (bookmark-name-from-full-record full-record)) - (ann (bookmark-get-annotation full-record))) - (insert (concat name ":\n")) - (if (and ann (not (string-equal ann ""))) - ;; insert the annotation, indented by 4 spaces. - (progn - (save-excursion (insert ann) (unless (bolp) - (insert "\n"))) - (while (< (point) (point-max)) - (beginning-of-line) ; paranoia - (insert " ") - (forward-line) - (end-of-line)))))) - (goto-char (point-min)))) + (let (buffer-read-only) + (erase-buffer) + (dolist (full-record (bookmark-maybe-sort-alist)) + (let* ((name (bookmark-name-from-full-record full-record)) + (ann (bookmark-get-annotation full-record))) + (insert (concat name ":\n")) + (if (and ann (not (string-equal ann ""))) + ;; insert the annotation, indented by 4 spaces. + (progn + (save-excursion (insert ann) (unless (bolp) + (insert "\n"))) + (while (< (point) (point-max)) + (beginning-of-line) ; paranoia + (insert " ") + (forward-line) + (end-of-line)))))) + (goto-char (point-min)) + (set-buffer-modified-p nil)) + (setq buffer-read-only t))) (defun bookmark-bmenu-mark () @@ -1919,13 +1976,13 @@ You can mark bookmarks with the \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-mar nil))) -(defun bookmark-bmenu-save (parg) +(defun bookmark-bmenu-save () "Save the current list into a bookmark file. With a prefix arg, prompts for a file to save them in." - (interactive "P") + (interactive) (save-excursion (save-window-excursion - (bookmark-save parg) + (call-interactively 'bookmark-save) (set-buffer-modified-p nil)))) @@ -1972,6 +2029,13 @@ With a prefix arg, prompts for a file to save them in." (bookmark--jump-via bookmark 'switch-to-buffer-other-window))) +(defun bookmark-bmenu-other-frame () + "Select this line's bookmark in other frame." + (interactive) + (let ((bookmark (bookmark-bmenu-bookmark)) + (pop-up-frames t)) + (bookmark-jump-other-window bookmark))) + (defun bookmark-bmenu-switch-other-window () "Make the other window select this line's bookmark. The current window remains selected." @@ -1981,7 +2045,9 @@ The current window remains selected." (bookmark--jump-via bookmark fun))) (defun bookmark-bmenu-other-window-with-mouse (event) - "Select bookmark at the mouse pointer in other window, leaving bookmark menu visible." + "Jump to bookmark at mouse EVENT position in other window. +Move point in menu buffer to the position of EVENT and leave +bookmark menu visible." (interactive "e") (with-current-buffer (window-buffer (posn-window (event-end event))) (save-excursion @@ -2006,7 +2072,7 @@ The current window remains selected." "Edit the annotation for the current bookmark in another window." (interactive) (let ((bookmark (bookmark-bmenu-bookmark))) - (bookmark-edit-annotation bookmark))) + (bookmark-edit-annotation bookmark t))) (defun bookmark-bmenu-unmark (&optional backup) @@ -2064,8 +2130,8 @@ To carry out the deletions that you've marked, use \\<bookmark-bmenu-mode-map>\\ (defun bookmark-bmenu-execute-deletions () "Delete bookmarks flagged `D'." (interactive) - (message "Deleting bookmarks...") - (let ((o-point (point)) + (let ((reporter (make-progress-reporter "Deleting bookmarks...")) + (o-point (point)) (o-str (save-excursion (beginning-of-line) (unless (= (following-char) ?D) @@ -2087,8 +2153,7 @@ To carry out the deletions that you've marked, use \\<bookmark-bmenu-mode-map>\\ (forward-char o-col)) (goto-char o-point)) (beginning-of-line) - (message "Deleting bookmarks...done") - )) + (progress-reporter-done reporter))) (defun bookmark-bmenu-rename () @@ -2107,8 +2172,8 @@ To carry out the deletions that you've marked, use \\<bookmark-bmenu-mode-map>\\ (message "%s" (bookmark-location bmrk)))) (defun bookmark-bmenu-relocate () - "Change the file path of the bookmark on the current line, - prompting with completion for the new path." + "Change the absolute file name of the bookmark on the current line. +Prompt with completion for the new path." (interactive) (let ((bmrk (bookmark-bmenu-bookmark)) (thispoint (point))) @@ -2255,8 +2320,6 @@ strings returned are not." "Hook run at the end of loading library `bookmark.el'.") ;; Exit Hook, called from kill-emacs-hook -(define-obsolete-variable-alias 'bookmark-exit-hooks - 'bookmark-exit-hook "22.1") (defvar bookmark-exit-hook nil "Hook run when Emacs exits.") diff --git a/lisp/bs.el b/lisp/bs.el index 06ba0042ab7..cd9524a440b 100644 --- a/lisp/bs.el +++ b/lisp/bs.el @@ -181,12 +181,7 @@ return a string representing the column's value." (list (bs--make-header-match-string) '(1 font-lock-type-face append) '(1 'bold append)) ;; Buffername embedded by * - (list "^\\(.*\\*.*\\*.*\\)$" - 1 - ;; problem in XEmacs with font-lock-constant-face - (if (facep 'font-lock-constant-face) - 'font-lock-constant-face - 'font-lock-comment-face)) + (list "^\\(.*\\*.*\\*.*\\)$" 1 'font-lock-constant-face) ;; Dired-Buffers '("^..\\(.*Dired .*\\)$" 1 font-lock-function-name-face) ;; the star for modified buffers @@ -343,11 +338,6 @@ configuration. A value of `never' means to never show the buffer. A value of `always' means to show buffer regardless of the configuration.") -;; Make face named region (for XEmacs) -(unless (facep 'region) - (make-face 'region) - (set-face-background 'region "gray75")) - (defun bs--sort-by-name (b1 b2) "Compare buffers B1 and B2 by buffer name." (string< (buffer-name b1) @@ -448,8 +438,7 @@ Used internally, only.") (define-key map "f" 'bs-select) (define-key map "v" 'bs-view) (define-key map "!" 'bs-select-in-one-window) - (define-key map [mouse-2] 'bs-mouse-select) ;; for GNU EMACS - (define-key map [button2] 'bs-mouse-select) ;; for XEmacs + (define-key map [mouse-2] 'bs-mouse-select) (define-key map "F" 'bs-select-other-frame) (let ((key ?1)) (while (<= key ?9) @@ -459,10 +448,7 @@ Used internally, only.") (define-key map "\e-" 'negative-argument) (define-key map "o" 'bs-select-other-window) (define-key map "\C-o" 'bs-tmp-select-other-window) - ;; for GNU EMACS (define-key map [mouse-3] 'bs-mouse-select-other-frame) - ;; for XEmacs - (define-key map [button3] 'bs-mouse-select-other-frame) (define-key map [up] 'bs-up) (define-key map "n" 'bs-down) (define-key map "p" 'bs-up) @@ -828,8 +814,8 @@ See `visit-tags-table'." (let ((res (with-current-buffer (bs--current-buffer) (setq bs-buffer-show-mark (pcase bs-buffer-show-mark - (`nil 'never) - (`never 'always) + ('nil 'never) + ('never 'always) (_ nil)))))) (bs--update-current-line) (bs--set-window-height) diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index 5f889866361..3cea186e6e3 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -279,7 +279,11 @@ The remaining columns show the buffer name, the buffer size in characters, its major mode, and the visited file name (if any). See `Buffer-menu-mode' for the keybindings available the Buffer -Menu." +Menu. + +The width of the various columns can be customized by changing +the `Buffer-menu-name-width', `Buffer-menu-size-width' and +`Buffer-menu-mode-width' variables." (interactive "P") (switch-to-buffer (list-buffers-noselect arg)) (message @@ -699,7 +703,8 @@ means list those buffers and no others." (defun Buffer-menu--pretty-file-name (file) (cond (file (abbreviate-file-name file)) - ((bound-and-true-p list-buffers-directory)) + ((bound-and-true-p list-buffers-directory) + (abbreviate-file-name list-buffers-directory)) (t ""))) ;;; buff-menu.el ends here diff --git a/lisp/button.el b/lisp/button.el index c46f3d9a52b..ca6f0d3b6ea 100644 --- a/lisp/button.el +++ b/lisp/button.el @@ -235,15 +235,19 @@ The action can either be a marker or a function. If it's a marker then goto it. Otherwise if it is a function then it is called with BUTTON as only argument. BUTTON is either an overlay, a buffer position, or (for buttons in the mode-line or -header-line) a string." +header-line) a string. + +If BUTTON has a `button-data' value, call the function with this +value instad of BUTTON." (let ((action (or (and use-mouse-action (button-get button 'mouse-action)) - (button-get button 'action)))) + (button-get button 'action))) + (data (button-get button 'button-data))) (if (markerp action) (save-selected-window (select-window (display-buffer (marker-buffer action))) (goto-char action) (recenter 0)) - (funcall action button)))) + (funcall action (or data button))))) (defun button-label (button) "Return BUTTON's text label." @@ -324,6 +328,10 @@ using `make-text-button'. Note, however, that if there is an existing face property at the site of the button, the button face may not be visible. You may want to use `make-button' in that case. +If the property `button-data' is present, it will later be used +as the argument for the `action' callback function instead of the +default argument, which is the button itself. + BEG can also be a string, in which case it is made into a button. Also see `insert-text-button'." @@ -382,10 +390,12 @@ Also see `make-text-button'." If the button at POS is a text property button, the return value is a marker pointing to POS." (let ((button (get-char-property pos 'button))) - (if (or (overlayp button) (null button)) - button - ;; Must be a text-property button; return a marker pointing to it. - (copy-marker pos t)))) + (and button (get-char-property pos 'category) + (if (overlayp button) + button + ;; Must be a text-property button; + ;; return a marker pointing to it. + (copy-marker pos t))))) (defun next-button (pos &optional count-current) "Return the next button after position POS in the current buffer. @@ -460,13 +470,17 @@ return t." (button-activate button use-mouse-action) t)))) -(defun forward-button (n &optional wrap display-message) +(defun forward-button (n &optional wrap display-message no-error) "Move to the Nth next button, or Nth previous button if N is negative. If N is 0, move to the start of any button at point. If WRAP is non-nil, moving past either end of the buffer continues from the other end. If DISPLAY-MESSAGE is non-nil, the button's help-echo string is displayed. Any button with a non-nil `skip' property is skipped over. + +If NO-ERROR, return nil if no further buttons could be found +instead of erroring out. + Returns the button found." (interactive "p\nd\nd") (let (button) @@ -495,22 +509,28 @@ Returns the button found." (unless (button-get button 'skip) (setq n (1- n))))))) (if (null button) - (user-error (if wrap "No buttons!" "No more buttons")) + (if no-error + nil + (user-error (if wrap "No buttons!" "No more buttons"))) (let ((msg (and display-message (button-get button 'help-echo)))) (when msg (message "%s" msg))) button))) -(defun backward-button (n &optional wrap display-message) +(defun backward-button (n &optional wrap display-message no-error) "Move to the Nth previous button, or Nth next button if N is negative. If N is 0, move to the start of any button at point. If WRAP is non-nil, moving past either end of the buffer continues from the other end. If DISPLAY-MESSAGE is non-nil, the button's help-echo string is displayed. Any button with a non-nil `skip' property is skipped over. + +If NO-ERROR, return nil if no further buttons could be found +instead of erroring out. + Returns the button found." (interactive "p\nd\nd") - (forward-button (- n) wrap display-message)) + (forward-button (- n) wrap display-message no-error)) (provide 'button) diff --git a/lisp/calc/calc-aent.el b/lisp/calc/calc-aent.el index f16e665fc34..f7731c95fc0 100644 --- a/lisp/calc/calc-aent.el +++ b/lisp/calc/calc-aent.el @@ -82,7 +82,7 @@ " ") shortbuf buf) (if (and (= (length alg-exp) 1) - (memq (car-safe (car alg-exp)) '(nil bigpos bigneg)) + (memq (car-safe (car alg-exp)) '(nil)) (< (length buf) 20) (= calc-number-radix 10)) (setq buf (concat buf " (" @@ -728,7 +728,7 @@ in Calc algebraic input.") math-exp-str (1- math-exp-pos)) (1- math-exp-pos)))))) (or (and (memq calc-language calc-lang-c-type-hex) - (eq (string-match "0[xX][0-9a-fA-F]+" math-exp-str + (eq (string-match "0[xX][[:xdigit:]]+" math-exp-str math-exp-pos) math-exp-pos)) (string-match "_?\\([0-9]+.?0*@ *\\)?\\([0-9]+.?0*' *\\)?\\(0*\\([2-9]\\|1[0-4]\\)\\(#[#]?\\|\\^\\^\\)[0-9a-dA-D.]+[eE][-+_]?[0-9]+\\|0*\\([2-9]\\|[0-2][0-9]\\|3[0-6]\\)\\(#[#]?\\|\\^\\^\\)[0-9a-zA-Zα-ωΑ-Ω:.]+\\|[0-9]+:[0-9:]+\\|[0-9.]+\\([eE][-+_]?[0-9]+\\)?\"?\\)?" diff --git a/lisp/calc/calc-alg.el b/lisp/calc/calc-alg.el index 8e3476d191e..c3efeeeb62c 100644 --- a/lisp/calc/calc-alg.el +++ b/lisp/calc/calc-alg.el @@ -1,4 +1,4 @@ -;;; calc-alg.el --- algebraic functions for Calc +;;; calc-alg.el --- algebraic functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2019 Free Software Foundation, Inc. @@ -258,9 +258,9 @@ (and (eq comp 0) (not (equal a b)) (> (length (memq (car-safe a) - '(bigneg nil bigpos frac float))) + '(nil frac float))) (length (memq (car-safe b) - '(bigneg nil bigpos frac float)))))))) + '(nil frac float)))))))) ((equal b '(neg (var inf var-inf))) nil) ((equal a '(neg (var inf var-inf))) t) ((equal a '(var inf var-inf)) nil) @@ -308,7 +308,7 @@ (let ((math-living-dangerously t)) (math-simplify a))) -(defalias 'calcFunc-esimplify 'math-simplify-extended) +(defalias 'calcFunc-esimplify #'math-simplify-extended) ;;; Rewrite the trig functions in a form easier to simplify. (defun math-trig-rewrite (fn) @@ -329,7 +329,7 @@ (list '/ (cons 'calcFunc-cos newfn) (cons 'calcFunc-sin newfn)))) (t - (mapcar 'math-trig-rewrite fn)))) + (mapcar #'math-trig-rewrite fn)))) (defun math-hyperbolic-trig-rewrite (fn) "Rewrite hyperbolic functions in terms of sinhs and coshs." @@ -349,7 +349,7 @@ (list '/ (cons 'calcFunc-cosh newfn) (cons 'calcFunc-sinh newfn)))) (t - (mapcar 'math-hyperbolic-trig-rewrite fn)))) + (mapcar #'math-hyperbolic-trig-rewrite fn)))) ;; math-top-only is local to math-simplify, but is used by ;; math-simplify-step, which is called by math-simplify. @@ -402,11 +402,11 @@ (setq top-expr res))))) top-expr) -(defalias 'calcFunc-simplify 'math-simplify) +(defalias 'calcFunc-simplify #'math-simplify) -;;; The following has a "bug" in that if any recursive simplifications -;;; occur only the first handler will be tried; this doesn't really -;;; matter, since math-simplify-step is iterated to a fixed point anyway. +;; The following has a "bug" in that if any recursive simplifications +;; occur only the first handler will be tried; this doesn't really +;; matter, since math-simplify-step is iterated to a fixed point anyway. (defun math-simplify-step (a) (if (Math-primp a) a @@ -414,7 +414,7 @@ (memq (car a) '(calcFunc-quote calcFunc-condition calcFunc-evalto))) a - (cons (car a) (mapcar 'math-simplify-step (cdr a)))))) + (cons (car a) (mapcar #'math-simplify-step (cdr a)))))) (and (symbolp (car aa)) (let ((handler (get (car aa) 'math-simplify))) (and handler @@ -427,159 +427,155 @@ (defmacro math-defsimplify (funcs &rest code) + "Define the simplification code for functions FUNCS. +Code can refer to the expression to simplify via lexical variable `expr' +and should return the simplified expression to use (or nil)." + (declare (indent 1) (debug (sexp body))) (cons 'progn (mapcar #'(lambda (func) `(put ',func 'math-simplify (nconc (get ',func 'math-simplify) (list - #'(lambda (math-simplify-expr) ,@code))))) + #'(lambda (expr) ,@code))))) (if (symbolp funcs) (list funcs) funcs)))) -(put 'math-defsimplify 'lisp-indent-hook 1) - -;; The function created by math-defsimplify uses the variable -;; math-simplify-expr, and so is used by functions in math-defsimplify -(defvar math-simplify-expr) (math-defsimplify (+ -) - (math-simplify-plus)) - -(defun math-simplify-plus () - (cond ((and (memq (car-safe (nth 1 math-simplify-expr)) '(+ -)) - (Math-numberp (nth 2 (nth 1 math-simplify-expr))) - (not (Math-numberp (nth 2 math-simplify-expr)))) - (let ((x (nth 2 math-simplify-expr)) - (op (car math-simplify-expr))) - (setcar (cdr (cdr math-simplify-expr)) (nth 2 (nth 1 math-simplify-expr))) - (setcar math-simplify-expr (car (nth 1 math-simplify-expr))) - (setcar (cdr (cdr (nth 1 math-simplify-expr))) x) - (setcar (nth 1 math-simplify-expr) op))) - ((and (eq (car math-simplify-expr) '+) - (Math-numberp (nth 1 math-simplify-expr)) - (not (Math-numberp (nth 2 math-simplify-expr)))) - (let ((x (nth 2 math-simplify-expr))) - (setcar (cdr (cdr math-simplify-expr)) (nth 1 math-simplify-expr)) - (setcar (cdr math-simplify-expr) x)))) - (let ((aa math-simplify-expr) + (cond ((and (memq (car-safe (nth 1 expr)) '(+ -)) + (Math-numberp (nth 2 (nth 1 expr))) + (not (Math-numberp (nth 2 expr)))) + (let ((x (nth 2 expr)) + (op (car expr))) + (setcar (cdr (cdr expr)) (nth 2 (nth 1 expr))) + (setcar expr (car (nth 1 expr))) + (setcar (cdr (cdr (nth 1 expr))) x) + (setcar (nth 1 expr) op))) + ((and (eq (car expr) '+) + (Math-numberp (nth 1 expr)) + (not (Math-numberp (nth 2 expr)))) + (let ((x (nth 2 expr))) + (setcar (cdr (cdr expr)) (nth 1 expr)) + (setcar (cdr expr) x)))) + (let ((aa expr) aaa temp) (while (memq (car-safe (setq aaa (nth 1 aa))) '(+ -)) - (if (setq temp (math-combine-sum (nth 2 aaa) (nth 2 math-simplify-expr) + (if (setq temp (math-combine-sum (nth 2 aaa) (nth 2 expr) (eq (car aaa) '-) - (eq (car math-simplify-expr) '-) t)) + (eq (car expr) '-) t)) (progn - (setcar (cdr (cdr math-simplify-expr)) temp) - (setcar math-simplify-expr '+) + (setcar (cdr (cdr expr)) temp) + (setcar expr '+) (setcar (cdr (cdr aaa)) 0))) (setq aa (nth 1 aa))) - (if (setq temp (math-combine-sum aaa (nth 2 math-simplify-expr) - nil (eq (car math-simplify-expr) '-) t)) + (if (setq temp (math-combine-sum aaa (nth 2 expr) + nil (eq (car expr) '-) t)) (progn - (setcar (cdr (cdr math-simplify-expr)) temp) - (setcar math-simplify-expr '+) + (setcar (cdr (cdr expr)) temp) + (setcar expr '+) (setcar (cdr aa) 0))) - math-simplify-expr)) + expr)) (math-defsimplify * - (math-simplify-times)) - -(defun math-simplify-times () - (if (eq (car-safe (nth 2 math-simplify-expr)) '*) - (and (math-beforep (nth 1 (nth 2 math-simplify-expr)) (nth 1 math-simplify-expr)) - (or (math-known-scalarp (nth 1 math-simplify-expr) t) - (math-known-scalarp (nth 1 (nth 2 math-simplify-expr)) t)) - (let ((x (nth 1 math-simplify-expr))) - (setcar (cdr math-simplify-expr) (nth 1 (nth 2 math-simplify-expr))) - (setcar (cdr (nth 2 math-simplify-expr)) x))) - (and (math-beforep (nth 2 math-simplify-expr) (nth 1 math-simplify-expr)) - (or (math-known-scalarp (nth 1 math-simplify-expr) t) - (math-known-scalarp (nth 2 math-simplify-expr) t)) - (let ((x (nth 2 math-simplify-expr))) - (setcar (cdr (cdr math-simplify-expr)) (nth 1 math-simplify-expr)) - (setcar (cdr math-simplify-expr) x)))) - (let ((aa math-simplify-expr) + (if (eq (car-safe (nth 2 expr)) '*) + (and (math-beforep (nth 1 (nth 2 expr)) (nth 1 expr)) + (or (math-known-scalarp (nth 1 expr) t) + (math-known-scalarp (nth 1 (nth 2 expr)) t)) + (let ((x (nth 1 expr))) + (setcar (cdr expr) (nth 1 (nth 2 expr))) + (setcar (cdr (nth 2 expr)) x))) + (and (math-beforep (nth 2 expr) (nth 1 expr)) + (or (math-known-scalarp (nth 1 expr) t) + (math-known-scalarp (nth 2 expr) t)) + (let ((x (nth 2 expr))) + (setcar (cdr (cdr expr)) (nth 1 expr)) + (setcar (cdr expr) x)))) + (let ((aa expr) aaa temp - (safe t) (scalar (math-known-scalarp (nth 1 math-simplify-expr)))) - (if (and (Math-ratp (nth 1 math-simplify-expr)) - (setq temp (math-common-constant-factor (nth 2 math-simplify-expr)))) + (safe t) (scalar (math-known-scalarp (nth 1 expr)))) + (if (and (Math-ratp (nth 1 expr)) + (setq temp (math-common-constant-factor (nth 2 expr)))) (progn - (setcar (cdr (cdr math-simplify-expr)) - (math-cancel-common-factor (nth 2 math-simplify-expr) temp)) - (setcar (cdr math-simplify-expr) (math-mul (nth 1 math-simplify-expr) temp)))) + (setcar (cdr (cdr expr)) + (math-cancel-common-factor (nth 2 expr) temp)) + (setcar (cdr expr) (math-mul (nth 1 expr) temp)))) (while (and (eq (car-safe (setq aaa (nth 2 aa))) '*) safe) - (if (setq temp (math-combine-prod (nth 1 math-simplify-expr) + (if (setq temp (math-combine-prod (nth 1 expr) (nth 1 aaa) nil nil t)) (progn - (setcar (cdr math-simplify-expr) temp) + (setcar (cdr expr) temp) (setcar (cdr aaa) 1))) (setq safe (or scalar (math-known-scalarp (nth 1 aaa) t)) aa (nth 2 aa))) - (if (and (setq temp (math-combine-prod aaa (nth 1 math-simplify-expr) nil nil t)) + (if (and (setq temp (math-combine-prod aaa (nth 1 expr) nil nil t)) safe) (progn - (setcar (cdr math-simplify-expr) temp) + (setcar (cdr expr) temp) (setcar (cdr (cdr aa)) 1))) - (if (and (eq (car-safe (nth 1 math-simplify-expr)) 'frac) - (memq (nth 1 (nth 1 math-simplify-expr)) '(1 -1))) - (math-div (math-mul (nth 2 math-simplify-expr) - (nth 1 (nth 1 math-simplify-expr))) - (nth 2 (nth 1 math-simplify-expr))) - math-simplify-expr))) + (if (and (eq (car-safe (nth 1 expr)) 'frac) + (memq (nth 1 (nth 1 expr)) '(1 -1))) + (math-div (math-mul (nth 2 expr) + (nth 1 (nth 1 expr))) + (nth 2 (nth 1 expr))) + expr))) (math-defsimplify / - (math-simplify-divide)) + (math-simplify-divide expr)) -(defun math-simplify-divide () - (let ((np (cdr math-simplify-expr)) +(defvar math--simplify-divide-expr) + +(defun math-simplify-divide (expr) + (let ((np (cdr expr)) (nover nil) - (nn (and (or (eq (car math-simplify-expr) '/) - (not (Math-realp (nth 2 math-simplify-expr)))) - (math-common-constant-factor (nth 2 math-simplify-expr)))) + (nn (and (or (eq (car expr) '/) + (not (Math-realp (nth 2 expr)))) + (math-common-constant-factor (nth 2 expr)))) n op) (if nn (progn - (setq n (and (or (eq (car math-simplify-expr) '/) - (not (Math-realp (nth 1 math-simplify-expr)))) - (math-common-constant-factor (nth 1 math-simplify-expr)))) + (setq n (and (or (eq (car expr) '/) + (not (Math-realp (nth 1 expr)))) + (math-common-constant-factor (nth 1 expr)))) (if (and (eq (car-safe nn) 'frac) (eq (nth 1 nn) 1) (not n)) - (unless (and (eq (car-safe math-simplify-expr) 'calcFunc-eq) - (eq (car-safe (nth 1 math-simplify-expr)) 'var) - (not (math-expr-contains (nth 2 math-simplify-expr) - (nth 1 math-simplify-expr)))) - (setcar (cdr math-simplify-expr) - (math-mul (nth 2 nn) (nth 1 math-simplify-expr))) - (setcar (cdr (cdr math-simplify-expr)) - (math-cancel-common-factor (nth 2 math-simplify-expr) nn)) + (unless (and (eq (car-safe expr) 'calcFunc-eq) + (eq (car-safe (nth 1 expr)) 'var) + (not (math-expr-contains (nth 2 expr) + (nth 1 expr)))) + (setcar (cdr expr) + (math-mul (nth 2 nn) (nth 1 expr))) + (setcar (cdr (cdr expr)) + (math-cancel-common-factor (nth 2 expr) nn)) (if (and (math-negp nn) - (setq op (assq (car math-simplify-expr) calc-tweak-eqn-table))) - (setcar math-simplify-expr (nth 1 op)))) + (setq op (assq (car expr) calc-tweak-eqn-table))) + (setcar expr (nth 1 op)))) (if (and n (not (eq (setq n (math-frac-gcd n nn)) 1))) (progn - (setcar (cdr math-simplify-expr) - (math-cancel-common-factor (nth 1 math-simplify-expr) n)) - (setcar (cdr (cdr math-simplify-expr)) - (math-cancel-common-factor (nth 2 math-simplify-expr) n)) + (setcar (cdr expr) + (math-cancel-common-factor (nth 1 expr) n)) + (setcar (cdr (cdr expr)) + (math-cancel-common-factor (nth 2 expr) n)) (if (and (math-negp n) - (setq op (assq (car math-simplify-expr) + (setq op (assq (car expr) calc-tweak-eqn-table))) - (setcar math-simplify-expr (nth 1 op)))))))) - (if (and (eq (car-safe (car np)) '/) - (math-known-scalarp (nth 2 math-simplify-expr) t)) - (progn - (setq np (cdr (nth 1 math-simplify-expr))) - (while (eq (car-safe (setq n (car np))) '*) - (and (math-known-scalarp (nth 2 n) t) - (math-simplify-divisor (cdr n) (cdr (cdr math-simplify-expr)) nil t)) - (setq np (cdr (cdr n)))) - (math-simplify-divisor np (cdr (cdr math-simplify-expr)) nil t) - (setq nover t - np (cdr (cdr (nth 1 math-simplify-expr)))))) - (while (eq (car-safe (setq n (car np))) '*) - (and (math-known-scalarp (nth 2 n) t) - (math-simplify-divisor (cdr n) (cdr (cdr math-simplify-expr)) nover t)) - (setq np (cdr (cdr n)))) - (math-simplify-divisor np (cdr (cdr math-simplify-expr)) nover t) - math-simplify-expr)) + (setcar expr (nth 1 op)))))))) + (let ((math--simplify-divide-expr expr)) ;For use in math-simplify-divisor + (if (and (eq (car-safe (car np)) '/) + (math-known-scalarp (nth 2 expr) t)) + (progn + (setq np (cdr (nth 1 expr))) + (while (eq (car-safe (setq n (car np))) '*) + (and (math-known-scalarp (nth 2 n) t) + (math-simplify-divisor (cdr n) (cdr (cdr expr)) nil t)) + (setq np (cdr (cdr n)))) + (math-simplify-divisor np (cdr (cdr expr)) nil t) + (setq nover t + np (cdr (cdr (nth 1 expr)))))) + (while (eq (car-safe (setq n (car np))) '*) + (and (math-known-scalarp (nth 2 n) t) + (math-simplify-divisor (cdr n) (cdr (cdr expr)) nover t)) + (setq np (cdr (cdr n)))) + (math-simplify-divisor np (cdr (cdr expr)) nover t) + expr))) ;; The variables math-simplify-divisor-nover and math-simplify-divisor-dover ;; are local variables for math-simplify-divisor, but are used by @@ -587,25 +583,25 @@ (defvar math-simplify-divisor-nover) (defvar math-simplify-divisor-dover) -(defun math-simplify-divisor (np dp math-simplify-divisor-nover - math-simplify-divisor-dover) +(defun math-simplify-divisor (np dp nover dover) (cond ((eq (car-safe (car dp)) '/) (math-simplify-divisor np (cdr (car dp)) - math-simplify-divisor-nover - math-simplify-divisor-dover) + nover dover) (and (math-known-scalarp (nth 1 (car dp)) t) (math-simplify-divisor np (cdr (cdr (car dp))) - math-simplify-divisor-nover - (not math-simplify-divisor-dover)))) - ((or (or (eq (car math-simplify-expr) '/) + nover (not dover)))) + ((or (or (eq (car math--simplify-divide-expr) '/) (let ((signs (math-possible-signs (car np)))) (or (memq signs '(1 4)) - (and (memq (car math-simplify-expr) '(calcFunc-eq calcFunc-neq)) + (and (memq (car math--simplify-divide-expr) + '(calcFunc-eq calcFunc-neq)) (eq signs 5)) math-living-dangerously))) (math-numberp (car np))) (let (d (safe t) + (math-simplify-divisor-nover nover) + (math-simplify-divisor-dover dover) (scalar (math-known-scalarp (car np)))) (while (and (eq (car-safe (setq d (car dp))) '*) safe) @@ -621,14 +617,16 @@ op) (if temp (progn - (and (not (memq (car math-simplify-expr) '(/ calcFunc-eq calcFunc-neq))) + (and (not (memq (car math--simplify-divide-expr) + '(/ calcFunc-eq calcFunc-neq))) (math-known-negp (car dp)) - (setq op (assq (car math-simplify-expr) calc-tweak-eqn-table)) - (setcar math-simplify-expr (nth 1 op))) + (setq op (assq (car math--simplify-divide-expr) + calc-tweak-eqn-table)) + (setcar math--simplify-divide-expr (nth 1 op))) (setcar np (if math-simplify-divisor-nover (math-div 1 temp) temp)) (setcar dp 1)) (and math-simplify-divisor-dover (not math-simplify-divisor-nover) - (eq (car math-simplify-expr) '/) + (eq (car math--simplify-divide-expr) '/) (eq (car-safe (car dp)) 'calcFunc-sqrt) (Math-integerp (nth 1 (car dp))) (progn @@ -680,26 +678,23 @@ (math-gcd (nth 2 a) (nth 2 b))))))) (math-defsimplify % - (math-simplify-mod)) - -(defun math-simplify-mod () - (and (Math-realp (nth 2 math-simplify-expr)) - (Math-posp (nth 2 math-simplify-expr)) - (let ((lin (math-is-linear (nth 1 math-simplify-expr))) - t1 t2 t3) + (and (Math-realp (nth 2 expr)) + (Math-posp (nth 2 expr)) + (let ((lin (math-is-linear (nth 1 expr))) + t1) (or (and lin (or (math-negp (car lin)) - (not (Math-lessp (car lin) (nth 2 math-simplify-expr)))) + (not (Math-lessp (car lin) (nth 2 expr)))) (list '% (list '+ (math-mul (nth 1 lin) (nth 2 lin)) - (math-mod (car lin) (nth 2 math-simplify-expr))) - (nth 2 math-simplify-expr))) + (math-mod (car lin) (nth 2 expr))) + (nth 2 expr))) (and lin (not (math-equal-int (nth 1 lin) 1)) (math-num-integerp (nth 1 lin)) - (math-num-integerp (nth 2 math-simplify-expr)) - (setq t1 (calcFunc-gcd (nth 1 lin) (nth 2 math-simplify-expr))) + (math-num-integerp (nth 2 expr)) + (setq t1 (calcFunc-gcd (nth 1 lin) (nth 2 expr))) (not (math-equal-int t1 1)) (list '* t1 @@ -709,53 +704,53 @@ (nth 2 lin)) (let ((calc-prefer-frac t)) (math-div (car lin) t1))) - (math-div (nth 2 math-simplify-expr) t1)))) - (and (math-equal-int (nth 2 math-simplify-expr) 1) + (math-div (nth 2 expr) t1)))) + (and (math-equal-int (nth 2 expr) 1) (math-known-integerp (if lin (math-mul (nth 1 lin) (nth 2 lin)) - (nth 1 math-simplify-expr))) + (nth 1 expr))) (if lin (math-mod (car lin) 1) 0)))))) (math-defsimplify (calcFunc-eq calcFunc-neq calcFunc-lt calcFunc-gt calcFunc-leq calcFunc-geq) - (if (= (length math-simplify-expr) 3) - (math-simplify-ineq))) + (if (= (length expr) 3) + (math-simplify-ineq expr))) -(defun math-simplify-ineq () - (let ((np (cdr math-simplify-expr)) +(defun math-simplify-ineq (expr) + (let ((np (cdr expr)) n) (while (memq (car-safe (setq n (car np))) '(+ -)) - (math-simplify-add-term (cdr (cdr n)) (cdr (cdr math-simplify-expr)) + (math-simplify-add-term (cdr (cdr n)) (cdr (cdr expr)) (eq (car n) '-) nil) (setq np (cdr n))) - (math-simplify-add-term np (cdr (cdr math-simplify-expr)) nil - (eq np (cdr math-simplify-expr))) - (math-simplify-divide) - (let ((signs (math-possible-signs (cons '- (cdr math-simplify-expr))))) - (or (cond ((eq (car math-simplify-expr) 'calcFunc-eq) + (math-simplify-add-term np (cdr (cdr expr)) nil + (eq np (cdr expr))) + (math-simplify-divide expr) + (let ((signs (math-possible-signs (cons '- (cdr expr))))) + (or (cond ((eq (car expr) 'calcFunc-eq) (or (and (eq signs 2) 1) (and (memq signs '(1 4 5)) 0))) - ((eq (car math-simplify-expr) 'calcFunc-neq) + ((eq (car expr) 'calcFunc-neq) (or (and (eq signs 2) 0) (and (memq signs '(1 4 5)) 1))) - ((eq (car math-simplify-expr) 'calcFunc-lt) + ((eq (car expr) 'calcFunc-lt) (or (and (eq signs 1) 1) (and (memq signs '(2 4 6)) 0))) - ((eq (car math-simplify-expr) 'calcFunc-gt) + ((eq (car expr) 'calcFunc-gt) (or (and (eq signs 4) 1) (and (memq signs '(1 2 3)) 0))) - ((eq (car math-simplify-expr) 'calcFunc-leq) + ((eq (car expr) 'calcFunc-leq) (or (and (eq signs 4) 0) (and (memq signs '(1 2 3)) 1))) - ((eq (car math-simplify-expr) 'calcFunc-geq) + ((eq (car expr) 'calcFunc-geq) (or (and (eq signs 1) 0) (and (memq signs '(2 4 6)) 1)))) - math-simplify-expr)))) + expr)))) (defun math-simplify-add-term (np dp minus lplain) (or (math-vectorp (car np)) (let ((rplain t) - n d dd temp) + n d temp) (while (memq (car-safe (setq n (car np) d (car dp))) '(+ -)) (setq rplain nil) (if (setq temp (math-combine-sum n (nth 2 d) @@ -782,27 +777,27 @@ (setcar dp (setq n (math-neg temp))))))))) (math-defsimplify calcFunc-sin - (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin) - (nth 1 (nth 1 math-simplify-expr))) - (and (math-looks-negp (nth 1 math-simplify-expr)) - (math-neg (list 'calcFunc-sin (math-neg (nth 1 math-simplify-expr))))) + (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin) + (nth 1 (nth 1 expr))) + (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-sin (math-neg (nth 1 expr))))) (and (eq calc-angle-mode 'rad) - (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi)))) + (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi)))) (and n (math-known-sin (car n) (nth 1 n) 120 0)))) (and (eq calc-angle-mode 'deg) - (let ((n (math-integer-plus (nth 1 math-simplify-expr)))) + (let ((n (math-integer-plus (nth 1 expr)))) (and n (math-known-sin (car n) (nth 1 n) '(frac 2 3) 0)))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos) (list 'calcFunc-sqrt (math-sub 1 (math-sqr - (nth 1 (nth 1 math-simplify-expr)))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan) - (math-div (nth 1 (nth 1 math-simplify-expr)) + (nth 1 (nth 1 expr)))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan) + (math-div (nth 1 (nth 1 expr)) (list 'calcFunc-sqrt (math-add 1 (math-sqr - (nth 1 (nth 1 math-simplify-expr))))))) - (let ((m (math-should-expand-trig (nth 1 math-simplify-expr)))) + (nth 1 (nth 1 expr))))))) + (let ((m (math-should-expand-trig (nth 1 expr)))) (and m (integerp (car m)) (let ((n (car m)) (a (nth 1 m))) (list '+ @@ -812,27 +807,27 @@ (list 'calcFunc-sin a)))))))) (math-defsimplify calcFunc-cos - (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos) - (nth 1 (nth 1 math-simplify-expr))) - (and (math-looks-negp (nth 1 math-simplify-expr)) - (list 'calcFunc-cos (math-neg (nth 1 math-simplify-expr)))) + (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos) + (nth 1 (nth 1 expr))) + (and (math-looks-negp (nth 1 expr)) + (list 'calcFunc-cos (math-neg (nth 1 expr)))) (and (eq calc-angle-mode 'rad) - (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi)))) + (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi)))) (and n (math-known-sin (car n) (nth 1 n) 120 300)))) (and (eq calc-angle-mode 'deg) - (let ((n (math-integer-plus (nth 1 math-simplify-expr)))) + (let ((n (math-integer-plus (nth 1 expr)))) (and n (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300)))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin) (list 'calcFunc-sqrt - (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan) + (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan) (math-div 1 (list 'calcFunc-sqrt (math-add 1 - (math-sqr (nth 1 (nth 1 math-simplify-expr))))))) - (let ((m (math-should-expand-trig (nth 1 math-simplify-expr)))) + (math-sqr (nth 1 (nth 1 expr))))))) + (let ((m (math-should-expand-trig (nth 1 expr)))) (and m (integerp (car m)) (let ((n (car m)) (a (nth 1 m))) (list '- @@ -842,53 +837,57 @@ (list 'calcFunc-sin a)))))))) (math-defsimplify calcFunc-sec - (or (and (math-looks-negp (nth 1 math-simplify-expr)) - (list 'calcFunc-sec (math-neg (nth 1 math-simplify-expr)))) + (or (and (math-looks-negp (nth 1 expr)) + (list 'calcFunc-sec (math-neg (nth 1 expr)))) (and (eq calc-angle-mode 'rad) - (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi)))) + (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi)))) (and n - (math-div 1 (math-known-sin (car n) (nth 1 n) 120 300))))) + (let ((s (math-known-sin (car n) (nth 1 n) 120 300))) + (and s (math-div 1 s)))))) (and (eq calc-angle-mode 'deg) - (let ((n (math-integer-plus (nth 1 math-simplify-expr)))) + (let ((n (math-integer-plus (nth 1 expr)))) (and n - (math-div 1 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin) + (let ((s (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300))) + (and s (math-div 1 s)))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin) (math-div 1 (list 'calcFunc-sqrt - (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos) + (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos) (math-div 1 - (nth 1 (nth 1 math-simplify-expr)))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan) + (nth 1 (nth 1 expr)))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan) (list 'calcFunc-sqrt (math-add 1 - (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))) + (math-sqr (nth 1 (nth 1 expr)))))))) (math-defsimplify calcFunc-csc - (or (and (math-looks-negp (nth 1 math-simplify-expr)) - (math-neg (list 'calcFunc-csc (math-neg (nth 1 math-simplify-expr))))) + (or (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-csc (math-neg (nth 1 expr))))) (and (eq calc-angle-mode 'rad) - (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi)))) + (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi)))) (and n - (math-div 1 (math-known-sin (car n) (nth 1 n) 120 0))))) + (let ((s (math-known-sin (car n) (nth 1 n) 120 0))) + (and s (math-div 1 s)))))) (and (eq calc-angle-mode 'deg) - (let ((n (math-integer-plus (nth 1 math-simplify-expr)))) + (let ((n (math-integer-plus (nth 1 expr)))) (and n - (math-div 1 (math-known-sin (car n) (nth 1 n) '(frac 2 3) 0))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin) - (math-div 1 (nth 1 (nth 1 math-simplify-expr)))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos) + (let ((s (math-known-sin (car n) (nth 1 n) '(frac 2 3) 0))) + (and s (math-div 1 s)))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin) + (math-div 1 (nth 1 (nth 1 expr)))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos) (math-div 1 (list 'calcFunc-sqrt (math-sub 1 (math-sqr - (nth 1 (nth 1 math-simplify-expr))))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan) + (nth 1 (nth 1 expr))))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan) (math-div (list 'calcFunc-sqrt (math-add 1 (math-sqr - (nth 1 (nth 1 math-simplify-expr))))) - (nth 1 (nth 1 math-simplify-expr)))))) + (nth 1 (nth 1 expr))))) + (nth 1 (nth 1 expr)))))) (defun math-should-expand-trig (x &optional hyperbolic) (let ((m (math-is-multiple x))) @@ -943,55 +942,57 @@ (t nil)))))) (math-defsimplify calcFunc-tan - (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan) - (nth 1 (nth 1 math-simplify-expr))) - (and (math-looks-negp (nth 1 math-simplify-expr)) - (math-neg (list 'calcFunc-tan (math-neg (nth 1 math-simplify-expr))))) + (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan) + (nth 1 (nth 1 expr))) + (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-tan (math-neg (nth 1 expr))))) (and (eq calc-angle-mode 'rad) - (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi)))) + (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi)))) (and n (math-known-tan (car n) (nth 1 n) 120)))) (and (eq calc-angle-mode 'deg) - (let ((n (math-integer-plus (nth 1 math-simplify-expr)))) + (let ((n (math-integer-plus (nth 1 expr)))) (and n (math-known-tan (car n) (nth 1 n) '(frac 2 3))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin) - (math-div (nth 1 (nth 1 math-simplify-expr)) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin) + (math-div (nth 1 (nth 1 expr)) (list 'calcFunc-sqrt - (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos) + (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos) (math-div (list 'calcFunc-sqrt - (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))) - (nth 1 (nth 1 math-simplify-expr)))) - (let ((m (math-should-expand-trig (nth 1 math-simplify-expr)))) + (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))) + (nth 1 (nth 1 expr)))) + (let ((m (math-should-expand-trig (nth 1 expr)))) (and m (if (equal (car m) '(frac 1 2)) (math-div (math-sub 1 (list 'calcFunc-cos (nth 1 m))) (list 'calcFunc-sin (nth 1 m))) - (math-div (list 'calcFunc-sin (nth 1 math-simplify-expr)) - (list 'calcFunc-cos (nth 1 math-simplify-expr)))))))) + (math-div (list 'calcFunc-sin (nth 1 expr)) + (list 'calcFunc-cos (nth 1 expr)))))))) (math-defsimplify calcFunc-cot - (or (and (math-looks-negp (nth 1 math-simplify-expr)) - (math-neg (list 'calcFunc-cot (math-neg (nth 1 math-simplify-expr))))) + (or (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-cot (math-neg (nth 1 expr))))) (and (eq calc-angle-mode 'rad) - (let ((n (math-linear-in (nth 1 math-simplify-expr) '(var pi var-pi)))) + (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi)))) (and n - (math-div 1 (math-known-tan (car n) (nth 1 n) 120))))) + (let ((tn (math-known-tan (car n) (nth 1 n) 120))) + (and tn (math-div 1 tn)))))) (and (eq calc-angle-mode 'deg) - (let ((n (math-integer-plus (nth 1 math-simplify-expr)))) + (let ((n (math-integer-plus (nth 1 expr)))) (and n - (math-div 1 (math-known-tan (car n) (nth 1 n) '(frac 2 3)))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsin) + (let ((tn (math-known-tan (car n) (nth 1 n) '(frac 2 3)))) + (and tn (math-div 1 tn)))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin) (math-div (list 'calcFunc-sqrt - (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))) - (nth 1 (nth 1 math-simplify-expr)))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccos) - (math-div (nth 1 (nth 1 math-simplify-expr)) + (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))) + (nth 1 (nth 1 expr)))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos) + (math-div (nth 1 (nth 1 expr)) (list 'calcFunc-sqrt - (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctan) - (math-div 1 (nth 1 (nth 1 math-simplify-expr)))))) + (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan) + (math-div 1 (nth 1 (nth 1 expr)))))) (defun math-known-tan (plus n mul) (setq n (math-mul n mul)) @@ -1026,20 +1027,20 @@ (t nil)))))) (math-defsimplify calcFunc-sinh - (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh) - (nth 1 (nth 1 math-simplify-expr))) - (and (math-looks-negp (nth 1 math-simplify-expr)) - (math-neg (list 'calcFunc-sinh (math-neg (nth 1 math-simplify-expr))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh) + (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh) + (nth 1 (nth 1 expr))) + (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-sinh (math-neg (nth 1 expr))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh) math-living-dangerously (list 'calcFunc-sqrt - (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh) + (math-sub (math-sqr (nth 1 (nth 1 expr))) 1))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh) math-living-dangerously - (math-div (nth 1 (nth 1 math-simplify-expr)) + (math-div (nth 1 (nth 1 expr)) (list 'calcFunc-sqrt - (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))) - (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t))) + (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))))) + (let ((m (math-should-expand-trig (nth 1 expr) t))) (and m (integerp (car m)) (let ((n (car m)) (a (nth 1 m))) (if (> n 1) @@ -1050,20 +1051,20 @@ (list 'calcFunc-sinh a))))))))) (math-defsimplify calcFunc-cosh - (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh) - (nth 1 (nth 1 math-simplify-expr))) - (and (math-looks-negp (nth 1 math-simplify-expr)) - (list 'calcFunc-cosh (math-neg (nth 1 math-simplify-expr)))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh) + (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh) + (nth 1 (nth 1 expr))) + (and (math-looks-negp (nth 1 expr)) + (list 'calcFunc-cosh (math-neg (nth 1 expr)))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh) math-living-dangerously (list 'calcFunc-sqrt - (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh) + (math-add (math-sqr (nth 1 (nth 1 expr))) 1))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh) math-living-dangerously (math-div 1 (list 'calcFunc-sqrt - (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))))) - (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t))) + (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))))) + (let ((m (math-should-expand-trig (nth 1 expr) t))) (and m (integerp (car m)) (let ((n (car m)) (a (nth 1 m))) (if (> n 1) @@ -1074,188 +1075,188 @@ (list 'calcFunc-sinh a))))))))) (math-defsimplify calcFunc-tanh - (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh) - (nth 1 (nth 1 math-simplify-expr))) - (and (math-looks-negp (nth 1 math-simplify-expr)) - (math-neg (list 'calcFunc-tanh (math-neg (nth 1 math-simplify-expr))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh) + (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh) + (nth 1 (nth 1 expr))) + (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-tanh (math-neg (nth 1 expr))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh) math-living-dangerously - (math-div (nth 1 (nth 1 math-simplify-expr)) + (math-div (nth 1 (nth 1 expr)) (list 'calcFunc-sqrt - (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh) + (math-add (math-sqr (nth 1 (nth 1 expr))) 1)))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh) math-living-dangerously (math-div (list 'calcFunc-sqrt - (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)) - (nth 1 (nth 1 math-simplify-expr)))) - (let ((m (math-should-expand-trig (nth 1 math-simplify-expr) t))) + (math-sub (math-sqr (nth 1 (nth 1 expr))) 1)) + (nth 1 (nth 1 expr)))) + (let ((m (math-should-expand-trig (nth 1 expr) t))) (and m (if (equal (car m) '(frac 1 2)) (math-div (math-sub (list 'calcFunc-cosh (nth 1 m)) 1) (list 'calcFunc-sinh (nth 1 m))) - (math-div (list 'calcFunc-sinh (nth 1 math-simplify-expr)) - (list 'calcFunc-cosh (nth 1 math-simplify-expr)))))))) + (math-div (list 'calcFunc-sinh (nth 1 expr)) + (list 'calcFunc-cosh (nth 1 expr)))))))) (math-defsimplify calcFunc-sech - (or (and (math-looks-negp (nth 1 math-simplify-expr)) - (list 'calcFunc-sech (math-neg (nth 1 math-simplify-expr)))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh) + (or (and (math-looks-negp (nth 1 expr)) + (list 'calcFunc-sech (math-neg (nth 1 expr)))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh) math-living-dangerously (math-div 1 (list 'calcFunc-sqrt - (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh) + (math-add (math-sqr (nth 1 (nth 1 expr))) 1)))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh) math-living-dangerously - (math-div 1 (nth 1 (nth 1 math-simplify-expr))) 1) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh) + (math-div 1 (nth 1 (nth 1 expr))) 1) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh) math-living-dangerously (list 'calcFunc-sqrt - (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr)))))))) + (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))))) (math-defsimplify calcFunc-csch - (or (and (math-looks-negp (nth 1 math-simplify-expr)) - (math-neg (list 'calcFunc-csch (math-neg (nth 1 math-simplify-expr))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh) + (or (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-csch (math-neg (nth 1 expr))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh) math-living-dangerously - (math-div 1 (nth 1 (nth 1 math-simplify-expr)))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh) + (math-div 1 (nth 1 (nth 1 expr)))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh) math-living-dangerously (math-div 1 (list 'calcFunc-sqrt - (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh) + (math-sub (math-sqr (nth 1 (nth 1 expr))) 1)))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh) math-living-dangerously (math-div (list 'calcFunc-sqrt - (math-sub 1 (math-sqr (nth 1 (nth 1 math-simplify-expr))))) - (nth 1 (nth 1 math-simplify-expr)))))) + (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))) + (nth 1 (nth 1 expr)))))) (math-defsimplify calcFunc-coth - (or (and (math-looks-negp (nth 1 math-simplify-expr)) - (math-neg (list 'calcFunc-coth (math-neg (nth 1 math-simplify-expr))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arcsinh) + (or (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-coth (math-neg (nth 1 expr))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh) math-living-dangerously (math-div (list 'calcFunc-sqrt - (math-add (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)) - (nth 1 (nth 1 math-simplify-expr)))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arccosh) + (math-add (math-sqr (nth 1 (nth 1 expr))) 1)) + (nth 1 (nth 1 expr)))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh) math-living-dangerously - (math-div (nth 1 (nth 1 math-simplify-expr)) + (math-div (nth 1 (nth 1 expr)) (list 'calcFunc-sqrt - (math-sub (math-sqr (nth 1 (nth 1 math-simplify-expr))) 1)))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-arctanh) + (math-sub (math-sqr (nth 1 (nth 1 expr))) 1)))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh) math-living-dangerously - (math-div 1 (nth 1 (nth 1 math-simplify-expr)))))) + (math-div 1 (nth 1 (nth 1 expr)))))) (math-defsimplify calcFunc-arcsin - (or (and (math-looks-negp (nth 1 math-simplify-expr)) - (math-neg (list 'calcFunc-arcsin (math-neg (nth 1 math-simplify-expr))))) - (and (eq (nth 1 math-simplify-expr) 1) + (or (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-arcsin (math-neg (nth 1 expr))))) + (and (eq (nth 1 expr) 1) (math-quarter-circle t)) - (and (equal (nth 1 math-simplify-expr) '(frac 1 2)) + (and (equal (nth 1 expr) '(frac 1 2)) (math-div (math-half-circle t) 6)) (and math-living-dangerously - (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sin) - (nth 1 (nth 1 math-simplify-expr))) + (eq (car-safe (nth 1 expr)) 'calcFunc-sin) + (nth 1 (nth 1 expr))) (and math-living-dangerously - (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos) + (eq (car-safe (nth 1 expr)) 'calcFunc-cos) (math-sub (math-quarter-circle t) - (nth 1 (nth 1 math-simplify-expr)))))) + (nth 1 (nth 1 expr)))))) (math-defsimplify calcFunc-arccos - (or (and (eq (nth 1 math-simplify-expr) 0) + (or (and (eq (nth 1 expr) 0) (math-quarter-circle t)) - (and (eq (nth 1 math-simplify-expr) -1) + (and (eq (nth 1 expr) -1) (math-half-circle t)) - (and (equal (nth 1 math-simplify-expr) '(frac 1 2)) + (and (equal (nth 1 expr) '(frac 1 2)) (math-div (math-half-circle t) 3)) - (and (equal (nth 1 math-simplify-expr) '(frac -1 2)) + (and (equal (nth 1 expr) '(frac -1 2)) (math-div (math-mul (math-half-circle t) 2) 3)) (and math-living-dangerously - (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos) - (nth 1 (nth 1 math-simplify-expr))) + (eq (car-safe (nth 1 expr)) 'calcFunc-cos) + (nth 1 (nth 1 expr))) (and math-living-dangerously - (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sin) + (eq (car-safe (nth 1 expr)) 'calcFunc-sin) (math-sub (math-quarter-circle t) - (nth 1 (nth 1 math-simplify-expr)))))) + (nth 1 (nth 1 expr)))))) (math-defsimplify calcFunc-arctan - (or (and (math-looks-negp (nth 1 math-simplify-expr)) - (math-neg (list 'calcFunc-arctan (math-neg (nth 1 math-simplify-expr))))) - (and (eq (nth 1 math-simplify-expr) 1) + (or (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-arctan (math-neg (nth 1 expr))))) + (and (eq (nth 1 expr) 1) (math-div (math-half-circle t) 4)) (and math-living-dangerously - (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-tan) - (nth 1 (nth 1 math-simplify-expr))))) + (eq (car-safe (nth 1 expr)) 'calcFunc-tan) + (nth 1 (nth 1 expr))))) (math-defsimplify calcFunc-arcsinh - (or (and (math-looks-negp (nth 1 math-simplify-expr)) - (math-neg (list 'calcFunc-arcsinh (math-neg (nth 1 math-simplify-expr))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sinh) + (or (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-arcsinh (math-neg (nth 1 expr))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-sinh) (or math-living-dangerously - (math-known-realp (nth 1 (nth 1 math-simplify-expr)))) - (nth 1 (nth 1 math-simplify-expr))))) + (math-known-realp (nth 1 (nth 1 expr)))) + (nth 1 (nth 1 expr))))) (math-defsimplify calcFunc-arccosh - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cosh) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-cosh) (or math-living-dangerously - (math-known-realp (nth 1 (nth 1 math-simplify-expr)))) - (nth 1 (nth 1 math-simplify-expr)))) + (math-known-realp (nth 1 (nth 1 expr)))) + (nth 1 (nth 1 expr)))) (math-defsimplify calcFunc-arctanh - (or (and (math-looks-negp (nth 1 math-simplify-expr)) - (math-neg (list 'calcFunc-arctanh (math-neg (nth 1 math-simplify-expr))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-tanh) + (or (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-arctanh (math-neg (nth 1 expr))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-tanh) (or math-living-dangerously - (math-known-realp (nth 1 (nth 1 math-simplify-expr)))) - (nth 1 (nth 1 math-simplify-expr))))) + (math-known-realp (nth 1 (nth 1 expr)))) + (nth 1 (nth 1 expr))))) (math-defsimplify calcFunc-sqrt - (math-simplify-sqrt)) + (math-simplify-sqrt expr)) -(defun math-simplify-sqrt () - (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'frac) +(defun math-simplify-sqrt (expr) + (or (and (eq (car-safe (nth 1 expr)) 'frac) (math-div (list 'calcFunc-sqrt - (math-mul (nth 1 (nth 1 math-simplify-expr)) - (nth 2 (nth 1 math-simplify-expr)))) - (nth 2 (nth 1 math-simplify-expr)))) - (let ((fac (if (math-objectp (nth 1 math-simplify-expr)) - (math-squared-factor (nth 1 math-simplify-expr)) - (math-common-constant-factor (nth 1 math-simplify-expr))))) + (math-mul (nth 1 (nth 1 expr)) + (nth 2 (nth 1 expr)))) + (nth 2 (nth 1 expr)))) + (let ((fac (if (math-objectp (nth 1 expr)) + (math-squared-factor (nth 1 expr)) + (math-common-constant-factor (nth 1 expr))))) (and fac (not (eq fac 1)) (math-mul (math-normalize (list 'calcFunc-sqrt fac)) (math-normalize (list 'calcFunc-sqrt (math-cancel-common-factor - (nth 1 math-simplify-expr) fac)))))) + (nth 1 expr) fac)))))) (and math-living-dangerously - (or (and (eq (car-safe (nth 1 math-simplify-expr)) '-) - (math-equal-int (nth 1 (nth 1 math-simplify-expr)) 1) - (eq (car-safe (nth 2 (nth 1 math-simplify-expr))) '^) - (math-equal-int (nth 2 (nth 2 (nth 1 math-simplify-expr))) 2) - (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr)))) + (or (and (eq (car-safe (nth 1 expr)) '-) + (math-equal-int (nth 1 (nth 1 expr)) 1) + (eq (car-safe (nth 2 (nth 1 expr))) '^) + (math-equal-int (nth 2 (nth 2 (nth 1 expr))) 2) + (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 expr)))) 'calcFunc-sin) (list 'calcFunc-cos - (nth 1 (nth 1 (nth 2 (nth 1 math-simplify-expr)))))) - (and (eq (car-safe (nth 1 (nth 2 (nth 1 math-simplify-expr)))) + (nth 1 (nth 1 (nth 2 (nth 1 expr)))))) + (and (eq (car-safe (nth 1 (nth 2 (nth 1 expr)))) 'calcFunc-cos) (list 'calcFunc-sin (nth 1 (nth 1 (nth 2 - (nth 1 math-simplify-expr)))))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) '-) - (math-equal-int (nth 2 (nth 1 math-simplify-expr)) 1) - (eq (car-safe (nth 1 (nth 1 math-simplify-expr))) '^) - (math-equal-int (nth 2 (nth 1 (nth 1 math-simplify-expr))) 2) - (and (eq (car-safe (nth 1 (nth 1 (nth 1 math-simplify-expr)))) + (nth 1 expr)))))))) + (and (eq (car-safe (nth 1 expr)) '-) + (math-equal-int (nth 2 (nth 1 expr)) 1) + (eq (car-safe (nth 1 (nth 1 expr))) '^) + (math-equal-int (nth 2 (nth 1 (nth 1 expr))) 2) + (and (eq (car-safe (nth 1 (nth 1 (nth 1 expr)))) 'calcFunc-cosh) (list 'calcFunc-sinh - (nth 1 (nth 1 (nth 1 (nth 1 math-simplify-expr))))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) '+) - (let ((a (nth 1 (nth 1 math-simplify-expr))) - (b (nth 2 (nth 1 math-simplify-expr)))) + (nth 1 (nth 1 (nth 1 (nth 1 expr))))))) + (and (eq (car-safe (nth 1 expr)) '+) + (let ((a (nth 1 (nth 1 expr))) + (b (nth 2 (nth 1 expr)))) (and (or (and (math-equal-int a 1) - (setq a b b (nth 1 (nth 1 math-simplify-expr)))) + (setq a b b (nth 1 (nth 1 expr)))) (math-equal-int b 1)) (eq (car-safe a) '^) (math-equal-int (nth 2 a) 2) @@ -1269,20 +1270,20 @@ (and (eq (car-safe (nth 1 a)) 'calcFunc-cot) (list '/ 1 (list 'calcFunc-sin (nth 1 (nth 1 a))))))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) '^) + (and (eq (car-safe (nth 1 expr)) '^) (list '^ - (nth 1 (nth 1 math-simplify-expr)) - (math-div (nth 2 (nth 1 math-simplify-expr)) 2))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sqrt) - (list '^ (nth 1 (nth 1 math-simplify-expr)) (math-div 1 4))) - (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /)) - (list (car (nth 1 math-simplify-expr)) - (list 'calcFunc-sqrt (nth 1 (nth 1 math-simplify-expr))) - (list 'calcFunc-sqrt (nth 2 (nth 1 math-simplify-expr))))) - (and (memq (car-safe (nth 1 math-simplify-expr)) '(+ -)) - (not (math-any-floats (nth 1 math-simplify-expr))) + (nth 1 (nth 1 expr)) + (math-div (nth 2 (nth 1 expr)) 2))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-sqrt) + (list '^ (nth 1 (nth 1 expr)) (math-div 1 4))) + (and (memq (car-safe (nth 1 expr)) '(* /)) + (list (car (nth 1 expr)) + (list 'calcFunc-sqrt (nth 1 (nth 1 expr))) + (list 'calcFunc-sqrt (nth 2 (nth 1 expr))))) + (and (memq (car-safe (nth 1 expr)) '(+ -)) + (not (math-any-floats (nth 1 expr))) (let ((f (calcFunc-factors (calcFunc-expand - (nth 1 math-simplify-expr))))) + (nth 1 expr))))) (and (math-vectorp f) (or (> (length f) 2) (> (nth 2 (nth 1 f)) 1)) @@ -1318,7 +1319,7 @@ fac))) (math-defsimplify calcFunc-exp - (math-simplify-exp (nth 1 math-simplify-expr))) + (math-simplify-exp (nth 1 expr))) (defun math-simplify-exp (x) (or (and (eq (car-safe x) 'calcFunc-ln) @@ -1349,22 +1350,22 @@ (list '+ c (list '* s '(var i var-i)))))))) (math-defsimplify calcFunc-ln - (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-exp) + (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-exp) (or math-living-dangerously - (math-known-realp (nth 1 (nth 1 math-simplify-expr)))) - (nth 1 (nth 1 math-simplify-expr))) - (and (eq (car-safe (nth 1 math-simplify-expr)) '^) - (equal (nth 1 (nth 1 math-simplify-expr)) '(var e var-e)) + (math-known-realp (nth 1 (nth 1 expr)))) + (nth 1 (nth 1 expr))) + (and (eq (car-safe (nth 1 expr)) '^) + (equal (nth 1 (nth 1 expr)) '(var e var-e)) (or math-living-dangerously - (math-known-realp (nth 2 (nth 1 math-simplify-expr)))) - (nth 2 (nth 1 math-simplify-expr))) + (math-known-realp (nth 2 (nth 1 expr)))) + (nth 2 (nth 1 expr))) (and calc-symbolic-mode - (math-known-negp (nth 1 math-simplify-expr)) - (math-add (list 'calcFunc-ln (math-neg (nth 1 math-simplify-expr))) + (math-known-negp (nth 1 expr)) + (math-add (list 'calcFunc-ln (math-neg (nth 1 expr))) '(* (var pi var-pi) (var i var-i)))) (and calc-symbolic-mode - (math-known-imagp (nth 1 math-simplify-expr)) - (let* ((ip (calcFunc-im (nth 1 math-simplify-expr))) + (math-known-imagp (nth 1 expr)) + (let* ((ip (calcFunc-im (nth 1 expr))) (ips (math-possible-signs ip))) (or (and (memq ips '(4 6)) (math-add (list 'calcFunc-ln ip) @@ -1374,95 +1375,92 @@ '(/ (* (var pi var-pi) (var i var-i)) 2)))))))) (math-defsimplify ^ - (math-simplify-pow)) - -(defun math-simplify-pow () (or (and math-living-dangerously - (or (and (eq (car-safe (nth 1 math-simplify-expr)) '^) + (or (and (eq (car-safe (nth 1 expr)) '^) (list '^ - (nth 1 (nth 1 math-simplify-expr)) - (math-mul (nth 2 math-simplify-expr) - (nth 2 (nth 1 math-simplify-expr))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-sqrt) + (nth 1 (nth 1 expr)) + (math-mul (nth 2 expr) + (nth 2 (nth 1 expr))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-sqrt) (list '^ - (nth 1 (nth 1 math-simplify-expr)) - (math-div (nth 2 math-simplify-expr) 2))) - (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /)) - (list (car (nth 1 math-simplify-expr)) - (list '^ (nth 1 (nth 1 math-simplify-expr)) - (nth 2 math-simplify-expr)) - (list '^ (nth 2 (nth 1 math-simplify-expr)) - (nth 2 math-simplify-expr)))))) - (and (math-equal-int (nth 1 math-simplify-expr) 10) - (eq (car-safe (nth 2 math-simplify-expr)) 'calcFunc-log10) - (nth 1 (nth 2 math-simplify-expr))) - (and (equal (nth 1 math-simplify-expr) '(var e var-e)) - (math-simplify-exp (nth 2 math-simplify-expr))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-exp) + (nth 1 (nth 1 expr)) + (math-div (nth 2 expr) 2))) + (and (memq (car-safe (nth 1 expr)) '(* /)) + (list (car (nth 1 expr)) + (list '^ (nth 1 (nth 1 expr)) + (nth 2 expr)) + (list '^ (nth 2 (nth 1 expr)) + (nth 2 expr)))))) + (and (math-equal-int (nth 1 expr) 10) + (eq (car-safe (nth 2 expr)) 'calcFunc-log10) + (nth 1 (nth 2 expr))) + (and (equal (nth 1 expr) '(var e var-e)) + (math-simplify-exp (nth 2 expr))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-exp) (not math-integrating) - (list 'calcFunc-exp (math-mul (nth 1 (nth 1 math-simplify-expr)) - (nth 2 math-simplify-expr)))) - (and (equal (nth 1 math-simplify-expr) '(var i var-i)) + (list 'calcFunc-exp (math-mul (nth 1 (nth 1 expr)) + (nth 2 expr)))) + (and (equal (nth 1 expr) '(var i var-i)) (math-imaginary-i) - (math-num-integerp (nth 2 math-simplify-expr)) - (let ((x (math-mod (math-trunc (nth 2 math-simplify-expr)) 4))) + (math-num-integerp (nth 2 expr)) + (let ((x (math-mod (math-trunc (nth 2 expr)) 4))) (cond ((eq x 0) 1) - ((eq x 1) (nth 1 math-simplify-expr)) + ((eq x 1) (nth 1 expr)) ((eq x 2) -1) - ((eq x 3) (math-neg (nth 1 math-simplify-expr)))))) + ((eq x 3) (math-neg (nth 1 expr)))))) (and math-integrating - (integerp (nth 2 math-simplify-expr)) - (>= (nth 2 math-simplify-expr) 2) - (or (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cos) - (math-mul (math-pow (nth 1 math-simplify-expr) - (- (nth 2 math-simplify-expr) 2)) + (integerp (nth 2 expr)) + (>= (nth 2 expr) 2) + (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-cos) + (math-mul (math-pow (nth 1 expr) + (- (nth 2 expr) 2)) (math-sub 1 (math-sqr (list 'calcFunc-sin - (nth 1 (nth 1 math-simplify-expr))))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-cosh) - (math-mul (math-pow (nth 1 math-simplify-expr) - (- (nth 2 math-simplify-expr) 2)) + (nth 1 (nth 1 expr))))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-cosh) + (math-mul (math-pow (nth 1 expr) + (- (nth 2 expr) 2)) (math-add 1 (math-sqr (list 'calcFunc-sinh - (nth 1 (nth 1 math-simplify-expr))))))))) - (and (eq (car-safe (nth 2 math-simplify-expr)) 'frac) - (Math-ratp (nth 1 math-simplify-expr)) - (Math-posp (nth 1 math-simplify-expr)) - (if (equal (nth 2 math-simplify-expr) '(frac 1 2)) - (list 'calcFunc-sqrt (nth 1 math-simplify-expr)) - (let ((flr (math-floor (nth 2 math-simplify-expr)))) + (nth 1 (nth 1 expr))))))))) + (and (eq (car-safe (nth 2 expr)) 'frac) + (Math-ratp (nth 1 expr)) + (Math-posp (nth 1 expr)) + (if (equal (nth 2 expr) '(frac 1 2)) + (list 'calcFunc-sqrt (nth 1 expr)) + (let ((flr (math-floor (nth 2 expr)))) (and (not (Math-zerop flr)) - (list '* (list '^ (nth 1 math-simplify-expr) flr) - (list '^ (nth 1 math-simplify-expr) - (math-sub (nth 2 math-simplify-expr) flr))))))) - (and (eq (math-quarter-integer (nth 2 math-simplify-expr)) 2) - (let ((temp (math-simplify-sqrt))) + (list '* (list '^ (nth 1 expr) flr) + (list '^ (nth 1 expr) + (math-sub (nth 2 expr) flr))))))) + (and (eq (math-quarter-integer (nth 2 expr)) 2) + (let ((temp (math-simplify-sqrt expr))) (and temp - (list '^ temp (math-mul (nth 2 math-simplify-expr) 2))))))) + (list '^ temp (math-mul (nth 2 expr) 2))))))) (math-defsimplify calcFunc-log10 - (and (eq (car-safe (nth 1 math-simplify-expr)) '^) - (math-equal-int (nth 1 (nth 1 math-simplify-expr)) 10) + (and (eq (car-safe (nth 1 expr)) '^) + (math-equal-int (nth 1 (nth 1 expr)) 10) (or math-living-dangerously - (math-known-realp (nth 2 (nth 1 math-simplify-expr)))) - (nth 2 (nth 1 math-simplify-expr)))) + (math-known-realp (nth 2 (nth 1 expr)))) + (nth 2 (nth 1 expr)))) (math-defsimplify calcFunc-erf - (or (and (math-looks-negp (nth 1 math-simplify-expr)) - (math-neg (list 'calcFunc-erf (math-neg (nth 1 math-simplify-expr))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-conj) + (or (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-erf (math-neg (nth 1 expr))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-conj) (list 'calcFunc-conj - (list 'calcFunc-erf (nth 1 (nth 1 math-simplify-expr))))))) + (list 'calcFunc-erf (nth 1 (nth 1 expr))))))) (math-defsimplify calcFunc-erfc - (or (and (math-looks-negp (nth 1 math-simplify-expr)) - (math-sub 2 (list 'calcFunc-erfc (math-neg (nth 1 math-simplify-expr))))) - (and (eq (car-safe (nth 1 math-simplify-expr)) 'calcFunc-conj) + (or (and (math-looks-negp (nth 1 expr)) + (math-sub 2 (list 'calcFunc-erfc (math-neg (nth 1 expr))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-conj) (list 'calcFunc-conj - (list 'calcFunc-erfc (nth 1 (nth 1 math-simplify-expr))))))) + (list 'calcFunc-erfc (nth 1 (nth 1 expr))))))) (defun math-linear-in (expr term &optional always) @@ -1614,10 +1612,12 @@ (defvar math-expr-subst-old) (defvar math-expr-subst-new) -(defun math-expr-subst (expr math-expr-subst-old math-expr-subst-new) - (math-expr-subst-rec expr)) +(defun math-expr-subst (expr old new) + (let ((math-expr-subst-old old) + (math-expr-subst-new new)) + (math-expr-subst-rec expr))) -(defalias 'calcFunc-subst 'math-expr-subst) +(defalias 'calcFunc-subst #'math-expr-subst) (defun math-expr-subst-rec (expr) (cond ((equal expr math-expr-subst-old) math-expr-subst-new) @@ -1632,7 +1632,7 @@ (math-expr-subst-rec (nth 2 expr))))) (t (cons (car expr) - (mapcar 'math-expr-subst-rec (cdr expr)))))) + (mapcar #'math-expr-subst-rec (cdr expr)))))) ;;; Various measures of the size of an expression. (defun math-expr-weight (expr) @@ -1659,7 +1659,7 @@ (defun calcFunc-collect (expr base) (let ((p (math-is-polynomial expr base 50 t))) (if (cdr p) - (math-build-polynomial-expr (mapcar 'math-normalize p) base) + (math-build-polynomial-expr (mapcar #'math-normalize p) base) (car p)))) ;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...), @@ -1672,13 +1672,16 @@ (defvar math-is-poly-loose) (defvar math-var) -(defun math-is-polynomial (expr math-var &optional math-is-poly-degree math-is-poly-loose) - (let* ((math-poly-base-variable (if math-is-poly-loose - (if (eq math-is-poly-loose 'gen) math-var '(var XXX XXX)) +(defun math-is-polynomial (expr var &optional degree loose) + (let* ((math-poly-base-variable (if loose + (if (eq loose 'gen) var '(var XXX XXX)) math-poly-base-variable)) + (math-var var) + (math-is-poly-loose loose) + (math-is-poly-degree degree) (poly (math-is-poly-rec expr math-poly-neg-powers))) - (and (or (null math-is-poly-degree) - (<= (length poly) (1+ math-is-poly-degree))) + (and (or (null degree) + (<= (length poly) (1+ degree))) poly))) (defun math-is-poly-rec (expr negpow) @@ -1749,7 +1752,7 @@ (math-poly-mix p1 1 p2 (if (eq (car expr) '+) 1 -1))))))) ((eq (car expr) 'neg) - (mapcar 'math-neg (math-is-poly-rec (nth 1 expr) negpow))) + (mapcar #'math-neg (math-is-poly-rec (nth 1 expr) negpow))) ((eq (car expr) '*) (let ((p1 (math-is-poly-rec (nth 1 expr) negpow))) (and p1 @@ -1812,24 +1815,20 @@ (math-expr-contains expr math-poly-base-variable) (math-expr-depends expr var))) -;;; Find the variable (or sub-expression) which is the base of polynomial expr. ;; The variables math-poly-base-const-ok and math-poly-base-pred are ;; local to math-polynomial-base, but are used by math-polynomial-base-rec. (defvar math-poly-base-const-ok) (defvar math-poly-base-pred) -;; The variable math-poly-base-top-expr is local to math-polynomial-base, -;; but is used by math-polynomial-p1 in calc-poly.el, which is called -;; by math-polynomial-base. - -(defun math-polynomial-base (math-poly-base-top-expr &optional math-poly-base-pred) - (or math-poly-base-pred - (setq math-poly-base-pred (function (lambda (base) (math-polynomial-p - math-poly-base-top-expr base))))) +(defun math-polynomial-base (top-expr &optional pred) + "Find the variable (or sub-expression) which is the base of polynomial expr." + (let ((math-poly-base-pred + (or pred (function (lambda (base) (math-polynomial-p + top-expr base)))))) (or (let ((math-poly-base-const-ok nil)) - (math-polynomial-base-rec math-poly-base-top-expr)) + (math-polynomial-base-rec top-expr)) (let ((math-poly-base-const-ok t)) - (math-polynomial-base-rec math-poly-base-top-expr)))) + (math-polynomial-base-rec top-expr))))) (defun math-polynomial-base-rec (mpb-expr) (and (not (Math-objvecp mpb-expr)) @@ -1846,8 +1845,8 @@ (funcall math-poly-base-pred mpb-expr) mpb-expr)))) -;;; Return non-nil if expr refers to any variables. (defun math-expr-contains-vars (expr) + "Return non-nil if expr refers to any variables." (or (eq (car-safe expr) 'var) (and (not (Math-primp expr)) (progn @@ -1855,9 +1854,9 @@ (not (math-expr-contains-vars (car expr))))) expr)))) -;;; Simplify a polynomial in list form by stripping off high-end zeros. -;;; This always leaves the constant part, i.e., nil->nil and non-nil->non-nil. (defun math-poly-simplify (p) + "Simplify a polynomial in list form by stripping off high-end zeros. +This always leaves the constant part, i.e., nil->nil and non-nil->non-nil." (and p (if (Math-zerop (nth (1- (length p)) p)) (let ((pp (copy-sequence p))) @@ -1879,14 +1878,14 @@ (or (null a) (and (null (cdr a)) (Math-zerop (car a))))) -;;; Multiply two polynomials in list form. (defun math-poly-mul (a b) + "Multiply two polynomials in list form." (and a b (math-poly-mix b (car a) (math-poly-mul (cdr a) (cons 0 b)) 1))) -;;; Build an expression from a polynomial list. (defun math-build-polynomial-expr (p var) + "Build an expression from a polynomial list." (if p (if (Math-numberp var) (math-with-extra-prec 1 @@ -1897,8 +1896,7 @@ accum)) (let* ((rp (reverse p)) (n (1- (length rp))) - (accum (math-mul (car rp) (math-pow var n))) - term) + (accum (math-mul (car rp) (math-pow var n)))) (while (setq rp (cdr rp)) (setq n (1- n)) (or (math-zerop (car rp)) diff --git a/lisp/calc/calc-bin.el b/lisp/calc/calc-bin.el index a85792a6113..558e309e472 100644 --- a/lisp/calc/calc-bin.el +++ b/lisp/calc/calc-bin.el @@ -28,17 +28,6 @@ (require 'calc-ext) (require 'calc-macs) -;;; Some useful numbers -(defconst math-bignum-logb-digit-size - (logb math-bignum-digit-size) - "The logb of the size of a bignum digit. -This is the largest value of B such that 2^B is less than -the size of a Calc bignum digit.") - -(defconst math-bignum-digit-power-of-two - (expt 2 (logb math-bignum-digit-size)) - "The largest power of 2 less than the size of a Calc bignum digit.") - ;;; b-prefix binary commands. (defun calc-and (n) @@ -268,18 +257,14 @@ the size of a Calc bignum digit.") (math-reject-arg a 'integerp)) ((not (Math-num-integerp b)) (math-reject-arg b 'integerp)) - (t (math-clip (cons 'bigpos - (math-and-bignum (math-binary-arg a w) - (math-binary-arg b w))) - w)))) + (t (math-clip (logand (math-binary-arg a w) (math-binary-arg b w)) w)))) (defun math-binary-arg (a w) (if (not (Math-integerp a)) (setq a (math-trunc a))) - (if (Math-integer-negp a) - (math-not-bignum (cdr (math-bignum-test (math-sub -1 a))) - (math-abs (if w (math-trunc w) calc-word-size))) - (cdr (Math-bignum-test a)))) + (if (< a 0) + (logand a (1- (ash 1 (if w (math-trunc w) calc-word-size)))) + a)) (defun math-binary-modulo-args (f a b w) (let (mod) @@ -310,15 +295,6 @@ the size of a Calc bignum digit.") (funcall f a w)) mod)))) -(defun math-and-bignum (a b) ; [l l l] - (and a b - (let ((qa (math-div-bignum-digit a math-bignum-digit-power-of-two)) - (qb (math-div-bignum-digit b math-bignum-digit-power-of-two))) - (math-mul-bignum-digit (math-and-bignum (math-norm-bignum (car qa)) - (math-norm-bignum (car qb))) - math-bignum-digit-power-of-two - (logand (cdr qa) (cdr qb)))))) - (defun calcFunc-or (a b &optional w) ; [I I I] [Public] (cond ((Math-messy-integerp w) (calcFunc-or a b (math-trunc w))) @@ -332,19 +308,7 @@ the size of a Calc bignum digit.") (math-reject-arg a 'integerp)) ((not (Math-num-integerp b)) (math-reject-arg b 'integerp)) - (t (math-clip (cons 'bigpos - (math-or-bignum (math-binary-arg a w) - (math-binary-arg b w))) - w)))) - -(defun math-or-bignum (a b) ; [l l l] - (and (or a b) - (let ((qa (math-div-bignum-digit a math-bignum-digit-power-of-two)) - (qb (math-div-bignum-digit b math-bignum-digit-power-of-two))) - (math-mul-bignum-digit (math-or-bignum (math-norm-bignum (car qa)) - (math-norm-bignum (car qb))) - math-bignum-digit-power-of-two - (logior (cdr qa) (cdr qb)))))) + (t (math-clip (logior (math-binary-arg a w) (math-binary-arg b w)) w)))) (defun calcFunc-xor (a b &optional w) ; [I I I] [Public] (cond ((Math-messy-integerp w) @@ -359,19 +323,7 @@ the size of a Calc bignum digit.") (math-reject-arg a 'integerp)) ((not (Math-num-integerp b)) (math-reject-arg b 'integerp)) - (t (math-clip (cons 'bigpos - (math-xor-bignum (math-binary-arg a w) - (math-binary-arg b w))) - w)))) - -(defun math-xor-bignum (a b) ; [l l l] - (and (or a b) - (let ((qa (math-div-bignum-digit a math-bignum-digit-power-of-two)) - (qb (math-div-bignum-digit b math-bignum-digit-power-of-two))) - (math-mul-bignum-digit (math-xor-bignum (math-norm-bignum (car qa)) - (math-norm-bignum (car qb))) - math-bignum-digit-power-of-two - (logxor (cdr qa) (cdr qb)))))) + (t (math-clip (logxor (math-binary-arg a w) (math-binary-arg b w)) w)))) (defun calcFunc-diff (a b &optional w) ; [I I I] [Public] (cond ((Math-messy-integerp w) @@ -386,19 +338,9 @@ the size of a Calc bignum digit.") (math-reject-arg a 'integerp)) ((not (Math-num-integerp b)) (math-reject-arg b 'integerp)) - (t (math-clip (cons 'bigpos - (math-diff-bignum (math-binary-arg a w) - (math-binary-arg b w))) - w)))) - -(defun math-diff-bignum (a b) ; [l l l] - (and a - (let ((qa (math-div-bignum-digit a math-bignum-digit-power-of-two)) - (qb (math-div-bignum-digit b math-bignum-digit-power-of-two))) - (math-mul-bignum-digit (math-diff-bignum (math-norm-bignum (car qa)) - (math-norm-bignum (car qb))) - math-bignum-digit-power-of-two - (logand (cdr qa) (lognot (cdr qb))))))) + (t (math-clip (logand (math-binary-arg a w) + (lognot (math-binary-arg b w))) + w)))) (defun calcFunc-not (a &optional w) ; [I I] [Public] (cond ((Math-messy-integerp w) @@ -411,21 +353,7 @@ the size of a Calc bignum digit.") (math-reject-arg a 'integerp)) ((< (or w (setq w calc-word-size)) 0) (math-clip (calcFunc-not a (- w)) w)) - (t (math-normalize - (cons 'bigpos - (math-not-bignum (math-binary-arg a w) - w)))))) - -(defun math-not-bignum (a w) ; [l l] - (let ((q (math-div-bignum-digit a math-bignum-digit-power-of-two))) - (if (<= w math-bignum-logb-digit-size) - (list (logand (lognot (cdr q)) - (1- (lsh 1 w)))) - (math-mul-bignum-digit (math-not-bignum (math-norm-bignum (car q)) - (- w math-bignum-logb-digit-size)) - math-bignum-digit-power-of-two - (logxor (cdr q) - (1- math-bignum-digit-power-of-two)))))) + (t (math-clip (lognot (math-binary-arg a w)) w)))) (defun calcFunc-lsh (a &optional n w) ; [I I] [Public] (setq a (math-trunc a) @@ -525,29 +453,12 @@ the size of a Calc bignum digit.") a (math-sub a (math-power-of-2 (- w))))) ((Math-negp a) - (math-normalize (cons 'bigpos (math-binary-arg a w)))) - ((and (integerp a) (< a math-small-integer-size)) - (if (> w (logb math-small-integer-size)) - a - (logand a (1- (lsh 1 w))))) - (t - (math-normalize - (cons 'bigpos - (math-clip-bignum (cdr (math-bignum-test (math-trunc a))) - w)))))) + (math-binary-arg a w)) + ((integerp a) + (logand a (1- (ash 1 w)))))) (defalias 'calcFunc-clip 'math-clip) -(defun math-clip-bignum (a w) ; [l l] - (let ((q (math-div-bignum-digit a math-bignum-digit-power-of-two))) - (if (<= w math-bignum-logb-digit-size) - (list (logand (cdr q) - (1- (lsh 1 w)))) - (math-mul-bignum-digit (math-clip-bignum (math-norm-bignum (car q)) - (- w math-bignum-logb-digit-size)) - math-bignum-digit-power-of-two - (cdr q))))) - (defvar math-max-digits-cache nil) (defun math-compute-max-digits (w r) (let* ((pair (+ (* r 100000) w)) @@ -595,60 +506,9 @@ the size of a Calc bignum digit.") a (/ a calc-number-radix))) s))) -(defconst math-binary-digits ["000" "001" "010" "011" - "100" "101" "110" "111"]) (defun math-format-binary (a) ; [X S] - (if (< a 8) - (if (< a 0) - (concat "-" (math-format-binary (- a))) - (math-format-radix a)) - (let ((s "")) - (while (> a 7) - (setq s (concat (aref math-binary-digits (% a 8)) s) - a (/ a 8))) - (concat (math-format-radix a) s)))) - -(defun math-format-bignum-radix (a) ; [X L] - (cond ((null a) "0") - ((and (null (cdr a)) - (< (car a) calc-number-radix)) - (math-format-radix-digit (car a))) - (t - (let ((q (math-div-bignum-digit a calc-number-radix))) - (concat (math-format-bignum-radix (math-norm-bignum (car q))) - (math-format-radix-digit (cdr q))))))) - -(defun math-format-bignum-binary (a) ; [X L] - (cond ((null a) "0") - ((null (cdr a)) - (math-format-binary (car a))) - (t - (let ((q (math-div-bignum-digit a 512))) - (concat (math-format-bignum-binary (math-norm-bignum (car q))) - (aref math-binary-digits (/ (cdr q) 64)) - (aref math-binary-digits (% (/ (cdr q) 8) 8)) - (aref math-binary-digits (% (cdr q) 8))))))) - -(defun math-format-bignum-octal (a) ; [X L] - (cond ((null a) "0") - ((null (cdr a)) - (math-format-radix (car a))) - (t - (let ((q (math-div-bignum-digit a 512))) - (concat (math-format-bignum-octal (math-norm-bignum (car q))) - (math-format-radix-digit (/ (cdr q) 64)) - (math-format-radix-digit (% (/ (cdr q) 8) 8)) - (math-format-radix-digit (% (cdr q) 8))))))) - -(defun math-format-bignum-hex (a) ; [X L] - (cond ((null a) "0") - ((null (cdr a)) - (math-format-radix (car a))) - (t - (let ((q (math-div-bignum-digit a 256))) - (concat (math-format-bignum-hex (math-norm-bignum (car q))) - (math-format-radix-digit (/ (cdr q) 16)) - (math-format-radix-digit (% (cdr q) 16))))))) + (let ((calc-number-radix 2)) + (math-format-radix a))) ;;; Decompose into integer and fractional parts, without depending ;;; on calc-internal-prec. @@ -665,7 +525,7 @@ the size of a Calc bignum digit.") (list (math-scale-rounding (nth 1 a) (nth 2 a)) '(float 0 0) 0))))) -(defun math-format-radix-float (a prec) +(defun math-format-radix-float (a _prec) (let ((fmt (car calc-float-format)) (figs (nth 1 calc-float-format)) (point calc-point-char) @@ -823,20 +683,14 @@ the size of a Calc bignum digit.") (defun math-format-twos-complement (a) "Format an integer in two's complement mode." (let* (;(calc-leading-zeros t) - (overflow nil) - (negative nil) (num (cond ((or (eq a 0) - (and (Math-integer-posp a))) - (if (integerp a) - (math-format-radix a) - (math-format-bignum-radix (cdr a)))) + (Math-integer-posp a)) + (math-format-radix a)) ((Math-integer-negp a) (let ((newa (math-add a math-2-word-size))) - (if (integerp newa) - (math-format-radix newa) - (math-format-bignum-radix (cdr newa)))))))) + (math-format-radix newa)))))) (let* ((calc-internal-prec 6) (digs (math-compute-max-digits (math-abs calc-word-size) calc-number-radix)) diff --git a/lisp/calc/calc-comb.el b/lisp/calc/calc-comb.el index d74c815bd24..5bede650dd3 100644 --- a/lisp/calc/calc-comb.el +++ b/lisp/calc/calc-comb.el @@ -211,8 +211,8 @@ (calc-invert-func) (calc-next-prime iters)) -(defun calc-prime-factors (iters) - (interactive "p") +(defun calc-prime-factors (&optional _iters) + (interactive) (calc-slow-wrapper (let ((res (calcFunc-prfac (calc-top-n 1)))) (if (not math-prime-factors-finished) @@ -580,7 +580,7 @@ ;; deduce a better value for RAND_MAX. (let ((i 0)) (while (< (setq i (1+ i)) 30) - (if (> (lsh (math-abs (random)) math-random-shift) 4095) + (if (> (ash (math-abs (random)) math-random-shift) 4095) (setq math-random-shift (1- math-random-shift)))))) (setq math-last-RandSeed var-RandSeed math-gaussian-cache nil)) @@ -592,11 +592,11 @@ (cdr math-random-table)) math-random-ptr2 (or (cdr math-random-ptr2) (cdr math-random-table))) - (logand (lsh (setcar math-random-ptr1 + (logand (ash (setcar math-random-ptr1 (logand (- (car math-random-ptr1) (car math-random-ptr2)) 524287)) -6) 1023)) - (logand (lsh (random) math-random-shift) 1023))) + (logand (ash (random) math-random-shift) 1023))) ;;; Produce a random digit in the range 0..999. @@ -806,7 +806,6 @@ ((Math-integer-negp n) '(nil)) ((Math-natnum-lessp n 8000000) - (setq n (math-fixnum n)) (let ((i -1) v) (while (and (> (% n (setq v (aref math-primes-table (setq i (1+ i))))) diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el index f2e70906e94..0b3c489d453 100644 --- a/lisp/calc/calc-ext.el +++ b/lisp/calc/calc-ext.el @@ -1,4 +1,4 @@ -;;; calc-ext.el --- various extension functions for Calc +;;; calc-ext.el --- various extension functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2019 Free Software Foundation, Inc. @@ -25,6 +25,7 @@ (require 'calc) (require 'calc-macs) +(require 'cl-lib) ;; Declare functions which are defined elsewhere. (declare-function math-clip "calc-bin" (a &optional w)) @@ -62,10 +63,8 @@ (declare-function math-format-radix-float "calc-bin" (a prec)) (declare-function math-compose-expr "calccomp" (a prec &optional div)) (declare-function math-abs "calc-arith" (a)) -(declare-function math-format-bignum-binary "calc-bin" (a)) -(declare-function math-format-bignum-octal "calc-bin" (a)) -(declare-function math-format-bignum-hex "calc-bin" (a)) -(declare-function math-format-bignum-radix "calc-bin" (a)) +(declare-function math-format-binary "calc-bin" (a)) +(declare-function math-format-radix "calc-bin" (a)) (declare-function math-compute-max-digits "calc-bin" (w r)) (declare-function math-map-vec "calc-vec" (f a)) (declare-function math-make-frac "calc-frac" (num den)) @@ -88,7 +87,7 @@ (defvar calc-alg-map) (defvar calc-alg-esc-map) -;;; The following was made a function so that it could be byte-compiled. +;; The following was made a function so that it could be byte-compiled. (defun calc-init-extensions () (define-key calc-mode-map ":" 'calc-fdiv) @@ -714,8 +713,8 @@ ;;;; (Autoloads here) (mapc (function (lambda (x) - (mapcar (function (lambda (func) - (autoload func (car x)))) (cdr x)))) + (mapcar (function (lambda (func) (autoload func (car x)))) + (cdr x)))) '( ("calc-alg" calc-has-rules math-defsimplify @@ -779,8 +778,7 @@ math-sqr-float math-trunc-fancy math-trunc-special) calcFunc-clip calcFunc-diff calcFunc-lsh calcFunc-not calcFunc-or calcFunc-rash calcFunc-rot calcFunc-rsh calcFunc-xor math-clip math-compute-max-digits math-convert-radix-digits math-float-parts -math-format-bignum-binary math-format-bignum-hex -math-format-bignum-octal math-format-bignum-radix math-format-binary +math-format-binary math-format-radix math-format-radix-float math-integer-log2 math-power-of-2 math-radix-float-power) @@ -881,7 +879,7 @@ calcFunc-tanh math-arccos-raw math-arcsin-raw math-arctan-raw math-arctan2-raw math-cos-raw math-cot-raw math-csc-raw math-exp-minus-1-raw math-exp-raw math-from-radians math-from-radians-2 math-hypot math-infinite-dir -math-isqrt-small math-ln-raw math-nearly-equal math-nearly-equal-float +math-ln-raw math-nearly-equal math-nearly-equal-float math-nearly-zerop math-nearly-zerop-float math-nth-root math-sin-cos-raw math-sin-raw math-sqrt math-sqrt-float math-sqrt-raw math-tan-raw math-to-radians math-to-radians-2) @@ -894,8 +892,8 @@ calcFunc-pcont calcFunc-pdeg calcFunc-pdiv calcFunc-pdivide calcFunc-pdivrem calcFunc-pgcd calcFunc-plead calcFunc-pprim calcFunc-prem math-accum-factors math-atomic-factorp math-div-poly-const math-div-thru math-expand-power math-expand-term -math-factor-contains math-factor-expr math-factor-expr-part -math-factor-expr-try math-factor-finish math-factor-poly-coefs +math-factor-contains math-factor-expr +math-factor-finish math-factor-protect math-mul-thru math-padded-polynomial math-partial-fractions math-poly-degree math-poly-deriv-coefs math-poly-gcd-frac-list math-poly-modulus-rec math-ratpoly-p @@ -984,8 +982,8 @@ calc-force-refresh calc-locate-cursor-element calc-show-edit-buffer) )) (mapcar (function (lambda (x) - (mapcar (function (lambda (cmd) - (autoload cmd (car x) nil t))) (cdr x)))) + (mapcar (function (lambda (cmd) (autoload cmd (car x) nil t))) + (cdr x)))) '( ("calc-alg" calc-alg-evaluate calc-apart calc-collect calc-expand @@ -1307,8 +1305,9 @@ calc-kill calc-kill-region calc-yank)))) (message "%s" (if msg (concat group ": " msg ":" (make-string - (- (apply 'max (mapcar 'length msgs)) - (length msg)) 32) + (- (apply #'max (mapcar #'length msgs)) + (length msg)) + ?\s) " [MORE]" (if key (concat " " (char-to-string key) @@ -1334,6 +1333,8 @@ calc-kill calc-kill-region calc-yank)))) ;;; General. +(defvar calc-embedded-quiet) + (defun calc-reset (arg) (interactive "P") (setq arg (if arg (prefix-numeric-value arg) nil)) @@ -1398,7 +1399,7 @@ calc-kill calc-kill-region calc-yank)))) (defun calc-scroll-up (n) (interactive "P") - (condition-case err + (condition-case nil (scroll-up (or n (/ (window-height) 2))) (error nil)) (if (pos-visible-in-window-p (max 1 (- (point-max) 2))) @@ -1484,14 +1485,14 @@ calc-kill calc-kill-region calc-yank)))) (not calc-is-keypad-press) (if (boundp 'overriding-terminal-local-map) (setq overriding-terminal-local-map calc-fancy-prefix-map) - (let ((event (calc-read-key t))) - (if (eq (setq last-command-event (car event)) ?\C-u) + (let ((event (read-event))) + (if (eq (setq last-command-event event) ?\C-u) (universal-argument) (if (or (not (integerp last-command-event)) (and (>= last-command-event 0) (< last-command-event ? ) (not (memq last-command-event '(?\e))))) (calc-wrapper)) ; clear flags if not a Calc command. - (setq last-command-event (cdr event)) + (setq last-command-event event) (if (or (not (integerp last-command-event)) (eq last-command-event ?-)) (calc-unread-command) @@ -1657,7 +1658,7 @@ calc-kill calc-kill-region calc-yank)))) (let ((entries (calc-top-list n 1 'entry)) (calc-undo-list nil) (calc-redo-list nil)) (calc-pop-stack n 1 t) - (calc-push-list (mapcar 'car entries) + (calc-push-list (mapcar #'car entries) 1 (mapcar (function (lambda (x) (nth 2 x))) entries))))))) @@ -1707,7 +1708,7 @@ calc-kill calc-kill-region calc-yank)))) (calc-pop-push-record-list 1 "eval" (math-evaluate-expr (calc-top (- n))) (- n)) - (calc-pop-push-record-list n "eval" (mapcar 'math-evaluate-expr + (calc-pop-push-record-list n "eval" (mapcar #'math-evaluate-expr (calc-top-list n))))) (calc-handle-whys))) @@ -1912,8 +1913,6 @@ calc-kill calc-kill-region calc-yank)))) ;;; User menu. (defun calc-user-key-map () - (if (featurep 'xemacs) - (error "User-defined keys are not supported in XEmacs")) (let ((res (cdr (lookup-key calc-mode-map "z")))) (if (eq (car (car res)) 27) (cdr res) @@ -1928,7 +1927,7 @@ calc-kill calc-kill-region calc-yank)))) (calc-z-prefix-buf "") (kmap (sort (copy-sequence (calc-user-key-map)) (function (lambda (x y) (< (car x) (car y)))))) - (flags (apply 'logior + (flags (apply #'logior (mapcar (function (lambda (k) (calc-user-function-classify (car k)))) @@ -2003,20 +2002,21 @@ calc-kill calc-kill-region calc-yank)))) ;;;; Caches. (defmacro math-defcache (name init form) + (declare (indent 2) (debug (symbolp sexp form))) (let ((cache-prec (intern (concat (symbol-name name) "-cache-prec"))) (cache-val (intern (concat (symbol-name name) "-cache"))) (last-prec (intern (concat (symbol-name name) "-last-prec"))) (last-val (intern (concat (symbol-name name) "-last")))) `(progn -; (defvar ,cache-prec ,(if init (math-numdigs (nth 1 init)) -100)) + ;; (defvar ,cache-prec ,(if init (math-numdigs (nth 1 init)) -100)) (defvar ,cache-prec (cond ((consp ,init) (math-numdigs (nth 1 ,init))) (,init - (nth 1 (math-numdigs (eval ,init)))) + (nth 1 (math-numdigs (eval ,init t)))) (t -100))) (defvar ,cache-val (cond ((consp ,init) ,init) - (,init (eval ,init)) + (,init (eval ,init t)) (t ,init))) (defvar ,last-prec -100) (defvar ,last-val nil) @@ -2037,7 +2037,6 @@ calc-kill calc-kill-region calc-yank)))) ,cache-val)) ,last-prec calc-internal-prec)) ,last-val)))) -(put 'math-defcache 'lisp-indent-hook 2) ;;; Betcha didn't know that pi = 16 atan(1/5) - 4 atan(1/239). [F] [Public] (defconst math-approx-pi @@ -2116,77 +2115,61 @@ calc-kill calc-kill-region calc-yank)))) ;;; True if A is an odd integer. [P R R] [Public] (defun math-oddp (a) - (if (consp a) - (and (memq (car a) '(bigpos bigneg)) - (= (% (nth 1 a) 2) 1)) - (/= (% a 2) 0))) + (and (integerp a) (cl-oddp a))) -;;; True if A is a small or big integer. [P x] [Public] -(defun math-integerp (a) - (or (integerp a) - (memq (car-safe a) '(bigpos bigneg)))) +;;; True if A is an integer. [P x] [Public] +(defalias 'math-integerp #'integerp) ;;; True if A is (numerically) a non-negative integer. [P N] [Public] -(defun math-natnump (a) - (or (natnump a) - (eq (car-safe a) 'bigpos))) +(defalias 'math-natnump #'natnump) ;;; True if A is a rational (or integer). [P x] [Public] -(defun math-ratp (a) - (or (integerp a) - (memq (car-safe a) '(bigpos bigneg frac)))) +(defalias 'math-ratp #'Math-ratp) ;;; True if A is a real (or rational). [P x] [Public] -(defun math-realp (a) - (or (integerp a) - (memq (car-safe a) '(bigpos bigneg frac float)))) +(defalias 'math-realp #'Math-realp) ;;; True if A is a real or HMS form. [P x] [Public] -(defun math-anglep (a) - (or (integerp a) - (memq (car-safe a) '(bigpos bigneg frac float hms)))) +(defalias 'math-anglep #'Math-anglep) ;;; True if A is a number of any kind. [P x] [Public] -(defun math-numberp (a) - (or (integerp a) - (memq (car-safe a) '(bigpos bigneg frac float cplx polar)))) +(defalias 'math-numberp #'Math-numberp) ;;; True if A is a complex number or angle. [P x] [Public] -(defun math-scalarp (a) - (or (integerp a) - (memq (car-safe a) '(bigpos bigneg frac float cplx polar hms)))) +(defalias 'math-scalarp #'Math-scalarp) ;;; True if A is a vector. [P x] [Public] -(defun math-vectorp (a) - (eq (car-safe a) 'vec)) +(defalias 'math-vectorp #'Math-vectorp) ;;; True if A is any vector or scalar data object. [P x] (defun math-objvecp (a) ; [Public] (or (integerp a) - (memq (car-safe a) '(bigpos bigneg frac float cplx polar - hms date sdev intv mod vec incomplete)))) + (memq (car-safe a) '(frac float cplx polar + hms date sdev intv mod vec + ;; FIXME: Math-objvecp does not include this one! + incomplete)))) ;;; True if A is an object not composed of sub-formulas . [P x] [Public] (defun math-primp (a) (or (integerp a) - (memq (car-safe a) '(bigpos bigneg frac float cplx polar - hms date mod var)))) + (memq (car-safe a) '(frac float cplx polar + hms date mod var)))) ;;; True if A is numerically (but not literally) an integer. [P x] [Public] (defun math-messy-integerp (a) (cond ((eq (car-safe a) 'float) (>= (nth 2 a) 0)) + ;; FIXME: Math-messy-integerp does not include this case! ((eq (car-safe a) 'frac) (Math-integerp (math-normalize a))))) ;;; True if A is numerically an integer. [P x] [Public] (defun math-num-integerp (a) - (or (Math-integerp a) + (or (integerp a) (Math-messy-integerp a))) ;;; True if A is (numerically) a non-negative integer. [P N] [Public] (defun math-num-natnump (a) (or (natnump a) - (eq (car-safe a) 'bigpos) (and (eq (car-safe a) 'float) (Math-natnump (nth 1 a)) (>= (nth 2 a) 0)))) @@ -2276,32 +2259,28 @@ calc-kill calc-kill-region calc-yank)))) ;;; True if A is any scalar data object. [P x] (defun math-objectp (a) ; [Public] (or (integerp a) - (memq (car-safe a) '(bigpos bigneg frac float cplx - polar hms date sdev intv mod)))) + (memq (car-safe a) '(frac float cplx + polar hms date sdev intv mod)))) ;;; Verify that A is an integer and return A in integer form. [I N; - x] (defun math-check-integer (a) ; [Public] - (cond ((integerp a) a) ; for speed - ((math-integerp a) a) + (cond ((integerp a) a) ((math-messy-integerp a) (math-trunc a)) (t (math-reject-arg a 'integerp)))) ;;; Verify that A is a small integer and return A in integer form. [S N; - x] (defun math-check-fixnum (a &optional allow-inf) ; [Public] - (cond ((integerp a) a) ; for speed + (cond ((fixnump a) a) ; for speed ((Math-num-integerp a) (let ((a (math-trunc a))) - (if (integerp a) + (if (fixnump a) a - (if (or (Math-lessp (lsh -1 -1) a) - (Math-lessp a (- (lsh -1 -1)))) - (math-reject-arg a 'fixnump) - (math-fixnum a))))) + (math-reject-arg a 'fixnump)))) ((and allow-inf (equal a '(var inf var-inf))) - (lsh -1 -1)) + most-positive-fixnum) ((and allow-inf (equal a '(neg (var inf var-inf)))) - (- (lsh -1 -1))) + (- most-positive-fixnum)) (t (math-reject-arg a 'fixnump)))) ;;; Verify that A is an integer >= 0 and return A in integer form. [I N; - x] @@ -2347,20 +2326,6 @@ If X is not an error form, return 1." (memq t (mapcar (lambda (x) (eq (car-safe x) 'sdev)) ls)))) ;;; Coerce integer A to be a small integer. [S I] -(defun math-fixnum (a) - (if (consp a) - (if (cdr a) - (if (eq (car a) 'bigneg) - (- (math-fixnum-big (cdr a))) - (math-fixnum-big (cdr a))) - 0) - a)) - -(defun math-fixnum-big (a) - (if (cdr a) - (+ (car a) (* (math-fixnum-big (cdr a)) math-bignum-digit-size)) - (car a))) - (defvar math-simplify-only nil) (defun math-normalize-fancy (a) @@ -2400,7 +2365,7 @@ If X is not an error form, return 1." (list 'calcFunc-intv mask lo hi) (math-make-intv mask lo hi)))) ((eq (car a) 'vec) - (cons 'vec (mapcar 'math-normalize (cdr a)))) + (cons 'vec (mapcar #'math-normalize (cdr a)))) ((eq (car a) 'quote) (math-normalize (nth 1 a))) ((eq (car a) 'special-const) @@ -2412,7 +2377,7 @@ If X is not an error form, return 1." (math-normalize-logical-op a)) ((memq (car a) '(calcFunc-lambda calcFunc-quote calcFunc-condition)) (let ((calc-simplify-mode 'none)) - (cons (car a) (mapcar 'math-normalize (cdr a))))) + (cons (car a) (mapcar #'math-normalize (cdr a))))) ((eq (car a) 'calcFunc-evalto) (setq a (or (nth 1 a) 0)) (or calc-refreshing-evaltos @@ -2435,27 +2400,25 @@ If X is not an error form, return 1." ;; The variable math-normalize-a is local to math-normalize in calc.el, ;; but is used by math-normalize-nonstandard, which is called by ;; math-normalize. -(defvar math-normalize-a) - -(defun math-normalize-nonstandard () +(defun math-normalize-nonstandard (a) (if (consp calc-simplify-mode) (progn (setq calc-simplify-mode 'none - math-simplify-only (car-safe (cdr-safe math-normalize-a))) + math-simplify-only (car-safe (cdr-safe a))) nil) - (and (symbolp (car math-normalize-a)) + (and (symbolp (car a)) (or (eq calc-simplify-mode 'none) (and (eq calc-simplify-mode 'num) - (let ((aptr (setq math-normalize-a + (let ((aptr (setq a (cons - (car math-normalize-a) - (mapcar 'math-normalize - (cdr math-normalize-a)))))) + (car a) + (mapcar #'math-normalize + (cdr a)))))) (while (and aptr (math-constp (car aptr))) (setq aptr (cdr aptr))) aptr))) - (cons (car math-normalize-a) - (mapcar 'math-normalize (cdr math-normalize-a)))))) + (cons (car a) + (mapcar #'math-normalize (cdr a)))))) ;;; Normalize a bignum digit list by trimming high-end zeros. [L l] @@ -2469,12 +2432,6 @@ If X is not an error form, return 1." (setcdr last nil) a)))) -(defun math-bignum-test (a) ; [B N; B s; b b] - (if (consp a) - a - (math-bignum a))) - - ;;; Return 0 for zero, -1 for negative, 1 for positive. [S n] [Public] (defun calcFunc-sign (a &optional x) (let ((signs (math-possible-signs a))) @@ -2497,17 +2454,7 @@ If X is not an error form, return 1." 2 0)) ((and (integerp a) (Math-integerp b)) - (if (consp b) - (if (eq (car b) 'bigpos) -1 1) - (if (< a b) -1 1))) - ((and (eq (car-safe a) 'bigpos) (Math-integerp b)) - (if (eq (car-safe b) 'bigpos) - (math-compare-bignum (cdr a) (cdr b)) - 1)) - ((and (eq (car-safe a) 'bigneg) (Math-integerp b)) - (if (eq (car-safe b) 'bigneg) - (math-compare-bignum (cdr b) (cdr a)) - -1)) + (if (< a b) -1 1)) ((eq (car-safe a) 'frac) (if (eq (car-safe b) 'frac) (math-compare (math-mul (nth 1 a) (nth 2 b)) @@ -2808,7 +2755,7 @@ If X is not an error form, return 1." x) (if (Math-primp x) x - (cons (car x) (mapcar 'math-evaluate-expr-rec (cdr x)))))) + (cons (car x) (mapcar #'math-evaluate-expr-rec (cdr x)))))) x)) (defun math-any-floats (expr) @@ -2822,9 +2769,10 @@ If X is not an error form, return 1." (defvar math-mt-many nil) (defvar math-mt-func nil) -(defun math-map-tree (math-mt-func mmt-expr &optional math-mt-many) - (or math-mt-many (setq math-mt-many 1000000)) - (math-map-tree-rec mmt-expr)) +(defun math-map-tree (func mmt-expr &optional many) + (let ((math-mt-func func) + (math-mt-many (or many 1000000))) + (math-map-tree-rec mmt-expr))) (defun math-map-tree-rec (mmt-expr) (or (= math-mt-many 0) @@ -2842,7 +2790,7 @@ If X is not an error form, return 1." (<= math-mt-many 0)) (setq mmt-done t) (setq mmt-nextval (cons (car mmt-expr) - (mapcar 'math-map-tree-rec + (mapcar #'math-map-tree-rec (cdr mmt-expr)))) (if (equal mmt-nextval mmt-expr) (setq mmt-done t) @@ -2867,6 +2815,7 @@ If X is not an error form, return 1." (defvar math-integral-cache) (defmacro math-defintegral (funcs &rest code) + (declare (indent 1) (debug (sexp body))) (setq math-integral-cache nil) (cons 'progn (mapcar #'(lambda (func) @@ -2876,9 +2825,9 @@ If X is not an error form, return 1." (list #'(lambda (u) ,@code))))) (if (symbolp funcs) (list funcs) funcs)))) -(put 'math-defintegral 'lisp-indent-hook 1) (defmacro math-defintegral-2 (funcs &rest code) + (declare (indent 1) (debug (sexp body))) (setq math-integral-cache nil) (cons 'progn (mapcar #'(lambda (func) @@ -2887,7 +2836,6 @@ If X is not an error form, return 1." (get ',func 'math-integral-2) (list #'(lambda (u v) ,@code))))) (if (symbolp funcs) (list funcs) funcs)))) -(put 'math-defintegral-2 'lisp-indent-hook 1) (defvar var-IntegAfterRules 'calc-IntegAfterRules) @@ -3017,13 +2965,13 @@ If X is not an error form, return 1." ;; C language hexadecimal notation ((and (eq calc-language 'c) - (string-match "^0[xX]\\([0-9a-fA-F]+\\)$" s)) + (string-match "^0[xX]\\([[:xdigit:]]+\\)$" s)) (let ((digs (math-match-substring s 1))) (math-read-radix digs 16))) ;; Pascal language hexadecimal notation ((and (eq calc-language 'pascal) - (string-match "^\\$\\([0-9a-fA-F]+\\)$" s)) + (string-match "^\\$\\([[:xdigit:]]+\\)$" s)) (let ((digs (math-match-substring s 1))) (math-read-radix digs 16))) @@ -3097,9 +3045,16 @@ If X is not an error form, return 1." ;;; Expression parsing. (defvar math-expr-data) +(defvar math-exp-pos) +(defvar math-exp-old-pos) +(defvar math-exp-keep-spaces) +(defvar math-exp-token) +(defvar math-expr-data) +(defvar math-exp-str) -(defun math-read-expr (math-exp-str) +(defun math-read-expr (str) (let ((math-exp-pos 0) + (math-exp-str str) (math-exp-old-pos 0) (math-exp-keep-spaces nil) math-exp-token math-expr-data) @@ -3138,6 +3093,10 @@ If X is not an error form, return 1." ;;; They said it couldn't be done... +(defvar math-read-big-baseline) +(defvar math-read-big-h2) +(defvar math-read-big-err-msg) + (defun math-read-big-expr (str) (and (> (length calc-left-label) 0) (string-match (concat "^" (regexp-quote calc-left-label)) str) @@ -3179,6 +3138,8 @@ If X is not an error form, return 1." '(error 0 "Syntax error")) (math-read-expr str))))) +(defvar math-rb-h2) + (defun math-read-big-bigp (math-read-big-lines) (and (cdr math-read-big-lines) (let ((matrix nil) @@ -3438,16 +3399,10 @@ If X is not an error form, return 1." (list 'frac (math-mul (nth 1 a) g) (math-mul (nth 2 a) g)))) a)) -(defun math-format-bignum-fancy (a) ; [X L] - (let ((str (cond ((= calc-number-radix 10) - (math-format-bignum-decimal a)) - ((= calc-number-radix 2) - (math-format-bignum-binary a)) - ((= calc-number-radix 8) - (math-format-bignum-octal a)) - ((= calc-number-radix 16) - (math-format-bignum-hex a)) - (t (math-format-bignum-radix a))))) +(defun math--format-integer-fancy (a) ; [I] + (let ((str (if (= calc-number-radix 10) + (number-to-string a) + (math-format-radix a)))) (if calc-leading-zeros (let* ((calc-internal-prec 6) (digs (math-compute-max-digits (math-abs calc-word-size) diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el index e521eaeaff2..bdfc0e44ddd 100644 --- a/lisp/calc/calc-forms.el +++ b/lisp/calc/calc-forms.el @@ -37,13 +37,13 @@ (defun calc-time () (interactive) (calc-wrapper - (let ((time (current-time-string))) + (let ((time (decode-time))) (calc-enter-result 0 "time" (list 'mod (list 'hms - (string-to-number (substring time 11 13)) - (string-to-number (substring time 14 16)) - (string-to-number (substring time 17 19))) + (decoded-time-hour time) + (decoded-time-minute time) + (decoded-time-second time)) (list 'hms 24 0 0)))))) (defun calc-to-hms (arg) @@ -62,7 +62,7 @@ (defun calc-hms-notation (fmt) - (interactive "sHours-minutes-seconds format (hms, @ \\=' \", etc.): ") + (interactive "sHours-minutes-seconds format (hms, @ ' \", etc.): ") (calc-wrapper (if (string-match "\\`\\([^,; ]+\\)\\([,; ]*\\)\\([^,; ]\\)\\([,; ]*\\)\\([^,; ]\\)\\'" fmt) (progn @@ -525,7 +525,7 @@ in the Gregorian calendar and the remaining part determines the time." (defun math-this-year () - (nth 5 (decode-time))) + (decoded-time-year (decode-time))) (defun math-leap-year-p (year &optional julian) "Non-nil if YEAR is a leap year. @@ -1341,16 +1341,19 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)." (math-parse-iso-date-validate isoyear isoweek isoweekday hour minute second))))) (defun calcFunc-now (&optional zone) - (let ((date (let ((calc-date-format nil)) - (math-parse-date (current-time-string))))) - (if (consp date) - (if zone - (math-add date (math-div (math-sub (calcFunc-tzone nil date) - (calcFunc-tzone zone date)) - '(float 864 2))) - date) - (calc-record-why "*Unable to interpret current date from system") - (append (list 'calcFunc-now) (and zone (list zone)))))) + (let ((date (let ((now (decode-time))) + (list 'date (math-dt-to-date + (list (decoded-time-year now) + (decoded-time-month now) + (decoded-time-day now) + (decoded-time-hour now) + (decoded-time-minute now) + (decoded-time-second now))))))) + (if zone + (math-add date (math-div (math-sub (calcFunc-tzone nil date) + (calcFunc-tzone zone date)) + '(float 864 2))) + date))) (defun calcFunc-year (date) (car (math-date-to-dt date))) @@ -1475,9 +1478,6 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)." (defvar var-TimeZone nil) -;; From cal-dst -(defvar calendar-current-time-zone-cache) - (defvar math-calendar-tzinfo nil "Information about the timezone, retrieved from the calendar.") @@ -1490,11 +1490,9 @@ second, the number of seconds offset for daylight savings." (if math-calendar-tzinfo math-calendar-tzinfo (require 'cal-dst) - (let ((tzinfo (progn - (calendar-current-time-zone) - calendar-current-time-zone-cache))) + (let ((tzinfo (calendar-current-time-zone))) (setq math-calendar-tzinfo - (list (* 60 (abs (nth 0 tzinfo))) + (list (* 60 (- (nth 0 tzinfo))) (* 60 (nth 1 tzinfo))))))) (defun calcFunc-tzone (&optional zone date) diff --git a/lisp/calc/calc-funcs.el b/lisp/calc/calc-funcs.el index a9d153961d8..17e79354835 100644 --- a/lisp/calc/calc-funcs.el +++ b/lisp/calc/calc-funcs.el @@ -27,6 +27,7 @@ (require 'calc-ext) (require 'calc-macs) +(require 'cl-lib) (defun calc-inc-gamma (arg) (interactive "P") @@ -177,7 +178,7 @@ '(float 0 0) 2))))))) -(defun math-gamma-series (sum x xinvsqr oterm n) +(defun math-gamma-series (sum x xinvsqr _oterm n) (math-working "gamma" sum) (let* ((bn (math-bernoulli-number n)) (term (math-mul (math-div-float (math-float (nth 1 bn)) @@ -525,7 +526,7 @@ bj)) (t (if (Math-lessp 100 v) (math-reject-arg v 'range)) - (let* ((j (logior (+ v (math-isqrt-small (* 40 v))) 1)) + (let* ((j (logior (+ v (cl-isqrt (* 40 v))) 1)) (two-over-x (math-div 2 x)) (jsum nil) (bjp '(float 0 0)) diff --git a/lisp/calc/calc-graph.el b/lisp/calc/calc-graph.el index 317f403ead6..56f11c67119 100644 --- a/lisp/calc/calc-graph.el +++ b/lisp/calc/calc-graph.el @@ -1121,7 +1121,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0." (eval (intern (concat "var-" (save-excursion - (re-search-backward ":\\(.*\\)\\}") + (re-search-backward ":\\(.*\\)}") (match-string 1)))))) (error nil))) (if yerr @@ -1186,7 +1186,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0." (or (looking-at "{") (error "Can't hide this curve (wrong format)")) (forward-char 1) - (if (looking-at "*") + (if (looking-at "\\*") (if (or (null flag) (<= (prefix-numeric-value flag) 0)) (delete-char 1)) (if (or (null flag) (> (prefix-numeric-value flag) 0)) diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el index cf7574e7385..3b8bfda4a02 100644 --- a/lisp/calc/calc-help.el +++ b/lisp/calc/calc-help.el @@ -77,14 +77,14 @@ C-w Describe how there is no warranty for Calc." (select-window (get-buffer-window "*Help*")) (while (progn (message "Calc Help options: Help, Info, ... press SPC, DEL to scroll, C-g to cancel") - (memq (car (setq key (calc-read-key t))) + (memq (setq key (read-event)) '(? ?\C-h ?\C-? ?\C-v ?\M-v))) (condition-case err - (if (memq (car key) '(? ?\C-v)) + (if (memq key '(? ?\C-v)) (scroll-up) (scroll-down)) (error (beep))))) - (calc-unread-command (cdr key)) + (calc-unread-command key) (calc-help-prefix nil)) (let ((calc-dispatch-help t)) (calc-help-prefix arg)))) @@ -172,7 +172,7 @@ C-w Describe how there is no warranty for Calc." (setq desc (concat "M-" (substring desc 4)))) (while (string-match "^M-# \\(ESC \\|C-\\)" desc) (setq desc (concat "M-# " (substring desc (match-end 0))))) - (if (string-match "\\(DEL\\|\\LFD\\|RET\\|SPC\\|TAB\\)" desc) + (if (string-match "\\(DEL\\|LFD\\|RET\\|SPC\\|TAB\\)" desc) (setq desc (replace-match "<\\&>" nil nil desc))) (if briefly (let ((msg (with-current-buffer (get-buffer-create "*Calc Summary*") @@ -255,8 +255,8 @@ C-w Describe how there is no warranty for Calc." msg (if (equal notes "") "" (format " (?=notes %s)" notes))) - (let ((key (calc-read-key t))) - (if (eq (car key) ??) + (let ((key (read-event))) + (if (eq key ??) (if (equal notes "") (message "No notes for this command") (while (string-match "," notes) @@ -280,7 +280,7 @@ C-w Describe how there is no warranty for Calc." (princ (buffer-substring pt (point)))) (setq notes (cdr notes))) (help-print-return-message))) - (calc-unread-command (cdr key))))) + (calc-unread-command key)))) (if (or (null defn) (integerp defn)) (message "%s is undefined" desc) (message "%s runs the command %s" diff --git a/lisp/calc/calc-lang.el b/lisp/calc/calc-lang.el index 3f55fb15d56..4a9771d7438 100644 --- a/lisp/calc/calc-lang.el +++ b/lisp/calc/calc-lang.el @@ -243,7 +243,7 @@ (put 'pascal 'math-lang-read-symbol '((?\$ (eq (string-match - "\\(\\$[0-9a-fA-F]+\\)\\($\\|[^0-9a-zA-Zα-ωΑ-Ω]\\)" + "\\(\\$[[:xdigit:]]+\\)\\($\\|[^0-9a-zA-Zα-ωΑ-Ω]\\)" math-exp-str math-exp-pos) math-exp-pos) (setq math-exp-token 'number @@ -753,8 +753,8 @@ right " \\right)")) ((and (eq (aref func 0) ?\\) (not (or - (string-match "\\hbox{" func) - (string-match "\\text{" func))) + (string-match "\\\\hbox{" func) + (string-match "\\\\text{" func))) (= (length a) 2) (or (Math-realp (nth 1 a)) (memq (car (nth 1 a)) '(var *)))) @@ -1127,7 +1127,7 @@ (math-read-token))))))) (put 'eqn 'math-lang-read - '((eq (string-match "->\\|<-\\|+-\\|\\\\dots\\|~\\|\\^" + '((eq (string-match "->\\|<-\\|\\+-\\|\\\\dots\\|~\\|\\^" math-exp-str math-exp-pos) math-exp-pos) (progn diff --git a/lisp/calc/calc-macs.el b/lisp/calc/calc-macs.el index 033f6e9080c..aadfabbd21e 100644 --- a/lisp/calc/calc-macs.el +++ b/lisp/calc/calc-macs.el @@ -1,4 +1,4 @@ -;;; calc-macs.el --- important macros for Calc +;;; calc-macs.el --- important macros for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2019 Free Software Foundation, Inc. @@ -29,7 +29,6 @@ (declare-function math-looks-negp "calc-misc" (a)) (declare-function math-posp "calc-misc" (a)) (declare-function math-compare "calc-ext" (a b)) -(declare-function math-bignum "calc" (a)) (declare-function math-compare-bignum "calc-ext" (a b)) @@ -70,29 +69,22 @@ ;;; Faster in-line version zerop, normalized values only. (defsubst Math-zerop (a) ; [P N] (if (consp a) - (and (not (memq (car a) '(bigpos bigneg))) - (if (eq (car a) 'float) - (eq (nth 1 a) 0) - (math-zerop a))) + (if (eq (car a) 'float) + (eq (nth 1 a) 0) + (math-zerop a)) (eq a 0))) (defsubst Math-integer-negp (a) - (if (consp a) - (eq (car a) 'bigneg) - (< a 0))) + (and (integerp a) (< a 0))) (defsubst Math-integer-posp (a) - (if (consp a) - (eq (car a) 'bigpos) - (> a 0))) + (and (integerp a) (> a 0))) (defsubst Math-negp (a) (if (consp a) - (or (eq (car a) 'bigneg) - (and (not (eq (car a) 'bigpos)) - (if (memq (car a) '(frac float)) - (Math-integer-negp (nth 1 a)) - (math-negp a)))) + (if (memq (car a) '(frac float)) + (Math-integer-negp (nth 1 a)) + (math-negp a)) (< a 0))) (defsubst Math-looks-negp (a) ; [P x] [Public] @@ -104,44 +96,38 @@ (defsubst Math-posp (a) (if (consp a) - (or (eq (car a) 'bigpos) - (and (not (eq (car a) 'bigneg)) - (if (memq (car a) '(frac float)) - (Math-integer-posp (nth 1 a)) - (math-posp a)))) + (if (memq (car a) '(frac float)) + (Math-integer-posp (nth 1 a)) + (math-posp a)) (> a 0))) -(defsubst Math-integerp (a) - (or (not (consp a)) - (memq (car a) '(bigpos bigneg)))) +(defalias 'Math-integerp #'integerp) (defsubst Math-natnump (a) - (if (consp a) - (eq (car a) 'bigpos) - (>= a 0))) + (and (integerp a) (>= a 0))) (defsubst Math-ratp (a) (or (not (consp a)) - (memq (car a) '(bigpos bigneg frac)))) + (eq (car a) 'frac))) (defsubst Math-realp (a) (or (not (consp a)) - (memq (car a) '(bigpos bigneg frac float)))) + (memq (car a) '(frac float)))) (defsubst Math-anglep (a) (or (not (consp a)) - (memq (car a) '(bigpos bigneg frac float hms)))) + (memq (car a) '(frac float hms)))) (defsubst Math-numberp (a) (or (not (consp a)) - (memq (car a) '(bigpos bigneg frac float cplx polar)))) + (memq (car a) '(frac float cplx polar)))) (defsubst Math-scalarp (a) (or (not (consp a)) - (memq (car a) '(bigpos bigneg frac float cplx polar hms)))) + (memq (car a) '(frac float cplx polar hms)))) (defsubst Math-vectorp (a) - (and (consp a) (eq (car a) 'vec))) + (eq (car-safe a) 'vec)) (defsubst Math-messy-integerp (a) (and (consp a) @@ -151,21 +137,17 @@ (defsubst Math-objectp (a) ; [Public] (or (not (consp a)) (memq (car a) - '(bigpos bigneg frac float cplx polar hms date sdev intv mod)))) + '(frac float cplx polar hms date sdev intv mod)))) (defsubst Math-objvecp (a) ; [Public] (or (not (consp a)) (memq (car a) - '(bigpos bigneg frac float cplx polar hms date - sdev intv mod vec)))) + '(frac float cplx polar hms date + sdev intv mod vec)))) ;;; Compute the negative of A. [O O; o o] [Public] (defsubst Math-integer-neg (a) - (if (consp a) - (if (eq (car a) 'bigpos) - (cons 'bigneg (cdr a)) - (cons 'bigpos (cdr a))) - (- a))) + (- a)) (defsubst Math-equal (a b) (= (math-compare a b) 0)) @@ -175,20 +157,14 @@ (defsubst Math-primp (a) (or (not (consp a)) - (memq (car a) '(bigpos bigneg frac float cplx polar - hms date mod var)))) + (memq (car a) '(frac float cplx polar + hms date mod var)))) (defsubst Math-num-integerp (a) (or (not (consp a)) - (memq (car a) '(bigpos bigneg)) (and (eq (car a) 'float) (>= (nth 2 a) 0)))) -(defsubst Math-bignum-test (a) ; [B N; B s; b b] - (if (consp a) - a - (math-bignum a))) - (defsubst Math-equal-int (a b) (or (eq a b) (and (consp a) diff --git a/lisp/calc/calc-math.el b/lisp/calc/calc-math.el index 50c8758ace2..4ca8515989b 100644 --- a/lisp/calc/calc-math.el +++ b/lisp/calc/calc-math.el @@ -25,6 +25,8 @@ ;; This file is autoloaded from calc-ext.el. + +(require 'cl-lib) (require 'calc-ext) (require 'calc-macs) @@ -95,8 +97,7 @@ If this can't be done, return NIL." (and (<= calc-internal-prec math-emacs-precision) (math-realp x) - (let* ((fx (math-float x)) - (xpon (+ (nth 2 x) (1- (math-numdigs (nth 1 x)))))) + (let* ((xpon (+ (nth 2 x) (1- (math-numdigs (nth 1 x)))))) (and (<= math-smallest-emacs-expt xpon) (<= xpon math-largest-emacs-expt) (condition-case nil @@ -371,51 +372,15 @@ If this can't be done, return NIL." ;;; with an overestimate always works, even using truncating integer division! (defun math-isqrt (a) (cond ((Math-zerop a) a) - ((not (math-natnump a)) + ((not (natnump a)) (math-reject-arg a 'natnump)) - ((integerp a) - (math-isqrt-small a)) - (t - (math-normalize (cons 'bigpos (cdr (math-isqrt-bignum (cdr a)))))))) + (t (cl-isqrt a)))) (defun calcFunc-isqrt (a) (if (math-realp a) (math-isqrt (math-floor a)) (math-floor (math-sqrt a)))) - -;;; This returns (flag . result) where the flag is t if A is a perfect square. -(defun math-isqrt-bignum (a) ; [P.l L] - (let ((len (length a))) - (if (= (% len 2) 0) - (let* ((top (nthcdr (- len 2) a))) - (math-isqrt-bignum-iter - a - (math-scale-bignum-digit-size - (math-bignum-big - (1+ (math-isqrt-small - (+ (* (nth 1 top) math-bignum-digit-size) (car top))))) - (1- (/ len 2))))) - (let* ((top (nth (1- len) a))) - (math-isqrt-bignum-iter - a - (math-scale-bignum-digit-size - (list (1+ (math-isqrt-small top))) - (/ len 2))))))) - -(defun math-isqrt-bignum-iter (a guess) ; [l L l] - (math-working "isqrt" (cons 'bigpos guess)) - (let* ((q (math-div-bignum a guess)) - (s (math-add-bignum (car q) guess)) - (g2 (math-div2-bignum s)) - (comp (math-compare-bignum g2 guess))) - (if (< comp 0) - (math-isqrt-bignum-iter a g2) - (cons (and (= comp 0) - (math-zerop-bignum (cdr q)) - (= (% (car s) 2) 0)) - guess)))) - (defun math-zerop-bignum (a) (and (eq (car a) 0) (progn @@ -428,19 +393,6 @@ If this can't be done, return NIL." n (1- n))) a) -(defun math-isqrt-small (a) ; A > 0. [S S] - (let ((g (cond ((>= a 1000000) 10000) - ((>= a 10000) 1000) - ((>= a 100) 100) - (t 10))) - g2) - (while (< (setq g2 (/ (+ g (/ a g)) 2)) g) - (setq g g2)) - g)) - - - - ;;; Compute the square root of a number. ;;; [T N] if possible, else [F N] if possible, else [C N]. [Public] (defun math-sqrt (a) @@ -449,32 +401,24 @@ If this can't be done, return NIL." (and (math-known-nonposp a) (math-imaginary (math-sqrt (math-neg a)))) (and (integerp a) - (let ((sqrt (math-isqrt-small a))) + (let ((sqrt (cl-isqrt a))) (if (= (* sqrt sqrt) a) sqrt (if calc-symbolic-mode (list 'calcFunc-sqrt a) (math-sqrt-float (math-float a) (math-float sqrt)))))) - (and (eq (car-safe a) 'bigpos) - (let* ((res (math-isqrt-bignum (cdr a))) - (sqrt (math-normalize (cons 'bigpos (cdr res))))) - (if (car res) - sqrt - (if calc-symbolic-mode - (list 'calcFunc-sqrt a) - (math-sqrt-float (math-float a) (math-float sqrt)))))) (and (eq (car-safe a) 'frac) - (let* ((num-res (math-isqrt-bignum (cdr (Math-bignum-test (nth 1 a))))) - (num-sqrt (math-normalize (cons 'bigpos (cdr num-res)))) - (den-res (math-isqrt-bignum (cdr (Math-bignum-test (nth 2 a))))) - (den-sqrt (math-normalize (cons 'bigpos (cdr den-res))))) - (if (and (car num-res) (car den-res)) + (let* ((num-sqrt (cl-isqrt (nth 1 a))) + (num-exact (= (* num-sqrt num-sqrt) (nth 1 a))) + (den-sqrt (cl-isqrt (nth 2 a))) + (den-exact (= (* den-sqrt den-sqrt) (nth 2 a)))) + (if (and num-exact den-exact) (list 'frac num-sqrt den-sqrt) (if calc-symbolic-mode - (if (or (car num-res) (car den-res)) - (math-div (if (car num-res) + (if (or num-exact den-exact) + (math-div (if num-exact num-sqrt (list 'calcFunc-sqrt (nth 1 a))) - (if (car den-res) + (if den-exact den-sqrt (list 'calcFunc-sqrt (nth 2 a)))) (list 'calcFunc-sqrt a)) (math-sqrt-float (math-float a) @@ -482,12 +426,9 @@ If this can't be done, return NIL." (and (eq (car-safe a) 'float) (if calc-symbolic-mode (if (= (% (nth 2 a) 2) 0) - (let ((res (math-isqrt-bignum - (cdr (Math-bignum-test (nth 1 a)))))) - (if (car res) - (math-make-float (math-normalize - (cons 'bigpos (cdr res))) - (/ (nth 2 a) 2)) + (let ((res (cl-isqrt (nth 1 a)))) + (if (= (* res res) (nth 1 a)) + (math-make-float res (/ (nth 2 a) 2)) (signal 'inexact-result nil))) (signal 'inexact-result nil)) (math-sqrt-float a))) @@ -551,7 +492,7 @@ If this can't be done, return NIL." (if (null guess) (let ((ldiff (- (math-numdigs (nth 1 a)) 6))) (or (= (% (+ (nth 2 a) ldiff) 2) 0) (setq ldiff (1+ ldiff))) - (setq guess (math-make-float (math-isqrt-small + (setq guess (math-make-float (cl-isqrt (math-scale-int (nth 1 a) (- ldiff))) (/ (+ (nth 2 a) ldiff) 2))))) (math-sqrt-float-iter a guess))))) @@ -1697,7 +1638,7 @@ If this can't be done, return NIL." (while (not (Math-lessp x pow)) (setq pows (cons pow pows) pow (math-sqr pow))) - (setq n (lsh 1 (1- (length pows))) + (setq n (ash 1 (1- (length pows))) sum n pow (car pows)) (while (and (setq pows (cdr pows)) diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el index aedb68726a5..d86b117c1f1 100644 --- a/lisp/calc/calc-misc.el +++ b/lisp/calc/calc-misc.el @@ -27,6 +27,7 @@ (require 'calc) (require 'calc-macs) +(require 'cl-lib) ;; Declare functions which are defined elsewhere. (declare-function calc-do-keypad "calc-keypd" (&optional full-display interactive)) @@ -116,14 +117,14 @@ Calc user interface as before (either C-x * C or C-x * K; initially C-x * C). (while (progn (message "Calc options: Calc, Keypad, ... %s" "press SPC, DEL to scroll, C-g to cancel") - (memq (car (setq key (calc-read-key t))) + (memq (setq key (read-event)) '(? ?\C-h ?\C-? ?\C-v ?\M-v))) - (condition-case err - (if (memq (car key) '(? ?\C-v)) + (condition-case nil + (if (memq key '(? ?\C-v)) (scroll-up) (scroll-down)) (error (beep)))) - (calc-unread-command (cdr key)))))) + (calc-unread-command key))))) (calc-do-dispatch nil)) (let ((calc-dispatch-help t)) (calc-do-dispatch arg)))) @@ -658,10 +659,7 @@ loaded and the keystroke automatically re-typed." ;;;###autoload (defun math-zerop (a) (if (consp a) - (cond ((memq (car a) '(bigpos bigneg)) - (while (eq (car (setq a (cdr a))) 0)) - (null a)) - ((memq (car a) '(frac float polar mod)) + (cond ((memq (car a) '(frac float polar mod)) (math-zerop (nth 1 a))) ((eq (car a) 'cplx) (and (math-zerop (nth 1 a)) (math-zerop (nth 2 a)))) @@ -677,9 +675,7 @@ loaded and the keystroke automatically re-typed." ;;;###autoload (defun math-negp (a) (if (consp a) - (cond ((eq (car a) 'bigpos) nil) - ((eq (car a) 'bigneg) (cdr a)) - ((memq (car a) '(float frac)) + (cond ((memq (car a) '(float frac)) (Math-integer-negp (nth 1 a))) ((eq (car a) 'hms) (if (math-zerop (nth 1 a)) @@ -712,9 +708,7 @@ loaded and the keystroke automatically re-typed." ;;;###autoload (defun math-posp (a) (if (consp a) - (cond ((eq (car a) 'bigpos) (cdr a)) - ((eq (car a) 'bigneg) nil) - ((memq (car a) '(float frac)) + (cond ((memq (car a) '(float frac)) (Math-integer-posp (nth 1 a))) ((eq (car a) 'hms) (if (math-zerop (nth 1 a)) @@ -734,36 +728,20 @@ loaded and the keystroke automatically re-typed." (> a 0))) ;;;###autoload -(defalias 'math-fixnump 'integerp) +(defalias 'math-fixnump #'fixnump) ;;;###autoload -(defalias 'math-fixnatnump 'natnump) - +(defun math-fixnatnump (x) (and (fixnump x) (natnump x))) ;; True if A is an even integer. [P R R] [Public] ;;;###autoload (defun math-evenp (a) - (if (consp a) - (and (memq (car a) '(bigpos bigneg)) - (= (% (nth 1 a) 2) 0)) - (= (% a 2) 0))) + (and (integerp a) (cl-evenp a))) ;; Compute A / 2, for small or big integer A. [I i] ;; If A is negative, type of truncation is undefined. ;;;###autoload (defun math-div2 (a) - (if (consp a) - (if (cdr a) - (math-normalize (cons (car a) (math-div2-bignum (cdr a)))) - 0) - (/ a 2))) - -;;;###autoload -(defun math-div2-bignum (a) ; [l l] - (if (cdr a) - (cons (+ (/ (car a) 2) (* (% (nth 1 a) 2) (/ math-bignum-digit-size 2))) - (math-div2-bignum (cdr a))) - (list (/ (car a) 2)))) - + (/ a 2)) ;; Reject an argument to a calculator function. [Public] ;;;###autoload diff --git a/lisp/calc/calc-poly.el b/lisp/calc/calc-poly.el index 7e3e423868c..5fba85e059d 100644 --- a/lisp/calc/calc-poly.el +++ b/lisp/calc/calc-poly.el @@ -1,4 +1,4 @@ -;;; calc-poly.el --- polynomial functions for Calc +;;; calc-poly.el --- polynomial functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2019 Free Software Foundation, Inc. @@ -177,8 +177,8 @@ (math-add (car res) (math-div (cdr res) pd)))) -;;; Multiply two terms, expanding out products of sums. (defun math-mul-thru (lhs rhs) + "Multiply two terms, expanding out products of sums." (if (memq (car-safe lhs) '(+ -)) (list (car lhs) (math-mul-thru (nth 1 lhs) rhs) @@ -197,8 +197,8 @@ (math-div num den))) -;;; Sort the terms of a sum into canonical order. (defun math-sort-terms (expr) + "Sort the terms of a sum into canonical order." (if (memq (car-safe expr) '(+ -)) (math-list-to-sum (sort (math-sum-to-list expr) @@ -223,8 +223,8 @@ (math-sum-to-list (nth 2 tree) (not neg)))) (t (list (cons tree neg))))) -;;; Check if the polynomial coefficients are modulo forms. (defun math-poly-modulus (expr &optional expr2) + "Check if the polynomial coefficients are modulo forms." (or (math-poly-modulus-rec expr) (and expr2 (math-poly-modulus-rec expr2)) 1)) @@ -237,12 +237,13 @@ (math-poly-modulus-rec (nth 2 expr)))))) -;;; Divide two polynomials. Return (quotient . remainder). (defvar math-poly-div-base nil) -(defun math-poly-div (u v &optional math-poly-div-base) - (if math-poly-div-base - (math-do-poly-div u v) - (math-do-poly-div (calcFunc-expand u) (calcFunc-expand v)))) +(defun math-poly-div (u v &optional div-base) + "Divide two polynomials. Return (quotient . remainder)." + (let ((math-poly-div-base div-base)) + (if div-base + (math-do-poly-div u v) + (math-do-poly-div (calcFunc-expand u) (calcFunc-expand v))))) (defun math-poly-div-exact (u v &optional base) (let ((res (math-poly-div u v base))) @@ -308,8 +309,8 @@ (math-div (math-build-polynomial-expr (cdr res) base) v))))))) -;;; Divide two polynomials in coefficient-list form. Return (quot . rem). (defun math-poly-div-coefs (u v) + "Divide two polynomials in coefficient-list form. Return (quot . rem)." (cond ((null v) (math-reject-arg nil "Division by zero")) ((< (length u) (length v)) (cons nil u)) ((cdr u) @@ -334,9 +335,9 @@ (cons (list (math-poly-div-rec (car u) (car v))) nil)))) -;;; Perform a pseudo-division of polynomials. (See Knuth section 4.6.1.) -;;; This returns only the remainder from the pseudo-division. (defun math-poly-pseudo-div (u v) + "Perform a pseudo-division of polynomials. (See Knuth section 4.6.1.) +This returns only the remainder from the pseudo-division." (cond ((null v) nil) ((< (length u) (length v)) u) ((or (cdr u) (cdr v)) @@ -359,8 +360,8 @@ (nreverse (mapcar 'math-simplify urev)))) (t nil))) -;;; Compute the GCD of two multivariate polynomials. (defun math-poly-gcd (u v) + "Compute the GCD of two multivariate polynomials." (cond ((Math-equal u v) u) ((math-constp u) (if (Math-zerop u) @@ -423,7 +424,7 @@ (defun math-poly-gcd-coefs (u v) (let ((d (math-poly-gcd (math-poly-gcd-list u) (math-poly-gcd-list v))) - (g 1) (h 1) (z 0) hh r delta ghd) + (g 1) (h 1) (z 0) r delta) (while (and u v (Math-zerop (car u)) (Math-zerop (car v))) (setq u (cdr u) v (cdr v) z (1+ z))) (or (eq d 1) @@ -452,8 +453,8 @@ v)) -;;; Return true if is a factor containing no sums or quotients. (defun math-atomic-factorp (expr) + "Return true if is a factor containing no sums or quotients." (cond ((eq (car-safe expr) '*) (and (math-atomic-factorp (nth 1 expr)) (math-atomic-factorp (nth 2 expr)))) @@ -463,14 +464,13 @@ (math-atomic-factorp (nth 1 expr))) (t t))) -;;; Find a suitable base for dividing a by b. -;;; The base must exist in both expressions. -;;; The degree in the numerator must be higher or equal than the -;;; degree in the denominator. -;;; If the above conditions are not met the quotient is just a remainder. -;;; Return nil if this is the case. - (defun math-poly-div-base (a b) + "Find a suitable base for dividing a by b. +The base must exist in both expressions. +The degree in the numerator must be higher or equal than the +degree in the denominator. +If the above conditions are not met the quotient is just a remainder. +Return nil if this is the case." (let (a-base b-base) (and (setq a-base (math-total-polynomial-base a)) (setq b-base (math-total-polynomial-base b)) @@ -482,12 +482,11 @@ (throw 'return (car (car a-base)))))) (setq a-base (cdr a-base))))))) -;;; Same as above but for gcd algorithm. -;;; Here there is no requirement that degree(a) > degree(b). -;;; Take the base that has the highest degree considering both a and b. -;;; ("a^20+b^21+x^3+a+b", "a+b^2+x^5+a^22+b^10") --> (a 22) - (defun math-poly-gcd-base (a b) + "Same as `math-poly-div-base' but for gcd algorithm. +Here there is no requirement that degree(a) > degree(b). +Take the base that has the highest degree considering both a and b. + (\"a^20+b^21+x^3+a+b\", \"a+b^2+x^5+a^22+b^10\") --> (a 22)" (let (a-base b-base) (and (setq a-base (math-total-polynomial-base a)) (setq b-base (math-total-polynomial-base b)) @@ -501,8 +500,8 @@ (throw 'return (car (car b-base))) (setq b-base (cdr b-base))))))))) -;;; Sort a list of polynomial bases. (defun math-sort-poly-base-list (lst) + "Sort a list of polynomial bases." (sort lst (function (lambda (a b) (or (> (nth 1 a) (nth 1 b)) (and (= (nth 1 a) (nth 1 b)) @@ -511,21 +510,18 @@ ;;; Given an expression find all variables that are polynomial bases. ;;; Return list in the form '( (var1 degree1) (var2 degree2) ... ). -;; The variable math-poly-base-total-base is local to -;; math-total-polynomial-base, but is used by math-polynomial-p1, -;; which is called by math-total-polynomial-base. +;; The variable math-poly-base-total-base and math-poly-base-top-expr are local +;; to math-total-polynomial-base, but used by math-polynomial-p1, which is +;; called by math-total-polynomial-base. (defvar math-poly-base-total-base) +(defvar math-poly-base-top-expr) (defun math-total-polynomial-base (expr) - (let ((math-poly-base-total-base nil)) - (math-polynomial-base expr 'math-polynomial-p1) + (let ((math-poly-base-total-base nil) + (math-poly-base-top-expr expr)) + (math-polynomial-base expr #'math-polynomial-p1) (math-sort-poly-base-list math-poly-base-total-base))) -;; The variable math-poly-base-top-expr is local to math-polynomial-base -;; in calc-alg.el, but is used by math-polynomial-p1 which is called -;; by math-polynomial-base. -(defvar math-poly-base-top-expr) - (defun math-polynomial-p1 (subexpr) (or (assoc subexpr math-poly-base-total-base) (memq (car subexpr) '(+ - * / neg)) @@ -554,28 +550,30 @@ ;; called (indirectly) by calcFunc-factors and calcFunc-factor. (defvar math-to-list) -(defun calcFunc-factors (math-fact-expr &optional var) +(defun calcFunc-factors (expr &optional var) (let ((math-factored-vars (if var t nil)) (math-to-list t) (calc-prefer-frac t)) (or var - (setq var (math-polynomial-base math-fact-expr))) + (setq var (math-polynomial-base expr))) (let ((res (math-factor-finish - (or (catch 'factor (math-factor-expr-try var)) - math-fact-expr)))) + (or (catch 'factor + (let ((math-fact-expr expr)) (math-factor-expr-try var))) + expr)))) (math-simplify (if (math-vectorp res) res (list 'vec (list 'vec res 1))))))) -(defun calcFunc-factor (math-fact-expr &optional var) +(defun calcFunc-factor (expr &optional var) (let ((math-factored-vars nil) (math-to-list nil) (calc-prefer-frac t)) (math-simplify (math-factor-finish (if var - (let ((math-factored-vars t)) - (or (catch 'factor (math-factor-expr-try var)) math-fact-expr)) - (math-factor-expr math-fact-expr)))))) + (let ((math-factored-vars t) + (math-fact-expr expr)) + (or (catch 'factor (math-factor-expr-try var)) expr)) + (math-factor-expr expr)))))) (defun math-factor-finish (x) (if (Math-primp x) @@ -589,18 +587,19 @@ (list 'calcFunc-Fac-Prot x) x)) -(defun math-factor-expr (math-fact-expr) - (cond ((eq math-factored-vars t) math-fact-expr) - ((or (memq (car-safe math-fact-expr) '(* / ^ neg)) - (assq (car-safe math-fact-expr) calc-tweak-eqn-table)) - (cons (car math-fact-expr) (mapcar 'math-factor-expr (cdr math-fact-expr)))) - ((memq (car-safe math-fact-expr) '(+ -)) +(defun math-factor-expr (expr) + (cond ((eq math-factored-vars t) expr) + ((or (memq (car-safe expr) '(* / ^ neg)) + (assq (car-safe expr) calc-tweak-eqn-table)) + (cons (car expr) (mapcar 'math-factor-expr (cdr expr)))) + ((memq (car-safe expr) '(+ -)) (let* ((math-factored-vars math-factored-vars) - (y (catch 'factor (math-factor-expr-part math-fact-expr)))) + (y (catch 'factor (let ((math-fact-expr expr)) + (math-factor-expr-part expr))))) (if y (math-factor-expr y) - math-fact-expr))) - (t math-fact-expr))) + expr))) + (t expr))) (defun math-factor-expr-part (x) ; uses "expr" (if (memq (car-safe x) '(+ - * / ^ neg)) @@ -616,20 +615,20 @@ ;; used by math-factor-poly-coefs, which is called by math-factor-expr-try. (defvar math-fet-x) -(defun math-factor-expr-try (math-fet-x) +(defun math-factor-expr-try (x) (if (eq (car-safe math-fact-expr) '*) (let ((res1 (catch 'factor (let ((math-fact-expr (nth 1 math-fact-expr))) - (math-factor-expr-try math-fet-x)))) + (math-factor-expr-try x)))) (res2 (catch 'factor (let ((math-fact-expr (nth 2 math-fact-expr))) - (math-factor-expr-try math-fet-x))))) + (math-factor-expr-try x))))) (and (or res1 res2) (throw 'factor (math-accum-factors (or res1 (nth 1 math-fact-expr)) 1 (or res2 (nth 2 math-fact-expr)))))) - (let* ((p (math-is-polynomial math-fact-expr math-fet-x 30 'gen)) + (let* ((p (math-is-polynomial math-fact-expr x 30 'gen)) (math-poly-modulus (math-poly-modulus math-fact-expr)) res) (and (cdr p) - (setq res (math-factor-poly-coefs p)) + (setq res (let ((math-fet-x x)) (math-factor-poly-coefs p))) (throw 'factor res))))) (defun math-accum-factors (fac pow facs) @@ -735,7 +734,6 @@ (let ((roots (car t1)) (csign (if (math-negp (nth (1- (length p)) p)) -1 1)) (expr 1) - (unfac (nth 1 t1)) (scale (nth 2 t1))) (while roots (let ((coef0 (car (car roots))) @@ -1108,7 +1106,7 @@ If no partial fraction representation can be found, return nil." (t expr))) (defun calcFunc-expand (expr &optional many) - (math-normalize (math-map-tree 'math-expand-term expr many))) + (math-normalize (math-map-tree #'math-expand-term expr many))) (defun math-expand-power (x n &optional var else-nil) (or (and (natnump n) diff --git a/lisp/calc/calc-store.el b/lisp/calc/calc-store.el index 589a776c413..3987c129c23 100644 --- a/lisp/calc/calc-store.el +++ b/lisp/calc/calc-store.el @@ -405,8 +405,8 @@ sconst)))) (if var (let ((msg (calc-store-value var value ""))) - (message (concat "Special constant \"%s\" copied to \"%s\"" msg) - sconst (calc-var-name var))))))))) + (message "Special constant \"%s\" copied to \"%s\"%s" + sconst (calc-var-name var) msg)))))))) (defun calc-copy-variable (&optional var1 var2) (interactive) diff --git a/lisp/calc/calc-units.el b/lisp/calc/calc-units.el index 8794d1f3c67..86bebe6a9ed 100644 --- a/lisp/calc/calc-units.el +++ b/lisp/calc/calc-units.el @@ -1,4 +1,4 @@ -;;; calc-units.el --- unit conversion functions for Calc +;;; calc-units.el --- unit conversion functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2019 Free Software Foundation, Inc. @@ -455,7 +455,6 @@ If COMP or STD is non-nil, put that in the units table instead." (uoldname nil) (unitscancel nil) (nouold nil) - unew units defunits) (if (or (not (math-units-in-expr-p expr t)) @@ -672,8 +671,8 @@ If COMP or STD is non-nil, put that in the units table instead." (substring name (1+ pos))))) (setq name (concat "(" name ")")))) (or (eq (nth 1 expr) (car u)) - (setq name (concat (nth 2 (assq (aref (symbol-name - (nth 1 expr)) 0) + (setq name (concat (nth 2 (assq (aref (symbol-name (nth 1 expr)) + 0) math-unit-prefixes)) (if (and (string-match "[^a-zA-Zα-ωΑ-Ω0-9']" name) (not (memq (car u) '(mHg gf)))) @@ -857,7 +856,7 @@ If COMP or STD is non-nil, put that in the units table instead." (or math-units-table (let* ((combined-units (append math-additional-units math-standard-units)) - (math-cu-unit-list (mapcar 'car combined-units)) + (math-cu-unit-list (mapcar #'car combined-units)) tab) (message "Building units table...") (setq math-units-table-buffer-valid nil) @@ -880,7 +879,7 @@ If COMP or STD is non-nil, put that in the units table instead." (nth 4 x)))) combined-units)) (let ((math-units-table tab)) - (mapc 'math-find-base-units tab)) + (mapc #'math-find-base-units tab)) (message "Building units table...done") (setq math-units-table tab)))) @@ -890,15 +889,16 @@ If COMP or STD is non-nil, put that in the units table instead." (defvar math-fbu-base) (defvar math-fbu-entry) -(defun math-find-base-units (math-fbu-entry) - (if (eq (nth 4 math-fbu-entry) 'boom) - (error "Circular definition involving unit %s" (car math-fbu-entry))) - (or (nth 4 math-fbu-entry) - (let (math-fbu-base) - (setcar (nthcdr 4 math-fbu-entry) 'boom) - (math-find-base-units-rec (nth 1 math-fbu-entry) 1) +(defun math-find-base-units (entry) + (if (eq (nth 4 entry) 'boom) + (error "Circular definition involving unit %s" (car entry))) + (or (nth 4 entry) + (let (math-fbu-base + (math-fbu-entry entry)) + (setcar (nthcdr 4 entry) 'boom) + (math-find-base-units-rec (nth 1 entry) 1) '(or math-fbu-base - (error "Dimensionless definition for unit %s" (car math-fbu-entry))) + (error "Dimensionless definition for unit %s" (car entry))) (while (eq (cdr (car math-fbu-base)) 0) (setq math-fbu-base (cdr math-fbu-base))) (let ((b math-fbu-base)) @@ -907,7 +907,7 @@ If COMP or STD is non-nil, put that in the units table instead." (setcdr b (cdr (cdr b))) (setq b (cdr b))))) (setq math-fbu-base (sort math-fbu-base 'math-compare-unit-names)) - (setcar (nthcdr 4 math-fbu-entry) math-fbu-base) + (setcar (nthcdr 4 entry) math-fbu-base) math-fbu-base))) (defun math-compare-unit-names (a b) @@ -942,7 +942,8 @@ If COMP or STD is non-nil, put that in the units table instead." (error "Unknown name %s in defining expression for unit %s" (nth 1 expr) (car math-fbu-entry)))) ((equal expr '(calcFunc-ln 10))) - (t (error "Malformed defining expression for unit %s" (car math-fbu-entry)))))) + (t (error "Malformed defining expression for unit %s" + (car math-fbu-entry)))))) (defun math-units-in-expr-p (expr sub-exprs) @@ -1018,8 +1019,9 @@ If COMP or STD is non-nil, put that in the units table instead." ;; math-to-standard-units. (defvar math-which-standard) -(defun math-to-standard-units (expr math-which-standard) - (math-to-standard-rec expr)) +(defun math-to-standard-units (expr which-standard) + (let ((math-which-standard which-standard)) + (math-to-standard-rec expr))) (defun math-to-standard-rec (expr) (if (eq (car-safe expr) 'var) @@ -1052,7 +1054,7 @@ If COMP or STD is non-nil, put that in the units table instead." (eq (car-safe (nth 1 expr)) 'var))) expr (cons (car expr) - (mapcar 'math-to-standard-rec (cdr expr)))))) + (mapcar #'math-to-standard-rec (cdr expr)))))) (defun math-apply-units (expr units ulist &optional pure) (setq expr (math-simplify-units expr)) @@ -1085,8 +1087,7 @@ If COMP or STD is non-nil, put that in the units table instead." (let ((entry (list units calc-internal-prec calc-prefer-frac))) (or (equal entry (car math-decompose-units-cache)) (let ((ulist nil) - (utemp units) - qty unit) + (utemp units)) (while (eq (car-safe utemp) '+) (setq ulist (cons (math-decompose-unit-part (nth 2 utemp)) ulist) @@ -1144,15 +1145,15 @@ If COMP or STD is non-nil, put that in the units table instead." (defvar math-cu-new-units) (defvar math-cu-pure) -(defun math-convert-units (expr math-cu-new-units &optional math-cu-pure) - (if (eq (car-safe math-cu-new-units) 'var) - (let ((unew (assq (nth 1 math-cu-new-units) +(defun math-convert-units (expr new-units &optional pure) + (if (eq (car-safe new-units) 'var) + (let ((unew (assq (nth 1 new-units) (math-build-units-table)))) (if (eq (car-safe (nth 1 unew)) '+) - (setq math-cu-new-units (nth 1 unew))))) + (setq new-units (nth 1 unew))))) (math-with-extra-prec 2 - (let ((compat (and (not math-cu-pure) - (math-find-compatible-unit expr math-cu-new-units))) + (let ((compat (and (not pure) + (math-find-compatible-unit expr new-units))) (math-cu-unit-list nil) (math-combining-units nil)) (if compat @@ -1160,21 +1161,23 @@ If COMP or STD is non-nil, put that in the units table instead." (math-mul (math-mul (math-simplify-units (math-div expr (math-pow (car compat) (cdr compat)))) - (math-pow math-cu-new-units (cdr compat))) + (math-pow new-units (cdr compat))) (math-simplify-units (math-to-standard-units - (math-pow (math-div (car compat) math-cu-new-units) + (math-pow (math-div (car compat) new-units) (cdr compat)) nil)))) - (when (setq math-cu-unit-list (math-decompose-units math-cu-new-units)) - (setq math-cu-new-units (nth 2 (car math-cu-unit-list)))) + (when (setq math-cu-unit-list (math-decompose-units new-units)) + (setq new-units (nth 2 (car math-cu-unit-list)))) (when (eq (car-safe expr) '+) (setq expr (math-simplify-units expr))) (if (math-units-in-expr-p expr t) - (math-convert-units-rec expr) + (let ((math-cu-new-units new-units) + (math-cu-pure pure)) + (math-convert-units-rec expr)) (math-apply-units (math-to-standard-units - (list '/ expr math-cu-new-units) nil) - math-cu-new-units math-cu-unit-list math-cu-pure)))))) + (list '/ expr new-units) nil) + new-units math-cu-unit-list pure)))))) (defun math-convert-units-rec (expr) (if (math-units-in-expr-p expr nil) @@ -1184,7 +1187,7 @@ If COMP or STD is non-nil, put that in the units table instead." (if (Math-primp expr) expr (cons (car expr) - (mapcar 'math-convert-units-rec (cdr expr)))))) + (mapcar #'math-convert-units-rec (cdr expr)))))) (defun math-convert-temperature (expr old new &optional pure) (let* ((units (math-single-units-in-expr-p expr)) @@ -1228,37 +1231,34 @@ If COMP or STD is non-nil, put that in the units table instead." (math-simplify a))) (defalias 'calcFunc-usimplify 'math-simplify-units) -;; The function created by math-defsimplify uses the variable -;; math-simplify-expr, and so is used by functions in math-defsimplify -(defvar math-simplify-expr) - +;; The function created by math-defsimplify uses the variable `expr'. (math-defsimplify (+ -) (and math-simplifying-units - (math-units-in-expr-p (nth 1 math-simplify-expr) nil) - (let* ((units (math-extract-units (nth 1 math-simplify-expr))) + (math-units-in-expr-p (nth 1 expr) nil) + (let* ((units (math-extract-units (nth 1 expr))) (ratio (math-simplify (math-to-standard-units - (list '/ (nth 2 math-simplify-expr) units) nil)))) + (list '/ (nth 2 expr) units) nil)))) (if (math-units-in-expr-p ratio nil) (progn - (calc-record-why "*Inconsistent units" math-simplify-expr) - math-simplify-expr) - (list '* (math-add (math-remove-units (nth 1 math-simplify-expr)) - (if (eq (car math-simplify-expr) '-) + (calc-record-why "*Inconsistent units" expr) + expr) + (list '* (math-add (math-remove-units (nth 1 expr)) + (if (eq (car expr) '-) (math-neg ratio) ratio)) units))))) (math-defsimplify * - (math-simplify-units-prod)) + (math-simplify-units-prod expr)) -(defun math-simplify-units-prod () +(defun math-simplify-units-prod (expr) (and math-simplifying-units calc-autorange-units - (Math-realp (nth 1 math-simplify-expr)) - (let* ((num (math-float (nth 1 math-simplify-expr))) + (Math-realp (nth 1 expr)) + (let* ((num (math-float (nth 1 expr))) (xpon (calcFunc-xpon num)) - (unitp (cdr (cdr math-simplify-expr))) + (unitp (cdr (cdr expr))) (unit (car unitp)) - (pow (if (eq (car math-simplify-expr) '*) 1 -1)) + (pow (if (eq (car expr) '*) 1 -1)) u) (and (eq (car-safe unit) '*) (setq unitp (cdr unit) @@ -1308,46 +1308,46 @@ If COMP or STD is non-nil, put that in the units table instead." (or (not (eq p pref)) (< xpon (+ pxpon (* (math-abs pow) 3)))) (progn - (setcar (cdr math-simplify-expr) + (setcar (cdr expr) (let ((calc-prefer-frac nil)) - (calcFunc-scf (nth 1 math-simplify-expr) + (calcFunc-scf (nth 1 expr) (- uxpon pxpon)))) (setcar unitp pname) - math-simplify-expr))))))) + expr))))))) (defvar math-try-cancel-units) (math-defsimplify / (and math-simplifying-units - (let ((np (cdr math-simplify-expr)) + (let ((np (cdr expr)) (math-try-cancel-units 0) - n nn) - (setq n (if (eq (car-safe (nth 2 math-simplify-expr)) '*) - (cdr (nth 2 math-simplify-expr)) - (nthcdr 2 math-simplify-expr))) + n) + (setq n (if (eq (car-safe (nth 2 expr)) '*) + (cdr (nth 2 expr)) + (nthcdr 2 expr))) (if (math-realp (car n)) (progn - (setcar (cdr math-simplify-expr) (math-mul (nth 1 math-simplify-expr) + (setcar (cdr expr) (math-mul (nth 1 expr) (let ((calc-prefer-frac nil)) (math-div 1 (car n))))) (setcar n 1))) (while (eq (car-safe (setq n (car np))) '*) - (math-simplify-units-divisor (cdr n) (cdr (cdr math-simplify-expr))) + (math-simplify-units-divisor (cdr n) (cdr (cdr expr))) (setq np (cdr (cdr n)))) - (math-simplify-units-divisor np (cdr (cdr math-simplify-expr))) + (math-simplify-units-divisor np (cdr (cdr expr))) (if (eq math-try-cancel-units 0) (let* ((math-simplifying-units nil) (base (math-simplify - (math-to-standard-units math-simplify-expr nil)))) + (math-to-standard-units expr nil)))) (if (Math-numberp base) - (setq math-simplify-expr base)))) - (if (eq (car-safe math-simplify-expr) '/) - (math-simplify-units-prod)) - math-simplify-expr))) + (setq expr base)))) + (if (eq (car-safe expr) '/) + (math-simplify-units-prod expr)) + expr))) (defun math-simplify-units-divisor (np dp) (let ((n (car np)) - d dd temp) + d temp) (while (eq (car-safe (setq d (car dp))) '*) (when (setq temp (math-simplify-units-quotient n (nth 1 d))) (setcar np (setq n temp)) @@ -1387,23 +1387,23 @@ If COMP or STD is non-nil, put that in the units table instead." (math-defsimplify ^ (and math-simplifying-units - (math-realp (nth 2 math-simplify-expr)) - (if (memq (car-safe (nth 1 math-simplify-expr)) '(* /)) - (list (car (nth 1 math-simplify-expr)) - (list '^ (nth 1 (nth 1 math-simplify-expr)) - (nth 2 math-simplify-expr)) - (list '^ (nth 2 (nth 1 math-simplify-expr)) - (nth 2 math-simplify-expr))) - (math-simplify-units-pow (nth 1 math-simplify-expr) - (nth 2 math-simplify-expr))))) + (math-realp (nth 2 expr)) + (if (memq (car-safe (nth 1 expr)) '(* /)) + (list (car (nth 1 expr)) + (list '^ (nth 1 (nth 1 expr)) + (nth 2 expr)) + (list '^ (nth 2 (nth 1 expr)) + (nth 2 expr))) + (math-simplify-units-pow (nth 1 expr) + (nth 2 expr))))) (math-defsimplify calcFunc-sqrt (and math-simplifying-units - (if (memq (car-safe (nth 1 math-simplify-expr)) '(* /)) - (list (car (nth 1 math-simplify-expr)) - (list 'calcFunc-sqrt (nth 1 (nth 1 math-simplify-expr))) - (list 'calcFunc-sqrt (nth 2 (nth 1 math-simplify-expr)))) - (math-simplify-units-pow (nth 1 math-simplify-expr) '(frac 1 2))))) + (if (memq (car-safe (nth 1 expr)) '(* /)) + (list (car (nth 1 expr)) + (list 'calcFunc-sqrt (nth 1 (nth 1 expr))) + (list 'calcFunc-sqrt (nth 2 (nth 1 expr)))) + (math-simplify-units-pow (nth 1 expr) '(frac 1 2))))) (math-defsimplify (calcFunc-floor calcFunc-ceil @@ -1416,21 +1416,21 @@ If COMP or STD is non-nil, put that in the units table instead." calcFunc-abs calcFunc-clean) (and math-simplifying-units - (= (length math-simplify-expr) 2) - (if (math-only-units-in-expr-p (nth 1 math-simplify-expr)) - (nth 1 math-simplify-expr) - (if (and (memq (car-safe (nth 1 math-simplify-expr)) '(* /)) + (= (length expr) 2) + (if (math-only-units-in-expr-p (nth 1 expr)) + (nth 1 expr) + (if (and (memq (car-safe (nth 1 expr)) '(* /)) (or (math-only-units-in-expr-p - (nth 1 (nth 1 math-simplify-expr))) + (nth 1 (nth 1 expr))) (math-only-units-in-expr-p - (nth 2 (nth 1 math-simplify-expr))))) - (list (car (nth 1 math-simplify-expr)) - (cons (car math-simplify-expr) - (cons (nth 1 (nth 1 math-simplify-expr)) - (cdr (cdr math-simplify-expr)))) - (cons (car math-simplify-expr) - (cons (nth 2 (nth 1 math-simplify-expr)) - (cdr (cdr math-simplify-expr))))))))) + (nth 2 (nth 1 expr))))) + (list (car (nth 1 expr)) + (cons (car expr) + (cons (nth 1 (nth 1 expr)) + (cdr (cdr expr)))) + (cons (car expr) + (cons (nth 2 (nth 1 expr)) + (cdr (cdr expr))))))))) (defun math-simplify-units-pow (a pow) (if (and (eq (car-safe a) '^) @@ -1453,10 +1453,10 @@ If COMP or STD is non-nil, put that in the units table instead." (math-defsimplify calcFunc-sin (and math-simplifying-units - (math-units-in-expr-p (nth 1 math-simplify-expr) nil) + (math-units-in-expr-p (nth 1 expr) nil) (let ((rad (math-simplify-units (math-evaluate-expr - (math-to-standard-units (nth 1 math-simplify-expr) nil)))) + (math-to-standard-units (nth 1 expr) nil)))) (calc-angle-mode 'rad)) (and (eq (car-safe rad) '*) (math-realp (nth 1 rad)) @@ -1466,10 +1466,10 @@ If COMP or STD is non-nil, put that in the units table instead." (math-defsimplify calcFunc-cos (and math-simplifying-units - (math-units-in-expr-p (nth 1 math-simplify-expr) nil) + (math-units-in-expr-p (nth 1 expr) nil) (let ((rad (math-simplify-units (math-evaluate-expr - (math-to-standard-units (nth 1 math-simplify-expr) nil)))) + (math-to-standard-units (nth 1 expr) nil)))) (calc-angle-mode 'rad)) (and (eq (car-safe rad) '*) (math-realp (nth 1 rad)) @@ -1479,10 +1479,10 @@ If COMP or STD is non-nil, put that in the units table instead." (math-defsimplify calcFunc-tan (and math-simplifying-units - (math-units-in-expr-p (nth 1 math-simplify-expr) nil) + (math-units-in-expr-p (nth 1 expr) nil) (let ((rad (math-simplify-units (math-evaluate-expr - (math-to-standard-units (nth 1 math-simplify-expr) nil)))) + (math-to-standard-units (nth 1 expr) nil)))) (calc-angle-mode 'rad)) (and (eq (car-safe rad) '*) (math-realp (nth 1 rad)) @@ -1492,10 +1492,10 @@ If COMP or STD is non-nil, put that in the units table instead." (math-defsimplify calcFunc-sec (and math-simplifying-units - (math-units-in-expr-p (nth 1 math-simplify-expr) nil) + (math-units-in-expr-p (nth 1 expr) nil) (let ((rad (math-simplify-units (math-evaluate-expr - (math-to-standard-units (nth 1 math-simplify-expr) nil)))) + (math-to-standard-units (nth 1 expr) nil)))) (calc-angle-mode 'rad)) (and (eq (car-safe rad) '*) (math-realp (nth 1 rad)) @@ -1505,10 +1505,10 @@ If COMP or STD is non-nil, put that in the units table instead." (math-defsimplify calcFunc-csc (and math-simplifying-units - (math-units-in-expr-p (nth 1 math-simplify-expr) nil) + (math-units-in-expr-p (nth 1 expr) nil) (let ((rad (math-simplify-units (math-evaluate-expr - (math-to-standard-units (nth 1 math-simplify-expr) nil)))) + (math-to-standard-units (nth 1 expr) nil)))) (calc-angle-mode 'rad)) (and (eq (car-safe rad) '*) (math-realp (nth 1 rad)) @@ -1518,10 +1518,10 @@ If COMP or STD is non-nil, put that in the units table instead." (math-defsimplify calcFunc-cot (and math-simplifying-units - (math-units-in-expr-p (nth 1 math-simplify-expr) nil) + (math-units-in-expr-p (nth 1 expr) nil) (let ((rad (math-simplify-units (math-evaluate-expr - (math-to-standard-units (nth 1 math-simplify-expr) nil)))) + (math-to-standard-units (nth 1 expr) nil)))) (calc-angle-mode 'rad)) (and (eq (car-safe rad) '*) (math-realp (nth 1 rad)) @@ -1536,13 +1536,13 @@ If COMP or STD is non-nil, put that in the units table instead." (if (Math-primp expr) expr (cons (car expr) - (mapcar 'math-remove-units (cdr expr)))))) + (mapcar #'math-remove-units (cdr expr)))))) (defun math-extract-units (expr) (cond ((memq (car-safe expr) '(* /)) (cons (car expr) - (mapcar 'math-extract-units (cdr expr)))) + (mapcar #'math-extract-units (cdr expr)))) ((eq (car-safe expr) 'neg) (math-extract-units (nth 1 expr))) ((eq (car-safe expr) '^) @@ -1669,7 +1669,7 @@ In symbolic mode, return the list (^ a b)." (defun math-extract-logunits (expr) (if (memq (car-safe expr) '(* /)) (cons (car expr) - (mapcar 'math-extract-logunits (cdr expr))) + (mapcar #'math-extract-logunits (cdr expr))) (if (memq (car-safe expr) '(^)) (list '^ (math-extract-logunits (nth 1 expr)) (nth 2 expr)) (if (member expr math-logunits) expr 1)))) diff --git a/lisp/calc/calc-vec.el b/lisp/calc/calc-vec.el index a3e98c06249..364ba4d23bf 100644 --- a/lisp/calc/calc-vec.el +++ b/lisp/calc/calc-vec.el @@ -242,7 +242,7 @@ (cdr item))) ((> mode 0) (let ((dims nil) - type new row) + type new) (setq item (list item)) (while (> mode 0) (setq type (calc-unpack-type (car item)) @@ -1375,9 +1375,7 @@ (aa (if neg (math-sub -1 a) a)) (str (if (eq aa 0) "" - (if (consp aa) - (math-format-bignum-binary (cdr aa)) - (math-format-binary aa)))) + (math-format-binary aa))) (zero (if neg ?1 ?0)) (one (if neg ?0 ?1)) (len (length str)) @@ -1467,7 +1465,7 @@ a) (defun math-clean-set (a &optional always-vec) - (let ((p a) res) + (let ((p a)) (while (cdr p) (if (and (eq (car-safe (nth 1 p)) 'intv) (Math-equal (nth 2 (nth 1 p)) (nth 3 (nth 1 p)))) diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index 1d403b73943..3a9a2804cf2 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -1,4 +1,4 @@ -;;; calc.el --- the GNU Emacs calculator +;;; calc.el --- the GNU Emacs calculator -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2019 Free Software Foundation, Inc. @@ -37,13 +37,12 @@ ;; work for the foreseeable future. ;; ;; Bug reports and suggestions are always welcome! (Type M-x -;; report-calc-bug to send them). +;; report-emacs-bug to send them). ;; All functions, macros, and Lisp variables defined here begin with one ;; of the prefixes "math", "Math", or "calc", with the exceptions of ;; "full-calc", "full-calc-keypad", "another-calc", "quick-calc", -;; "report-calc-bug", and "defmath". User-accessible variables begin -;; with "var-". +;; and "defmath". User-accessible variables begin with "var-". ;;; TODO: @@ -178,7 +177,7 @@ (declare-function math-read-radix-digit "calc-misc" (dig)) (declare-function calc-digit-dots "calc-incom" ()) (declare-function math-normalize-fancy "calc-ext" (a)) -(declare-function math-normalize-nonstandard "calc-ext" ()) +(declare-function math-normalize-nonstandard "calc-ext" (a)) (declare-function math-recompile-eval-rules "calc-alg" ()) (declare-function math-apply-rewrites "calc-rewr" (expr rules &optional heads math-apply-rw-ruleset)) (declare-function calc-record-why "calc-misc" (&rest stuff)) @@ -203,7 +202,7 @@ (declare-function math-compose-expr "calccomp" (a prec &optional div)) (declare-function math-comp-width "calccomp" (c)) (declare-function math-composition-to-string "calccomp" (c &optional width)) -(declare-function math-stack-value-offset-fancy "calccomp" ()) +(declare-function math-stack-value-offset-fancy "calccomp" (c)) (declare-function math-format-flat-expr-fancy "calc-ext" (a prec)) (declare-function math-adjust-fraction "calc-ext" (a)) (declare-function math-format-binary "calc-bin" (a)) @@ -212,7 +211,6 @@ (declare-function math-group-float "calc-ext" (str)) (declare-function math-mod "calc-misc" (a b)) (declare-function math-format-number-fancy "calc-ext" (a prec)) -(declare-function math-format-bignum-fancy "calc-ext" (a)) (declare-function math-read-number-fancy "calc-ext" (s)) (declare-function calc-do-grab-region "calc-yank" (top bot arg)) (declare-function calc-do-grab-rectangle "calc-yank" (top bot arg &optional reduce)) @@ -233,7 +231,6 @@ (defcustom calc-settings-file (locate-user-emacs-file "calc.el" ".calc.el") "File in which to record permanent settings." - :group 'calc :type '(file)) (defcustom calc-language-alist @@ -249,14 +246,12 @@ (f90-mode . fortran) (texinfo-mode . calc-normal-language)) "Alist of major modes with appropriate Calc languages." - :group 'calc :type '(alist :key-type (symbol :tag "Major mode") :value-type (symbol :tag "Calc language"))) (defcustom calc-embedded-announce-formula "%Embed\n\\(% .*\n\\)*" "A regular expression which is sure to be followed by a calc-embedded formula." - :group 'calc :type '(regexp)) (defcustom calc-embedded-announce-formula-alist @@ -272,26 +267,22 @@ (xml-mode . "<!-- Embed -->\n\\(<!-- .* -->\n\\)*") (texinfo-mode . "@c Embed\n\\(@c .*\n\\)*")) "Alist of major modes with appropriate values for `calc-embedded-announce-formula'." - :group 'calc :type '(alist :key-type (symbol :tag "Major mode") :value-type (regexp :tag "Regexp to announce formula"))) (defcustom calc-embedded-open-formula "\\`\\|^\n\\|\\$\\$?\\|\\\\\\[\\|^\\\\begin[^{].*\n\\|^\\\\begin{.*[^x]}.*\n\\|^@.*\n\\|^\\.EQ.*\n\\|\\\\(\\|^%\n\\|^\\.\\\\\"\n" "A regular expression for the opening delimiter of a formula used by calc-embedded." - :group 'calc :type '(regexp)) (defcustom calc-embedded-close-formula "\\'\\|\n$\\|\\$\\$?\\|\\\\]\\|^\\\\end[^{].*\n\\|^\\\\end{.*[^x]}.*\n\\|^@.*\n\\|^\\.EN.*\n\\|\\\\)\\|\n%\n\\|^\\.\\\\\"\n" "A regular expression for the closing delimiter of a formula used by calc-embedded." - :group 'calc :type '(regexp)) (defcustom calc-embedded-open-close-formula-alist nil "Alist of major modes with pairs of formula delimiters used by calc-embedded." - :group 'calc :type '(alist :key-type (symbol :tag "Major mode") :value-type (list (regexp :tag "Opening formula delimiter") (regexp :tag "Closing formula delimiter")))) @@ -299,13 +290,11 @@ (defcustom calc-embedded-word-regexp "[-+]?[0-9]+\\(\\.[0-9]+\\)?\\([eE][-+]?[0-9]+\\)?" "A regular expression determining a word for calc-embedded-word." - :group 'calc :type '(regexp)) (defcustom calc-embedded-word-regexp-alist nil "Alist of major modes with word regexps used by calc-embedded-word." - :group 'calc :type '(alist :key-type (symbol :tag "Major mode") :value-type (regexp :tag "Regexp for word"))) @@ -314,14 +303,12 @@ "A string which is the opening delimiter for a \"plain\" formula. If calc-show-plain mode is enabled, this is inserted at the front of each formula." - :group 'calc :type '(string)) (defcustom calc-embedded-close-plain " %%%\n" "A string which is the closing delimiter for a \"plain\" formula. See calc-embedded-open-plain." - :group 'calc :type '(string)) (defcustom calc-embedded-open-close-plain-alist @@ -337,7 +324,6 @@ See calc-embedded-open-plain." (xml-mode "<!-- %% " " %% -->\n") (texinfo-mode "@c %% " " %%\n")) "Alist of major modes with pairs of delimiters for \"plain\" formulas." - :group 'calc :type '(alist :key-type (symbol :tag "Major mode") :value-type (list (string :tag "Opening \"plain\" delimiter") (string :tag "Closing \"plain\" delimiter")))) @@ -345,19 +331,16 @@ See calc-embedded-open-plain." (defcustom calc-embedded-open-new-formula "\n\n" "A string which is inserted at front of formula by calc-embedded-new-formula." - :group 'calc :type '(string)) (defcustom calc-embedded-close-new-formula "\n\n" "A string which is inserted at end of formula by calc-embedded-new-formula." - :group 'calc :type '(string)) (defcustom calc-embedded-open-close-new-formula-alist nil "Alist of major modes with pairs of new formula delimiters used by calc-embedded." - :group 'calc :type '(alist :key-type (symbol :tag "Major mode") :value-type (list (string :tag "Opening new formula delimiter") (string :tag "Closing new formula delimiter")))) @@ -366,14 +349,12 @@ See calc-embedded-open-plain." "% " "A string which should precede calc-embedded mode annotations. This is not required to be present for user-written mode annotations." - :group 'calc :type '(string)) (defcustom calc-embedded-close-mode "\n" "A string which should follow calc-embedded mode annotations. This is not required to be present for user-written mode annotations." - :group 'calc :type '(string)) (defcustom calc-embedded-open-close-mode-alist @@ -389,7 +370,6 @@ This is not required to be present for user-written mode annotations." (xml-mode "<!-- " " -->\n") (texinfo-mode "@c " "\n")) "Alist of major modes with pairs of strings to delimit annotations." - :group 'calc :type '(alist :key-type (symbol :tag "Major mode") :value-type (list (string :tag "Opening annotation delimiter") (string :tag "Closing annotation delimiter")))) @@ -403,34 +383,29 @@ This is not required to be present for user-written mode annotations." "pgnuplot" "gnuplot") "Name of GNUPLOT program, for calc-graph features." - :group 'calc :type '(string) :version "26.2") (defcustom calc-gnuplot-plot-command nil "Name of command for displaying GNUPLOT output; %s = file name to print." - :group 'calc :type '(choice (string) (sexp))) (defcustom calc-gnuplot-print-command "lp %s" "Name of command for printing GNUPLOT output; %s = file name to print." - :group 'calc :type '(choice (string) (sexp))) (defcustom calc-multiplication-has-precedence t "If non-nil, multiplication has precedence over division in normal mode." - :group 'calc :type 'boolean) (defcustom calc-ensure-consistent-units nil "If non-nil, make sure new units are consistent with current units when converting units." - :group 'calc :version "24.3" :type 'boolean) @@ -438,14 +413,12 @@ when converting units." nil "If non-nil, the stack element under the cursor will be copied by `calc-enter' and deleted by `calc-pop'." - :group 'calc :version "24.4" :type 'boolean) (defcustom calc-undo-length 100 "The number of undo steps that will be preserved when Calc is quit." - :group 'calc :type 'integer) (defcustom calc-highlight-selections-with-faces @@ -456,42 +429,36 @@ shown by displaying the rest of the formula in `calc-nonselected-face'. If option `calc-show-selections' is nil, then selected sub-formulas are shown by displaying the sub-formula in `calc-selected-face'." :version "24.1" - :group 'calc :type 'boolean) (defcustom calc-lu-field-reference "20 uPa" "The default reference level for logarithmic units (field)." :version "24.1" - :group 'calc :type '(string)) (defcustom calc-lu-power-reference "mW" "The default reference level for logarithmic units (power)." :version "24.1" - :group 'calc :type '(string)) (defcustom calc-note-threshold "1" "The number of cents that a frequency should be near a note to be identified as that note." :version "24.1" - :type 'string - :group 'calc) + :type 'string) (defvar math-format-date-cache) ; calc-forms.el (defface calc-nonselected-face '((t :inherit shadow :slant italic)) - "Face used to show the non-selected portion of a formula." - :group 'calc) + "Face used to show the non-selected portion of a formula.") (defface calc-selected-face '((t :weight bold)) - "Face used to show the selected portion of a formula." - :group 'calc) + "Face used to show the selected portion of a formula.") (define-obsolete-variable-alias 'calc-bug-address 'report-emacs-bug-address "26.2") @@ -935,7 +902,6 @@ Used by `calc-user-invocation'.") ;; The following modes use specially-formatted data. (put 'calc-mode 'mode-class 'special) -(put 'calc-trail-mode 'mode-class 'special) (define-error 'calc-error "Calc internal error") (define-error 'inexact-result @@ -1114,15 +1080,7 @@ Used by `calc-user-invocation'.") (ignore-errors (define-key calc-digit-map x 'calcDigit-backspace) (define-key calc-mode-map x 'calc-pop) - (define-key calc-mode-map - (if (and (vectorp x) (featurep 'xemacs)) - (if (= (length x) 1) - (vector (if (consp (aref x 0)) - (cons 'meta (aref x 0)) - (list 'meta (aref x 0)))) - "\e\C-d") - (vconcat "\e" x)) - 'calc-pop-above))) + (define-key calc-mode-map (vconcat "\e" x) 'calc-pop-above))) (if calc-scan-for-dels (append (where-is-internal 'delete-backward-char global-map) (where-is-internal 'backward-delete-char global-map) @@ -1231,9 +1189,9 @@ Used by `calc-user-invocation'.") (let ((glob (current-global-map)) (loc (current-local-map))) (or (input-pending-p) (message "%s" prompt)) - (let ((key (calc-read-key t)) + (let ((key (read-event)) (input-method-function nil)) - (calc-unread-command (cdr key)) + (calc-unread-command key) (unwind-protect (progn (use-global-map map) @@ -1338,16 +1296,17 @@ Notations: 3.14e6 3.14 * 10^6 " (interactive) (mapc (function ;FIXME: Why (set-default v (symbol-value v)) ?!?!? - (lambda (v) (set-default v (symbol-value v)))) calc-local-var-list) + (lambda (v) (set-default v (symbol-value v)))) + calc-local-var-list) (kill-all-local-variables) (use-local-map (if (eq calc-algebraic-mode 'total) (progn (require 'calc-ext) calc-alg-map) calc-mode-map)) (mapc #'make-local-variable calc-local-var-list) (make-local-variable 'overlay-arrow-position) (make-local-variable 'overlay-arrow-string) - (add-hook 'change-major-mode-hook 'font-lock-defontify nil t) + (add-hook 'change-major-mode-hook #'font-lock-defontify nil t) (add-hook 'kill-buffer-query-functions - 'calc-kill-stack-buffer + #'calc-kill-stack-buffer t t) (setq truncate-lines t) (setq buffer-read-only t) @@ -1392,7 +1351,7 @@ Notations: 3.14e6 3.14 * 10^6 (set-buffer "*Calculator*") (while plist (put 'calc-define (car plist) nil) - (eval (nth 1 plist)) + (eval (nth 1 plist) t) (setq plist (cdr (cdr plist)))) ;; See if this has added any more calc-define properties. (calc-check-defines)) @@ -1418,7 +1377,7 @@ commands given here will actually operate on the *Calculator* stack." (make-local-variable 'overlay-arrow-position) (make-local-variable 'overlay-arrow-string) (when (= (buffer-size) 0) - (let ((buffer-read-only nil)) + (let ((inhibit-read-only t)) (insert (propertize "Emacs Calculator Trail\n" 'face 'italic))))) (defun calc-create-buffer () @@ -1802,7 +1761,7 @@ See calc-keypad for details." (if calc-hyperbolic-flag "Hyp " "") (if calc-keep-args-flag "Keep " "") (if (/= calc-stack-top 1) "Narrow " "") - (apply 'concat calc-other-modes))))) + (apply #'concat calc-other-modes))))) (if (equal new-mode-string mode-line-buffer-identification) nil (setq mode-line-buffer-identification new-mode-string) @@ -1876,7 +1835,7 @@ See calc-keypad for details." (if (and (consp vals) (or (integerp (car vals)) (consp (car vals)))) - (setq vals (mapcar 'calc-normalize vals)) + (setq vals (mapcar #'calc-normalize vals)) (setq vals (calc-normalize vals))) (or (and (consp vals) (or (integerp (car vals)) @@ -1959,8 +1918,8 @@ See calc-keypad for details." (mapcar (lambda (x) (calc-get-stack-element x sel-mode)) top))))) (defun calc-top-list-n (&optional n m sel-mode) - (mapcar 'math-check-complete - (mapcar 'calc-normalize (calc-top-list n m sel-mode)))) + (mapcar #'math-check-complete + (mapcar #'calc-normalize (calc-top-list n m sel-mode)))) (defun calc-renumber-stack () @@ -2051,7 +2010,6 @@ on 15 October 1582 (Gregorian), and many Catholic countries made the change then. Great Britain and its colonies had the Gregorian calendar take effect on 14 September 1752 (Gregorian); this includes the United States." - :group 'calc :version "24.4" :type '(choice (const :tag "Always use the Gregorian calendar" nil) (const :tag "1582-10-15 - Italy, Poland, Portugal, Spain" (1582 10 15 577736)) @@ -2214,7 +2172,7 @@ the United States." (setq calc-aborted-prefix name) (if (null arg) (calc-enter-result 2 name (cons (or func2 func) - (mapcar 'math-check-complete + (mapcar #'math-check-complete (calc-top-list 2)))) (require 'calc-ext) (calc-binary-op-fancy name func arg ident unary))) @@ -2333,21 +2291,14 @@ the United States." (calc-prev-char nil) (calc-prev-prev-char nil) (calc-buffer (current-buffer)) - (buf (if (featurep 'xemacs) - (catch 'calc-foo - (catch 'execute-kbd-macro - (throw 'calc-foo - (read-from-minibuffer - "Calc: " "" calc-digit-map))) - (error "XEmacs requires RET after %s" - "digit entry in kbd macro")) - (let ((old-esc (lookup-key global-map "\e"))) - (unwind-protect - (progn - (define-key global-map "\e" nil) - (read-from-minibuffer - "Calc: " (calc-digit-start-entry) calc-digit-map)) - (define-key global-map "\e" old-esc)))))) + (buf + (let ((old-esc (lookup-key global-map "\e"))) + (unwind-protect + (progn + (define-key global-map "\e" nil) + (read-from-minibuffer + "Calc: " (calc-digit-start-entry) calc-digit-map)) + (define-key global-map "\e" old-esc))))) (or calc-digit-value (setq calc-digit-value (math-read-number buf))) (if (stringp calc-digit-value) (calc-alg-entry calc-digit-value) @@ -2429,7 +2380,7 @@ the United States." (beep) (and (not (calc-minibuffer-contains "[-+]?\\(1[5-9]\\|[2-9][0-9]\\)#.*")) (search-forward "e" nil t)) - (if (looking-at "+") + (if (looking-at "\\+") (delete-char 1)) (if (looking-at "-") (delete-char 1) @@ -2505,51 +2456,18 @@ the United States." (setq last-command-event 13) (calcDigit-nondigit)))) - - - -(defconst math-bignum-digit-length - (truncate (/ (log (/ most-positive-fixnum 2) 10) 2)) - "The length of a \"digit\" in Calc bignums. -If a big integer is of the form (bigpos N0 N1 ...), this is the -length of the allowable Emacs integers N0, N1,... -The value of 2*10^(2*MATH-BIGNUM-DIGIT-LENGTH) must be less than the -largest Emacs integer.") - -(defconst math-bignum-digit-size - (expt 10 math-bignum-digit-length) - "An upper bound for the size of the \"digit\"s in Calc bignums.") - -(defconst math-small-integer-size - (expt math-bignum-digit-size 2) - "An upper bound for the size of \"small integer\"s in Calc.") - - ;;;; Arithmetic routines. ;; ;; An object as manipulated by one of these routines may take any of the ;; following forms: ;; -;; integer An integer. For normalized numbers, this format -;; is used only for -;; negative math-small-integer-size + 1 to -;; math-small-integer-size - 1 +;; integer An integer. ;; -;; (bigpos N0 N1 N2 ...) A big positive integer, -;; N0 + N1*math-bignum-digit-size -;; + N2*(math-bignum-digit-size)^2 ... -;; (bigneg N0 N1 N2 ...) A big negative integer, -;; - N0 - N1*math-bignum-digit-size ... -;; Each digit N is in the range -;; 0 ... math-bignum-digit-size -1. -;; Normalized, always at least three N present, -;; and the most significant N is nonzero. -;; -;; (frac NUM DEN) A fraction. NUM and DEN are small or big integers. +;; (frac NUM DEN) A fraction. NUM and DEN are integers. ;; Normalized, DEN > 1. ;; ;; (float NUM EXP) A floating-point number, NUM * 10^EXP; -;; NUM is a small or big integer, EXP is a small int. +;; NUM and EXP are integers. ;; Normalized, NUM is not a multiple of 10, and ;; abs(NUM) < 10^calc-internal-prec. ;; Normalized zero is stored as (float 0 0). @@ -2610,8 +2528,7 @@ largest Emacs integer.") ;; B Normalized big integer ;; S Normalized small integer ;; D Digit (small integer, 0..999) -;; L Normalized bignum digit list (without "bigpos" or "bigneg" symbol) -;; or normalized vector element list (without "vec") +;; L normalized vector element list (without "vec") ;; P Predicate (truth value) ;; X Any Lisp object ;; Z "nil" @@ -2626,78 +2543,41 @@ largest Emacs integer.") (defvar math-eval-rules-cache-other) ;;; Reduce an object to canonical (normalized) form. [O o; Z Z] [Public] -(defvar math-normalize-a) (defvar math-normalize-error nil "Non-nil if the last call the `math-normalize' returned an error.") -(defun math-normalize (math-normalize-a) +(defun math-normalize (a) (setq math-normalize-error nil) (cond - ((not (consp math-normalize-a)) - (if (integerp math-normalize-a) - (if (or (>= math-normalize-a math-small-integer-size) - (<= math-normalize-a (- math-small-integer-size))) - (math-bignum math-normalize-a) - math-normalize-a) - math-normalize-a)) - ((eq (car math-normalize-a) 'bigpos) - (if (eq (nth (1- (length math-normalize-a)) math-normalize-a) 0) - (let* ((last (setq math-normalize-a - (copy-sequence math-normalize-a))) (digs math-normalize-a)) - (while (setq digs (cdr digs)) - (or (eq (car digs) 0) (setq last digs))) - (setcdr last nil))) - (if (cdr (cdr (cdr math-normalize-a))) - math-normalize-a - (cond - ((cdr (cdr math-normalize-a)) (+ (nth 1 math-normalize-a) - (* (nth 2 math-normalize-a) - math-bignum-digit-size))) - ((cdr math-normalize-a) (nth 1 math-normalize-a)) - (t 0)))) - ((eq (car math-normalize-a) 'bigneg) - (if (eq (nth (1- (length math-normalize-a)) math-normalize-a) 0) - (let* ((last (setq math-normalize-a (copy-sequence math-normalize-a))) - (digs math-normalize-a)) - (while (setq digs (cdr digs)) - (or (eq (car digs) 0) (setq last digs))) - (setcdr last nil))) - (if (cdr (cdr (cdr math-normalize-a))) - math-normalize-a - (cond - ((cdr (cdr math-normalize-a)) (- (+ (nth 1 math-normalize-a) - (* (nth 2 math-normalize-a) - math-bignum-digit-size)))) - ((cdr math-normalize-a) (- (nth 1 math-normalize-a))) - (t 0)))) - ((eq (car math-normalize-a) 'float) - (math-make-float (math-normalize (nth 1 math-normalize-a)) - (nth 2 math-normalize-a))) - ((or (memq (car math-normalize-a) + ((not (consp a)) a) + ((eq (car a) 'float) + (math-make-float (math-normalize (nth 1 a)) + (nth 2 a))) + ((or (memq (car a) '(frac cplx polar hms date mod sdev intv vec var quote special-const calcFunc-if calcFunc-lambda calcFunc-quote calcFunc-condition calcFunc-evalto)) - (integerp (car math-normalize-a)) - (and (consp (car math-normalize-a)) - (not (eq (car (car math-normalize-a)) 'lambda)))) + (integerp (car a)) + (and (consp (car a)) + (not (eq (car (car a)) 'lambda)))) (require 'calc-ext) - (math-normalize-fancy math-normalize-a)) + (math-normalize-fancy a)) (t (or (and calc-simplify-mode (require 'calc-ext) - (math-normalize-nonstandard)) - (let ((args (mapcar 'math-normalize (cdr math-normalize-a)))) + (math-normalize-nonstandard a)) + (let ((args (mapcar #'math-normalize (cdr a)))) (or (condition-case err (let ((func - (assq (car math-normalize-a) '( ( + . math-add ) - ( - . math-sub ) - ( * . math-mul ) - ( / . math-div ) - ( % . math-mod ) - ( ^ . math-pow ) - ( neg . math-neg ) - ( | . math-concat ) )))) + (assq (car a) '( ( + . math-add ) + ( - . math-sub ) + ( * . math-mul ) + ( / . math-div ) + ( % . math-mod ) + ( ^ . math-pow ) + ( neg . math-neg ) + ( | . math-concat ) )))) (or (and var-EvalRules (progn (or (eq var-EvalRules math-eval-rules-cache-tag) @@ -2705,59 +2585,59 @@ largest Emacs integer.") (require 'calc-ext) (math-recompile-eval-rules))) (and (or math-eval-rules-cache-other - (assq (car math-normalize-a) + (assq (car a) math-eval-rules-cache)) (math-apply-rewrites - (cons (car math-normalize-a) args) + (cons (car a) args) (cdr math-eval-rules-cache) nil math-eval-rules-cache)))) (if func (apply (cdr func) args) - (and (or (consp (car math-normalize-a)) - (fboundp (car math-normalize-a)) + (and (or (consp (car a)) + (fboundp (car a)) (and (not (featurep 'calc-ext)) (require 'calc-ext) - (fboundp (car math-normalize-a)))) - (apply (car math-normalize-a) args))))) + (fboundp (car a)))) + (apply (car a) args))))) (wrong-number-of-arguments (setq math-normalize-error t) (calc-record-why "*Wrong number of arguments" - (cons (car math-normalize-a) args)) + (cons (car a) args)) nil) (wrong-type-argument (or calc-next-why (calc-record-why "Wrong type of argument" - (cons (car math-normalize-a) args))) + (cons (car a) args))) nil) (args-out-of-range (setq math-normalize-error t) (calc-record-why "*Argument out of range" - (cons (car math-normalize-a) args)) + (cons (car a) args)) nil) (inexact-result (calc-record-why "No exact representation for result" - (cons (car math-normalize-a) args)) + (cons (car a) args)) nil) (math-overflow (setq math-normalize-error t) (calc-record-why "*Floating-point overflow occurred" - (cons (car math-normalize-a) args)) + (cons (car a) args)) nil) (math-underflow (setq math-normalize-error t) (calc-record-why "*Floating-point underflow occurred" - (cons (car math-normalize-a) args)) + (cons (car a) args)) nil) (void-variable (setq math-normalize-error t) (if (eq (nth 1 err) 'var-EvalRules) (progn (setq var-EvalRules nil) - (math-normalize (cons (car math-normalize-a) args))) + (math-normalize (cons (car a) args))) (calc-record-why "*Variable is void" (nth 1 err))))) - (if (consp (car math-normalize-a)) + (if (consp (car a)) (math-dimension-error) - (cons (car math-normalize-a) args)))))))) + (cons (car a) args)))))))) @@ -2781,30 +2661,6 @@ largest Emacs integer.") ((consp a) a) (t (error "Invalid data object encountered")))) - - -;; Coerce integer A to be a bignum. [B S] -(defun math-bignum (a) - (cond - ((>= a 0) - (cons 'bigpos (math-bignum-big a))) - ((= a most-negative-fixnum) - ;; Note: cannot get the negation directly because - ;; (- most-negative-fixnum) is most-negative-fixnum. - ;; - ;; most-negative-fixnum := -most-positive-fixnum - 1 - (math-sub (cons 'bigneg (math-bignum-big most-positive-fixnum)) - 1)) - (t - (cons 'bigneg (math-bignum-big (- a)))))) - -(defun math-bignum-big (a) ; [L s] - (if (= a 0) - nil - (cons (% a math-bignum-digit-size) - (math-bignum-big (/ a math-bignum-digit-size))))) - - ;; Build a normalized floating-point number. [F I S] (defun math-make-float (mant exp) (if (eq mant 0) @@ -2813,20 +2669,9 @@ largest Emacs integer.") (if (< ldiff 0) (setq mant (math-scale-rounding mant ldiff) exp (- exp ldiff)))) - (if (consp mant) - (let ((digs (cdr mant))) - (if (= (% (car digs) 10) 0) - (progn - (while (= (car digs) 0) - (setq digs (cdr digs) - exp (+ exp math-bignum-digit-length))) - (while (= (% (car digs) 10) 0) - (setq digs (math-div10-bignum digs) - exp (1+ exp))) - (setq mant (math-normalize (cons (car mant) digs)))))) - (while (= (% mant 10) 0) - (setq mant (/ mant 10) - exp (1+ exp)))) + (while (= (% mant 10) 0) + (setq mant (/ mant 10) + exp (1+ exp))) (if (and (<= exp -4000000) (<= (+ exp (math-numdigs mant) -1) -4000000)) (signal 'math-underflow nil) @@ -2835,49 +2680,40 @@ largest Emacs integer.") (signal 'math-overflow nil) (list 'float mant exp))))) -(defun math-div10-bignum (a) ; [l l] - (if (cdr a) - (cons (+ (/ (car a) 10) (* (% (nth 1 a) 10) - (expt 10 (1- math-bignum-digit-length)))) - (math-div10-bignum (cdr a))) - (list (/ (car a) 10)))) - ;;; Coerce A to be a float. [F N; V V] [Public] (defun math-float (a) (cond ((Math-integerp a) (math-make-float a 0)) ((eq (car a) 'frac) (math-div (math-float (nth 1 a)) (nth 2 a))) ((eq (car a) 'float) a) ((memq (car a) '(cplx polar vec hms date sdev mod)) - (cons (car a) (mapcar 'math-float (cdr a)))) + (cons (car a) (mapcar #'math-float (cdr a)))) (t (math-float-fancy a)))) (defun math-neg (a) (cond ((not (consp a)) (- a)) - ((eq (car a) 'bigpos) (cons 'bigneg (cdr a))) - ((eq (car a) 'bigneg) (cons 'bigpos (cdr a))) ((memq (car a) '(frac float)) (list (car a) (Math-integer-neg (nth 1 a)) (nth 2 a))) ((memq (car a) '(cplx vec hms date calcFunc-idn)) - (cons (car a) (mapcar 'math-neg (cdr a)))) + (cons (car a) (mapcar #'math-neg (cdr a)))) (t (math-neg-fancy a)))) ;;; Compute the number of decimal digits in integer A. [S I] (defun math-numdigs (a) - (if (consp a) - (if (cdr a) - (let* ((len (1- (length a))) - (top (nth len a))) - (+ (* (1- len) math-bignum-digit-length) (math-numdigs top))) - 0) - (cond ((>= a 100) (+ (math-numdigs (/ a 1000)) 3)) - ((>= a 10) 2) - ((>= a 1) 1) - ((= a 0) 0) - ((> a -10) 1) - ((> a -100) 2) - (t (math-numdigs (- a)))))) + (cond + ((= a 0) 0) + ((progn (when (< a 0) (setq a (- a))) + (>= a 100)) + (let* ((bd (logb a)) + (d (truncate (/ bd (eval-when-compile (log 10 2)))))) + (let ((b (expt 10 d))) + (cond + ((> b a) d) + ((> (* 10 b) a) (1+ d)) + (t (+ d 2)))))) + ((>= a 10) 2) + (t 1))) ;;; Multiply (with truncation toward 0) the integer A by 10^N. [I i S] (defun math-scale-int (a n) @@ -2888,76 +2724,23 @@ largest Emacs integer.") (defun math-scale-left (a n) ; [I I S] (if (= n 0) a - (if (consp a) - (cons (car a) (math-scale-left-bignum (cdr a) n)) - (if (>= n math-bignum-digit-length) - (if (or (>= a math-bignum-digit-size) - (<= a (- math-bignum-digit-size))) - (math-scale-left (math-bignum a) n) - (math-scale-left (* a math-bignum-digit-size) - (- n math-bignum-digit-length))) - (let ((sz (expt 10 (- (* 2 math-bignum-digit-length) n)))) - (if (or (>= a sz) (<= a (- sz))) - (math-scale-left (math-bignum a) n) - (* a (expt 10 n)))))))) - -(defun math-scale-left-bignum (a n) - (if (>= n math-bignum-digit-length) - (while (>= (setq a (cons 0 a) - n (- n math-bignum-digit-length)) - math-bignum-digit-length))) - (if (> n 0) - (math-mul-bignum-digit a (expt 10 n) 0) - a)) + (* a (expt 10 n)))) (defun math-scale-right (a n) ; [i i S] (if (= n 0) a - (if (consp a) - (cons (car a) (math-scale-right-bignum (cdr a) n)) - (if (<= a 0) - (if (= a 0) - 0 - (- (math-scale-right (- a) n))) - (if (>= n math-bignum-digit-length) - (while (and (> (setq a (/ a math-bignum-digit-size)) 0) - (>= (setq n (- n math-bignum-digit-length)) - math-bignum-digit-length)))) - (if (> n 0) - (/ a (expt 10 n)) - a))))) - -(defun math-scale-right-bignum (a n) ; [L L S; l l S] - (if (>= n math-bignum-digit-length) - (setq a (nthcdr (/ n math-bignum-digit-length) a) - n (% n math-bignum-digit-length))) - (if (> n 0) - (cdr (math-mul-bignum-digit a (expt 10 (- math-bignum-digit-length n)) 0)) - a)) + (if (<= a 0) + (if (= a 0) + 0 + (- (math-scale-right (- a) n))) + (if (> n 0) + (/ a (expt 10 n)) + a)))) ;;; Multiply (with rounding) the integer A by 10^N. [I i S] (defun math-scale-rounding (a n) (cond ((>= n 0) (math-scale-left a n)) - ((consp a) - (math-normalize - (cons (car a) - (let ((val (if (< n (- math-bignum-digit-length)) - (math-scale-right-bignum - (cdr a) - (- (- math-bignum-digit-length) n)) - (if (< n 0) - (math-mul-bignum-digit - (cdr a) - (expt 10 (+ math-bignum-digit-length n)) 0) - (cdr a))))) ; n = -math-bignum-digit-length - (if (and val (>= (car val) (/ math-bignum-digit-size 2))) - (if (cdr val) - (if (eq (car (cdr val)) (1- math-bignum-digit-size)) - (math-add-bignum (cdr val) '(1)) - (cons (1+ (car (cdr val))) (cdr (cdr val)))) - '(1)) - (cdr val)))))) (t (if (< a 0) (- (math-scale-rounding (- a) n)) @@ -2970,36 +2753,13 @@ largest Emacs integer.") (defun math-add (a b) (or (and (not (or (consp a) (consp b))) - (progn - (setq a (+ a b)) - (if (or (<= a (- math-small-integer-size)) (>= a math-small-integer-size)) - (math-bignum a) - a))) + (+ a b)) (and (Math-zerop a) (not (eq (car-safe a) 'mod)) (if (and (math-floatp a) (Math-ratp b)) (math-float b) b)) (and (Math-zerop b) (not (eq (car-safe b) 'mod)) (if (and (math-floatp b) (Math-ratp a)) (math-float a) a)) (and (Math-objvecp a) (Math-objvecp b) (or - (and (Math-integerp a) (Math-integerp b) - (progn - (or (consp a) (setq a (math-bignum a))) - (or (consp b) (setq b (math-bignum b))) - (if (eq (car a) 'bigneg) - (if (eq (car b) 'bigneg) - (cons 'bigneg (math-add-bignum (cdr a) (cdr b))) - (math-normalize - (let ((diff (math-sub-bignum (cdr b) (cdr a)))) - (if (eq diff 'neg) - (cons 'bigneg (math-sub-bignum (cdr a) (cdr b))) - (cons 'bigpos diff))))) - (if (eq (car b) 'bigneg) - (math-normalize - (let ((diff (math-sub-bignum (cdr a) (cdr b)))) - (if (eq diff 'neg) - (cons 'bigneg (math-sub-bignum (cdr b) (cdr a))) - (cons 'bigpos diff)))) - (cons 'bigpos (math-add-bignum (cdr a) (cdr b))))))) (and (Math-ratp a) (Math-ratp b) (require 'calc-ext) (calc-add-fractions a b)) @@ -3015,79 +2775,6 @@ largest Emacs integer.") (and (require 'calc-ext) (math-add-symb-fancy a b)))) -(defun math-add-bignum (a b) ; [L L L; l l l] - (if a - (if b - (let* ((a (copy-sequence a)) (aa a) (carry nil) sum) - (while (and aa b) - (if carry - (if (< (setq sum (+ (car aa) (car b))) - (1- math-bignum-digit-size)) - (progn - (setcar aa (1+ sum)) - (setq carry nil)) - (setcar aa (- sum (1- math-bignum-digit-size)))) - (if (< (setq sum (+ (car aa) (car b))) math-bignum-digit-size) - (setcar aa sum) - (setcar aa (- sum math-bignum-digit-size)) - (setq carry t))) - (setq aa (cdr aa) - b (cdr b))) - (if carry - (if b - (nconc a (math-add-bignum b '(1))) - (while (eq (car aa) (1- math-bignum-digit-size)) - (setcar aa 0) - (setq aa (cdr aa))) - (if aa - (progn - (setcar aa (1+ (car aa))) - a) - (nconc a '(1)))) - (if b - (nconc a b) - a))) - a) - b)) - -(defun math-sub-bignum (a b) ; [l l l] - (if b - (if a - (let* ((a (copy-sequence a)) (aa a) (borrow nil) diff) - (while (and aa b) - (if borrow - (if (>= (setq diff (- (car aa) (car b))) 1) - (progn - (setcar aa (1- diff)) - (setq borrow nil)) - (setcar aa (+ diff (1- math-bignum-digit-size)))) - (if (>= (setq diff (- (car aa) (car b))) 0) - (setcar aa diff) - (setcar aa (+ diff math-bignum-digit-size)) - (setq borrow t))) - (setq aa (cdr aa) - b (cdr b))) - (if borrow - (progn - (while (eq (car aa) 0) - (setcar aa (1- math-bignum-digit-size)) - (setq aa (cdr aa))) - (if aa - (progn - (setcar aa (1- (car aa))) - a) - 'neg)) - (while (eq (car b) 0) - (setq b (cdr b))) - (if b - 'neg - a))) - (while (eq (car b) 0) - (setq b (cdr b))) - (and b - 'neg)) - a)) - (defun math-add-float (a b) ; [F F F] (let ((ediff (- (nth 2 a) (nth 2 b)))) (if (>= ediff 0) @@ -3110,9 +2797,7 @@ largest Emacs integer.") (if (or (consp a) (consp b)) (math-add a (math-neg b)) (setq a (- a b)) - (if (or (<= a (- math-small-integer-size)) (>= a math-small-integer-size)) - (math-bignum a) - a))) + a)) (defun math-sub-float (a b) ; [F F F] (let ((ediff (- (nth 2 a) (nth 2 b)))) @@ -3137,8 +2822,6 @@ largest Emacs integer.") (defun math-mul (a b) (or (and (not (consp a)) (not (consp b)) - (< a math-bignum-digit-size) (> a (- math-bignum-digit-size)) - (< b math-bignum-digit-size) (> b (- math-bignum-digit-size)) (* a b)) (and (Math-zerop a) (not (eq (car-safe b) 'mod)) (if (Math-scalarp b) @@ -3152,17 +2835,6 @@ largest Emacs integer.") (math-mul-zero b a))) (and (Math-objvecp a) (Math-objvecp b) (or - (and (Math-integerp a) (Math-integerp b) - (progn - (or (consp a) (setq a (math-bignum a))) - (or (consp b) (setq b (math-bignum b))) - (math-normalize - (cons (if (eq (car a) (car b)) 'bigpos 'bigneg) - (if (cdr (cdr a)) - (if (cdr (cdr b)) - (math-mul-bignum (cdr a) (cdr b)) - (math-mul-bignum-digit (cdr a) (nth 1 b) 0)) - (math-mul-bignum-digit (cdr b) (nth 1 a) 0)))))) (and (Math-ratp a) (Math-ratp b) (require 'calc-ext) (calc-mul-fractions a b)) @@ -3191,146 +2863,19 @@ largest Emacs integer.") '(var uinf var-uinf) a))) -;;; Multiply digit lists A and B. [L L L; l l l] -(defun math-mul-bignum (a b) - (and a b - (let* ((sum (if (<= (car b) 1) - (if (= (car b) 0) - (list 0) - (copy-sequence a)) - (math-mul-bignum-digit a (car b) 0))) - (sump sum) c d aa ss prod) - (while (setq b (cdr b)) - (setq ss (setq sump (or (cdr sump) (setcdr sump (list 0)))) - d (car b) - c 0 - aa a) - (while (progn - (setcar ss (% (setq prod (+ (+ (car ss) (* (car aa) d)) - c)) - math-bignum-digit-size)) - (setq aa (cdr aa))) - (setq c (/ prod math-bignum-digit-size) - ss (or (cdr ss) (setcdr ss (list 0))))) - (if (>= prod math-bignum-digit-size) - (if (cdr ss) - (setcar (cdr ss) (+ (/ prod math-bignum-digit-size) (car (cdr ss)))) - (setcdr ss (list (/ prod math-bignum-digit-size)))))) - sum))) - -;;; Multiply digit list A by digit D. [L L D D; l l D D] -(defun math-mul-bignum-digit (a d c) - (if a - (if (<= d 1) - (and (= d 1) a) - (let* ((a (copy-sequence a)) (aa a) prod) - (while (progn - (setcar aa - (% (setq prod (+ (* (car aa) d) c)) - math-bignum-digit-size)) - (cdr aa)) - (setq aa (cdr aa) - c (/ prod math-bignum-digit-size))) - (if (>= prod math-bignum-digit-size) - (setcdr aa (list (/ prod math-bignum-digit-size)))) - a)) - (and (> c 0) - (list c)))) - - ;;; Compute the integer (quotient . remainder) of A and B, which may be ;;; small or big integers. Type and consistency of truncation is undefined ;;; if A or B is negative. B must be nonzero. [I.I I I] [Public] (defun math-idivmod (a b) (if (eq b 0) (math-reject-arg a "*Division by zero")) - (if (or (consp a) (consp b)) - (if (and (natnump b) (< b math-bignum-digit-size)) - (let ((res (math-div-bignum-digit (cdr a) b))) - (cons - (math-normalize (cons (car a) (car res))) - (cdr res))) - (or (consp a) (setq a (math-bignum a))) - (or (consp b) (setq b (math-bignum b))) - (let ((res (math-div-bignum (cdr a) (cdr b)))) - (cons - (math-normalize (cons (if (eq (car a) (car b)) 'bigpos 'bigneg) - (car res))) - (math-normalize (cons (car a) (cdr res)))))) - (cons (/ a b) (% a b)))) + (cons (/ a b) (% a b))) (defun math-quotient (a b) ; [I I I] [Public] (if (and (not (consp a)) (not (consp b))) (if (= b 0) (math-reject-arg a "*Division by zero") - (/ a b)) - (if (and (natnump b) (< b math-bignum-digit-size)) - (if (= b 0) - (math-reject-arg a "*Division by zero") - (math-normalize (cons (car a) - (car (math-div-bignum-digit (cdr a) b))))) - (or (consp a) (setq a (math-bignum a))) - (or (consp b) (setq b (math-bignum b))) - (let* ((alen (1- (length a))) - (blen (1- (length b))) - (d (/ math-bignum-digit-size (1+ (nth (1- blen) (cdr b))))) - (res (math-div-bignum-big (math-mul-bignum-digit (cdr a) d 0) - (math-mul-bignum-digit (cdr b) d 0) - alen blen))) - (math-normalize (cons (if (eq (car a) (car b)) 'bigpos 'bigneg) - (car res))))))) - - -;;; Divide a bignum digit list by another. [l.l l L] -;;; The following division algorithm is borrowed from Knuth vol. II, sec. 4.3.1 -(defun math-div-bignum (a b) - (if (cdr b) - (let* ((alen (length a)) - (blen (length b)) - (d (/ math-bignum-digit-size (1+ (nth (1- blen) b)))) - (res (math-div-bignum-big (math-mul-bignum-digit a d 0) - (math-mul-bignum-digit b d 0) - alen blen))) - (if (= d 1) - res - (cons (car res) - (car (math-div-bignum-digit (cdr res) d))))) - (let ((res (math-div-bignum-digit a (car b)))) - (cons (car res) (list (cdr res)))))) - -;;; Divide a bignum digit list by a digit. [l.D l D] -(defun math-div-bignum-digit (a b) - (if a - (let* ((res (math-div-bignum-digit (cdr a) b)) - (num (+ (* (cdr res) math-bignum-digit-size) (car a)))) - (cons - (cons (/ num b) (car res)) - (% num b))) - '(nil . 0))) - -(defun math-div-bignum-big (a b alen blen) ; [l.l l L] - (if (< alen blen) - (cons nil a) - (let* ((res (math-div-bignum-big (cdr a) b (1- alen) blen)) - (num (cons (car a) (cdr res))) - (res2 (math-div-bignum-part num b blen))) - (cons - (cons (car res2) (car res)) - (cdr res2))))) - -(defun math-div-bignum-part (a b blen) ; a < b*math-bignum-digit-size [D.l l L] - (let* ((num (+ (* (or (nth blen a) 0) math-bignum-digit-size) - (or (nth (1- blen) a) 0))) - (den (nth (1- blen) b)) - (guess (min (/ num den) (1- math-bignum-digit-size)))) - (math-div-bignum-try a b (math-mul-bignum-digit b guess 0) guess))) - -(defun math-div-bignum-try (a b c guess) ; [D.l l l D] - (let ((rem (math-sub-bignum a c))) - (if (eq rem 'neg) - (math-div-bignum-try a b (math-sub-bignum c b) (1- guess)) - (cons guess rem)))) - + (/ a b)))) ;;; Compute the quotient of A and B. [O O N] [Public] (defun math-div (a b) @@ -3439,22 +2984,21 @@ largest Emacs integer.") (setcar (cdr entry) (calc-count-lines s)) s)) -;; The variables math-svo-c, math-svo-wid and math-svo-off are local +;; The variables math-svo-wid and math-svo-off are local ;; to math-stack-value-offset, but are used by math-stack-value-offset-fancy ;; in calccomp.el. -(defvar math-svo-c) (defvar math-svo-wid) (defvar math-svo-off) -(defun math-stack-value-offset (math-svo-c) +(defun math-stack-value-offset (c) (let* ((num (if calc-line-numbering 4 0)) (math-svo-wid (calc-window-width)) math-svo-off) (if calc-display-just (progn (require 'calc-ext) - (math-stack-value-offset-fancy)) + (math-stack-value-offset-fancy c)) (setq math-svo-off (or calc-display-origin 0)) (when (integerp calc-line-breaking) (setq math-svo-wid calc-line-breaking))) @@ -3555,11 +3099,11 @@ largest Emacs integer.") (math-format-binary a) (math-format-radix a)))) (math-format-radix a)))) - (math-format-number (math-bignum a)))) + (require 'calc-ext) + (declare-function math--format-integer-fancy "calc-ext" (a)) + (concat (if (< a 0) "-") (math--format-integer-fancy (abs a))))) ((stringp a) a) ((not (consp a)) (prin1-to-string a)) - ((eq (car a) 'bigpos) (math-format-bignum (cdr a))) - ((eq (car a) 'bigneg) (concat "-" (math-format-bignum (cdr a)))) ((and (eq (car a) 'float) (= calc-number-radix 10)) (if (Math-integer-negp (nth 1 a)) (concat "-" (math-format-number (math-neg a))) @@ -3574,9 +3118,7 @@ largest Emacs integer.") (> (+ exp (math-numdigs mant)) (- figs)))) (progn (setq mant (math-scale-rounding mant (+ exp figs)) - str (if (integerp mant) - (int-to-string mant) - (math-format-bignum-decimal (cdr mant)))) + str (int-to-string mant)) (if (<= (length str) figs) (setq str (concat (make-string (1+ (- figs (length str))) ?0) str))) @@ -3594,9 +3136,7 @@ largest Emacs integer.") (when (< adj 0) (setq mant (math-scale-rounding mant adj) exp (- exp adj))))) - (setq str (if (integerp mant) - (int-to-string mant) - (math-format-bignum-decimal (cdr mant)))) + (setq str (int-to-string mant)) (let* ((len (length str)) (dpos (+ exp len))) (if (and (eq fmt 'float) @@ -3640,31 +3180,6 @@ largest Emacs integer.") (require 'calc-ext) (math-format-number-fancy a prec)))) -(defun math-format-bignum (a) ; [X L] - (if (and (= calc-number-radix 10) - (not calc-leading-zeros) - (not calc-group-digits)) - (math-format-bignum-decimal a) - (require 'calc-ext) - (math-format-bignum-fancy a))) - -(defun math-format-bignum-decimal (a) ; [X L] - (if a - (let ((s "")) - (while (cdr (cdr a)) - (setq s (concat - (format - (concat "%0" - (number-to-string (* 2 math-bignum-digit-length)) - "d") - (+ (* (nth 1 a) math-bignum-digit-size) (car a))) s) - a (cdr (cdr a)))) - (concat (int-to-string - (+ (* (or (nth 1 a) 0) math-bignum-digit-size) (car a))) s)) - "0")) - - - ;;; Parse a simple number in string form. [N X] [Public] (defun math-read-number (s &optional decimal) "Convert the string S into a Calc number." @@ -3680,9 +3195,7 @@ largest Emacs integer.") (eq (aref digs 0) ?0) (null decimal)) (math-read-number (concat "8#" digs)) - (if (<= (length digs) (* 2 math-bignum-digit-length)) - (string-to-number digs) - (cons 'bigpos (math-read-bignum digs)))))) + (string-to-number digs)))) ;; Clean up the string if necessary ((string-match "\\`\\(.*\\)[ \t\n]+\\([^\001]*\\)\\'" s) @@ -3737,14 +3250,10 @@ and all digits are kept, regardless of Calc's current precision." ((string-match "^[0-9]+$" s) (if (string-match "^\\(0+\\)" s) (setq s (substring s (match-end 0)))) - (if (<= (length s) (* 2 math-bignum-digit-length)) - (string-to-number s) - (cons 'bigpos (math-read-bignum s)))) + (string-to-number s)) ;; Minus sign ((string-match "^-[0-9]+$" s) - (if (<= (length s) (1+ (* 2 math-bignum-digit-length))) - (string-to-number s) - (cons 'bigneg (math-read-bignum (substring s 1))))) + (string-to-number s)) ;; Decimal point ((string-match "^\\(-?[0-9]*\\)\\.\\([0-9]*\\)$" s) (let ((int (math-match-substring s 1)) @@ -3759,12 +3268,6 @@ and all digits are kept, regardless of Calc's current precision." (substring s (match-beginning n) (match-end n)) "")) -(defun math-read-bignum (s) ; [l X] - (if (> (length s) math-bignum-digit-length) - (cons (string-to-number (substring s (- math-bignum-digit-length))) - (math-read-bignum (substring s 0 (- math-bignum-digit-length)))) - (list (string-to-number s)))) - (defconst math-standard-opers '( ( "_" calcFunc-subscr 1200 1201 ) ( "%" calcFunc-percent 1100 -1 ) @@ -3887,33 +3390,20 @@ 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)) + (declare (doc-string 3)) ;; FIXME: Edebug spec? (require 'calc-ext) (math-do-defmath func args body)) -;;; Functions needed for Lucid Emacs support. - -(defun calc-read-key (&optional optkey) - (cond ((featurep 'xemacs) - (let ((event (next-command-event))) - (let ((key (event-to-character event t t))) - (or key optkey (error "Expected a plain keystroke")) - (cons key event)))) - (t - (let ((key (read-event))) - (cons key key))))) +(defun calc-read-key (&optional _optkey) + (declare (obsolete read-event "27.1")) + (let ((key (read-event))) + (cons key key))) (defun calc-unread-command (&optional input) - (if (featurep 'xemacs) - (setq unread-command-event - (if (integerp input) (character-to-event input) - (or input last-command-event))) - (push (or input last-command-event) unread-command-events))) + (push (or input last-command-event) unread-command-events)) (defun calc-clear-unread-commands () - (if (featurep 'xemacs) - (setq unread-command-event nil) - (setq unread-command-events nil))) + (setq unread-command-events nil)) (defcalcmodevar math-2-word-size (math-read-number-simple "4294967296") diff --git a/lisp/calc/calccomp.el b/lisp/calc/calccomp.el index d81cc04fe50..91eadfbb4e8 100644 --- a/lisp/calc/calccomp.el +++ b/lisp/calc/calccomp.el @@ -1,4 +1,4 @@ -;;; calccomp.el --- composition functions for Calc +;;; calccomp.el --- composition functions for Calc -*- lexical-binding:t -*- ;; Copyright (C) 1990-1993, 2001-2019 Free Software Foundation, Inc. @@ -121,7 +121,8 @@ calc-lang-slash-idiv) (math-float (nth 1 aa)) (nth 1 aa)) - (nth 2 aa)) prec)) + (nth 2 aa)) + prec)) (if (and (eq calc-language 'big) (= (length (car calc-frac-format)) 1)) (let* ((aa (math-adjust-fraction a)) @@ -202,8 +203,9 @@ (math-comp-comma-spc (or calc-vector-commas " ")) (math-comp-comma (or calc-vector-commas "")) (math-comp-vector-prec (if (or (and calc-vector-commas - (math-vector-no-parens a)) - (memq 'P calc-matrix-brackets)) 0 1000)) + (math-vector-no-parens a)) + (memq 'P calc-matrix-brackets)) + 0 1000)) (math-comp-just (cond ((eq calc-matrix-just 'right) 'vright) ((eq calc-matrix-just 'center) 'vcent) (t 'vleft))) @@ -803,8 +805,7 @@ ( % . calcFunc-mod ) ( ^ . calcFunc-pow ) ( neg . calcFunc-neg ) - ( | . calcFunc-vconcat )))) - left right args) + ( | . calcFunc-vconcat ))))) (if func2 (setq func (cdr func2))) (if (setq func2 (rassq func math-expr-function-mapping)) @@ -858,7 +859,7 @@ (or (cdr (cdr a)) (not (eq (car-safe (nth 1 a)) '*)))) -(defun math-compose-matrix (a col cols base) +(defun math-compose-matrix (a _col cols base) (let ((col 0) (res nil)) (while (<= (setq col (1+ col)) cols) @@ -968,8 +969,8 @@ (and (memq (car a) '(^ calcFunc-subscr)) (math-tex-expr-is-flat (nth 1 a))))) -(put 'calcFunc-log 'math-compose-big 'math-compose-log) -(defun math-compose-log (a prec) +(put 'calcFunc-log 'math-compose-big #'math-compose-log) +(defun math-compose-log (a _prec) (and (= (length a) 3) (list 'horiz (list 'subscr "log" @@ -979,8 +980,8 @@ (math-compose-expr (nth 1 a) 1000) ")"))) -(put 'calcFunc-log10 'math-compose-big 'math-compose-log10) -(defun math-compose-log10 (a prec) +(put 'calcFunc-log10 'math-compose-big #'math-compose-log10) +(defun math-compose-log10 (a _prec) (and (= (length a) 2) (list 'horiz (list 'subscr "log" "10") @@ -988,8 +989,8 @@ (math-compose-expr (nth 1 a) 1000) ")"))) -(put 'calcFunc-deriv 'math-compose-big 'math-compose-deriv) -(put 'calcFunc-tderiv 'math-compose-big 'math-compose-deriv) +(put 'calcFunc-deriv 'math-compose-big #'math-compose-deriv) +(put 'calcFunc-tderiv 'math-compose-big #'math-compose-deriv) (defun math-compose-deriv (a prec) (when (= (length a) 3) (math-compose-expr (list '/ @@ -1003,8 +1004,8 @@ (nth 2 a)))) prec))) -(put 'calcFunc-sqrt 'math-compose-big 'math-compose-sqrt) -(defun math-compose-sqrt (a prec) +(put 'calcFunc-sqrt 'math-compose-big #'math-compose-sqrt) +(defun math-compose-sqrt (a _prec) (when (= (length a) 2) (let* ((c (math-compose-expr (nth 1 a) 0)) (a (math-comp-ascent c)) @@ -1024,8 +1025,8 @@ " " c))))) -(put 'calcFunc-choose 'math-compose-big 'math-compose-choose) -(defun math-compose-choose (a prec) +(put 'calcFunc-choose 'math-compose-big #'math-compose-choose) +(defun math-compose-choose (a _prec) (let ((a1 (math-compose-expr (nth 1 a) 0)) (a2 (math-compose-expr (nth 2 a) 0))) (list 'horiz @@ -1035,7 +1036,7 @@ a1 " " a2) ")"))) -(put 'calcFunc-integ 'math-compose-big 'math-compose-integ) +(put 'calcFunc-integ 'math-compose-big #'math-compose-integ) (defun math-compose-integ (a prec) (and (memq (length a) '(3 5)) (eq (car-safe (nth 2 a)) 'var) @@ -1072,7 +1073,7 @@ (list 'horiz " d" var)) (if parens ")" ""))))) -(put 'calcFunc-sum 'math-compose-big 'math-compose-sum) +(put 'calcFunc-sum 'math-compose-big #'math-compose-sum) (defun math-compose-sum (a prec) (and (memq (length a) '(3 5 6)) (let* ((expr (math-compose-expr (nth 1 a) 185)) @@ -1097,7 +1098,7 @@ expr (if (memq prec '(180 201)) ")" ""))))) -(put 'calcFunc-prod 'math-compose-big 'math-compose-prod) +(put 'calcFunc-prod 'math-compose-big #'math-compose-prod) (defun math-compose-prod (a prec) (and (memq (length a) '(3 5 6)) (let* ((expr (math-compose-expr (nth 1 a) 198)) @@ -1124,12 +1125,11 @@ ;; The variables math-svo-c, math-svo-wid and math-svo-off are local ;; to math-stack-value-offset in calc.el, but are used by ;; math-stack-value-offset-fancy, which is called by math-stack-value-offset.. -(defvar math-svo-c) (defvar math-svo-wid) (defvar math-svo-off) -(defun math-stack-value-offset-fancy () - (let ((cwid (+ (math-comp-width math-svo-c)))) +(defun math-stack-value-offset-fancy (c) + (let ((cwid (+ (math-comp-width c)))) (cond ((eq calc-display-just 'right) (if calc-display-origin (setq math-svo-wid (max calc-display-origin 5)) @@ -1215,7 +1215,7 @@ ;; which are called by math-comp-to-string-flat. (defvar math-comp-pos) -(defun math-comp-to-string-flat (c math-comp-full-width) +(defun math-comp-to-string-flat (c full-width) (if math-comp-sel-hpos (let ((math-comp-pos 0)) (math-comp-sel-flat-term c)) @@ -1224,6 +1224,7 @@ (math-comp-pos 0) (math-comp-margin 0) (math-comp-highlight (and math-comp-selected calc-show-selections)) + (math-comp-full-width full-width) (math-comp-level -1)) (math-comp-to-string-flat-term '(set -1 0)) (math-comp-to-string-flat-term c) @@ -1387,7 +1388,7 @@ (defvar math-comp-hpos) (defvar math-comp-vpos) -(defun math-comp-simplify (c full-width) +(defun math-comp-simplify (c _full-width) (let ((math-comp-buf (list "")) (math-comp-base 0) (math-comp-hgt 1) diff --git a/lisp/calculator.el b/lisp/calculator.el index 39aa4ec1d28..281151c7c25 100644 --- a/lisp/calculator.el +++ b/lisp/calculator.el @@ -1054,7 +1054,7 @@ the `left' or `right' when one of the standard modes is used." ;; print with radix -- for binary, convert the octal number (let* ((fmt (if (eq calculator-output-radix 'hex) "%x" "%o")) (str (if calculator-2s-complement num (abs num))) - (str (format fmt (calculator-truncate str))) + (str (format fmt (truncate str))) (bins '((?0 "000") (?1 "001") (?2 "010") (?3 "011") (?4 "100") (?5 "101") (?6 "110") (?7 "111"))) (str (if (not (eq calculator-output-radix 'bin)) str @@ -1184,7 +1184,7 @@ arguments." (DX (if (and X calculator-deg) (degrees-to-radians X) X)) (L calculator-saved-list) (fF `(calculator-funcall ',f x y)) - (fD `(if calculator-deg (radians-to-degrees x) x))) + (fD '(if calculator-deg (radians-to-degrees x) x))) (eval `(cl-flet ((F (&optional x y) ,fF) (D (x) ,fD)) (let ((X ,X) (Y ,Y) (DX ,DX) (TX ,TX) (TY ,TY) (L ',L)) ,f)) @@ -1226,7 +1226,7 @@ OP is the operator (if any) that caused this call." (when (and (or calculator-display-fragile (not (numberp (car calculator-stack)))) (<= inp (pcase calculator-input-radix - (`nil ?9) (`bin ?1) (`oct ?7) (_ 999)))) + ('nil ?9) ('bin ?1) ('oct ?7) (_ 999)))) (calculator-clear-fragile) (setq calculator-curnum (concat (if (equal calculator-curnum "0") "" diff --git a/lisp/calendar/appt.el b/lisp/calendar/appt.el index da041f024f8..944054eee35 100644 --- a/lisp/calendar/appt.el +++ b/lisp/calendar/appt.el @@ -1,10 +1,10 @@ -;;; appt.el --- appointment notification functions +;;; appt.el --- appointment notification functions -*- lexical-binding:t -*- ;; Copyright (C) 1989-1990, 1994, 1998, 2001-2019 Free Software ;; Foundation, Inc. ;; Author: Neil Mager <neilm@juliet.ll.mit.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; Package: calendar @@ -90,8 +90,7 @@ The first subexpression matches the time in minutes (an integer). This overrides the default `appt-message-warning-time'. You may want to put this inside a diary comment (see `diary-comment-start'). For example, to be warned 30 minutes in advance of an appointment: - 2011/06/01 12:00 Do something ## warntime 30 -" + 2011/06/01 12:00 Do something ## warntime 30" :version "24.1" :type 'regexp :group 'appt) @@ -150,7 +149,7 @@ always updates every minute." :type 'integer :group 'appt) -(defcustom appt-disp-window-function 'appt-disp-window +(defcustom appt-disp-window-function #'appt-disp-window "Function called to display appointment window. Only relevant if reminders are being displayed in a window. It should take three string arguments: the number of minutes till @@ -160,7 +159,7 @@ relevant at any one time." :type 'function :group 'appt) -(defcustom appt-delete-window-function 'appt-delete-window +(defcustom appt-delete-window-function #'appt-delete-window "Function called to remove appointment window and buffer. Only relevant if reminders are being displayed in a window." :type 'function @@ -228,12 +227,11 @@ also calls `beep' for an audible reminder." string (car string))) (cond ((eq appt-display-format 'window) ;; TODO use calendar-month-abbrev-array rather than %b? - (let ((time (format-time-string "%a %b %e ")) - err) + (let ((time (format-time-string "%a %b %e "))) (condition-case err (funcall appt-disp-window-function (if (listp mins) - (mapcar 'number-to-string mins) + (mapcar #'number-to-string mins) (number-to-string mins)) time string) (wrong-type-argument @@ -250,7 +248,7 @@ update it for multiple appts?") appt-delete-window-function)) ((eq appt-display-format 'echo) (message "%s" (if (listp string) - (mapconcat 'identity string "\n") + (mapconcat #'identity string "\n") string))))) (defun appt-mode-line (min-to-app &optional abbrev) @@ -267,7 +265,7 @@ If ABBREV is non-nil, abbreviates some text." (if multiple "s" "") (if (equal imin "0") "now" (format "in %s %s" - (or imin (mapconcat 'identity min-to-app ",")) + (or imin (mapconcat #'identity min-to-app ",")) (if abbrev "min." (format "minute%s" (if (equal imin "1") "" "s")))))))) @@ -327,7 +325,7 @@ displayed in a window: (prev-appt-display-count appt-display-count) ;; Convert current time to minutes after midnight (12.01am = 1). (now (decode-time)) - (now-mins (+ (* 60 (nth 2 now)) (nth 1 now))) + (now-mins (+ (* 60 (decoded-time-hour now)) (decoded-time-minute now))) appt-mins appt-warn-time min-to-app min-list string-list) (save-excursion ; FIXME ? ;; At first check in any day, update appointments to today's list. @@ -335,9 +333,9 @@ displayed in a window: (null appt-prev-comp-time) ; first check (< now-mins appt-prev-comp-time)) ; new day (ignore-errors - (let ((diary-hook (if (assoc 'appt-make-list diary-hook) + (let ((diary-hook (if (memq #'appt-make-list diary-hook) diary-hook - (cons 'appt-make-list diary-hook)))) + (cons #'appt-make-list diary-hook)))) (if appt-display-diary (diary) ;; Not displaying the diary, so we can ignore @@ -405,8 +403,9 @@ displayed in a window: (when appt-display-mode-line (setq appt-mode-string (concat " " (propertize - (appt-mode-line (mapcar 'number-to-string - min-list) t) + (appt-mode-line (mapcar #'number-to-string + min-list) + t) 'face 'mode-line-emphasis)))) ;; Reset count to 0 in case we display another appt on the next cycle. (setq appt-display-count (if (eq '(0) min-list) 0 @@ -458,14 +457,14 @@ separate appointment." ;; FIXME Link to diary entry? (calendar-set-mode-line (format " %s. %s" (appt-mode-line min-to-app) - (mapconcat 'identity new-time ", "))) + (mapconcat #'identity new-time ", "))) (setq buffer-read-only nil buffer-undo-list t) (erase-buffer) ;; If we have appointments at different times, prepend the times. (if (or (= 1 (length min-to-app)) (not (delete (car min-to-app) min-to-app))) - (insert (mapconcat 'identity appt-msg "\n")) + (insert (mapconcat #'identity appt-msg "\n")) (dotimes (i (length appt-msg)) (insert (format "%s%sm: %s" (if (> i 0) "\n" "") (nth i min-to-app) (nth i appt-msg))))) @@ -547,19 +546,18 @@ sMinutes before the appointment to start warning: ") (message "")) -(defvar number) -(defvar original-date) (defvar diary-entries-list) (defun appt-make-list () "Update the appointments list from today's diary buffer. The time must be at the beginning of a line for it to be put in the appointments list (see examples in documentation of -the function `appt-check'). We assume that the variables DATE and -NUMBER hold the arguments that `diary-list-entries' received. +the function `appt-check'). We assume that the variables `original-date' and +`number' hold the arguments that `diary-list-entries' received. They specify the range of dates that the diary is being processed for. Any appointments made with `appt-add' are not affected by this function." + (with-no-warnings (defvar number) (defvar original-date)) ;; We have something to do if the range of dates that the diary is ;; considering includes the current date. (if (and (not (calendar-date-compare @@ -649,7 +647,8 @@ Any appointments made with `appt-add' are not affected by this function." ;; Convert current time to minutes after midnight (12:01am = 1), ;; and remove elements in the list that are in the past. (let* ((now (decode-time)) - (now-mins (+ (* 60 (nth 2 now)) (nth 1 now)))) + (now-mins (+ (* 60 (decoded-time-hour now)) + (decoded-time-minute now)))) (while (and appt-time-msg-list (< (caar (car appt-time-msg-list)) now-mins)) (setq appt-time-msg-list (cdr appt-time-msg-list))))))) @@ -701,7 +700,7 @@ ARG is positive, otherwise off." (let ((appt-active appt-timer)) (setq appt-active (if arg (> (prefix-numeric-value arg) 0) (not appt-active))) - (remove-hook 'write-file-functions 'appt-update-list) + (remove-hook 'write-file-functions #'appt-update-list) (or global-mode-string (setq global-mode-string '(""))) (delq 'appt-mode-string global-mode-string) (when appt-timer @@ -709,8 +708,8 @@ ARG is positive, otherwise off." (setq appt-timer nil)) (if appt-active (progn - (add-hook 'write-file-functions 'appt-update-list) - (setq appt-timer (run-at-time t 60 'appt-check) + (add-hook 'write-file-functions #'appt-update-list) + (setq appt-timer (run-at-time t 60 #'appt-check) global-mode-string (append global-mode-string '(appt-mode-string))) (appt-check t) diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el index ec491ec782f..5a8ee77b7f6 100644 --- a/lisp/calendar/cal-bahai.el +++ b/lisp/calendar/cal-bahai.el @@ -313,9 +313,13 @@ Prefix argument ARG will make the entry nonmarking." diary-bahai-entry-symbol 'calendar-bahai-from-absolute)) -(defvar date) +;; The function below is designed to be used in sexp diary entries, +;; and may be present in users' diary files, so suppress the warning +;; about this prefix-less dynamic variable. It's called from +;; `diary-list-sexp-entries', which binds the variable. +(with-suppressed-warnings ((lexical date)) + (defvar date)) -;; To be called from diary-list-sexp-entries, where DATE is bound. ;;;###diary-autoload (defun diary-bahai-date () "Bahá’í calendar equivalent of date diary entry." diff --git a/lisp/calendar/cal-china.el b/lisp/calendar/cal-china.el index f92947ed288..7fbdb8fc144 100644 --- a/lisp/calendar/cal-china.el +++ b/lisp/calendar/cal-china.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1995, 1997, 2001-2019 Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; Human-Keywords: Chinese calendar, calendar, holidays, diary ;; Package: calendar @@ -632,9 +632,13 @@ Echo Chinese date unless NOECHO is non-nil." (calendar-chinese-to-absolute date))) (or noecho (calendar-chinese-print-date))) -(defvar date) +;; The function below is designed to be used in sexp diary entries, +;; and may be present in users' diary files, so suppress the warning +;; about this prefix-less dynamic variable. It's called from +;; `diary-list-sexp-entries', which binds the variable. +(with-suppressed-warnings ((lexical date)) + (defvar date)) -;; To be called from diary-list-sexp-entries, where DATE is bound. ;;;###diary-autoload (defun diary-chinese-date () "Chinese calendar equivalent of date diary entry." @@ -650,7 +654,10 @@ Echo Chinese date unless NOECHO is non-nil." (autoload 'diary-make-date "diary-lib") (autoload 'diary-ordinal-suffix "diary-lib") (defvar diary-sexp-entry-symbol) -(defvar entry) ;used by `diary-chinese-anniversary' +;; `diary-chinese-anniversary' can be used in users' diary files, and +;; `entry' har to be dynamically bound when that is called. +(with-suppressed-warnings ((lexical entry)) + (defvar entry)) ;used by `diary-chinese-anniversary' (defvar calendar-chinese-month-name-array ["正月" "二月" "三月" "四月" "五月" "六月" diff --git a/lisp/calendar/cal-coptic.el b/lisp/calendar/cal-coptic.el index 6fa460625c9..8d223590875 100644 --- a/lisp/calendar/cal-coptic.el +++ b/lisp/calendar/cal-coptic.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1995, 1997, 2001-2019 Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; Human-Keywords: Coptic calendar, Ethiopic calendar, calendar, diary ;; Package: calendar @@ -168,9 +168,13 @@ Echo Coptic date unless NOECHO is t." (or noecho (calendar-coptic-print-date))) -(defvar date) +;; The function below is designed to be used in sexp diary entries, +;; and may be present in users' diary files, so suppress the warning +;; about this prefix-less dynamic variable. It's called from +;; `diary-list-sexp-entries', which binds the variable. +(with-suppressed-warnings ((lexical date)) + (defvar date)) -;; To be called from diary-list-sexp-entries, where DATE is bound. ;;;###diary-autoload (defun diary-coptic-date () "Coptic calendar equivalent of date diary entry." diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el index e78f19f803f..510cd6808e4 100644 --- a/lisp/calendar/cal-dst.el +++ b/lisp/calendar/cal-dst.el @@ -1,10 +1,10 @@ -;;; cal-dst.el --- calendar functions for daylight saving rules +;;; cal-dst.el --- calendar functions for daylight saving rules -*- lexical-binding:t -*- ;; Copyright (C) 1993-1996, 2001-2019 Free Software Foundation, Inc. -;; Author: Paul Eggert <eggert@twinsun.com> +;; Author: Paul Eggert <eggert@cs.ucla.edu> ;; Edward M. Reingold <reingold@cs.uiuc.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; Human-Keywords: daylight saving time, calendar, diary, holidays ;; Package: calendar @@ -97,62 +97,48 @@ If the locale never uses daylight saving time, set this to nil." ;;;###autoload (put 'calendar-current-time-zone-cache 'risky-local-variable t) -(defvar calendar-system-time-basis +(defconst calendar-system-time-basis (calendar-absolute-from-gregorian '(1 1 1970)) "Absolute date of starting date of system clock.") (defun calendar-absolute-from-time (x utc-diff) "Absolute local date of time X; local time is UTC-DIFF seconds from UTC. -X is (HIGH . LOW) or (HIGH LOW . IGNORED) where HIGH and LOW are the -high and low 16 bits, respectively, of the number of seconds since -1970-01-01 00:00:00 UTC, ignoring leap seconds. +X is the number of seconds since 1970-01-01 00:00:00 UTC, +ignoring leap seconds. Returns the pair (ABS-DATE . SECONDS) where SECONDS after local midnight on absolute date ABS-DATE is the equivalent moment to X." - (let* ((h (car x)) - (xtail (cdr x)) - (l (+ utc-diff (if (numberp xtail) xtail (car xtail)))) - (u (+ (* 512 (mod h 675)) (floor l 128)))) - ;; Overflow is a terrible thing! - (cons (+ calendar-system-time-basis - ;; floor((2^16 h +l) / (60*60*24)) - (* 512 (floor h 675)) (floor u 675)) - ;; (2^16 h +l) mod (60*60*24) - (+ (* (mod u 675) 128) (mod l 128))))) + (let ((secsperday 86400) + (local (+ x utc-diff))) + (cons (+ calendar-system-time-basis (floor local secsperday)) + (mod local secsperday)))) (defun calendar-time-from-absolute (abs-date s) "Time of absolute date ABS-DATE, S seconds after midnight. -Returns the list (HIGH LOW) where HIGH and LOW are the high and low -16 bits, respectively, of the number of seconds 1970-01-01 00:00:00 UTC, -ignoring leap seconds, that is the equivalent moment to S seconds after -midnight UTC on absolute date ABS-DATE." - (let* ((a (- abs-date calendar-system-time-basis)) - (u (+ (* 163 (mod a 512)) (floor s 128)))) - ;; Overflow is a terrible thing! - (list - ;; floor((60*60*24*a + s) / 2^16) - (+ a (* 163 (floor a 512)) (floor u 512)) - ;; (60*60*24*a + s) mod 2^16 - (+ (* 128 (mod u 512)) (mod s 128))))) +Return the number of seconds since 1970-01-01 00:00:00 UTC, +ignoring leap seconds, that is the equivalent moment to S seconds +after midnight UTC on absolute date ABS-DATE." + (let ((secsperday 86400)) + (+ s (* secsperday (- abs-date calendar-system-time-basis))))) (defun calendar-next-time-zone-transition (time) "Return the time of the next time zone transition after TIME. Both TIME and the result are acceptable arguments to `current-time-zone'. Return nil if no such transition can be found." - (let* ((base 65536) ; 2^16 = base of current-time output - (quarter-multiple 120) ; approx = (seconds per quarter year) / base + (let* ((time (encode-time time 'integer)) (time-zone (current-time-zone time)) (time-utc-diff (car time-zone)) hi hi-zone (hi-utc-diff time-utc-diff) + (quarter-seconds 7889238) ; Average seconds per 1/4 Gregorian year. (quarters '(2 1 3))) ;; Heuristic: probe the time zone offset in the next three calendar ;; quarters, looking for a time zone offset different from TIME. (while (and quarters (eq time-utc-diff hi-utc-diff)) - (setq hi (cons (+ (car time) (* (car quarters) quarter-multiple)) 0) + (setq hi (+ time (* (car quarters) quarter-seconds)) hi-zone (current-time-zone hi) hi-utc-diff (car hi-zone) quarters (cdr quarters))) @@ -163,23 +149,16 @@ Return nil if no such transition can be found." ;; Now HI is after the next time zone transition. ;; Set LO to TIME, and then binary search to increase LO and decrease HI ;; until LO is just before and HI is just after the time zone transition. - (let* ((tail (cdr time)) - (lo (cons (car time) (if (numberp tail) tail (car tail)))) + (let* ((lo time) probe) (while ;; Set PROBE to halfway between LO and HI, rounding down. ;; If PROBE equals LO, we are done. - (let* ((lsum (+ (cdr lo) (cdr hi))) - (hsum (+ (car lo) (car hi) (/ lsum base))) - (hsumodd (logand 1 hsum))) - (setq probe (cons (/ (- hsum hsumodd) 2) - (/ (+ (* hsumodd base) (% lsum base)) 2))) - (not (equal lo probe))) + (not (= lo (setq probe (floor (+ lo hi) 2)))) ;; Set either LO or HI to PROBE, depending on probe results. (if (eq (car (current-time-zone probe)) hi-utc-diff) (setq hi probe) (setq lo probe))) - (setcdr hi (list (cdr hi))) hi)))) (autoload 'calendar-persian-to-absolute "cal-persia") @@ -220,29 +199,30 @@ The result has the proper form for `calendar-daylight-savings-starts'." '((calendar-gregorian-from-absolute (calendar-persian-to-absolute `(7 1 ,(- year 621)))))))) (prevday-sec (- -1 utc-diff)) ; last sec of previous local day - (year (1+ y)) new-rules) - ;; Scan through the next few years until only one rule remains. - (while (cdr candidate-rules) - (dolist (rule candidate-rules) - ;; The rule we return should give a Gregorian date, but here - ;; we require an absolute date. The following is for efficiency. - (setq date (cond ((eq (car rule) 'calendar-nth-named-day) - (eval (cons 'calendar-nth-named-absday (cdr rule)))) - ((eq (car rule) 'calendar-gregorian-from-absolute) - (eval (cadr rule))) - (t (calendar-absolute-from-gregorian (eval rule))))) - (or (equal (current-time-zone - (calendar-time-from-absolute date prevday-sec)) - (current-time-zone - (calendar-time-from-absolute (1+ date) prevday-sec))) - (setq new-rules (cons rule new-rules)))) - ;; If no rules remain, just use the first candidate rule; - ;; it's wrong in general, but it's right for at least one year. - (setq candidate-rules (if new-rules (nreverse new-rules) - (list (car candidate-rules))) - new-rules nil - year (1+ year))) + (calendar-dlet* ((year (1+ y))) + ;; Scan through the next few years until only one rule remains. + (while (cdr candidate-rules) + (dolist (rule candidate-rules) + ;; The rule we return should give a Gregorian date, but here + ;; we require an absolute date. The following is for efficiency. + (setq date (cond ((eq (car rule) #'calendar-nth-named-day) + (eval (cons #'calendar-nth-named-absday + (cdr rule)))) + ((eq (car rule) #'calendar-gregorian-from-absolute) + (eval (cadr rule))) + (t (calendar-absolute-from-gregorian (eval rule))))) + (or (equal (current-time-zone + (calendar-time-from-absolute date prevday-sec)) + (current-time-zone + (calendar-time-from-absolute (1+ date) prevday-sec))) + (setq new-rules (cons rule new-rules)))) + ;; If no rules remain, just use the first candidate rule; + ;; it's wrong in general, but it's right for at least one year. + (setq candidate-rules (if new-rules (nreverse new-rules) + (list (car candidate-rules))) + new-rules nil + year (1+ year)))) (car candidate-rules))) ;; TODO it might be better to extract this information directly from @@ -251,7 +231,7 @@ The result has the proper form for `calendar-daylight-savings-starts'." ;; https://lists.gnu.org/r/emacs-pretest-bug/2006-11/msg00060.html (defun calendar-dst-find-data (&optional time) "Find data on the first daylight saving time transitions after TIME. -TIME defaults to `current-time'. Return value is as described +TIME defaults to the current time. Return value is as described for `calendar-current-time-zone'." (let* ((t0 (or time (current-time))) (t0-zone (current-time-zone t0)) @@ -279,14 +259,11 @@ for `calendar-current-time-zone'." (car t2-date-sec) t1-utc-diff)) (t1-time (/ (cdr t1-date-sec) 60)) (t2-time (/ (cdr t2-date-sec) 60))) - (cons - (/ (min t0-utc-diff t1-utc-diff) 60) - (cons - (/ (abs (- t0-utc-diff t1-utc-diff)) 60) - (if (< t0-utc-diff t1-utc-diff) - (list t0-name t1-name t1-rules t2-rules t1-time t2-time) - (list t1-name t0-name t2-rules t1-rules t2-time t1-time) - ))))))))) + (if (decoded-time-dst (decode-time t1)) + (list (/ t0-utc-diff 60) (/ (- t1-utc-diff t0-utc-diff) 60) + t0-name t1-name t1-rules t2-rules t1-time t2-time) + (list (/ t1-utc-diff 60) (/ (- t0-utc-diff t1-utc-diff) 60) + t1-name t0-name t2-rules t1-rules t2-time t1-time)))))))) (defvar calendar-dst-transition-cache nil "Internal cal-dst variable storing date of daylight saving time transitions. @@ -302,8 +279,8 @@ expressions that when evaluated return the start and end dates, respectively. This function first attempts to use pre-calculated data from `calendar-dst-transition-cache', otherwise it calls `calendar-dst-find-data' (and adds the results to the cache). -If dates in YEAR cannot be handled by `encode-time' (e.g. if they -are too large to be represented as a lisp integer), then rather +If dates in YEAR cannot be handled by `encode-time' (e.g., +if they are out of range for POSIX time_t), then rather than an error this function returns the result appropriate for the current year." (let ((e (assoc year calendar-dst-transition-cache)) @@ -314,7 +291,8 @@ the current year." (condition-case nil (encode-time 1 0 0 1 1 year) (error - (encode-time 1 0 0 1 1 (nth 5 (decode-time)))))) + (encode-time 1 0 0 1 1 + (decoded-time-year (decode-time)))))) f (nth 4 e) e (list year f (nth 5 e)) calendar-dst-transition-cache @@ -405,7 +383,8 @@ This function respects the value of `calendar-dst-check-each-year-flag'." (or (let ((expr (if calendar-dst-check-each-year-flag (cadr (calendar-dst-find-startend year)) (nth 4 calendar-current-time-zone-cache)))) - (if expr (eval expr))) + (calendar-dlet* ((year year)) + (if expr (eval expr)))) ;; New US rules commencing 2007. https://www.iana.org/time-zones (and (not (zerop calendar-daylight-time-offset)) (calendar-nth-named-day 2 0 3 year)))) @@ -416,7 +395,8 @@ This function respects the value of `calendar-dst-check-each-year-flag'." (or (let ((expr (if calendar-dst-check-each-year-flag (nth 2 (calendar-dst-find-startend year)) (nth 5 calendar-current-time-zone-cache)))) - (if expr (eval expr))) + (calendar-dlet* ((year year)) + (if expr (eval expr)))) ;; New US rules commencing 2007. https://www.iana.org/time-zones (and (not (zerop calendar-daylight-time-offset)) (calendar-nth-named-day 1 0 11 year)))) @@ -425,25 +405,25 @@ This function respects the value of `calendar-dst-check-each-year-flag'." (defun dst-in-effect (date) "True if on absolute DATE daylight saving time is in effect. Fractional part of DATE is local standard time of day." - (let* ((year (calendar-extract-year - (calendar-gregorian-from-absolute (floor date)))) - (dst-starts-gregorian (eval calendar-daylight-savings-starts)) - (dst-ends-gregorian (eval calendar-daylight-savings-ends)) - (dst-starts (and dst-starts-gregorian + (calendar-dlet* ((year (calendar-extract-year + (calendar-gregorian-from-absolute (floor date))))) + (let* ((dst-starts-gregorian (eval calendar-daylight-savings-starts)) + (dst-ends-gregorian (eval calendar-daylight-savings-ends)) + (dst-starts (and dst-starts-gregorian + (+ (calendar-absolute-from-gregorian + dst-starts-gregorian) + (/ calendar-daylight-savings-starts-time + 60.0 24.0)))) + (dst-ends (and dst-ends-gregorian (+ (calendar-absolute-from-gregorian - dst-starts-gregorian) - (/ calendar-daylight-savings-starts-time - 60.0 24.0)))) - (dst-ends (and dst-ends-gregorian - (+ (calendar-absolute-from-gregorian - dst-ends-gregorian) - (/ (- calendar-daylight-savings-ends-time - calendar-daylight-time-offset) - 60.0 24.0))))) - (and dst-starts dst-ends - (if (< dst-starts dst-ends) - (and (<= dst-starts date) (< date dst-ends)) - (or (<= dst-starts date) (< date dst-ends)))))) + dst-ends-gregorian) + (/ (- calendar-daylight-savings-ends-time + calendar-daylight-time-offset) + 60.0 24.0))))) + (and dst-starts dst-ends + (if (< dst-starts dst-ends) + (and (<= dst-starts date) (< date dst-ends)) + (or (<= dst-starts date) (< date dst-ends))))))) ;; used by calc, lunar, solar. (defun dst-adjust-time (date time) diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el index b9abab5ffa8..0d4b2f2e390 100644 --- a/lisp/calendar/cal-french.el +++ b/lisp/calendar/cal-french.el @@ -4,7 +4,7 @@ ;; Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; Human-Keywords: French Revolutionary calendar, calendar, diary ;; Package: calendar @@ -243,9 +243,13 @@ Echo French Revolutionary date unless NOECHO is non-nil." (calendar-french-to-absolute date))) (or noecho (calendar-french-print-date))) -(defvar date) +;; The function below is designed to be used in sexp diary entries, +;; and may be present in users' diary files, so suppress the warning +;; about this prefix-less dynamic variable. It's called from +;; `diary-list-sexp-entries', which binds the variable. +(with-suppressed-warnings ((lexical date)) + (defvar date)) -;; To be called from diary-list-sexp-entries, where DATE is bound. ;;;###diary-autoload (defun diary-french-date () "French calendar equivalent of date diary entry." diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el index b26dbbebdae..a64af631115 100644 --- a/lisp/calendar/cal-hebrew.el +++ b/lisp/calendar/cal-hebrew.el @@ -4,7 +4,7 @@ ;; Author: Nachum Dershowitz <nachum@cs.uiuc.edu> ;; Edward M. Reingold <reingold@cs.uiuc.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; Human-Keywords: Hebrew calendar, calendar, diary ;; Package: calendar @@ -748,15 +748,22 @@ from the cursor position." ;; or the corresponding day in years without that date. (+ (calendar-hebrew-to-absolute (list b-month 1 year)) b-day -1)))) -(defvar date) +;; The function below is designed to be used in sexp diary entries, +;; and may be present in users' diary files, so suppress the warning +;; about this prefix-less dynamic variable. It's called from +;; `diary-list-sexp-entries', which binds the variable. +(with-suppressed-warnings ((lexical date)) + (defvar date)) -;; To be called from diary-list-sexp-entries, where DATE is bound. ;;;###diary-autoload (defun diary-hebrew-date () "Hebrew calendar equivalent of date diary entry." (format "Hebrew date (until sunset): %s" (calendar-hebrew-date-string date))) -(defvar entry) +;; `diary-hebrew-birthday' can be used in users' diary files, and +;; `entry' has to be dynamically bound when that is used. +(with-suppressed-warnings ((lexical entry)) + (defvar entry)) (declare-function diary-ordinal-suffix "diary-lib" (n)) ;;;###diary-autoload diff --git a/lisp/calendar/cal-islam.el b/lisp/calendar/cal-islam.el index 32e15f538d2..81ac4d0332b 100644 --- a/lisp/calendar/cal-islam.el +++ b/lisp/calendar/cal-islam.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1995, 1997, 2001-2019 Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; Human-Keywords: Islamic calendar, calendar, diary ;; Package: calendar @@ -305,9 +305,13 @@ Prefix argument ARG makes the entry nonmarking." diary-islamic-entry-symbol 'calendar-islamic-from-absolute)) -(defvar date) +;; The function below is designed to be used in sexp diary entries, +;; and may be present in users' diary files, so suppress the warning +;; about this prefix-less dynamic variable. It's called from +;; `diary-list-sexp-entries', which binds the variable. +(with-suppressed-warnings ((lexical date)) + (defvar date)) -;; To be called from diary-sexp-entry, where DATE, ENTRY are bound. ;;;###diary-autoload (defun diary-islamic-date () "Islamic calendar equivalent of date diary entry." diff --git a/lisp/calendar/cal-iso.el b/lisp/calendar/cal-iso.el index 8568afeb054..884c15db6c7 100644 --- a/lisp/calendar/cal-iso.el +++ b/lisp/calendar/cal-iso.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1995, 1997, 2001-2019 Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; Human-Keywords: ISO calendar, calendar, diary ;; Package: calendar @@ -129,9 +129,12 @@ Interactively, goes to the first day of the specified week." (calendar-iso-to-absolute date))) (or noecho (calendar-iso-print-date))) -(defvar date) +;; The function below is designed to be used from sexp diary entries, +;; and may be present in users' diary files, so suppress the warning +;; about this prefix-less dynamic variable. +(with-suppressed-warnings ((lexical date)) + (defvar date)) -;; To be called from diary-list-sexp-entries, where DATE is bound. ;;;###diary-autoload (defun diary-iso-date () "ISO calendar equivalent of date diary entry." diff --git a/lisp/calendar/cal-julian.el b/lisp/calendar/cal-julian.el index 1297a96bf9e..d912f8323c8 100644 --- a/lisp/calendar/cal-julian.el +++ b/lisp/calendar/cal-julian.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1995, 1997, 2001-2019 Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; Human-Keywords: Julian calendar, Julian day number, calendar, diary ;; Package: calendar @@ -183,9 +183,13 @@ Echo astronomical (Julian) day number unless NOECHO is non-nil." (or noecho (calendar-astro-print-day-number))) -(defvar date) +;; The function below is designed to be used in sexp diary entries, +;; and may be present in users' diary files, so suppress the warning +;; about this prefix-less dynamic variable. It's called from +;; `diary-list-sexp-entries', which binds the variable. +(with-suppressed-warnings ((lexical date)) + (defvar date)) -;; To be called from diary-list-sexp-entries, where DATE is bound. ;;;###diary-autoload (defun diary-julian-date () "Julian calendar equivalent of date diary entry." diff --git a/lisp/calendar/cal-mayan.el b/lisp/calendar/cal-mayan.el index 37fe4b9a2e6..cda2c888f22 100644 --- a/lisp/calendar/cal-mayan.el +++ b/lisp/calendar/cal-mayan.el @@ -5,7 +5,7 @@ ;; Author: Stewart M. Clamen <clamen@cs.cmu.edu> ;; Edward M. Reingold <reingold@cs.uiuc.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; Human-Keywords: Mayan calendar, Maya, calendar, diary ;; Package: calendar @@ -353,9 +353,13 @@ Echo Mayan date unless NOECHO is non-nil." (calendar-mayan-long-count-to-absolute date))) (or noecho (calendar-mayan-print-date))) -(defvar date) +;; The function below is designed to be used in sexp diary entries, +;; and may be present in users' diary files, so suppress the warning +;; about this prefix-less dynamic variable. It's called from +;; `diary-list-sexp-entries', which binds the variable. +(with-suppressed-warnings ((lexical date)) + (defvar date)) -;; To be called from diary-list-sexp-entries, where DATE is bound. ;;;###diary-autoload (defun diary-mayan-date () "Show the Mayan long count, haab, and tzolkin dates as a diary entry." diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el index cf7d04fbb47..67181f8645e 100644 --- a/lisp/calendar/cal-menu.el +++ b/lisp/calendar/cal-menu.el @@ -4,7 +4,7 @@ ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> ;; Lara Rios <lrios@coewl.cen.uiuc.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; Human-Keywords: calendar, popup menus, menu bar ;; Package: calendar diff --git a/lisp/calendar/cal-move.el b/lisp/calendar/cal-move.el index ecd05e7e494..41407f28e53 100644 --- a/lisp/calendar/cal-move.el +++ b/lisp/calendar/cal-move.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1995, 2001-2019 Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; Human-Keywords: calendar ;; Package: calendar diff --git a/lisp/calendar/cal-persia.el b/lisp/calendar/cal-persia.el index c0b6cb23cf5..59fe52a592a 100644 --- a/lisp/calendar/cal-persia.el +++ b/lisp/calendar/cal-persia.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1996-1997, 2001-2019 Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; Human-Keywords: Persian calendar, calendar, diary ;; Package: calendar @@ -100,13 +100,7 @@ Gregorian date Sunday, December 31, 1 BC." (d2 ; prior days not in n2820 or n768 (mod d1 280506)) (n1 ; years not in n2820 or n768 - ;; Want: - ;; (floor (+ (* 2820 d2) (* 2820 366)) 1029983)) - ;; but that causes overflow, so use the following. - ;; Use 366 as the divisor because (2820*366 mod 1029983) is small. - (let ((a (floor d2 366)) - (b (mod d2 366))) - (+ 1 a (floor (+ (* 2137 a) (* 2820 b) 2137) 1029983)))) + (floor (* 2820 (+ d2 366)) 1029983)) (year (+ (* 2820 n2820) ; complete 2820 year cycles (* 768 n768) ; complete 768 year cycles ;; Remaining years. @@ -196,9 +190,13 @@ Echo Persian date unless NOECHO is non-nil." (or noecho (calendar-persian-print-date))) -(defvar date) +;; The function below is designed to be used in sexp diary entries, +;; and may be present in users' diary files, so suppress the warning +;; about this prefix-less dynamic variable. It's called from +;; `diary-list-sexp-entries', which binds the variable. +(with-suppressed-warnings ((lexical date)) + (defvar date)) -;; To be called from diary-list-sexp-entries, where DATE is bound. ;;;###diary-autoload (defun diary-persian-date () "Persian calendar equivalent of date diary entry." diff --git a/lisp/calendar/cal-tex.el b/lisp/calendar/cal-tex.el index 30429b6d592..f46c07407d6 100644 --- a/lisp/calendar/cal-tex.el +++ b/lisp/calendar/cal-tex.el @@ -4,7 +4,7 @@ ;; Author: Steve Fisk <fisk@bowdoin.edu> ;; Edward M. Reingold <reingold@cs.uiuc.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; Human-Keywords: Calendar, LaTeX ;; Package: calendar @@ -246,8 +246,6 @@ This definition is the heart of the calendar!") (autoload 'holiday-in-range "holidays") -(define-obsolete-function-alias 'cal-tex-list-holidays 'holiday-in-range "24.3") - (autoload 'diary-list-entries "diary-lib") (defun cal-tex-list-diary-entries (d1 d2) diff --git a/lisp/calendar/cal-x.el b/lisp/calendar/cal-x.el index 58d1eeb60ed..adef1fad050 100644 --- a/lisp/calendar/cal-x.el +++ b/lisp/calendar/cal-x.el @@ -2,9 +2,9 @@ ;; Copyright (C) 1994-1995, 2001-2019 Free Software Foundation, Inc. -;; Author: Michael Kifer <kifer@cs.sunysb.edu> +;; Author: Michael Kifer <kifer@cs.stonybrook.edu> ;; Edward M. Reingold <reingold@cs.uiuc.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; Human-Keywords: calendar, dedicated frames ;; Package: calendar diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index a15f15cf307..14604a673d0 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -1,10 +1,10 @@ -;;; calendar.el --- calendar functions +;;; calendar.el --- calendar functions -*- lexical-binding:t -*- ;; Copyright (C) 1988-1995, 1997, 2000-2019 Free Software Foundation, ;; Inc. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; Human-Keywords: calendar, Gregorian calendar, diary, holidays @@ -114,6 +114,37 @@ (load "cal-loaddefs" nil t) +;; Calendar has historically relied heavily on dynamic scoping. +;; Concretely, this manifests in the use of references to let-bound variables +;; in Custom vars as well as code in diary files. +;; `eval` is hence the core of the culprit. It's used on: +;; - calendar-date-display-form +;; - calendar-time-display-form +;; - calendar-chinese-time-zone +;; - in cal-dst's there are various calls to `eval' but they seem not to refer +;; to let-bound variables, surprisingly. +;; - calendar-date-echo-text +;; - calendar-mode-line-format +;; - cal-tex-daily-string +;; - diary-date-forms +;; - diary-remind-message +;; - calendar-holidays +;; - calendar-location-name +;; - whatever is passed to calendar-string-spread +;; - whatever is passed to calendar-insert-at-column +;; - whatever is passed to diary-sexp-entry +;; - whatever is passed to diary-remind + +(defmacro calendar-dlet* (binders &rest body) + "Like `let*' but using dynamic scoping." + (declare (indent 1) (debug let)) + `(progn + (with-no-warnings ;Silence "lacks a prefix" warnings! + ,@(mapcar (lambda (binder) + `(defvar ,(if (consp binder) (car binder) binder))) + binders)) + (let* ,binders ,@body))) + ;; Avoid recursive load of calendar when loading cal-menu. Yuck. (provide 'calendar) (require 'cal-menu) @@ -181,8 +212,7 @@ update the calendar display to reflect the change, otherwise movement commands will not work correctly." :type 'integer ;; Change the initialize so that if you reload calendar.el, it will not - ;; cause a redraw (which may fail, e.g. with "invalid byte-code in - ;; calendar.elc" because of the "byte-compile-dynamic"). + ;; cause a redraw. :initialize 'custom-initialize-default :set (lambda (sym val) (set sym val) @@ -371,7 +401,7 @@ redisplays the diary for whatever date the cursor is moved to." (defcustom calendar-date-echo-text "mouse-2: general menu\nmouse-3: menu for this date" "String displayed when the cursor is over a date in the calendar. -Can be either a fixed string, or a lisp expression that returns one. +Can be either a fixed string, or a Lisp expression that returns one. When this expression is evaluated, DAY, MONTH, and YEAR are integers appropriate to the relevant date. For example, to display the ISO date: @@ -465,8 +495,8 @@ Then redraw the calendar, if necessary." (defcustom calendar-left-margin 5 "Empty space to the left of the first month in the calendar." :group 'calendar - :initialize 'custom-initialize-default - :set 'calendar-set-layout-variable + :initialize #'custom-initialize-default + :set #'calendar-set-layout-variable :type 'integer :version "23.1") @@ -476,7 +506,7 @@ Then redraw the calendar, if necessary." (defcustom calendar-intermonth-spacing 4 "Space between months in the calendar. Minimum value is 1." :group 'calendar - :initialize 'custom-initialize-default + :initialize #'custom-initialize-default :set (lambda (sym val) (calendar-set-layout-variable sym val 1)) :type 'integer @@ -485,7 +515,7 @@ Then redraw the calendar, if necessary." ;; FIXME calendar-month-column-width? (defcustom calendar-column-width 3 "Width of each day column in the calendar. Minimum value is 3." - :initialize 'custom-initialize-default + :initialize #'custom-initialize-default :set (lambda (sym val) (calendar-set-layout-variable sym val 3)) :type 'integer @@ -505,7 +535,7 @@ WIDTH defaults to `calendar-day-header-width'." "Width of the day column headers in the calendar. Must be at least one less than `calendar-column-width'." :group 'calendar - :initialize 'custom-initialize-default + :initialize #'custom-initialize-default :set (lambda (sym val) (or (calendar-customized-p 'calendar-day-header-array) (setq calendar-day-header-array @@ -518,7 +548,7 @@ Must be at least one less than `calendar-column-width'." (defcustom calendar-day-digit-width 2 "Width of the day digits in the calendar. Minimum value is 2." :group 'calendar - :initialize 'custom-initialize-default + :initialize #'custom-initialize-default :set (lambda (sym val) (calendar-set-layout-variable sym val 2)) :type 'integer @@ -542,8 +572,8 @@ See `calendar-intermonth-text'." (defcustom calendar-intermonth-text nil "Text to display in the space to the left of each calendar month. -Can be nil, a fixed string, or a lisp expression that returns a string. -When the expression is evaluated, the variables DAY, MONTH and YEAR +Can be nil, a fixed string, or a Lisp expression that returns a string. +When the expression is evaluated, the variables `day', `month' and `year' are integers appropriate for the first day in each week. Will be truncated to the smaller of `calendar-left-margin' and `calendar-intermonth-spacing'. The last character is forced to be a space. @@ -714,7 +744,7 @@ calendar package is already loaded). Rather, use either (const european :tag "Day/Month/Year") (const iso :tag "Year/Month/Day")) :initialize 'custom-initialize-default - :set (lambda (symbol value) + :set (lambda (_symbol value) (calendar-set-date-style value)) :group 'calendar) @@ -939,7 +969,7 @@ Normally you should not customize this, but `calendar-month-header'." calendar-european-month-header) (t calendar-american-month-header)) "Expression to evaluate to return the calendar month headings. -When this expression is evaluated, the variables MONTH and YEAR are +When this expression is evaluated, the variables `month' and `year' are integers appropriate to the relevant month. The result is padded to the width of `calendar-month-digit-width'. @@ -1104,7 +1134,7 @@ MON defaults to `displayed-month'. YR defaults to `displayed-year'." (defmacro calendar-in-read-only-buffer (buffer &rest body) "Switch to BUFFER and execute the forms in BODY. First creates or erases BUFFER as needed. Leaves BUFFER read-only, -with disabled undo. Leaves point at point-min, displays BUFFER." +with disabled undo. Leaves point at `point-min', displays BUFFER." (declare (indent 1) (debug t)) `(progn (set-buffer (get-buffer-create ,buffer)) @@ -1356,7 +1386,7 @@ Optional integers MON and YR are used instead of today's date." (let* ((inhibit-read-only t) (today (calendar-current-date)) (month (calendar-extract-month today)) - (day (calendar-extract-day today)) + ;; (day (calendar-extract-day today)) (year (calendar-extract-year today)) (today-visible (or (not mon) (<= (abs (calendar-interval mon yr month year)) 1))) @@ -1458,8 +1488,9 @@ line." (goto-char (point-min)) (calendar-move-to-column indent) (insert - (calendar-string-spread (list calendar-month-header) - ?\s calendar-month-digit-width)) + (calendar-dlet* ((month month) (year year)) + (calendar-string-spread (list calendar-month-header) + ?\s calendar-month-digit-width))) (calendar-ensure-newline) (calendar-insert-at-column indent calendar-intermonth-header trunc) ;; Use the first N characters of each day to head the columns. @@ -1474,7 +1505,8 @@ line." calendar-day-header-width nil ?\s) (make-string (- calendar-column-width calendar-day-header-width) ?\s))) (calendar-ensure-newline) - (calendar-insert-at-column indent calendar-intermonth-text trunc) + (calendar-dlet* ((day day) (month month) (year year)) + (calendar-insert-at-column indent calendar-intermonth-text trunc)) ;; Add blank days before the first of the month. (insert (make-string (* blank-days calendar-column-width) ?\s)) ;; Put in the days of the month. @@ -1484,7 +1516,8 @@ line." (insert (propertize (format (format "%%%dd" calendar-day-digit-width) day) 'mouse-face 'highlight - 'help-echo (eval calendar-date-echo-text) + 'help-echo (calendar-dlet* ((day day) (month month) (year year)) + (eval calendar-date-echo-text)) ;; 'date property prevents intermonth text confusing re-searches. ;; (Tried intangible, it did not really work.) 'date t) @@ -1494,7 +1527,8 @@ line." (/= day last)) (calendar-ensure-newline) (setq day (1+ day)) ; first day of next week - (calendar-insert-at-column indent calendar-intermonth-text trunc))))) + (calendar-dlet* ((day day) (month month) (year year)) + (calendar-insert-at-column indent calendar-intermonth-text trunc)))))) (defun calendar-redraw () "Redraw the calendar display, if `calendar-buffer' is live." @@ -1754,25 +1788,22 @@ For a complete description, see the info node `Calendar/Diary'. ;; so let's make sure they're always set. Most likely, this will be reset ;; soon in calendar-generate, but better safe than sorry. (unless (boundp 'displayed-month) (setq displayed-month 1)) - (unless (boundp 'displayed-year) (setq displayed-year 2001)) - (if (bound-and-true-p calendar-font-lock-keywords) - (set (make-local-variable 'font-lock-defaults) - '(calendar-font-lock-keywords t)))) + (unless (boundp 'displayed-year) (setq displayed-year 2001))) (defun calendar-string-spread (strings char length) "Concatenate list of STRINGS separated with copies of CHAR to fill LENGTH. -The effect is like mapconcat but the separating pieces are as balanced as +The effect is like `mapconcat' but the separating pieces are as balanced as possible. Each item of STRINGS is evaluated before concatenation so it can actually be an expression that evaluates to a string. If LENGTH is too short, the STRINGS are just concatenated and the result truncated." -;; The algorithm is based on equation (3.25) on page 85 of Concrete -;; Mathematics by Ronald L. Graham, Donald E. Knuth, and Oren Patashnik, -;; Addison-Wesley, Reading, MA, 1989. - (let* ((strings (mapcar 'eval + ;; The algorithm is based on equation (3.25) on page 85 of Concrete + ;; Mathematics by Ronald L. Graham, Donald E. Knuth, and Oren Patashnik, + ;; Addison-Wesley, Reading, MA, 1989. + (let* ((strings (mapcar #'eval (if (< (length strings) 2) (append (list "") strings (list "")) strings))) - (n (- length (string-width (apply 'concat strings)))) + (n (- length (string-width (apply #'concat strings)))) (m (* (1- (length strings)) (char-width char))) (s (car strings)) (strings (cdr strings)) @@ -1789,17 +1820,18 @@ the STRINGS are just concatenated and the result truncated." (if (and calendar-mode-line-format (bufferp (get-buffer calendar-buffer))) (with-current-buffer calendar-buffer - (let ((start (- calendar-left-margin 2)) - (date (condition-case nil - (calendar-cursor-to-nearest-date) - (error (calendar-current-date))))) - (setq mode-line-format - (concat (make-string (max 0 (+ start - (- (car (window-inside-edges)) - (car (window-edges))))) ?\s) - (calendar-string-spread - (mapcar 'eval calendar-mode-line-format) - ?\s (- calendar-right-margin (1- start)))))) + (let ((start (- calendar-left-margin 2))) + (calendar-dlet* ((date (condition-case nil + (calendar-cursor-to-nearest-date) + (error (calendar-current-date))))) + (setq mode-line-format + (concat (make-string (max 0 (+ start + (- (car (window-inside-edges)) + (car (window-edges))))) + ?\s) + (calendar-string-spread + calendar-mode-line-format + ?\s (- calendar-right-margin (1- start))))))) (force-mode-line-update)))) (defun calendar-buffer-list () @@ -1839,7 +1871,9 @@ the STRINGS are just concatenated and the result truncated." "Return the current date in a list (month day year). Optional integer OFFSET is a number of days from the current date." (let* ((now (decode-time)) - (now (list (nth 4 now) (nth 3 now) (nth 5 now)))) + (now (list (decoded-time-month now) + (decoded-time-day now) + (decoded-time-year now)))) (if (zerop (or offset 0)) now (calendar-gregorian-from-absolute @@ -2033,11 +2067,11 @@ is a string to insert in the minibuffer before reading." Each abbreviation is no longer than MAXLEN (default `calendar-abbrev-length') characters." (or maxlen (setq maxlen calendar-abbrev-length)) - (apply 'vector (mapcar - (lambda (f) - ;; TODO? truncate-string-to-width? - (substring f 0 (min maxlen (length f)))) - full))) + (apply #'vector (mapcar + (lambda (f) + ;; TODO? truncate-string-to-width? + (substring f 0 (min maxlen (length f)))) + full))) (defcustom calendar-day-name-array ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"] @@ -2255,7 +2289,7 @@ If optional NODAY is t, does not ask for day, but just returns (month (cdr (assoc-string (completing-read "Month name: " - (mapcar 'list (append month-array nil)) + (mapcar #'list (append month-array nil)) nil t) (calendar-make-alist month-array 1) t))) (last (calendar-last-day-of-month month year))) @@ -2277,13 +2311,6 @@ Negative years are interpreted as years BC; -1 being 1 BC, and so on." (+ (* 12 (- yr2 yr1)) (- mon2 mon1))) -(defvar calendar-font-lock-keywords nil - "Default keywords to highlight in Calendar mode.") - -(make-obsolete-variable 'calendar-font-lock-keywords - "set font-lock keywords in `calendar-mode-hook', \ -or customize calendar faces." "24.4") - (defun calendar-day-name (date &optional abbrev absolute) "Return a string with the name of the day of the week of DATE. DATE should be a list in the format (MONTH DAY YEAR), unless the @@ -2323,7 +2350,7 @@ interpreted as BC; -1 being 1 BC, and so on." (setq calendar-mark-holidays-flag nil calendar-mark-diary-entries-flag nil) (with-current-buffer calendar-buffer - (mapc 'delete-overlay (overlays-in (point-min) (point-max))))) + (mapc #'delete-overlay (overlays-in (point-min) (point-max))))) (defun calendar-date-is-visible-p (date) "Return non-nil if DATE is valid and is visible in the calendar window." @@ -2426,7 +2453,7 @@ ATTRLIST is a list with elements of the form :face face :foreground color." (make-face temp-face) (copy-face face temp-face) ;; Apply the font aspects. - (apply 'set-face-attribute temp-face nil (nreverse faceinfo)) + (apply #'set-face-attribute temp-face nil (nreverse faceinfo)) temp-face))) (defun calendar-mark-visible-date (date &optional mark) @@ -2498,13 +2525,14 @@ and day names to be abbreviated as specified by `calendar-month-abbrev-array' and `calendar-day-abbrev-array', respectively. An optional parameter NODAYNAME, when t, omits the name of the day of the week." - (let* ((dayname (unless nodayname (calendar-day-name date abbreviate))) - (month (calendar-extract-month date)) + (let ((month (calendar-extract-month date))) + (calendar-dlet* + ((dayname (unless nodayname (calendar-day-name date abbreviate))) (monthname (calendar-month-name month abbreviate)) (day (number-to-string (calendar-extract-day date))) (month (number-to-string month)) (year (number-to-string (calendar-extract-year date)))) - (mapconcat 'eval calendar-date-display-form ""))) + (mapconcat #'eval calendar-date-display-form "")))) (defun calendar-dayname-on-or-before (dayname date) "Return the absolute date of the DAYNAME on or before absolute DATE. @@ -2607,11 +2635,11 @@ If called by a mouse-event, pops up a menu with the result." selection) (if (mouse-event-p event) (and (setq selection (cal-menu-x-popup-menu event title - (mapcar 'list others))) + (mapcar #'list others))) (call-interactively selection)) (calendar-in-read-only-buffer calendar-other-calendars-buffer (calendar-set-mode-line title) - (insert (mapconcat 'identity others "\n")))))) + (insert (mapconcat #'identity others "\n")))))) (defun calendar-print-day-of-year () "Show day number in year/days remaining in year for date under the cursor." @@ -2639,8 +2667,4 @@ If called by a mouse-event, pops up a menu with the result." (provide 'calendar) -;; Local variables: -;; byte-compile-dynamic: t -;; End: - ;;; calendar.el ends here diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index 164363c2b70..a0e90c439bf 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el @@ -1,10 +1,10 @@ -;;; diary-lib.el --- diary functions +;;; diary-lib.el --- diary functions -*- lexical-binding:t -*- ;; Copyright (C) 1989-1990, 1992-1995, 2001-2019 Free Software ;; Foundation, Inc. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; This file is part of GNU Emacs. @@ -119,7 +119,7 @@ are: `string', `symbol', `int', `tnil', `stringtnil.'" :type 'boolean :group 'diary) -(defcustom diary-file-name-prefix-function 'identity +(defcustom diary-file-name-prefix-function #'identity "The function that will take a diary file name and return the desired prefix." :type 'function :group 'diary) @@ -151,12 +151,14 @@ See also `diary-comment-start'." :group 'diary) (defcustom diary-hook nil - "List of functions called after the display of the diary. -Used for example by the appointment package - see `appt-activate'." + "Hook run after displaying the diary. +Used for example by the appointment package - see `appt-activate'. +The variables `number' and `original-date' are dynamically bound around +the call." :type 'hook :group 'diary) -(defcustom diary-display-function 'diary-fancy-display +(defcustom diary-display-function #'diary-fancy-display "Function used to display the diary. The two standard options are `diary-fancy-display' and `diary-simple-display'. @@ -185,9 +187,9 @@ diary buffer to be displayed with diary entries from various included files, each day's entries sorted into lexicographic order, add the following to your init file: - (setq diary-display-function \\='diary-fancy-display) - (add-hook \\='diary-list-entries-hook \\='diary-include-other-diary-files) - (add-hook \\='diary-list-entries-hook \\='diary-sort-entries t) + (setq diary-display-function #\\='diary-fancy-display) + (add-hook \\='diary-list-entries-hook #\\='diary-include-other-diary-files) + (add-hook \\='diary-list-entries-hook #\\='diary-sort-entries t) Note how the sort function is placed last, so that it can sort the entries included from other files. @@ -251,7 +253,7 @@ use `diary-mark-entries-hook', which runs only for the main diary file." diary-islamic-mark-entries) :group 'diary) -(defcustom diary-print-entries-hook 'lpr-buffer +(defcustom diary-print-entries-hook #'lpr-buffer "Run by `diary-print-entries' after preparing a temporary diary buffer. The buffer shows only the diary entries currently visible in the diary buffer. The default just does the printing. Other uses @@ -328,7 +330,8 @@ Returns a string using match elements 1-5, where: ;; use the standard function calendar-date-string. (concat (if month (calendar-date-string (list month (string-to-number day) - (string-to-number year)) nil t) + (string-to-number year)) + nil t) (cond ((eq calendar-date-style 'iso) "\\3 \\1 \\2") ; YMD ((eq calendar-date-style 'european) "\\2 \\1 \\3") ; DMY (t "\\1 \\2 \\3"))) ; MDY @@ -552,42 +555,40 @@ If ENTRY is a string, search for matches in that string, and remove them. Returns a list of ENTRY followed by (ATTRIBUTE VALUE) pairs. When ENTRY is non-nil, FILEGLOBATTRS forms the start of the (ATTRIBUTE VALUE) pairs." - (let (regexp regnum attrname attrname attrvalue type ret-attr) + (let (ret-attr) (if (null entry) (save-excursion (dolist (attr diary-face-attrs) ;; FIXME inefficient searching. (goto-char (point-min)) - (setq regexp (concat diary-glob-file-regexp-prefix (car attr)) - regnum (cadr attr) - attrname (nth 2 attr) - type (nth 3 attr) - attrvalue (if (re-search-forward regexp nil t) - (match-string-no-properties regnum))) - (and attrvalue - (setq attrvalue (diary-attrtype-convert attrvalue type)) - (setq ret-attr (append ret-attr - (list attrname attrvalue)))))) + (let* ((regexp (concat diary-glob-file-regexp-prefix (car attr))) + (regnum (cadr attr)) + (attrname (nth 2 attr)) + (type (nth 3 attr)) + (attrvalue (if (re-search-forward regexp nil t) + (match-string-no-properties regnum)))) + (and attrvalue + (setq attrvalue (diary-attrtype-convert attrvalue type)) + (setq ret-attr (append ret-attr + (list attrname attrvalue))))))) (setq ret-attr fileglobattrs) (dolist (attr diary-face-attrs) - (setq regexp (car attr) - regnum (cadr attr) - attrname (nth 2 attr) - type (nth 3 attr) - attrvalue nil) - ;; If multiple matches, replace all, use the last (which may - ;; be the first instance in the line, if the regexp is - ;; anchored with $). - (while (string-match regexp entry) - (setq attrvalue (match-string-no-properties regnum entry) - entry (replace-match "" t t entry))) - (and attrvalue - (setq attrvalue (diary-attrtype-convert attrvalue type)) - (setq ret-attr (append ret-attr (list attrname attrvalue)))))) + (let ((regexp (car attr)) + (regnum (cadr attr)) + (attrname (nth 2 attr)) + (type (nth 3 attr)) + (attrvalue nil)) + ;; If multiple matches, replace all, use the last (which may + ;; be the first instance in the line, if the regexp is + ;; anchored with $). + (while (string-match regexp entry) + (setq attrvalue (match-string-no-properties regnum entry) + entry (replace-match "" t t entry))) + (and attrvalue + (setq attrvalue (diary-attrtype-convert attrvalue type)) + (setq ret-attr (append ret-attr (list attrname attrvalue))))))) (list entry ret-attr))) - - (defvar diary-modify-entry-list-string-function nil "Function applied to entry string before putting it into the entries list. Can be used by programs integrating a diary list into other buffers (e.g. @@ -656,9 +657,12 @@ any entries were found." (let* ((month (calendar-extract-month date)) (day (calendar-extract-day date)) (year (calendar-extract-year date)) - (dayname (format "%s\\|%s\\.?" (calendar-day-name date) - (calendar-day-name date 'abbrev))) (calendar-month-name-array (or months calendar-month-name-array)) + (case-fold-search t) + entry-found) + (calendar-dlet* + ((dayname (format "%s\\|%s\\.?" (calendar-day-name date) + (calendar-day-name date 'abbrev))) (monthname (format "\\*\\|%s%s" (calendar-month-name month) (if months "" (format "\\|%s\\.?" @@ -668,61 +672,60 @@ any entries were found." (year (format "\\*\\|0*%d%s" year (if diary-abbreviated-year-flag (format "\\|%02d" (% year 100)) - ""))) - (case-fold-search t) - entry-found) - (dolist (date-form diary-date-forms) - (let ((backup (when (eq (car date-form) 'backup) - (setq date-form (cdr date-form)) - t)) - ;; date-form uses day etc as set above. - (regexp (format "^%s?%s\\(%s\\)" (regexp-quote mark) - (if symbol (regexp-quote symbol) "") - (mapconcat 'eval date-form "\\)\\(?:"))) - entry-start date-start temp) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (if backup (re-search-backward "\\<" nil t)) - ;; regexp moves us past the end of date, onto the next line. - ;; Trailing whitespace after date not allowed (see diary-file). - (if (and (bolp) (not (looking-at "[ \t]"))) - ;; Diary entry that consists only of date. - (backward-char 1) - ;; Found a nonempty diary entry--make it - ;; visible and add it to the list. - (setq date-start (line-end-position 0)) - ;; Actual entry starts on the next-line? - (if (looking-at "[ \t]*\n[ \t]") (forward-line 1)) - (setq entry-found t - entry-start (point)) - (forward-line 1) - (while (looking-at "[ \t]") ; continued entry - (forward-line 1)) - (unless (and (eobp) (not (bolp))) - (backward-char 1)) - (unless list-only - (remove-overlays date-start (point) 'invisible 'diary)) - (setq temp (diary-pull-attrs - (buffer-substring-no-properties - entry-start (point)) globattr)) - (diary-add-to-list - (or gdate date) (car temp) - (buffer-substring-no-properties (1+ date-start) (1- entry-start)) - (copy-marker entry-start) (cadr temp)))))) - entry-found)) + "")))) + (dolist (date-form diary-date-forms) + (let ((backup (when (eq (car date-form) 'backup) + (setq date-form (cdr date-form)) + t)) + ;; date-form uses day etc as set above. + (regexp (format "^%s?%s\\(%s\\)" (regexp-quote mark) + (if symbol (regexp-quote symbol) "") + (mapconcat #'eval date-form "\\)\\(?:"))) + entry-start date-start temp) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (if backup (re-search-backward "\\<" nil t)) + ;; regexp moves us past the end of date, onto the next line. + ;; Trailing whitespace after date not allowed (see diary-file). + (if (and (bolp) (not (looking-at "[ \t]"))) + ;; Diary entry that consists only of date. + (backward-char 1) + ;; Found a nonempty diary entry--make it + ;; visible and add it to the list. + (setq date-start (line-end-position 0)) + ;; Actual entry starts on the next-line? + (if (looking-at "[ \t]*\n[ \t]") (forward-line 1)) + (setq entry-found t + entry-start (point)) + (forward-line 1) + (while (looking-at "[ \t]") ; continued entry + (forward-line 1)) + (unless (and (eobp) (not (bolp))) + (backward-char 1)) + (unless list-only + (remove-overlays date-start (point) 'invisible 'diary)) + (setq temp (diary-pull-attrs + (buffer-substring-no-properties + entry-start (point)) + globattr)) + (diary-add-to-list + (or gdate date) (car temp) + (buffer-substring-no-properties + (1+ date-start) (1- entry-start)) + (copy-marker entry-start) (cadr temp)))))) + entry-found))) (defvar original-date) ; from diary-list-entries (defvar file-glob-attrs) -(defvar list-only) -(defvar number) (defun diary-list-entries-1 (months symbol absfunc) "List diary entries of a certain type. MONTHS is an array of month names. SYMBOL marks diary entries of the type in question. ABSFUNC is a function that converts absolute dates to dates of the appropriate type." + (with-no-warnings (defvar number) (defvar list-only)) (let ((gdate original-date)) - (dotimes (_idummy number) + (dotimes (_ number) (diary-list-entries-2 (funcall absfunc (calendar-absolute-from-gregorian gdate)) diary-nonmarking-symbol file-glob-attrs list-only months symbol gdate) @@ -735,6 +738,10 @@ of the appropriate type." "List of any diary files included in the last call to `diary-list-entries'. Or to `diary-mark-entries'.") +(defvar diary-saved-point) ; bound in diary-list-entries +(defvar diary-including) +(defvar diary--date-string) ; bound in diary-list-entries + (defun diary-list-entries (date number &optional list-only) "Create and display a buffer containing the relevant lines in `diary-file'. Selects entries for NUMBER days starting with date DATE. Hides any @@ -774,10 +781,10 @@ After preparing the initial list, hooks run in this order: `diary-hook' runs last, after the diary is displayed. This is used e.g. by `appt-check'. -Functions called by these hooks may use the variables ORIGINAL-DATE -and NUMBER, which are the arguments with which this function was called. -Note that hook functions should _not_ use DATE, but ORIGINAL-DATE. -\(Sexp diary entries may use DATE - see `diary-list-sexp-entries'.) +Functions called by these hooks may use the variables `original-date' +and `number', which are the arguments with which this function was called. +Note that hook functions should _not_ use `date', but `original-date'. +\(Sexp diary entries may use `date' - see `diary-list-sexp-entries'.) This function displays the list using `diary-display-function', unless LIST-ONLY is non-nil, in which case it just returns the list." @@ -787,7 +794,7 @@ LIST-ONLY is non-nil, in which case it just returns the list." diary-number-of-entries))) (when (> number 0) (let* ((original-date date) ; save for possible use in the hooks - (date-string (calendar-date-string date)) + (diary--date-string (calendar-date-string date)) (diary-buffer (find-buffer-visiting diary-file)) ;; Dynamically bound in diary-include-files. (d-incp (and (boundp 'diary-including) diary-including)) @@ -832,7 +839,7 @@ LIST-ONLY is non-nil, in which case it just returns the list." (set (make-local-variable 'diary-selective-display) t) (overlay-put ol 'invisible 'diary) (overlay-put ol 'evaporate t))) - (dotimes (_idummy number) + (dotimes (_ number) (let ((sexp-found (diary-list-sexp-entries date)) (entry-found (diary-list-entries-2 date diary-nonmarking-symbol @@ -848,8 +855,10 @@ LIST-ONLY is non-nil, in which case it just returns the list." ;; every time, diary-include-other-diary-files ;; binds it to nil (essentially) when it runs ;; in included files. - (run-hooks 'diary-nongregorian-listing-hook - 'diary-list-entries-hook) + (calendar-dlet* ((number number) + (list-only list-only)) + (run-hooks 'diary-nongregorian-listing-hook + 'diary-list-entries-hook)) ;; We could make this explicit: ;;; (run-hooks 'diary-nongregorian-listing-hook) ;;; (if d-incp @@ -865,7 +874,9 @@ LIST-ONLY is non-nil, in which case it just returns the list." (copy-sequence (car display-buffer-fallback-action)))))) (funcall diary-display-function))) - (run-hooks 'diary-hook))))) + (calendar-dlet* ((number number) + (original-date original-date)) + (run-hooks 'diary-hook)))))) (and temp-buff (buffer-name temp-buff) (kill-buffer temp-buff))) (or d-incp (message "Preparing diary...done")) diary-entries-list))) @@ -878,8 +889,6 @@ LIST-ONLY is non-nil, in which case it just returns the list." (remove-overlays (point-min) (point-max) 'invisible 'diary)) (kill-local-variable 'mode-line-format)) -(defvar original-date) ; bound in diary-list-entries -;(defvar number) ; already declared above (defun diary-include-files (&optional mark) "Process diary entries from included diary files. @@ -894,8 +903,8 @@ This is recursive; that is, included files may include other files." (format "^%s \"\\([^\"]*\\)\"" (regexp-quote diary-include-string)) nil t) (let ((diary-file (match-string-no-properties 1)) - (diary-mark-entries-hook 'diary-mark-included-diary-files) - (diary-list-entries-hook 'diary-include-other-diary-files) + (diary-mark-entries-hook #'diary-mark-included-diary-files) + (diary-list-entries-hook #'diary-include-other-diary-files) (diary-including t) diary-hook diary-list-include-blanks efile) (if (file-exists-p diary-file) @@ -907,6 +916,13 @@ This is recursive; that is, included files may include other files." (append diary-included-files (list efile))) (if mark (diary-mark-entries) + ;; FIXME: `diary-include-files' can be run from + ;; diary-mark-entries-hook (via + ;; diary-mark-included-diary-files) or from + ;; diary-list-entries-hook (via + ;; diary-include-other-diary-files). In the "list" case, + ;; `number' is dynamically bound, but not in the "mark" case! + (with-no-warnings (defvar number)) (setq diary-entries-list (append diary-entries-list (diary-list-entries original-date number t))))) @@ -929,8 +945,6 @@ For details, see `diary-include-files'. See also `diary-mark-included-diary-files'." (diary-include-files)) -(defvar date-string) ; bound in diary-list-entries - (defun diary-display-no-entries () "Common subroutine of `diary-simple-display' and `diary-fancy-display'. Handles the case where there are no diary entries. @@ -938,9 +952,9 @@ Returns a cons (NOENTRIES . HOLIDAY-STRING)." (let* ((holiday-list (if diary-show-holidays-flag (calendar-check-holidays original-date))) (hol-string (format "%s%s%s" - date-string + diary--date-string (if holiday-list ": " "") - (mapconcat 'identity holiday-list "; "))) + (mapconcat #'identity holiday-list "; "))) (msg (format "No diary entries for %s" hol-string)) ;; Empty list, or single item with no text. ;; FIXME multiple items with no text? @@ -956,14 +970,13 @@ Returns a cons (NOENTRIES . HOLIDAY-STRING)." (message "%s" msg) ;; holiday-list which is too wide for a message gets a buffer. (calendar-in-read-only-buffer holiday-buffer - (calendar-set-mode-line (format "Holidays for %s" date-string)) - (insert (mapconcat 'identity holiday-list "\n"))) - (message "No diary entries for %s" date-string))) + (calendar-set-mode-line (format "Holidays for %s" + diary--date-string)) + (insert (mapconcat #'identity holiday-list "\n"))) + (message "No diary entries for %s" diary--date-string))) (cons noentries hol-string))) -(defvar diary-saved-point) ; bound in diary-list-entries - (defun diary-simple-display () "Display the diary buffer if there are any relevant entries or holidays. Entries that do not apply are made invisible. Holidays are shown @@ -987,7 +1000,7 @@ in the mode line. This is an option for `diary-display-function'." (set-window-point window diary-saved-point) (set-window-start window (point-min))))))) -(defvar diary-goto-entry-function 'diary-goto-entry +(defvar diary-goto-entry-function #'diary-goto-entry "Function called to jump to a diary entry. Modes that require special handling of the included file containing the diary entry can assign a suitable function to this @@ -1022,6 +1035,9 @@ variable.") (goto-char (match-beginning 1))))) (message "Unable to locate this diary entry"))))) +(defvar displayed-year) ; bound in calendar-generate +(defvar displayed-month) + (defun diary-fancy-display () "Prepare a diary buffer with relevant entries in a fancy, noneditable form. Holidays are shown unless `diary-show-holidays-flag' is nil. @@ -1111,7 +1127,7 @@ This is an option for `diary-display-function'." (if (eq major-mode 'diary-fancy-display-mode) (run-hooks 'diary-fancy-display-mode-hook) (diary-fancy-display-mode)) - (calendar-set-mode-line date-string)))) + (calendar-set-mode-line diary--date-string)))) ;; FIXME modernize? (defun diary-print-entries () @@ -1204,7 +1220,7 @@ ensure that all relevant variables are set. (interactive "P") (if (string-equal diary-mail-addr "") (user-error "You must set `diary-mail-addr' to use this command") - (let ((diary-display-function 'diary-fancy-display)) + (let ((diary-display-function #'diary-fancy-display)) (diary-list-entries (calendar-current-date) (or ndays diary-mail-days))) (compose-mail diary-mail-addr (concat "Diary entries generated " @@ -1242,109 +1258,111 @@ MARKFUNC is a function that marks entries of the appropriate type matching a given date pattern. MONTHS is an array of month names. SYMBOL marks diary entries of the type in question. ABSFUNC is a function that converts absolute dates to dates of the appropriate type. " - (let ((dayname (diary-name-pattern calendar-day-name-array - calendar-day-abbrev-array)) - (monthname (format "%s\\|\\*" - (if months - (diary-name-pattern months) - (diary-name-pattern calendar-month-name-array - calendar-month-abbrev-array)))) - (month "[0-9]+\\|\\*") - (day "[0-9]+\\|\\*") - (year "[0-9]+\\|\\*") - (case-fold-search t) - marks) - (dolist (date-form diary-date-forms) - (if (eq (car date-form) 'backup) ; ignore 'backup directive - (setq date-form (cdr date-form))) - (let* ((l (length date-form)) - (d-name-pos (- l (length (memq 'dayname date-form)))) - (d-name-pos (if (/= l d-name-pos) (1+ d-name-pos))) - (m-name-pos (- l (length (memq 'monthname date-form)))) - (m-name-pos (if (/= l m-name-pos) (1+ m-name-pos))) - (d-pos (- l (length (memq 'day date-form)))) - (d-pos (if (/= l d-pos) (1+ d-pos))) - (m-pos (- l (length (memq 'month date-form)))) - (m-pos (if (/= l m-pos) (1+ m-pos))) - (y-pos (- l (length (memq 'year date-form)))) - (y-pos (if (/= l y-pos) (1+ y-pos))) - (regexp (format "^%s\\(%s\\)" - (if symbol (regexp-quote symbol) "") - (mapconcat 'eval date-form "\\)\\(")))) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((dd-name - (if d-name-pos - (match-string-no-properties d-name-pos))) - (mm-name - (if m-name-pos - (match-string-no-properties m-name-pos))) - (mm (string-to-number - (if m-pos - (match-string-no-properties m-pos) - ""))) - (dd (string-to-number - (if d-pos - (match-string-no-properties d-pos) - ""))) - (y-str (if y-pos - (match-string-no-properties y-pos))) - (yy (if (not y-str) - 0 - (if (and (= (length y-str) 2) - diary-abbreviated-year-flag) - (let* ((current-y - (calendar-extract-year - (if absfunc - (funcall - absfunc - (calendar-absolute-from-gregorian - (calendar-current-date))) - (calendar-current-date)))) - (y (+ (string-to-number y-str) - ;; Current century, eg 2000. - (* 100 (/ current-y 100)))) - (offset (- y current-y))) - ;; Add 2-digit year to current century. - ;; If more than 50 years in the future, - ;; assume last century. If more than 50 - ;; years in the past, assume next century. - (if (> offset 50) - (- y 100) - (if (< offset -50) - (+ y 100) - y))) - (string-to-number y-str))))) - (setq marks (cadr (diary-pull-attrs - (buffer-substring-no-properties - (point) (line-end-position)) - file-glob-attrs))) - ;; Only mark all days of a given name if the pattern - ;; contains no more specific elements. - (if (and dd-name (not (or d-pos m-pos y-pos))) - (calendar-mark-days-named - (cdr (assoc-string dd-name + (calendar-dlet* + ((dayname (diary-name-pattern calendar-day-name-array + calendar-day-abbrev-array)) + (monthname (format "%s\\|\\*" + (if months + (diary-name-pattern months) + (diary-name-pattern calendar-month-name-array + calendar-month-abbrev-array)))) + (month "[0-9]+\\|\\*") + (day "[0-9]+\\|\\*") + (year "[0-9]+\\|\\*")) + (let* ((case-fold-search t) + marks) + (dolist (date-form diary-date-forms) + (if (eq (car date-form) 'backup) ; ignore 'backup directive + (setq date-form (cdr date-form))) + (let* ((l (length date-form)) + (d-name-pos (- l (length (memq 'dayname date-form)))) + (d-name-pos (if (/= l d-name-pos) (1+ d-name-pos))) + (m-name-pos (- l (length (memq 'monthname date-form)))) + (m-name-pos (if (/= l m-name-pos) (1+ m-name-pos))) + (d-pos (- l (length (memq 'day date-form)))) + (d-pos (if (/= l d-pos) (1+ d-pos))) + (m-pos (- l (length (memq 'month date-form)))) + (m-pos (if (/= l m-pos) (1+ m-pos))) + (y-pos (- l (length (memq 'year date-form)))) + (y-pos (if (/= l y-pos) (1+ y-pos))) + (regexp (format "^%s\\(%s\\)" + (if symbol (regexp-quote symbol) "") + (mapconcat #'eval date-form "\\)\\(")))) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (let* ((dd-name + (if d-name-pos + (match-string-no-properties d-name-pos))) + (mm-name + (if m-name-pos + (match-string-no-properties m-name-pos))) + (mm (string-to-number + (if m-pos + (match-string-no-properties m-pos) + ""))) + (dd (string-to-number + (if d-pos + (match-string-no-properties d-pos) + ""))) + (y-str (if y-pos + (match-string-no-properties y-pos))) + (yy (if (not y-str) + 0 + (if (and (= (length y-str) 2) + diary-abbreviated-year-flag) + (let* ((current-y + (calendar-extract-year + (if absfunc + (funcall + absfunc + (calendar-absolute-from-gregorian + (calendar-current-date))) + (calendar-current-date)))) + (y (+ (string-to-number y-str) + ;; Current century, eg 2000. + (* 100 (/ current-y 100)))) + (offset (- y current-y))) + ;; Add 2-digit year to current century. + ;; If more than 50 years in the future, + ;; assume last century. If more than 50 + ;; years in the past, assume next century. + (if (> offset 50) + (- y 100) + (if (< offset -50) + (+ y 100) + y))) + (string-to-number y-str))))) + (setq marks (cadr (diary-pull-attrs + (buffer-substring-no-properties + (point) (line-end-position)) + file-glob-attrs))) + ;; Only mark all days of a given name if the pattern + ;; contains no more specific elements. + (if (and dd-name (not (or d-pos m-pos y-pos))) + (calendar-mark-days-named + (cdr (assoc-string dd-name + (calendar-make-alist + calendar-day-name-array + 0 nil calendar-day-abbrev-array + (mapcar (lambda (e) + (format "%s." e)) + calendar-day-abbrev-array)) + t)) + marks) + (if mm-name + (setq mm + (if (string-equal mm-name "*") 0 + (cdr (assoc-string + mm-name + (if months (calendar-make-alist months) (calendar-make-alist - calendar-day-name-array - 0 nil calendar-day-abbrev-array + calendar-month-name-array + 1 nil calendar-month-abbrev-array (mapcar (lambda (e) (format "%s." e)) - calendar-day-abbrev-array)) - t)) marks) - (if mm-name - (setq mm - (if (string-equal mm-name "*") 0 - (cdr (assoc-string - mm-name - (if months (calendar-make-alist months) - (calendar-make-alist - calendar-month-name-array - 1 nil calendar-month-abbrev-array - (mapcar (lambda (e) - (format "%s." e)) - calendar-month-abbrev-array))) - t))))) - (funcall markfunc mm dd yy marks)))))))) + calendar-month-abbrev-array))) + t))))) + (funcall markfunc mm dd yy marks))))))))) ;;;###cal-autoload (defun diary-mark-entries (&optional redraw) @@ -1394,42 +1412,44 @@ marks. This is intended to deal with deleted diary entries." (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '()))) (with-syntax-table diary-syntax-table (save-excursion - (diary-mark-entries-1 'calendar-mark-date-pattern) - (diary-mark-sexp-entries) - ;; Although it looks like mark-entries-hook runs every time, - ;; diary-mark-included-diary-files binds it to nil - ;; (essentially) when it runs in included files. - (run-hooks 'diary-nongregorian-marking-hook - 'diary-mark-entries-hook)))) + (save-restriction + (widen) ; bug#33423 + (diary-mark-entries-1 'calendar-mark-date-pattern) + (diary-mark-sexp-entries) + ;; Although it looks like mark-entries-hook runs every time, + ;; diary-mark-included-diary-files binds it to nil + ;; (essentially) when it runs in included files. + (run-hooks 'diary-nongregorian-marking-hook + 'diary-mark-entries-hook))))) (and temp-buff (buffer-name temp-buff) (kill-buffer temp-buff))) (or d-incp (message "Marking diary entries...done")))) (defun diary-sexp-entry (sexp entry date) "Process a SEXP diary ENTRY for DATE." - (let ((result (if calendar-debug-sexp - (let ((debug-on-error t)) - (eval (car (read-from-string sexp)))) - (let (err) - (condition-case err - (eval (car (read-from-string sexp))) - (error - (display-warning - 'diary - (format "Bad diary sexp at line %d in %s:\n%s\n\ -Error: %s\n" - (count-lines (point-min) (point)) - diary-file sexp err) - :error) - nil)))))) + (let ((result + (calendar-dlet* ((date date) + (entry entry)) + (if calendar-debug-sexp + (let ((debug-on-error t)) + (eval (car (read-from-string sexp)))) + (condition-case err + (eval (car (read-from-string sexp))) + (error + (display-warning + 'diary + (format "Bad diary sexp at line %d in %s:\n%s\n\ +Error: %S\n" + (count-lines (point-min) (point)) + diary-file sexp err) + :error) + nil)))))) (cond ((stringp result) result) ((and (consp result) - (stringp (cdr result))) result) + (stringp (cdr result))) + result) (result entry) (t nil)))) -(defvar displayed-year) ; bound in calendar-generate -(defvar displayed-month) - (defun diary-mark-sexp-entries () "Mark days in the calendar window that have sexp diary entries. Each entry in the diary file (or included files) visible in the calendar window @@ -1532,7 +1552,7 @@ passed to `calendar-mark-visible-date' as MARK." (let ((m displayed-month) (y displayed-year)) (calendar-increment-month m y -1) - (dotimes (_idummy 3) + (dotimes (_ 3) (calendar-mark-month m y month day year color) (calendar-increment-month m y 1))))) @@ -1651,7 +1671,7 @@ Sexp diary entries must be prefaced by a `diary-sexp-entry-symbol' %%(SEXP) ENTRY -Both ENTRY and DATE are available when the SEXP is evaluated. If +Both `entry' and `date' are available when the SEXP is evaluated. If the SEXP returns nil, the diary entry does not apply. If it returns a non-nil value, ENTRY will be taken to apply to DATE; if the value is a string, that string will be the diary entry in the @@ -1814,9 +1834,6 @@ form used internally by the calendar and diary." ;;; Sexp diary functions. -(defvar date) -(defvar entry) - ;; To be called from diary-sexp-entry, where DATE, ENTRY are bound. (defun diary-date (month day year &optional mark) "Specific date(s) diary entry. @@ -1827,6 +1844,7 @@ of the input parameters changes according to `calendar-date-style' An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." + (with-no-warnings (defvar date) (defvar entry)) (let* ((ddate (diary-make-date month day year)) (dd (calendar-extract-day ddate)) (mm (calendar-extract-month ddate)) @@ -1855,6 +1873,7 @@ of the input parameters changes according to `calendar-date-style' An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." + (with-no-warnings (defvar date) (defvar entry)) (let ((date1 (calendar-absolute-from-gregorian (diary-make-date m1 d1 y1))) (date2 (calendar-absolute-from-gregorian @@ -1873,6 +1892,7 @@ DAY defaults to 1 if N>0, and MONTH's last day otherwise. MONTH can be a list of months, an integer, or t (meaning all months). Optional MARK specifies a face or single-character string to use when highlighting the day in the calendar." + (with-no-warnings (defvar date) (defvar entry)) ;; This is messy because the diary entry may apply, but the date on which it ;; is based can be in a different month/year. For example, asking for the ;; first Monday after December 30. For large values of |n| the problem is @@ -1951,6 +1971,7 @@ is considered to be March 1 in non-leap years. An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." + (with-no-warnings (defvar date) (defvar entry)) (let* ((ddate (diary-make-date month day year)) (dd (calendar-extract-day ddate)) (mm (calendar-extract-month ddate)) @@ -1975,6 +1996,7 @@ and %s by the ordinal ending of that number (that is, `st', `nd', An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." + (with-no-warnings (defvar date) (defvar entry)) (or (> n 0) (user-error "Day count must be positive")) (let* ((diff (- (calendar-absolute-from-gregorian date) @@ -1986,6 +2008,7 @@ string to use when highlighting the day in the calendar." (defun diary-day-of-year () "Day of year and number of days remaining in the year of date diary entry." + (with-no-warnings (defvar date)) (calendar-day-of-year-string date)) (defun diary-remind (sexp days &optional marking) @@ -2007,11 +2030,12 @@ whether the entry itself is a marking or nonmarking; if optional parameter MARKING is non-nil then the reminders are marked on the calendar." ;; `date' has a value at this point, from diary-sexp-entry. + (with-no-warnings (defvar date)) ;; Convert a negative number to a list of days. (and (integerp days) (< days 0) (setq days (number-sequence 1 (- days)))) - (let ((diary-entry (eval sexp))) + (calendar-dlet* ((diary-entry (eval sexp))) (cond ;; Diary entry applies on date. ((and diary-entry @@ -2027,7 +2051,8 @@ calendar." (when (setq diary-entry (eval sexp)) ;; Discard any mark portion from diary-anniversary, etc. (if (consp diary-entry) (setq diary-entry (cdr diary-entry))) - (mapconcat 'eval diary-remind-message "")))) + (calendar-dlet* ((days days)) + (mapconcat #'eval diary-remind-message ""))))) ;; Diary entry may apply to one of a list of days before date. ((and (listp days) days) (or (diary-remind sexp (car days) marking) @@ -2037,27 +2062,34 @@ calendar." ;;; Diary insertion functions. ;;;###cal-autoload -(defun diary-make-entry (string &optional nonmarking file) +(defun diary-make-entry (string &optional nonmarking file omit-trailing-space + do-not-show) "Insert a diary entry STRING which may be NONMARKING in FILE. If omitted, NONMARKING defaults to nil and FILE defaults to -`diary-file'." - (let ((pop-up-frames (or pop-up-frames (window-dedicated-p)))) - (find-file-other-window (or file diary-file))) - (when (eq major-mode (default-value 'major-mode)) (diary-mode)) - (widen) - (diary-unhide-everything) - (goto-char (point-max)) - (when (let ((case-fold-search t)) - (search-backward "Local Variables:" - (max (- (point-max) 3000) (point-min)) - t)) - (beginning-of-line) - (insert "\n") - (forward-line -1)) - (insert - (if (bolp) "" "\n") - (if nonmarking diary-nonmarking-symbol "") - string " ")) +`diary-file'. If OMIT-TRAILING-SPACE is non-nil, then do not add +a trailing space to the entry. If DO-NOT-SHOW is non-nil, do not +show the diary buffer." + (with-current-buffer + (let ((diary-file-name (or file diary-file))) + (if do-not-show + (find-file-noselect diary-file-name) + (let ((pop-up-frames (or pop-up-frames (window-dedicated-p)))) + (find-file-other-window diary-file-name)))) + (when (eq major-mode (default-value 'major-mode)) (diary-mode)) + (widen) + (diary-unhide-everything) + (goto-char (point-max)) + (when (let ((case-fold-search t)) + (search-backward "Local Variables:" + (max (- (point-max) 3000) (point-min)) + t)) + (beginning-of-line) + (insert "\n") + (forward-line -1)) + (insert + (if (bolp) "" "\n") + (if nonmarking diary-nonmarking-symbol "") + string (if omit-trailing-space "" " ")))) ;;;###cal-autoload (defun diary-insert-entry (arg &optional event) @@ -2224,18 +2256,19 @@ If given, optional SYMBOL must be a prefix to entries. If optional ABBREV-ARRAY is present, also matches the abbreviations from this array (with or without a final `.'), in addition to the full month names." - (let ((dayname (diary-name-pattern calendar-day-name-array - calendar-day-abbrev-array t)) - (monthname (format "\\(%s\\|\\*\\)" - (diary-name-pattern month-array abbrev-array))) - (month "\\([0-9]+\\|\\*\\)") - (day "\\([0-9]+\\|\\*\\)") - (year "-?\\([0-9]+\\|\\*\\)")) + (calendar-dlet* + ((dayname (diary-name-pattern calendar-day-name-array + calendar-day-abbrev-array t)) + (monthname (format "\\(%s\\|\\*\\)" + (diary-name-pattern month-array abbrev-array))) + (month "\\([0-9]+\\|\\*\\)") + (day "\\([0-9]+\\|\\*\\)") + (year "-?\\([0-9]+\\|\\*\\)")) (mapcar (lambda (x) (cons (concat "^" (regexp-quote diary-nonmarking-symbol) "?" (if symbol (regexp-quote symbol) "") "\\(" - (mapconcat 'eval + (mapconcat #'eval ;; If backup, omit first item (backup) ;; and last item (not part of date). (if (equal (car x) 'backup) @@ -2312,7 +2345,7 @@ return a font-lock pattern matching array of MONTHS and marking SYMBOL." 'font-lock-constant-face) (cons (format "^%s?%s" (regexp-quote diary-nonmarking-symbol) - (regexp-opt (mapcar 'regexp-quote + (regexp-opt (mapcar #'regexp-quote (list diary-hebrew-entry-symbol diary-islamic-entry-symbol diary-bahai-entry-symbol @@ -2345,10 +2378,10 @@ return a font-lock pattern matching array of MONTHS and marking SYMBOL." (set (make-local-variable 'comment-start) diary-comment-start) (set (make-local-variable 'comment-end) diary-comment-end) (add-to-invisibility-spec '(diary . nil)) - (add-hook 'after-save-hook 'diary-redraw-calendar nil t) + (add-hook 'after-save-hook #'diary-redraw-calendar nil t) ;; In case the file was modified externally, refresh the calendar ;; after refreshing the diary buffer. - (add-hook 'after-revert-hook 'diary-redraw-calendar nil t) + (add-hook 'after-revert-hook #'diary-redraw-calendar nil t) (if diary-header-line-flag (setq header-line-format diary-header-line-format))) @@ -2359,18 +2392,19 @@ return a font-lock pattern matching array of MONTHS and marking SYMBOL." "Return a regexp matching the first line of a fancy diary date header. This depends on the calendar date style." (concat - (let ((dayname (diary-name-pattern calendar-day-name-array nil t)) - (monthname (diary-name-pattern calendar-month-name-array nil t)) - (day "1") - (month "2") - ;; FIXME? This used to be "-?[0-9]+" - what was the "-?" for? - (year "3")) + (calendar-dlet* + ((dayname (diary-name-pattern calendar-day-name-array nil t)) + (monthname (diary-name-pattern calendar-month-name-array nil t)) + (day "1") + (month "2") + ;; FIXME? This used to be "-?[0-9]+" - what was the "-?" for? + (year "3")) ;; This is ugly. c-d-d-form expects `day' etc to be "numbers in ;; string form"; eg the iso version calls string-to-number on some. ;; Therefore we cannot eg just let day = "[0-9]+". (Bug#8583). ;; Assumes no integers in c-day/month-name-array. (replace-regexp-in-string "[0-9]+" "[0-9]+" - (mapconcat 'eval calendar-date-display-form "") + (mapconcat #'eval calendar-date-display-form "") nil t)) ;; Optional ": holiday name" after the date. "\\(: .*\\)?")) @@ -2391,7 +2425,8 @@ This depends on the calendar date style." ("^Day.*omer.*$" . font-lock-builtin-face) ("^Parashat.*$" . font-lock-comment-face) (,(format "\\(^\\|\\s-\\)%s\\(-%s\\)?" diary-time-regexp - diary-time-regexp) . 'diary-time)) + diary-time-regexp) + . 'diary-time)) "Keywords to highlight in fancy diary display.") ;; If region looks like it might start or end in the middle of a diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el index 40bc066c9ec..89832ab73ef 100644 --- a/lisp/calendar/holidays.el +++ b/lisp/calendar/holidays.el @@ -1,10 +1,10 @@ -;;; holidays.el --- holiday functions for the calendar package +;;; holidays.el --- holiday functions for the calendar package -*- lexical-binding:t -*- ;; Copyright (C) 1989-1990, 1992-1994, 1997, 2001-2019 Free Software ;; Foundation, Inc. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: holidays, calendar ;; Package: calendar @@ -64,8 +64,7 @@ (holiday-float 11 4 4 "Thanksgiving"))) "General holidays. Default value is for the United States. See the documentation for `calendar-holidays' for details." - :type 'sexp - :group 'holidays) + :type 'sexp) ;;;###autoload (put 'holiday-general-holidays 'risky-local-variable t) @@ -86,8 +85,7 @@ See the documentation for `calendar-holidays' for details." "Oriental holidays. See the documentation for `calendar-holidays' for details." :version "23.1" ; added more holidays - :type 'sexp - :group 'holidays) + :type 'sexp) ;;;###autoload (put 'holiday-oriental-holidays 'risky-local-variable t) @@ -95,8 +93,7 @@ See the documentation for `calendar-holidays' for details." (defcustom holiday-local-holidays nil "Local holidays. See the documentation for `calendar-holidays' for details." - :type 'sexp - :group 'holidays) + :type 'sexp) ;;;###autoload (put 'holiday-local-holidays 'risky-local-variable t) @@ -104,8 +101,7 @@ See the documentation for `calendar-holidays' for details." (defcustom holiday-other-holidays nil "User defined holidays. See the documentation for `calendar-holidays' for details." - :type 'sexp - :group 'holidays) + :type 'sexp) ;;;###autoload (put 'holiday-other-holidays 'risky-local-variable t) @@ -122,8 +118,8 @@ See the documentation for `calendar-holidays' for details." "Jewish holidays. See the documentation for `calendar-holidays' for details." :type 'sexp - :version "23.1" ; removed dependency on hebrew-holidays-N - :group 'holidays) + :version "23.1") ; removed dependency on hebrew-holidays-N + ;;;###autoload (put 'holiday-hebrew-holidays 'risky-local-variable t) @@ -141,8 +137,7 @@ See the documentation for `calendar-holidays' for details." (holiday-advent 0 "Advent"))))) "Christian holidays. See the documentation for `calendar-holidays' for details." - :type 'sexp - :group 'holidays) + :type 'sexp) ;;;###autoload (put 'holiday-christian-holidays 'risky-local-variable t) @@ -162,8 +157,7 @@ See the documentation for `calendar-holidays' for details." (holiday-islamic 12 10 "Id-al-Adha"))))) "Islamic holidays. See the documentation for `calendar-holidays' for details." - :type 'sexp - :group 'holidays) + :type 'sexp) ;;;###autoload (put 'holiday-islamic-holidays 'risky-local-variable t) @@ -183,8 +177,7 @@ See the documentation for `calendar-holidays' for details." (holiday-fixed 11 28 "Ascension of `Abdu’l-Bahá"))))) "Bahá’í holidays. See the documentation for `calendar-holidays' for details." - :type 'sexp - :group 'holidays) + :type 'sexp) ;;;###autoload (put 'holiday-bahai-holidays 'risky-local-variable t) @@ -204,8 +197,7 @@ See the documentation for `calendar-holidays' for details." calendar-daylight-time-zone-name))))) "Sun-related holidays. See the documentation for `calendar-holidays' for details." - :type 'sexp - :group 'holidays) + :type 'sexp) ;;;###autoload (put 'holiday-solar-holidays 'risky-local-variable t) @@ -323,8 +315,7 @@ you've written to return a (possibly empty) list of the relevant VISIBLE dates with descriptive strings such as (((2 6 1989) \"New Moon\") ((2 12 1989) \"First Quarter Moon\") ... )." - :type 'sexp - :group 'holidays) + :type 'sexp) ;;;###autoload (put 'calendar-holidays 'risky-local-variable t) @@ -336,14 +327,14 @@ with descriptive strings such as (defun calendar-holiday-list () "Form the list of holidays that occur on dates in the calendar window. The holidays are those in the list `calendar-holidays'." - (let (res h err) + (let (res h) (sort (dolist (p calendar-holidays res) (if (setq h (if calendar-debug-sexp (let ((debug-on-error t)) - (eval p)) + (eval p t)) (condition-case err - (eval p) + (eval p t) (error (display-warning 'holidays @@ -470,7 +461,7 @@ The optional LABEL is used to label the buffer created." (choice (capitalize (completing-read "List (TAB for choices): " lists nil t))) (which (if (string-equal choice "Ask") - (eval (read-variable "Enter list name: ")) + (symbol-value (read-variable "Enter list name: ")) (cdr (assoc choice lists)))) (name (if (string-equal choice "Equinoxes/Solstices") choice @@ -522,7 +513,6 @@ strings describing those holidays that apply on DATE, or nil if none do." (setq holiday-list (append holiday-list (cdr h))))))) -;; Formerly cal-tex-list-holidays. (defun holiday-in-range (d1 d2) "Generate a list of all holidays in range from absolute date D1 to D2." (let* ((start (calendar-gregorian-from-absolute d1)) @@ -537,7 +527,7 @@ strings describing those holidays that apply on DATE, or nil if none do." 3))) holidays in-range a) (calendar-increment-month displayed-month displayed-year 1) - (dotimes (_idummy number-of-intervals) + (dotimes (_ number-of-intervals) (setq holidays (append holidays (calendar-holiday-list))) (calendar-increment-month displayed-month displayed-year 3)) (dolist (hol holidays) @@ -691,19 +681,19 @@ the holiday description of `date'. If `date' is visible in the calendar window, the holiday STRING is on that date. If date is nil, or if the date is not visible, there is no holiday." (let ((m displayed-month) - (y displayed-year) - year date) + (y displayed-year)) (calendar-increment-month m y -1) (holiday-filter-visible-calendar - (list - (progn - (setq year y - date (eval sexp)) - (list date (if date (eval string)))) - (progn - (setq year (1+ y) - date (eval sexp)) - (list date (if date (eval string)))))))) + (calendar-dlet* (year date) + (list + (progn + (setq year y + date (eval sexp t)) + (list date (if date (eval string t)))) + (progn + (setq year (1+ y) + date (eval sexp t)) + (list date (if date (eval string t))))))))) (defun holiday-advent (&optional n string) diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index 408ebdb789e..cf3315b45db 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -43,13 +43,13 @@ ;; 0.06: (2004-10-06) ;; - Bugfixes regarding icalendar-import-format-*. -;; - Fix in icalendar-convert-diary-to-ical -- thanks to Philipp Grau. +;; - Fix in icalendar-export-file -- thanks to Philipp Grau. ;; 0.05: (2003-06-19) ;; - New import format scheme: Replaced icalendar-import-prefix-*, ;; icalendar-import-ignored-properties, and ;; icalendar-import-separator with icalendar-import-format(-*). -;; - icalendar-import-file and icalendar-convert-diary-to-ical +;; - icalendar-import-file and icalendar-export-file ;; have an extra parameter which should prevent them from ;; erasing their target files (untested!). ;; - Tested with Emacs 21.3.2 @@ -643,12 +643,14 @@ FIXME: multiple comma-separated values should be allowed!" (setq year (nth 2 mdy)))) ;; create the decoded date-time ;; FIXME!?! - (condition-case nil - (decode-time (encode-time second minute hour day month year zone)) - (error - (message "Cannot decode \"%s\"" isodatetimestring) - ;; hope for the best... - (list second minute hour day month year 0 nil 0)))) + (let ((decoded-time (list second minute hour day month year + nil -1 zone))) + (condition-case nil + (decode-time (encode-time decoded-time 'integer)) + (error + (message "Cannot decode \"%s\"" isodatetimestring) + ;; Hope for the best.... + decoded-time)))) ;; isodatetimestring == nil nil)) @@ -719,12 +721,12 @@ Both times must be given in decoded form. One of these times must be valid (year > 1900 or something)." ;; FIXME: does this function exist already? (decode-time (encode-time - (+ (nth 0 time1) (nth 0 time2)) - (+ (nth 1 time1) (nth 1 time2)) - (+ (nth 2 time1) (nth 2 time2)) - (+ (nth 3 time1) (nth 3 time2)) - (+ (nth 4 time1) (nth 4 time2)) - (+ (nth 5 time1) (nth 5 time2)) + (+ (decoded-time-second time1) (decoded-time-second time2)) + (+ (decoded-time-minute time1) (decoded-time-minute time2)) + (+ (decoded-time-hour time1) (decoded-time-hour time2)) + (+ (decoded-time-day time1) (decoded-time-day time2)) + (+ (decoded-time-month time1) (decoded-time-month time2)) + (+ (decoded-time-year time1) (decoded-time-year time2)) nil nil ;;(or (nth 6 time1) (nth 6 time2)) ;; FIXME? @@ -996,9 +998,6 @@ Finto iCalendar file: ") (set-buffer (find-file diary-filename)) (icalendar-export-region (point-min) (point-max) ical-filename))) -(define-obsolete-function-alias 'icalendar-convert-diary-to-ical - 'icalendar-export-file "22.1") - (defvar icalendar--uid-count 0 "Auxiliary counter for creating unique ids.") @@ -1019,9 +1018,7 @@ current iCalendar object, as a string. Increase (setq icalendar--uid-count (1+ icalendar--uid-count)) (setq uid (replace-regexp-in-string "%t" - (format "%d%d%d" (car (current-time)) - (cadr (current-time)) - (car (cddr (current-time)))) + (format-time-string "%s%N") uid t t)) (setq uid (replace-regexp-in-string "%h" @@ -1048,12 +1045,10 @@ written into the buffer `*icalendar-errors*'." (interactive "r FExport diary data into iCalendar file: ") (let ((result "") - (start 0) (entry-main "") (entry-rest "") (entry-full "") (header "") - (contents-n-summary) (contents) (alarm) (found-error nil) @@ -1073,7 +1068,8 @@ FExport diary data into iCalendar file: ") ;; possibly ignore hidden entries beginning with "&" (if icalendar-export-hidden-diary-entries "^\\([^ \t\n#].+\\)\\(\\(\n[ \t].*\\)*\\)" - "^\\([^ \t\n&#].+\\)\\(\\(\n[ \t].*\\)*\\)") max t) + "^\\([^ \t\n&#].+\\)\\(\\(\n[ \t].*\\)*\\)") + max t) (setq entry-main (match-string 1)) (if (match-beginning 2) (setq entry-rest (match-string 2)) @@ -1095,7 +1091,7 @@ FExport diary data into iCalendar file: ") (loc (cdr (assoc 'loc other-elements))) (org (cdr (assoc 'org other-elements))) (sta (cdr (assoc 'sta other-elements))) - (sum (cdr (assoc 'sum other-elements))) + ;; (sum (cdr (assoc 'sum other-elements))) (url (cdr (assoc 'url other-elements))) (uid (cdr (assoc 'uid other-elements)))) (if cla @@ -1202,7 +1198,7 @@ Returns an alist." (p-uid (or (string-match "%U" icalendar-import-format) -1)) (p-list (sort (list p-cla p-des p-loc p-org p-sta p-sum p-url p-uid) '<)) (ct 0) - pos-cla pos-des pos-loc pos-org pos-sta pos-sum pos-url pos-uid) + pos-cla pos-des pos-loc pos-org pos-sta pos-url pos-uid) ;pos-sum (dotimes (i (length p-list)) ;; Use 'ct' to keep track of current position in list (cond ((and (>= p-cla 0) (= (nth i p-list) p-cla)) @@ -1222,7 +1218,8 @@ Returns an alist." (setq pos-sta (* 2 ct))) ((and (>= p-sum 0) (= (nth i p-list) p-sum)) (setq ct (+ ct 1)) - (setq pos-sum (* 2 ct))) + ;; (setq pos-sum (* 2 ct)) + ) ((and (>= p-url 0) (= (nth i p-list) p-url)) (setq ct (+ ct 1)) (setq pos-url (* 2 ct))) @@ -1254,11 +1251,11 @@ Returns an alist." (icalendar--rris "%s" "\\(.*?\\)" s nil t) "\\'")) (if (string-match s summary-and-rest) - (let (cla des loc org sta sum url uid) - (if (and pos-sum (match-beginning pos-sum)) - (setq sum (substring summary-and-rest - (match-beginning pos-sum) - (match-end pos-sum)))) + (let (cla des loc org sta url uid) ;; sum + ;; (if (and pos-sum (match-beginning pos-sum)) + ;; (setq sum (substring summary-and-rest + ;; (match-beginning pos-sum) + ;; (match-end pos-sum)))) (if (and pos-cla (match-beginning pos-cla)) (setq cla (substring summary-and-rest (match-beginning pos-cla) @@ -1601,8 +1598,7 @@ regular expression matching the start of non-marking entries. ENTRY-MAIN is the first line of the diary entry. Optional argument START determines the first day of the -enumeration, given as a time value, in same format as returned by -`current-time' -- used for test purposes." +enumeration, given as a Lisp time value -- used for test purposes." (cond ((string-match (concat nonmarker "%%(and \\(([^)]+)\\))\\(\\s-*.*?\\) ?$") entry-main) @@ -1626,11 +1622,10 @@ enumeration, given as a time value, in same format as returned by (mapcar (lambda (offset) (let* ((day (decode-time (time-add now - (seconds-to-time - (* offset 60 60 24))))) - (d (nth 3 day)) - (m (nth 4 day)) - (y (nth 5 day)) + (* 60 60 24 offset)))) + (d (decoded-time-day day)) + (m (decoded-time-month day)) + (y (decoded-time-year day)) (se (diary-sexp-entry p1 p2 (list m d y))) (see (cond ((stringp se) se) ((consp se) (cdr se)) @@ -1763,8 +1758,8 @@ entries. ENTRY-MAIN is the first line of the diary entry." ;;BUT remove today if `diary-float' ;;expression does not hold true for today: (when - (null (let ((date (calendar-current-date)) - (entry entry-main)) + (null (calendar-dlet* ((date (calendar-current-date)) + (entry entry-main)) (diary-float month dayname n))) (concat "\nEXDATE;VALUE=DATE:" @@ -1975,13 +1970,13 @@ P") (icalendar-import-buffer diary-filename t non-marking))) ;;;###autoload -(defun icalendar-import-buffer (&optional diary-file do-not-ask +(defun icalendar-import-buffer (&optional diary-filename do-not-ask non-marking) "Extract iCalendar events from current buffer. This function searches the current buffer for the first iCalendar object, reads it and adds all VEVENT elements to the diary -DIARY-FILE. +DIARY-FILENAME. It will ask for each appointment whether to add it to the diary unless DO-NOT-ASK is non-nil. When called interactively, @@ -2011,10 +2006,10 @@ buffer `*icalendar-errors*'." (message "Converting iCalendar...") (setq ical-errors (icalendar--convert-ical-to-diary ical-contents - diary-file do-not-ask non-marking)) - (when diary-file + diary-filename do-not-ask non-marking)) + (when diary-filename ;; save the diary file if it is visited already - (let ((b (find-buffer-visiting diary-file))) + (let ((b (find-buffer-visiting diary-filename))) (when b (save-current-buffer (set-buffer b) @@ -2027,9 +2022,6 @@ buffer `*icalendar-errors*'." ;; return nil, i.e. import did not work nil))) -(define-obsolete-function-alias 'icalendar-extract-ical-from-buffer - 'icalendar-import-buffer "22.1") - (defun icalendar--format-ical-event (event) "Create a string representation of an iCalendar EVENT." (if (functionp icalendar-import-format) @@ -2066,12 +2058,12 @@ buffer `*icalendar-errors*'." conversion-list) string))) -(defun icalendar--convert-ical-to-diary (ical-list diary-file +(defun icalendar--convert-ical-to-diary (ical-list diary-filename &optional do-not-ask non-marking) "Convert iCalendar data to an Emacs diary file. Import VEVENTS from the iCalendar object ICAL-LIST and saves them to a -DIARY-FILE. If DO-NOT-ASK is nil the user is asked for each event +DIARY-FILENAME. If DO-NOT-ASK is nil the user is asked for each event whether to actually import it. NON-MARKING determines whether diary events are created as non-marking. This function attempts to return t if something goes wrong. In this @@ -2164,7 +2156,7 @@ written into the buffer `*icalendar-errors*'." (rdate (icalendar--dmsg "rdate event") (setq diary-string "") - (mapc (lambda (datestring) + (mapc (lambda (_datestring) (setq diary-string (concat diary-string (format "......")))) @@ -2174,14 +2166,14 @@ written into the buffer `*icalendar-errors*'." ((not (string= start-d end-d)) (setq diary-string (icalendar--convert-non-recurring-all-day-to-diary - e start-d end-1-d)) + start-d end-1-d)) (setq event-ok t)) ;; not all-day ((and start-t (or (not end-t) (not (string= start-t end-t)))) (setq diary-string (icalendar--convert-non-recurring-not-all-day-to-diary - e dtstart-dec dtend-dec start-t end-t)) + dtstart-dec start-t end-t)) (setq event-ok t)) ;; all-day event (t @@ -2199,8 +2191,8 @@ written into the buffer `*icalendar-errors*'." (if do-not-ask (setq summary nil)) ;; add entry to diary and store actual name of diary ;; file (in case it was nil) - (setq diary-file - (icalendar--add-diary-entry diary-string diary-file + (setq diary-filename + (icalendar--add-diary-entry diary-string diary-filename non-marking summary))) ;; event was not ok (setq found-error t) @@ -2217,8 +2209,8 @@ written into the buffer `*icalendar-errors*'." (message "%s" error-string)))) ;; insert final newline - (if diary-file - (let ((b (find-buffer-visiting diary-file))) + (if diary-filename + (let ((b (find-buffer-visiting diary-filename))) (when b (save-current-buffer (set-buffer b) @@ -2467,7 +2459,7 @@ END-T is the event's end time in diary format." e 'EXRULE)))) result)) -(defun icalendar--convert-non-recurring-all-day-to-diary (event start-d end-d) +(defun icalendar--convert-non-recurring-all-day-to-diary (start-d end-d) "Convert non-recurring iCalendar EVENT to diary format. DTSTART is the decoded DTSTART property of E. @@ -2476,14 +2468,12 @@ Argument END-D gives the last day." (icalendar--dmsg "non-recurring all-day event") (format "%%%%(and (diary-block %s %s))" start-d end-d)) -(defun icalendar--convert-non-recurring-not-all-day-to-diary (event dtstart-dec - dtend-dec - start-t - end-t) +(defun icalendar--convert-non-recurring-not-all-day-to-diary (dtstart-dec + start-t + end-t) "Convert recurring icalendar EVENT to diary format. DTSTART-DEC is the decoded DTSTART property of E. -DTEND-DEC is the decoded DTEND property of E. START-T is the event's start time in diary format. END-T is the event's end time in diary format." (icalendar--dmsg "not all day event") @@ -2498,9 +2488,9 @@ END-T is the event's end time in diary format." dtstart-dec "/") start-t)))) -(defun icalendar--add-diary-entry (string diary-file non-marking +(defun icalendar--add-diary-entry (string diary-filename non-marking &optional summary) - "Add STRING to the diary file DIARY-FILE. + "Add STRING to the diary file DIARY-FILENAME. STRING must be a properly formatted valid diary entry. NON-MARKING determines whether diary events are created as non-marking. If SUMMARY is not nil it must be a string that gives the summary of the @@ -2512,22 +2502,12 @@ the entry." (when summary (setq non-marking (y-or-n-p (format "Make appointment non-marking? ")))) - (save-window-excursion - (unless diary-file - (setq diary-file - (read-file-name "Add appointment to this diary file: "))) - ;; Note: diary-make-entry will add a trailing blank char.... :( - (funcall (if (fboundp 'diary-make-entry) - 'diary-make-entry - 'make-diary-entry) - string non-marking diary-file))) - ;; Würgaround to remove the trailing blank char - (with-current-buffer (find-file diary-file) - (goto-char (point-max)) - (if (= (char-before) ? ) - (delete-char -1))) - ;; return diary-file in case it has been changed interactively - diary-file) + (unless diary-filename + (setq diary-filename + (read-file-name "Add appointment to this diary file: "))) + (diary-make-entry string non-marking diary-filename t t)) + ;; return diary-filename in case it has been changed interactively + diary-filename) ;; ====================================================================== ;; Examples diff --git a/lisp/calendar/iso8601.el b/lisp/calendar/iso8601.el new file mode 100644 index 00000000000..ab0077ac58d --- /dev/null +++ b/lisp/calendar/iso8601.el @@ -0,0 +1,370 @@ +;;; iso8601.el --- parse ISO 8601 date/time strings -*- lexical-binding:t -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; Keywords: dates + +;; 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: + +;; ISO8601 times basically look like 1985-04-01T15:23:49... Or so +;; you'd think. This is what everybody means when they say "ISO8601", +;; but it's in reality a quite large collection of syntaxes, including +;; week numbers, ordinal dates, durations and intervals. This package +;; has functions for parsing them all. +;; +;; The interface functions are `iso8601-parse', `iso8601-parse-date', +;; `iso8601-parse-time', `iso8601-parse-zone', +;; `iso8601-parse-duration' and `iso8601-parse-interval'. They all +;; return decoded time objects, except the last one, which returns a +;; list of three of them. +;; +;; (iso8601-parse-interval "P1Y2M10DT2H30M/2008W32T153000-01") +;; '((0 0 13 24 5 2007 nil nil -3600) +;; (0 30 15 3 8 2008 nil nil -3600) +;; (0 30 2 10 2 1 nil nil nil)) +;; +;; +;; The standard can be found at: +;; +;; http://www.loc.gov/standards/datetime/iso-tc154-wg5_n0038_iso_wd_8601-1_2016-02-16.pdf +;; +;; The Wikipedia page on the standard is also informative: +;; +;; https://en.wikipedia.org/wiki/ISO_8601 +;; +;; RFC3339 defines the subset that everybody thinks of as "ISO8601". + +;;; Code: + +(require 'time-date) +(require 'cl-lib) + +(defun iso8601--concat-regexps (regexps) + (mapconcat (lambda (regexp) + (concat "\\(?:" + (replace-regexp-in-string "(" "(?:" regexp) + "\\)")) + regexps "\\|")) + +(defconst iso8601--year-match + "\\([-+]\\)?\\([0-9][0-9][0-9][0-9]\\)") +(defconst iso8601--full-date-match + "\\([-+]\\)?\\([0-9][0-9][0-9][0-9]\\)-?\\([0-9][0-9]\\)-?\\([0-9][0-9]\\)") +(defconst iso8601--without-day-match + "\\([-+]\\)?\\([0-9][0-9][0-9][0-9]\\)-\\([0-9][0-9]\\)") +(defconst iso8601--outdated-date-match + "--\\([0-9][0-9]\\)-?\\([0-9][0-9]\\)") +(defconst iso8601--week-date-match + "\\([-+]\\)?\\([0-9][0-9][0-9][0-9]\\)-?W\\([0-9][0-9]\\)-?\\([0-9]\\)?") +(defconst iso8601--ordinal-date-match + "\\([-+]\\)?\\([0-9][0-9][0-9][0-9]\\)-?\\([0-9][0-9][0-9]\\)") +(defconst iso8601--date-match + (iso8601--concat-regexps + (list iso8601--year-match + iso8601--full-date-match + iso8601--without-day-match + iso8601--outdated-date-match + iso8601--week-date-match + iso8601--ordinal-date-match))) + +(defconst iso8601--time-match + "\\([0-9][0-9]\\):?\\([0-9][0-9]\\)?:?\\([0-9][0-9]\\)?\\.?\\([0-9][0-9][0-9]\\)?") + +(defconst iso8601--zone-match + "\\(Z\\|\\([-+]\\)\\([0-9][0-9]\\):?\\([0-9][0-9]\\)?\\)") + +(defconst iso8601--full-time-match + (concat "\\(" (replace-regexp-in-string "(" "(?:" iso8601--time-match) "\\)" + "\\(" iso8601--zone-match "\\)?")) + +(defconst iso8601--combined-match + (concat "\\(" iso8601--date-match "\\)" + "\\(?:T\\(" + (replace-regexp-in-string "(" "(?:" iso8601--time-match) + "\\)" + "\\(" iso8601--zone-match "\\)?\\)?")) + +(defconst iso8601--duration-full-match + "P\\([0-9]+Y\\)?\\([0-9]+M\\)?\\([0-9]+D\\)?\\(T\\([0-9]+H\\)?\\([0-9]+M\\)?\\([0-9]+S\\)?\\)?") +(defconst iso8601--duration-week-match + "P\\([0-9]+\\)W") +(defconst iso8601--duration-combined-match + (concat "P" iso8601--combined-match)) +(defconst iso8601--duration-match + (iso8601--concat-regexps + (list iso8601--duration-full-match + iso8601--duration-week-match + iso8601--duration-combined-match))) + +(defun iso8601-parse (string) + "Parse an ISO 8601 date/time string and return a `decoded-time' structure. + +The ISO 8601 date/time strings look like \"2008-03-02T13:47:30\", +but shorter, incomplete strings like \"2008-03-02\" are valid, as +well as variants like \"2008W32\" (week number) and +\"2008-234\" (ordinal day number)." + (if (not (iso8601-valid-p string)) + (signal 'wrong-type-argument string) + (let* ((date-string (match-string 1 string)) + (time-string (match-string 2 string)) + (zone-string (match-string 3 string)) + (date (iso8601-parse-date date-string))) + ;; The time portion is optional. + (when time-string + (let ((time (iso8601-parse-time time-string))) + (setf (decoded-time-hour date) (decoded-time-hour time)) + (setf (decoded-time-minute date) (decoded-time-minute time)) + (setf (decoded-time-second date) (decoded-time-second time)))) + ;; The time zone is optional. + (when zone-string + (setf (decoded-time-zone date) + ;; The time zone in decoded times are in seconds. + (* (iso8601-parse-zone zone-string) 60))) + date))) + +(defun iso8601-parse-date (string) + "Parse STRING (which should be on ISO 8601 format) and return a time value." + (cond + ;; Just a year: [-+]YYYY. + ((iso8601--match iso8601--year-match string) + (iso8601--decoded-time + :year (iso8601--adjust-year (match-string 1 string) + (match-string 2 string)))) + ;; Calendar dates: YYYY-MM-DD and variants. + ((iso8601--match iso8601--full-date-match string) + (iso8601--decoded-time + :year (iso8601--adjust-year (match-string 1 string) + (match-string 2 string)) + :month (match-string 3 string) + :day (match-string 4 string))) + ;; Calendar date without day: YYYY-MM. + ((iso8601--match iso8601--without-day-match string) + (iso8601--decoded-time + :year (iso8601--adjust-year (match-string 1 string) + (match-string 2 string)) + :month (match-string 3 string))) + ;; Outdated date without year: --MM-DD + ((iso8601--match iso8601--outdated-date-match string) + (iso8601--decoded-time + :month (match-string 1 string) + :day (match-string 2 string))) + ;; Week dates: YYYY-Www-D + ((iso8601--match iso8601--week-date-match string) + (let* ((year (iso8601--adjust-year (match-string 1 string) + (match-string 2 string))) + (week (string-to-number (match-string 3 string))) + (day-of-week (and (match-string 4 string) + (string-to-number (match-string 4 string)))) + (jan-start (decoded-time-weekday + (decode-time + (iso8601--encode-time + (iso8601--decoded-time :year year + :month 1 + :day 4))))) + (correction (+ (if (zerop jan-start) 7 jan-start) + 3)) + (ordinal (+ (* week 7) (or day-of-week 0) (- correction)))) + (cond + ;; Monday 29 December 2008 is written "2009-W01-1". + ((< ordinal 1) + (setq year (1- year) + ordinal (+ ordinal (if (date-leap-year-p year) + 366 365)))) + ;; Sunday 3 January 2010 is written "2009-W53-7". + ((> ordinal (if (date-leap-year-p year) + 366 365)) + (setq ordinal (- ordinal (if (date-leap-year-p year) + 366 365)) + year (1+ year)))) + (let ((month-day (date-ordinal-to-time year ordinal))) + (iso8601--decoded-time :year year + :month (decoded-time-month month-day) + :day (decoded-time-day month-day))))) + ;; Ordinal dates: YYYY-DDD + ((iso8601--match iso8601--ordinal-date-match string) + (let* ((year (iso8601--adjust-year (match-string 1 string) + (match-string 2 string))) + (ordinal (string-to-number (match-string 3 string))) + (month-day (date-ordinal-to-time year ordinal))) + (iso8601--decoded-time :year year + :month (decoded-time-month month-day) + :day (decoded-time-day month-day)))) + (t + (signal 'wrong-type-argument string)))) + +(defun iso8601--adjust-year (sign year) + (save-match-data + (let ((year (if (stringp year) + (string-to-number year) + year))) + (if (string= sign "-") + ;; -0001 is 2 BCE. + (1- (- year)) + year)))) + +(defun iso8601-parse-time (string) + "Parse STRING, which should be an ISO 8601 time string, and return a time value." + (if (not (iso8601--match iso8601--full-time-match string)) + (signal 'wrong-type-argument string) + (let ((time (match-string 1 string)) + (zone (match-string 2 string))) + (if (not (iso8601--match iso8601--time-match time)) + (signal 'wrong-type-argument string) + (let ((hour (string-to-number (match-string 1 time))) + (minute (and (match-string 2 time) + (string-to-number (match-string 2 time)))) + (second (and (match-string 3 time) + (string-to-number (match-string 3 time)))) + ;; Hm... + (_millisecond (and (match-string 4 time) + (string-to-number (match-string 4 time))))) + (iso8601--decoded-time :hour hour + :minute (or minute 0) + :second (or second 0) + :zone (and zone + (* 60 (iso8601-parse-zone + zone))))))))) + +(defun iso8601-parse-zone (string) + "Parse STRING, which should be an ISO 8601 time zone. +Return the number of minutes." + (if (not (iso8601--match iso8601--zone-match string)) + (signal 'wrong-type-argument string) + (if (match-string 2 string) + ;; HH:MM-ish. + (let ((hour (string-to-number (match-string 3 string))) + (minute (and (match-string 4 string) + (string-to-number (match-string 4 string))))) + (* (if (equal (match-string 2 string) "-") + -1 + 1) + (+ (* hour 60) + (or minute 0)))) + ;; "Z". + 0))) + +(defun iso8601-valid-p (string) + "Say whether STRING is a valid ISO 8601 representation." + (iso8601--match iso8601--combined-match string)) + +(defun iso8601-parse-duration (string) + "Parse ISO 8601 durations on the form P3Y6M4DT12H30M5S." + (cond + ((and (iso8601--match iso8601--duration-full-match string) + ;; Just a "P" isn't valid; there has to be at least one + ;; element, like P1M. + (> (length (match-string 0 string)) 2)) + (iso8601--decoded-time :year (or (match-string 1 string) 0) + :month (or (match-string 2 string) 0) + :day (or (match-string 3 string) 0) + :hour (or (match-string 5 string) 0) + :minute (or (match-string 6 string) 0) + :second (or (match-string 7 string) 0))) + ;; PnW: Weeks. + ((iso8601--match iso8601--duration-week-match string) + (let ((weeks (string-to-number (match-string 1 string)))) + ;; Does this make sense? Hm... + (iso8601--decoded-time :day (* weeks 7)))) + ;; P<date>T<time> + ((iso8601--match iso8601--duration-combined-match string) + (iso8601-parse (substring string 1))) + (t + (signal 'wrong-type-argument string)))) + +(defun iso8601-parse-interval (string) + "Parse ISO 8601 intervals." + (let ((bits (split-string string "/")) + start end duration) + (if (not (= (length bits) 2)) + (signal 'wrong-type-argument string) + ;; The intervals may be an explicit start/end times, or either a + ;; start or an end, and an accompanying duration. + (cond + ((and (string-match "\\`P" (car bits)) + (iso8601-valid-p (cadr bits))) + (setq duration (iso8601-parse-duration (car bits)) + end (iso8601-parse (cadr bits)))) + ((and (string-match "\\`P" (cadr bits)) + (iso8601-valid-p (car bits))) + (setq duration (iso8601-parse-duration (cadr bits)) + start (iso8601-parse (car bits)))) + ((and (iso8601-valid-p (car bits)) + (iso8601-valid-p (cadr bits))) + (setq start (iso8601-parse (car bits)) + end (iso8601-parse (cadr bits)))) + (t + (signal 'wrong-type-argument string)))) + (unless end + (setq end (decoded-time-add start duration))) + (unless start + (setq start (decoded-time-add end + ;; We negate the duration so that + ;; we get a subtraction. + (mapcar (lambda (elem) + (if (numberp elem) + (- elem) + elem)) + duration)))) + (list start end + (or duration + (decode-time (time-subtract (iso8601--encode-time end) + (iso8601--encode-time start)) + (or (decoded-time-zone end) 0)))))) + +(defun iso8601--match (regexp string) + (string-match (concat "\\`" regexp "\\'") string)) + +(defun iso8601--value (elem &optional default) + (if (stringp elem) + (string-to-number elem) + (or elem default))) + +(cl-defun iso8601--decoded-time (&key second minute hour + day month year + dst zone) + (list (iso8601--value second) + (iso8601--value minute) + (iso8601--value hour) + (iso8601--value day) + (iso8601--value month) + (iso8601--value year) + nil + dst + zone)) + +(defun iso8601--encode-time (time) + "Like `encode-time', but fill in nil values in TIME." + (setq time (copy-sequence time)) + (unless (decoded-time-second time) + (setf (decoded-time-second time) 0)) + (unless (decoded-time-minute time) + (setf (decoded-time-minute time) 0)) + (unless (decoded-time-hour time) + (setf (decoded-time-hour time) 0)) + + (unless (decoded-time-day time) + (setf (decoded-time-day time) 1)) + (unless (decoded-time-month time) + (setf (decoded-time-month time) 1)) + (unless (decoded-time-year time) + (setf (decoded-time-year time) 0)) + (encode-time time)) + +(provide 'iso8601) + +;;; iso8601.el ends here diff --git a/lisp/calendar/lunar.el b/lisp/calendar/lunar.el index 5424551e246..1cdcc97f36a 100644 --- a/lisp/calendar/lunar.el +++ b/lisp/calendar/lunar.el @@ -4,7 +4,7 @@ ;; Foundation, Inc. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; Human-Keywords: moon, lunar phases, calendar, diary ;; Package: calendar @@ -241,9 +241,12 @@ This function is suitable for execution in an init file." (displayed-year (calendar-extract-year date))) (calendar-lunar-phases)))) -(defvar date) - -;; To be called from diary-list-sexp-entries, where DATE is bound. +;; The function below is designed to be used in sexp diary entries, +;; and may be present in users' diary files, so suppress the warning +;; about this prefix-less dynamic variable. It's called from +;; `diary-list-sexp-entries', which binds the variable. +(with-suppressed-warnings ((lexical date)) + (defvar date)) ;;;###diary-autoload (defun diary-lunar-phases (&optional mark) diff --git a/lisp/calendar/parse-time.el b/lisp/calendar/parse-time.el index 41806cfc375..68d6ce05d6c 100644 --- a/lisp/calendar/parse-time.el +++ b/lisp/calendar/parse-time.el @@ -29,8 +29,9 @@ ;; `parse-time-string' parses a time in a string and returns a list of 9 ;; values, just like `decode-time', where unspecified elements in the -;; string are returned as nil. `encode-time' may be applied on these -;; values to obtain an internal time value. +;; string are returned as nil (except unspecfied DST is returned as -1). +;; `encode-time' may be applied on these values to obtain an internal +;; time value. ;;; Code: @@ -98,7 +99,7 @@ letters, digits, plus or minus signs or colons." `(((6) parse-time-weekdays) ((3) (1 31)) ((4) parse-time-months) - ((5) (100 ,most-positive-fixnum)) + ((5) (100)) ((2 1 0) ,#'(lambda () (and (stringp parse-time-elt) (= (length parse-time-elt) 8) @@ -151,8 +152,9 @@ STRING should be something resembling an RFC 822 (or later) date-time, e.g., somewhat liberal in what format it accepts, and will attempt to return a \"likely\" value even for somewhat malformed strings. The values returned are identical to those of `decode-time', but -any values that are unknown are returned as nil." - (let ((time (list nil nil nil nil nil nil nil nil nil)) +any unknown values other than DST are returned as nil, and an +unknown DST value is returned as -1." + (let ((time (list nil nil nil nil nil nil nil -1 nil)) (temp (parse-time-tokenize (downcase string)))) (while temp (let ((parse-time-elt (pop temp)) @@ -166,11 +168,12 @@ any values that are unknown are returned as nil." (when (and (not (nth (car slots) time)) ;not already set (setq parse-time-val (cond ((and (consp predicate) - (not (eq (car predicate) - 'lambda))) + (not (functionp predicate))) (and (numberp parse-time-elt) (<= (car predicate) parse-time-elt) - (<= parse-time-elt (cadr predicate)) + (or (not (cdr predicate)) + (<= parse-time-elt + (cadr predicate))) parse-time-elt)) ((symbolp predicate) (cdr (assoc parse-time-elt @@ -187,7 +190,7 @@ any values that are unknown are returned as nil." :end (aref this 1)) (funcall this))) parse-time-val))) - (rplaca (nthcdr (pop slots) time) new-val)))))))) + (setf (nth (pop slots) time) new-val)))))))) time)) (defconst parse-time-iso8601-regexp @@ -223,7 +226,7 @@ If DATE-STRING cannot be parsed, it falls back to (tz-re (nth 2 parse-time-iso8601-regexp)) re-start time seconds minute hour - day month year day-of-week dst tz) + day month year day-of-week (dst -1) tz) ;; We need to populate 'time' with ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ) @@ -239,16 +242,18 @@ If DATE-STRING cannot be parsed, it falls back to seconds (string-to-number (match-string 3 date-string)) re-start (match-end 0)) (when (string-match tz-re date-string re-start) - (if (string= "Z" (match-string 1 date-string)) - (setq tz 0) ;; UTC timezone indicated by Z - (setq tz (+ - (* 3600 - (string-to-number (match-string 3 date-string))) - (* 60 - (string-to-number - (or (match-string 4 date-string) "0"))))) - (when (string= "-" (match-string 2 date-string)) - (setq tz (- tz))))) + (setq dst nil) + (setq tz (if (string= "Z" (match-string 1 date-string)) + 0 ;; UTC timezone indicated by Z + (let ((tz (+ + (* 3600 + (string-to-number + (match-string 3 date-string))) + (* 60 + (string-to-number + (or (match-string 4 date-string) "0")))))) + (if (string= "-" (match-string 2 date-string)) + (- tz) tz))))) (setq time (list seconds minute hour day month year day-of-week dst tz)))) ;; Fall back to having `parse-time-string' do fancy things for us. @@ -256,7 +261,7 @@ If DATE-STRING cannot be parsed, it falls back to (setq time (parse-time-string date-string))) (and time - (apply 'encode-time time)))) + (encode-time time)))) (provide 'parse-time) diff --git a/lisp/calendar/solar.el b/lisp/calendar/solar.el index aa5ab91f16e..bf8a7f0b219 100644 --- a/lisp/calendar/solar.el +++ b/lisp/calendar/solar.el @@ -1,11 +1,11 @@ -;;; solar.el --- calendar functions for solar events +;;; solar.el --- calendar functions for solar events -*- lexical-binding:t -*- ;; Copyright (C) 1992-1993, 1995, 1997, 2001-2019 Free Software ;; Foundation, Inc. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> ;; Denis B. Roegel <Denis.Roegel@loria.fr> -;; Maintainer: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: calendar ;; Human-Keywords: sunrise, sunset, equinox, solstice, calendar, diary, holidays ;; Package: calendar @@ -552,12 +552,14 @@ degrees to find out if polar regions have 24 hours of sun or only night." "Printable form for decimal fraction TIME in TIME-ZONE. Format used is given by `calendar-time-display-form'." (let* ((time (round (* 60 time))) - (24-hours (/ time 60)) + (24-hours (/ time 60))) + (calendar-dlet* + ((time-zone time-zone) (minutes (format "%02d" (% time 60))) (12-hours (format "%d" (1+ (% (+ 24-hours 11) 12)))) (am-pm (if (>= 24-hours 12) "pm" "am")) (24-hours (format "%02d" 24-hours))) - (mapconcat 'eval calendar-time-display-form ""))) + (mapconcat #'eval calendar-time-display-form "")))) (defun solar-daylight (time) "Printable form for TIME expressed in hours." @@ -661,10 +663,10 @@ Optional NOLOCATION non-nil means do not print the location." (format "%s, %s%s (%s hrs daylight)" (if (car l) - (concat "Sunrise " (apply 'solar-time-string (car l))) + (concat "Sunrise " (apply #'solar-time-string (car l))) "No sunrise") (if (cadr l) - (concat "sunset " (apply 'solar-time-string (cadr l))) + (concat "sunset " (apply #'solar-time-string (cadr l))) "no sunset") (if nolocation "" (format " at %s" (eval calendar-location-name))) @@ -749,7 +751,7 @@ The values of `calendar-daylight-savings-starts', (+ 4.9353929 (* 62833.1961680 U) (* 0.0000001 - (apply '+ + (apply #'+ (mapcar (lambda (x) (* (car x) (sin (mod @@ -889,13 +891,12 @@ Accurate to a few seconds." (insert (format "%s %2d: " (calendar-month-name month t) (1+ i)) (solar-sunrise-sunset-string date t) "\n"))))) -(defvar date) - -;; To be called from diary-list-sexp-entries, where DATE is bound. ;;;###diary-autoload (defun diary-sunrise-sunset () "Local time of sunrise and sunset as a diary entry. Accurate to a few seconds." + ;; To be called from diary-list-sexp-entries, where DATE is bound. + (with-no-warnings (defvar date)) (or (and calendar-latitude calendar-longitude calendar-time-zone) (solar-setup)) (solar-sunrise-sunset-string date)) @@ -938,7 +939,7 @@ Accurate to within a minute between 1951 and 2050." (W (- (* 35999.373 T) 2.47)) (Delta-lambda (+ 1 (* 0.0334 (solar-cosine-degrees W)) (* 0.0007 (solar-cosine-degrees (* 2 W))))) - (S (apply '+ (mapcar (lambda(x) + (S (apply #'+ (mapcar (lambda(x) (* (car x) (solar-cosine-degrees (+ (* (nth 2 x) T) (cadr x))))) solar-seasons-data))) diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index afd5c091b40..e195f71c58a 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -36,6 +36,9 @@ ;;; Code: +(require 'cl-lib) +(require 'subr-x) + (defmacro with-decoded-time-value (varlist &rest body) "Decode a time value and bind it according to VARLIST, then eval BODY. @@ -151,34 +154,32 @@ 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 - (apply 'encode-time (parse-time-string date)) + (encode-time (parse-time-string date)) (error (let ((overflow-error '(error "Specified time is not representable"))) (if (equal err overflow-error) - (apply 'signal err) + (signal (car err) (cdr err)) (condition-case err - (apply 'encode-time - (parse-time-string - (timezone-make-date-arpa-standard date))) + (encode-time (parse-time-string + (timezone-make-date-arpa-standard date))) (error (if (equal err overflow-error) - (apply 'signal err) + (signal (car err) (cdr err)) (error "Invalid date: %s" date))))))))) ;;;###autoload (defalias 'time-to-seconds 'float-time) ;;;###autoload -(defun seconds-to-time (seconds) - "Convert SECONDS to a time value." - (time-add 0 seconds)) +(defalias 'seconds-to-time 'encode-time) ;;;###autoload (defun days-to-time (days) "Convert DAYS into a time value." - (let ((time (condition-case nil (seconds-to-time (* 86400.0 days)) - (range-error (list most-positive-fixnum 65535))))) - (if (integerp days) + (let ((time (encode-time (* 86400 days)))) + ;; Traditionally, this returned a two-element list if DAYS was an integer. + ;; Keep that tradition if encode-time outputs timestamps in list form. + (if (and (integerp days) (consp (cdr time))) (setcdr (cdr time) nil)) time)) @@ -236,7 +237,7 @@ DATE1 and DATE2 should be date-time strings." TIME should be a time value. The Gregorian date Sunday, December 31, 1bce is imaginary." (let* ((tim (decode-time time)) - (year (nth 5 tim))) + (year (decoded-time-year tim))) (+ (time-date--day-in-year tim) ; Days this year (* 365 (1- year)) ; + Days in prior years (/ (1- year) 4) ; + Julian leap years @@ -278,9 +279,7 @@ return something of the form \"001 year\". 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. - -This function does not work for SECONDS greater than `most-positive-fixnum'." +is output until the first non-zero unit is encountered." (let ((start 0) (units '(("y" "year" 31536000) ("d" "day" 86400) @@ -307,6 +306,7 @@ This function does not work for SECONDS greater than `most-positive-fixnum'." (push match usedunits))) (and zeroflag larger (error "Units are not in decreasing order of size")) + (setq seconds (floor seconds)) (dolist (u units) (setq spec (car u) name (cadr u) @@ -352,6 +352,152 @@ This function does not work for SECONDS greater than `most-positive-fixnum'." (<= (car here) delay))) (concat (format "%.2f" (/ delay (car (cddr here)))) (cadr here)))))) +(defun date-days-in-month (year month) + "The number of days in MONTH in YEAR." + (if (= month 2) + (if (date-leap-year-p year) + 29 + 28) + (if (memq month '(1 3 5 7 8 10 12)) + 31 + 30))) + +(defun date-ordinal-to-time (year ordinal) + "Convert a YEAR/ORDINAL to the equivalent `decoded-time' structure. +ORDINAL is the number of days since the start of the year, with +January 1st being 1." + (let ((month 1)) + (while (> ordinal (date-days-in-month year month)) + (setq ordinal (- ordinal (date-days-in-month year month)) + month (1+ month))) + (list nil nil nil ordinal month year nil nil nil))) + +(defun decoded-time-add (time delta) + "Add DELTA to TIME, both of which are `decoded-time' structures. +TIME should represent a time, while DELTA should only have +non-nil integers 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. + +If applying a month/year delta leaves the time spec invalid, it +is decreased to be valid (\"add one month\" to January 31st 2019 +will yield a result of February 28th 2019 and \"add one year\" to +February 29th 2020 will result in February 28th 2021). + +Fields are added in a most to least significant order, so if the +adjustment described above happens, it happens before adding +days, hours, minutes or seconds. + +When changing the time bits in TIME (i.e., second/minute/hour), +changes in daylight saving time are not taken into account." + (let ((time (copy-sequence time)) + seconds) + ;; Years are simple. + (when (decoded-time-year delta) + (cl-incf (decoded-time-year time) (decoded-time-year delta))) + + ;; Months are pretty simple. + (when (decoded-time-month delta) + (let ((new (+ (decoded-time-month time) (decoded-time-month delta)))) + (setf (decoded-time-month time) (mod new 12)) + (cl-incf (decoded-time-year time) (/ new 12)))) + + ;; Adjust for month length (as described in the doc string). + (setf (decoded-time-day time) + (min (date-days-in-month (decoded-time-year time) + (decoded-time-month time)) + (decoded-time-day time))) + + ;; Days are iterative. + (when-let* ((days (decoded-time-day delta))) + (let ((increase (> days 0)) + (days (abs days))) + (while (> days 0) + (decoded-time--alter-day time increase) + (cl-decf days)))) + + ;; Do the time part, which is pretty simple (except for leap + ;; seconds, I guess). + (setq seconds (+ (* (or (decoded-time-hour delta) 0) 3600) + (* (or (decoded-time-minute delta) 0) 60) + (or (decoded-time-second delta) 0))) + + ;; Time zone adjustments are basically the same as time adjustments. + (setq seconds (+ seconds (or (decoded-time-zone delta) 0))) + + (cond + ((> seconds 0) + (decoded-time--alter-second time seconds t)) + ((< seconds 0) + (decoded-time--alter-second time (abs seconds) nil))) + + time)) + +(defun decoded-time--alter-month (time increase) + "Increase or decrease the month in TIME by 1." + (if increase + (progn + (cl-incf (decoded-time-month time)) + (when (> (decoded-time-month time) 12) + (setf (decoded-time-month time) 1) + (cl-incf (decoded-time-year time)))) + (cl-decf (decoded-time-month time)) + (when (zerop (decoded-time-month time)) + (setf (decoded-time-month time) 12) + (cl-decf (decoded-time-year time))))) + +(defun decoded-time--alter-day (time increase) + "Increase or decrease the day in TIME by 1." + (if increase + (progn + (cl-incf (decoded-time-day time)) + (when (> (decoded-time-day time) + (date-days-in-month (decoded-time-year time) + (decoded-time-month time))) + (setf (decoded-time-day time) 1) + (decoded-time--alter-month time t))) + (cl-decf (decoded-time-day time)) + (when (zerop (decoded-time-day time)) + (decoded-time--alter-month time nil) + (setf (decoded-time-day time) + (date-days-in-month (decoded-time-year time) + (decoded-time-month time)))))) + +(defun decoded-time--alter-second (time seconds increase) + "Increase or decrease the time in TIME by SECONDS." + (let ((old (+ (* (or (decoded-time-hour time) 0) 3600) + (* (or (decoded-time-minute time) 0) 60) + (or (decoded-time-second time) 0)))) + + (if increase + (progn + (setq old (+ old seconds)) + (setf (decoded-time-second time) (% old 60) + (decoded-time-minute time) (% (/ old 60) 60) + (decoded-time-hour time) (% (/ old 3600) 24)) + ;; Hm... DST... + (let ((days (/ old (* 60 60 24)))) + (while (> days 0) + (decoded-time--alter-day time t) + (cl-decf days)))) + (setq old (abs (- old seconds))) + (setf (decoded-time-second time) (% old 60) + (decoded-time-minute time) (% (/ old 60) 60) + (decoded-time-hour time) (% (/ old 3600) 24)) + ;; Hm... DST... + (let ((days (/ old (* 60 60 24)))) + (while (> days 0) + (decoded-time--alter-day time nil) + (cl-decf days)))))) + +(cl-defun make-decoded-time (&key second minute hour + day month year + dst zone) + "Return a `decoded-time' structure with only the keywords given filled out." + (list second minute hour day month year nil dst zone)) + (provide 'time-date) ;;; time-date.el ends here diff --git a/lisp/calendar/timeclock.el b/lisp/calendar/timeclock.el index 769beddc3c4..60586e7aced 100644 --- a/lisp/calendar/timeclock.el +++ b/lisp/calendar/timeclock.el @@ -1,4 +1,4 @@ -;;; timeclock.el --- mode for keeping track of how much you work +;;; timeclock.el --- mode for keeping track of how much you work -*- lexical-binding:t -*- ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. @@ -62,7 +62,7 @@ ;; `timeclock-ask-before-exiting' to t using M-x customize (this is ;; the default), or by adding the following to your init file: ;; -;; (add-hook 'kill-emacs-query-functions 'timeclock-query-out) +;; (add-hook 'kill-emacs-query-functions #'timeclock-query-out) ;; NOTE: If you change your timelog file without using timeclock's ;; functions, or if you change the value of any of timeclock's @@ -75,6 +75,8 @@ ;;; Code: +(require 'cl-lib) + (defgroup timeclock nil "Keeping track of the time that gets spent." :group 'data) @@ -84,13 +86,11 @@ (defcustom timeclock-file (locate-user-emacs-file "timelog" ".timelog") "The file used to store timeclock data in." :version "24.4" ; added locate-user-emacs-file - :type 'file - :group 'timeclock) + :type 'file) (defcustom timeclock-workday (* 8 60 60) "The length of a work period in seconds." - :type 'integer - :group 'timeclock) + :type 'integer) (defcustom timeclock-relative t "Whether to make reported time relative to `timeclock-workday'. @@ -100,24 +100,21 @@ Tuesday is twelve hours -- relative to an averaged work period of eight hours -- or eight hours, non-relative. So relative time takes into account any discrepancy of time under-worked or over-worked on previous days. This only affects the timeclock mode line display." - :type 'boolean - :group 'timeclock) + :type 'boolean) (defcustom timeclock-get-project-function 'timeclock-ask-for-project "The function used to determine the name of the current project. When clocking in, and no project is specified, this function will be called to determine what is the current project to be worked on. If this variable is nil, no questions will be asked." - :type 'function - :group 'timeclock) + :type 'function) (defcustom timeclock-get-reason-function 'timeclock-ask-for-reason "A function used to determine the reason for clocking out. When clocking out, and no reason is specified, this function will be called to determine what is the reason. If this variable is nil, no questions will be asked." - :type 'function - :group 'timeclock) + :type 'function) (defcustom timeclock-get-workday-function nil "A function used to determine the length of today's workday. @@ -127,23 +124,24 @@ the return value is nil, or equal to `timeclock-workday', nothing special will be done. If it is a quantity different from `timeclock-workday', however, a record will be output to the timelog file to note the fact that that day has a length that is different from the norm." - :type '(choice (const nil) function) - :group 'timeclock) + :type '(choice (const nil) function)) (defcustom timeclock-ask-before-exiting t "If non-nil, ask if the user wants to clock out before exiting Emacs. This variable only has effect if set with \\[customize]." :set (lambda (symbol value) (if value - (add-hook 'kill-emacs-query-functions 'timeclock-query-out) - (remove-hook 'kill-emacs-query-functions 'timeclock-query-out)) + (add-hook 'kill-emacs-query-functions #'timeclock-query-out) + (remove-hook 'kill-emacs-query-functions #'timeclock-query-out)) (set symbol value)) - :type 'boolean - :group 'timeclock) + :type 'boolean) (defvar timeclock-update-timer nil "The timer used to update `timeclock-mode-string'.") +(define-obsolete-variable-alias 'timeclock-modeline-display + 'timeclock-mode-line-display "24.3") + ;; For byte-compiler. (defvar display-time-hook) (defvar timeclock-mode-line-display) @@ -169,7 +167,7 @@ a positive argument to force an update." (if (and currently-displaying (or (and value (boundp 'display-time-hook) - (memq 'timeclock-update-mode-line + (memq #'timeclock-update-mode-line display-time-hook)) (and (not value) timeclock-update-timer))) @@ -182,7 +180,6 @@ a positive argument to force an update." ;; FIXME: The return value isn't used, AFAIK! value)) :type 'boolean - :group 'timeclock :require 'time) (defcustom timeclock-first-in-hook nil @@ -191,40 +188,33 @@ Note that this hook is run before recording any events. Thus the value of `timeclock-hours-today', `timeclock-last-event' and the return value of function `timeclock-last-period' are relative previous to today." - :type 'hook - :group 'timeclock) + :type 'hook) (defcustom timeclock-load-hook nil "Hook that gets run after timeclock has been loaded." - :type 'hook - :group 'timeclock) + :type 'hook) (defcustom timeclock-in-hook nil "A hook run every time an \"in\" event is recorded." - :type 'hook - :group 'timeclock) + :type 'hook) (defcustom timeclock-day-over-hook nil "A hook that is run when the workday has been completed. This hook is only run if the current time remaining is being displayed in the mode line. See the variable `timeclock-mode-line-display'." - :type 'hook - :group 'timeclock) + :type 'hook) (defcustom timeclock-out-hook nil "A hook run every time an \"out\" event is recorded." - :type 'hook - :group 'timeclock) + :type 'hook) (defcustom timeclock-done-hook nil "A hook run every time a project is marked as completed." - :type 'hook - :group 'timeclock) + :type 'hook) (defcustom timeclock-event-hook nil "A hook run every time any event is recorded." - :type 'hook - :group 'timeclock) + :type 'hook) (defvar timeclock-last-event nil "A list containing the last event that was recorded. @@ -271,8 +261,6 @@ The time is bracketed by <> if you are clocked in, otherwise by [].") (define-obsolete-function-alias 'timeclock-modeline-display 'timeclock-mode-line-display "24.3") -(define-obsolete-variable-alias 'timeclock-modeline-display - 'timeclock-mode-line-display "24.3") ;;;###autoload (define-minor-mode timeclock-mode-line-display @@ -293,12 +281,12 @@ display (non-nil means on)." (or (memq 'timeclock-mode-string global-mode-string) (setq global-mode-string (append global-mode-string '(timeclock-mode-string)))) - (add-hook 'timeclock-event-hook 'timeclock-update-mode-line) + (add-hook 'timeclock-event-hook #'timeclock-update-mode-line) (when timeclock-update-timer (cancel-timer timeclock-update-timer) (setq timeclock-update-timer nil)) (if (boundp 'display-time-hook) - (remove-hook 'display-time-hook 'timeclock-update-mode-line)) + (remove-hook 'display-time-hook #'timeclock-update-mode-line)) (if timeclock-use-display-time (progn ;; Update immediately so there is a visible change @@ -307,15 +295,15 @@ display (non-nil means on)." (timeclock-update-mode-line) (message "Activate `display-time-mode' or turn off \ `timeclock-use-display-time' to see timeclock information")) - (add-hook 'display-time-hook 'timeclock-update-mode-line)) + (add-hook 'display-time-hook #'timeclock-update-mode-line)) (setq timeclock-update-timer (run-at-time nil 60 'timeclock-update-mode-line)))) (setq global-mode-string (delq 'timeclock-mode-string global-mode-string)) - (remove-hook 'timeclock-event-hook 'timeclock-update-mode-line) + (remove-hook 'timeclock-event-hook #'timeclock-update-mode-line) (if (boundp 'display-time-hook) (remove-hook 'display-time-hook - 'timeclock-update-mode-line)) + #'timeclock-update-mode-line)) (when timeclock-update-timer (cancel-timer timeclock-update-timer) (setq timeclock-update-timer nil)))) @@ -364,7 +352,8 @@ discover the name of the project." (if (not (= workday timeclock-workday)) (timeclock-log "h" (number-to-string (/ workday (if (zerop (% workday (* 60 60))) - 60 60.0) 60)))))) + 60 60.0) + 60)))))) (timeclock-log "i" (or project (and timeclock-get-project-function (or find-project @@ -416,12 +405,11 @@ If SHOW-SECONDS is non-nil, display second resolution. If TODAY-ONLY is non-nil, the display will be relative only to time worked today, ignoring the time worked on previous days." (interactive "P") - (let ((remainder (timeclock-workday-remaining - (or today-only - (not timeclock-relative)))) - (last-in (equal (car timeclock-last-event) "i")) - status) - (setq status + (let* ((remainder (timeclock-workday-remaining + (or today-only + (not timeclock-relative)))) + (last-in (equal (car timeclock-last-event) "i")) + (status (format "Currently %s since %s (%s), %s %s, leave at %s" (if last-in "IN" "OUT") (if show-seconds @@ -434,7 +422,7 @@ worked today, ignoring the time worked on previous days." (timeclock-seconds-to-string remainder show-seconds t) (if (> remainder 0) "remaining" "over") - (timeclock-when-to-leave-string show-seconds today-only))) + (timeclock-when-to-leave-string show-seconds today-only)))) (if (called-interactively-p 'interactive) (message "%s" status) status))) @@ -479,16 +467,10 @@ include the second count. If REVERSE-LEADER is non-nil, it means to output a \"+\" if the time value is negative, rather than a \"-\". This is used when negative time values have an inverted meaning (such as with time remaining, where negative time really means overtime)." - (if show-seconds - (format "%s%d:%02d:%02d" - (if (< seconds 0) (if reverse-leader "+" "-") "") - (truncate (/ (abs seconds) 60 60)) - (% (truncate (/ (abs seconds) 60)) 60) - (% (truncate (abs seconds)) 60)) - (format "%s%d:%02d" + (let ((s (abs (truncate seconds)))) + (format (if show-seconds "%s%d:%02d:%02d" "%s%d:%02d") (if (< seconds 0) (if reverse-leader "+" "-") "") - (truncate (/ (abs seconds) 60 60)) - (% (truncate (/ (abs seconds) 60)) 60)))) + (/ s 3600) (% (/ s 60) 60) (% s 60)))) (defsubst timeclock-currently-in-p () "Return non-nil if the user is currently clocked in." @@ -533,22 +515,19 @@ non-nil, the amount returned will be relative to past time worked." string))) (define-obsolete-function-alias 'timeclock-time-to-seconds 'float-time "26.1") -(define-obsolete-function-alias 'timeclock-seconds-to-time 'seconds-to-time - "26.1") +(define-obsolete-function-alias 'timeclock-seconds-to-time 'encode-time "26.1") ;; Should today-only be removed in favor of timeclock-relative? - gm (defsubst timeclock-when-to-leave (&optional today-only) "Return a time value representing the end of today's workday. If TODAY-ONLY is non-nil, the value returned will be relative only to the time worked today, and not to past time." - (seconds-to-time - (- (float-time) - (let ((discrep (timeclock-find-discrep))) - (if discrep - (if today-only - (cadr discrep) - (car discrep)) - 0.0))))) + (time-since (let ((discrep (timeclock-find-discrep))) + (if discrep + (if today-only + (cadr discrep) + (car discrep)) + 0)))) ;;;###autoload (defun timeclock-when-to-leave-string (&optional show-seconds @@ -607,23 +586,20 @@ OLD-DEFAULT hours are set for every day that has no number indicated." (defvar timeclock-last-project nil) (defun timeclock-completing-read (prompt alist &optional default) - "A version of `completing-read' that works on both Emacs and XEmacs. + "A version of `completing-read'. PROMPT, ALIST and DEFAULT are used for the PROMPT, COLLECTION and DEF arguments of `completing-read'." - (if (featurep 'xemacs) - (let ((str (completing-read prompt alist))) - (if (or (null str) (zerop (length str))) - default - str)) - (completing-read prompt alist nil nil nil nil default))) + (declare (obsolete completing-read "27.1")) + (completing-read prompt alist nil nil nil nil default)) (defun timeclock-ask-for-project () "Ask the user for the project they are clocking into." - (timeclock-completing-read + (completing-read (format "Clock into which project (default %s): " (or timeclock-last-project (car timeclock-project-list))) - (mapcar 'list timeclock-project-list) + timeclock-project-list + nil nil nil nil (or timeclock-last-project (car timeclock-project-list)))) @@ -631,8 +607,7 @@ arguments of `completing-read'." (defun timeclock-ask-for-reason () "Ask the user for the reason they are clocking out." - (timeclock-completing-read "Reason for clocking out: " - (mapcar 'list timeclock-reason-list))) + (completing-read "Reason for clocking out: " timeclock-reason-list)) (define-obsolete-function-alias 'timeclock-update-modeline 'timeclock-update-mode-line "24.3") @@ -685,8 +660,8 @@ being logged for. Normally only \"in\" events specify a project." "\n") (if (equal (downcase code) "o") (setq timeclock-last-period - (- (float-time now) - (float-time (cadr timeclock-last-event))) + (float-time + (time-subtract now (cadr timeclock-last-event))) timeclock-discrepancy (+ timeclock-discrepancy timeclock-last-period))) @@ -700,7 +675,7 @@ being logged for. Normally only \"in\" events specify a project." "\\([0-9]+\\)/\\([0-9]+\\)/\\([0-9]+\\)\\s-+" "\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)[ \t]*" "\\([^\n]*\\)")) -(defsubst timeclock-read-moment () +(defun timeclock-read-moment () "Read the moment under point from the timelog." (if (looking-at timeclock-moment-regexp) (let ((code (match-string 1)) @@ -721,30 +696,20 @@ recorded to disk. If MOMENT is non-nil, use that as the current time. This is only provided for coherency when used by `timeclock-discrepancy'." (if (equal (car timeclock-last-event) "i") - (- (float-time moment) - (float-time (cadr timeclock-last-event))) + (float-time (time-subtract moment (cadr timeclock-last-event))) timeclock-last-period)) +(cl-defstruct (timeclock-entry + (:constructor nil) (:copier nil) + (:type list)) + begin end project comment + ;; FIXME: Documented in docstring of timeclock-log-data, but I can't see + ;; where it's used in the code. + final-p) + (defsubst timeclock-entry-length (entry) "Return the length of ENTRY in seconds." - (- (float-time (cadr entry)) - (float-time (car entry)))) - -(defsubst timeclock-entry-begin (entry) - "Return the start time of ENTRY." - (car entry)) - -(defsubst timeclock-entry-end (entry) - "Return the end time of ENTRY." - (cadr entry)) - -(defsubst timeclock-entry-project (entry) - "Return the project of ENTRY." - (nth 2 entry)) - -(defsubst timeclock-entry-comment (entry) - "Return the comment of ENTRY." - (nth 3 entry)) + (float-time (time-subtract (cadr entry) (car entry)))) (defsubst timeclock-entry-list-length (entry-list) "Return the total length of ENTRY-LIST in seconds." @@ -763,22 +728,19 @@ This is only provided for coherency when used by (defsubst timeclock-entry-list-span (entry-list) "Return the total time in seconds spanned by ENTRY-LIST." - (- (float-time (timeclock-entry-list-end entry-list)) - (float-time (timeclock-entry-list-begin entry-list)))) + (float-time (time-subtract (timeclock-entry-list-end entry-list) + (timeclock-entry-list-begin entry-list)))) (defsubst timeclock-entry-list-break (entry-list) "Return the total break time (span - length) in ENTRY-LIST." (- (timeclock-entry-list-span entry-list) (timeclock-entry-list-length entry-list))) -(defsubst timeclock-entry-list-projects (entry-list) +(defun timeclock-entry-list-projects (entry-list) "Return a list of all the projects in ENTRY-LIST." - (let (projects proj) + (let (projects) (dolist (entry entry-list) - (setq proj (timeclock-entry-project entry)) - (if projects - (add-to-list 'projects proj) - (setq projects (list proj)))) + (cl-pushnew (timeclock-entry-project entry) projects :test #'equal)) projects)) (defsubst timeclock-day-required (day) @@ -854,9 +816,7 @@ This is only provided for coherency when used by (let (projects) (dolist (day day-list) (dolist (proj (timeclock-day-projects day)) - (if projects - (add-to-list 'projects proj) - (setq projects (list proj))))) + (cl-pushnew proj projects :test #'equal))) projects)) (defsubst timeclock-current-debt (&optional log-data) @@ -871,7 +831,7 @@ This is only provided for coherency when used by "Return a list of the cdrs of the date alist from LOG-DATA." (let (day-list) (dolist (date-list (timeclock-day-alist log-data)) - (setq day-list (cons (cdr date-list) day-list))) + (push (cdr date-list) day-list)) day-list)) (defsubst timeclock-project-alist (&optional log-data) @@ -1022,54 +982,55 @@ See the documentation for the given function if more info is needed." (and beg (not last) (setq last t event (list "o" now)))) (setq line (1+ line)) - (cond ((equal (car event) "b") - (setcar log-data (string-to-number (nth 2 event)))) - ((equal (car event) "h") - (setq last-date-limited (timeclock-time-to-date (cadr event)) - last-date-seconds (* (string-to-number (nth 2 event)) - 3600.0))) - ((equal (car event) "i") - (if beg - (error "Error in format of timelog file, line %d" line) - (setq beg t)) - (setq entry (list (cadr event) nil - (and (> (length (nth 2 event)) 0) - (nth 2 event)))) - (let ((date (timeclock-time-to-date (cadr event)))) - (if (and last-date - (not (equal date last-date))) - (progn - (setcar (cdr log-data) - (cons (cons last-date day) - (cadr log-data))) - (setq day (list (and last-date-limited - last-date-seconds)))) - (unless day - (setq day (list (and last-date-limited - last-date-seconds))))) - (setq last-date date - last-date-limited nil))) - ((equal (downcase (car event)) "o") - (if (not beg) - (error "Error in format of timelog file, line %d" line) - (setq beg nil)) - (setcar (cdr entry) (cadr event)) - (let ((desc (and (> (length (nth 2 event)) 0) - (nth 2 event)))) - (if desc - (nconc entry (list (nth 2 event)))) - (if (equal (car event) "O") - (nconc entry (if desc - (list t) - (list nil t)))) - (nconc day (list entry)) - (setq desc (nth 2 entry)) - (let ((proj (assoc desc (nth 2 log-data)))) - (if (null proj) - (setcar (cddr log-data) - (cons (cons desc (list entry)) - (nth 2 log-data))) - (nconc (cdr proj) (list entry))))))) + (pcase (car event) + ("b" + (setcar log-data (string-to-number (nth 2 event)))) + ("h" + (setq last-date-limited (timeclock-time-to-date (cadr event)) + last-date-seconds (* (string-to-number (nth 2 event)) + 3600.0))) + ("i" + (if beg + (error "Error in format of timelog file, line %d" line) + (setq beg t)) + (setq entry (list (cadr event) nil + (and (> (length (nth 2 event)) 0) + (nth 2 event)))) + (let ((date (timeclock-time-to-date (cadr event)))) + (if (and last-date + (not (equal date last-date))) + (progn + (setcar (cdr log-data) + (cons (cons last-date day) + (cadr log-data))) + (setq day (list (and last-date-limited + last-date-seconds)))) + (unless day + (setq day (list (and last-date-limited + last-date-seconds))))) + (setq last-date date + last-date-limited nil))) + ((or "o" "O") + (if (not beg) + (error "Error in format of timelog file, line %d" line) + (setq beg nil)) + (setcar (cdr entry) (cadr event)) + (let ((desc (and (> (length (nth 2 event)) 0) + (nth 2 event)))) + (if desc + (nconc entry (list (nth 2 event)))) + (if (equal (car event) "O") + (nconc entry (if desc + (list t) + (list nil t)))) + (nconc day (list entry)) + (setq desc (nth 2 entry)) + (let ((proj (assoc desc (nth 2 log-data)))) + (if (null proj) + (setcar (cddr log-data) + (cons (cons desc (list entry)) + (nth 2 log-data))) + (nconc (cdr proj) (list entry))))))) (forward-line)) (if day (setcar (cdr log-data) @@ -1135,7 +1096,7 @@ discrepancy, today's discrepancy, and the time worked today." last-date-limited nil) (if beg (error "Error in format of timelog file!") - (setq beg (float-time (cadr event)))))) + (setq beg (cadr event))))) ((equal (downcase (car event)) "o") (if (and (nth 2 event) (> (length (nth 2 event)) 0)) @@ -1143,7 +1104,7 @@ discrepancy, today's discrepancy, and the time worked today." (if (not beg) (error "Error in format of timelog file!") (setq timeclock-last-period - (- (float-time (cadr event)) beg) + (float-time (time-subtract (cadr event) beg)) accum (+ timeclock-last-period accum) beg nil)) (if (equal last-date todays-date) @@ -1178,21 +1139,19 @@ discrepancy, today's discrepancy, and the time worked today." "Given a time within a day, return 0:0:0 within that day. If optional argument TIME is non-nil, use that instead of the current time." (let ((decoded (decode-time time))) - (setcar (nthcdr 0 decoded) 0) - (setcar (nthcdr 1 decoded) 0) - (setcar (nthcdr 2 decoded) 0) - (apply 'encode-time decoded))) + (setf (decoded-time-second decoded) 0) + (setf (decoded-time-minute decoded) 0) + (setf (decoded-time-hour decoded) 0) + (encode-time decoded))) (defun timeclock-mean (l) "Compute the arithmetic mean of the values in the list L." - (let ((total 0) - (count 0)) - (dolist (thisl l) - (setq total (+ total thisl) - count (1+ count))) - (if (zerop count) - 0 - (/ total count)))) + (if (not (consp l)) + 0 + (let ((total 0)) + (dolist (thisl l) + (setq total (+ total thisl))) + (/ total (length l))))) (defun timeclock-generate-report (&optional html-p) "Generate a summary report based on the current timelog file. @@ -1223,9 +1182,7 @@ HTML-P is non-nil, HTML markup is added." (insert project "</b><br>\n") (insert project "*\n")) (let ((proj-data (cdr (assoc project (timeclock-project-alist log)))) - (two-weeks-ago (seconds-to-time - (- (float-time today) - (* 2 7 24 60 60)))) + (two-weeks-ago (time-subtract today (* 2 7 24 60 60))) two-week-len today-len) (while proj-data (if (not (time-less-p @@ -1276,18 +1233,10 @@ HTML-P is non-nil, HTML markup is added." <th>-1 year</th> </tr>") (let* ((day-list (timeclock-day-list)) - (thirty-days-ago (seconds-to-time - (- (float-time today) - (* 30 24 60 60)))) - (three-months-ago (seconds-to-time - (- (float-time today) - (* 90 24 60 60)))) - (six-months-ago (seconds-to-time - (- (float-time today) - (* 180 24 60 60)))) - (one-year-ago (seconds-to-time - (- (float-time today) - (* 365 24 60 60)))) + (thirty-days-ago (time-subtract today (* 30 24 60 60))) + (three-months-ago (time-subtract today (* 90 24 60 60))) + (six-months-ago (time-subtract today (* 180 24 60 60))) + (one-year-ago (time-subtract today (* 365 24 60 60))) (time-in (vector (list t) (list t) (list t) (list t) (list t))) (time-out (vector (list t) (list t) (list t) (list t) (list t))) (breaks (vector (list t) (list t) (list t) (list t) (list t))) @@ -1296,81 +1245,69 @@ HTML-P is non-nil, HTML markup is added." six-months-ago one-year-ago))) ;; collect statistics from complete timelog (dolist (day day-list) - (let ((i 0) (l 5)) - (while (< i l) - (unless (time-less-p - (timeclock-day-begin day) - (aref lengths i)) - (let ((base (float-time - (timeclock-day-base - (timeclock-day-begin day))))) - (nconc (aref time-in i) - (list (- (float-time (timeclock-day-begin day)) - base))) - (let ((span (timeclock-day-span day)) - (len (timeclock-day-length day)) - (req (timeclock-day-required day))) - ;; If the day's actual work length is less than - ;; 70% of its span, then likely the exit time - ;; and break amount are not worthwhile adding to - ;; the statistic - (when (and (> span 0) - (> (/ (float len) (float span)) 0.70)) - (nconc (aref time-out i) - (list (- (float-time (timeclock-day-end day)) - base))) - (nconc (aref breaks i) (list (- span len)))) - (if req - (setq len (+ len (- timeclock-workday req)))) - (nconc (aref workday i) (list len))))) - (setq i (1+ i))))) + (dotimes (i 5) + (unless (time-less-p + (timeclock-day-begin day) + (aref lengths i)) + (let ((base (timeclock-day-base (timeclock-day-begin day)))) + (nconc (aref time-in i) + (list (float-time (time-subtract + (timeclock-day-begin day) + base)))) + (let ((span (timeclock-day-span day)) + (len (timeclock-day-length day)) + (req (timeclock-day-required day))) + ;; If the day's actual work length is less than + ;; 70% of its span, then likely the exit time + ;; and break amount are not worthwhile adding to + ;; the statistic + (when (and (> span 0) + (> (/ (float len) (float span)) 0.70)) + (nconc (aref time-out i) + (list (float-time (time-subtract + (timeclock-day-end day) + base)))) + (nconc (aref breaks i) (list (- span len)))) + (if req + (setq len (+ len (- timeclock-workday req)))) + (nconc (aref workday i) (list len))))))) ;; average statistics - (let ((i 0) (l 5)) - (while (< i l) - (aset time-in i (timeclock-mean (cdr (aref time-in i)))) - (aset time-out i (timeclock-mean (cdr (aref time-out i)))) - (aset breaks i (timeclock-mean (cdr (aref breaks i)))) - (aset workday i (timeclock-mean (cdr (aref workday i)))) - (setq i (1+ i)))) + (dotimes (i 5) + (aset time-in i (timeclock-mean (cdr (aref time-in i)))) + (aset time-out i (timeclock-mean (cdr (aref time-out i)))) + (aset breaks i (timeclock-mean (cdr (aref breaks i)))) + (aset workday i (timeclock-mean (cdr (aref workday i))))) ;; Output the HTML table (insert "<tr>\n") (insert "<td align=\"center\">Time in</td>\n") - (let ((i 0) (l 5)) - (while (< i l) - (insert "<td align=\"right\">" - (timeclock-seconds-to-string (aref time-in i)) - "</td>\n") - (setq i (1+ i)))) + (dotimes (i 5) + (insert "<td align=\"right\">" + (timeclock-seconds-to-string (aref time-in i)) + "</td>\n")) (insert "</tr>\n") (insert "<tr>\n") (insert "<td align=\"center\">Time out</td>\n") - (let ((i 0) (l 5)) - (while (< i l) - (insert "<td align=\"right\">" - (timeclock-seconds-to-string (aref time-out i)) - "</td>\n") - (setq i (1+ i)))) + (dotimes (i 5) + (insert "<td align=\"right\">" + (timeclock-seconds-to-string (aref time-out i)) + "</td>\n")) (insert "</tr>\n") (insert "<tr>\n") (insert "<td align=\"center\">Break</td>\n") - (let ((i 0) (l 5)) - (while (< i l) - (insert "<td align=\"right\">" - (timeclock-seconds-to-string (aref breaks i)) - "</td>\n") - (setq i (1+ i)))) + (dotimes (i 5) + (insert "<td align=\"right\">" + (timeclock-seconds-to-string (aref breaks i)) + "</td>\n")) (insert "</tr>\n") (insert "<tr>\n") (insert "<td align=\"center\">Workday</td>\n") - (let ((i 0) (l 5)) - (while (< i l) - (insert "<td align=\"right\">" - (timeclock-seconds-to-string (aref workday i)) - "</td>\n") - (setq i (1+ i)))) + (dotimes (i 5) + (insert "<td align=\"right\">" + (timeclock-seconds-to-string (aref workday i)) + "</td>\n")) (insert "</tr>\n")) (insert "<tfoot> <td colspan=\"6\" align=\"center\"> @@ -1393,6 +1330,7 @@ HTML-P is non-nil, HTML markup is added." ;; make sure we know the list of reasons, projects, and have computed ;; the last event and current discrepancy. (if (file-readable-p timeclock-file) + ;; FIXME: Loading a file should not have these kinds of side-effects. (timeclock-reread-log)) ;;; timeclock.el ends here diff --git a/lisp/calendar/todo-mode.el b/lisp/calendar/todo-mode.el index 892e8bee95e..909f59f19c8 100644 --- a/lisp/calendar/todo-mode.el +++ b/lisp/calendar/todo-mode.el @@ -188,25 +188,17 @@ The final element is \"*\", indicating an unspecified month.") "Array of abbreviated month names, in order. The final element is \"*\", indicating an unspecified month.") -(with-no-warnings - ;; FIXME: These vars lack a prefix, but this is out of our control, because - ;; they're defined by Calendar, e.g. for calendar-date-display-form. - (defvar dayname) - (defvar monthname) - (defvar day) - (defvar month) - (defvar year)) - (defconst todo-date-pattern (let ((dayname (diary-name-pattern calendar-day-name-array nil t))) (concat "\\(?4:\\(?5:" dayname "\\)\\|" - (let ((dayname) - (monthname (format "\\(?6:%s\\)" (diary-name-pattern - todo-month-name-array - todo-month-abbrev-array))) - (month "\\(?7:[0-9]+\\|\\*\\)") - (day "\\(?8:[0-9]+\\|\\*\\)") - (year "-?\\(?9:[0-9]+\\|\\*\\)")) + (calendar-dlet* + ((dayname) + (monthname (format "\\(?6:%s\\)" (diary-name-pattern + todo-month-name-array + todo-month-abbrev-array))) + (month "\\(?7:[0-9]+\\|\\*\\)") + (day "\\(?8:[0-9]+\\|\\*\\)") + (year "-?\\(?9:[0-9]+\\|\\*\\)")) (mapconcat #'eval calendar-date-display-form "")) "\\)")) "Regular expression matching a todo item date header.") @@ -861,17 +853,18 @@ category. With non-nil argument BACK, visit the numerically previous category (the highest numbered one, if the current category is the first)." (interactive) - (setq todo-category-number - (1+ (mod (- todo-category-number (if back 2 0)) - (length todo-categories)))) - (when todo-skip-archived-categories - (while (and (zerop (todo-get-count 'todo)) - (zerop (todo-get-count 'done)) - (not (zerop (todo-get-count 'archived)))) - (setq todo-category-number - (funcall (if back #'1- #'1+) todo-category-number)))) - (todo-category-select) - (goto-char (point-min))) + (let ((setcatnum (lambda () (1+ (mod (- todo-category-number + (if back 2 0)) + (length todo-categories)))))) + (setq todo-category-number (funcall setcatnum)) + (when todo-skip-archived-categories + (while (and (zerop (todo-get-count 'todo)) + (zerop (todo-get-count 'done)) + (not (zerop (todo-get-count 'archived)))) + (setq todo-category-number (funcall setcatnum)))) + (todo-category-select) + (if transient-mark-mode (deactivate-mark)) + (goto-char (point-min)))) (defun todo-backward-category () "Visit the numerically previous category in this todo file. @@ -881,6 +874,7 @@ category." (todo-forward-category t)) (defvar todo-categories-buffer) +(declare-function hl-line-highlight "hl-line" ()) (defun todo-jump-to-category (&optional file where) "Prompt for a category in a todo file and jump to it. @@ -936,11 +930,13 @@ Categories mode." (when goto-archive (todo-archive-mode)) (set-window-buffer (selected-window) (set-buffer (find-buffer-visiting file0))) + (if transient-mark-mode (deactivate-mark)) (unless todo-global-current-todo-file (setq todo-global-current-todo-file todo-current-todo-file)) (todo-category-number category) (todo-category-select) (goto-char (point-min)) + (if (bound-and-true-p hl-line-mode) (hl-line-highlight)) (when add-item (todo-insert-item--basic)))))) (defun todo-next-item (&optional count) @@ -1026,15 +1022,17 @@ empty line above the done items separator." (setq shown (progn (goto-char (point-min)) (re-search-forward todo-done-string-start nil t))) - (if (not (pos-visible-in-window-p shown)) - (recenter) - (goto-char opoint))))))) + (if (pos-visible-in-window-p shown) + (goto-char opoint) + (recenter) + (if transient-mark-mode (deactivate-mark)))))))) (defun todo-toggle-view-done-only () "Switch between displaying only done or only todo items." (interactive) (setq todo-show-done-only (not todo-show-done-only)) - (todo-category-select)) + (todo-category-select) + (if transient-mark-mode (deactivate-mark))) (defun todo-toggle-item-highlighting () "Highlight or unhighlight the todo item the cursor is on." @@ -1109,7 +1107,9 @@ Noninteractively, return the name of the new file." (progn (set-window-buffer (selected-window) (set-buffer (find-file-noselect file))) - (setq todo-current-todo-file file) + ;; Since buffer is not yet in todo-mode, we need to + ;; explicitly make todo-current-todo-file buffer local. + (setq-local todo-current-todo-file file) (todo-show)) file))) @@ -1245,9 +1245,10 @@ this command should be used with caution." (widen) (todo-edit-mode) (remove-overlays) - (display-warning 'todo (format "\ + (display-warning + 'todo (format "\ -Type %s to return to Todo mode. +Type %s to return to Todo%s mode. This also runs a file format check and signals an error if the format has become invalid. However, this check cannot @@ -1257,7 +1258,12 @@ You can repair this inconsistency by invoking the command `todo-repair-categories-sexp', but this will revert any renumbering of the categories you have made, so you will have to renumber them again (see `(todo-mode) Reordering -Categories')." (substitute-command-keys "\\[todo-edit-quit]")))) +Categories'). +" + (substitute-command-keys "\\[todo-edit-quit]") + (if (equal "toda" (file-name-extension + (buffer-file-name))) + " Archive" "")))) (defun todo-add-category (&optional file cat) "Add a new category to a todo file. @@ -1833,7 +1839,6 @@ consist of the last todo items and the first done items." (defvar todo-date-from-calendar nil "Helper variable for setting item date from the Emacs Calendar.") -(defvar todo-insert-item--keys-so-far) (defvar todo-insert-item--parameters) (defun todo-insert-item (&optional arg) @@ -1855,8 +1860,7 @@ already been entered and which remain available. See `(todo-mode) Inserting New Items' for details of the parameters, their associated keys and their effects." (interactive "P") - (setq todo-insert-item--keys-so-far "i") - (todo-insert-item--next-param nil (list arg) todo-insert-item--parameters)) + (todo-insert-item--next-param (list arg) todo-insert-item--parameters nil "i")) (defun todo-insert-item--basic (&optional arg diary-type date-type time where) "Function implementing the core of `todo-insert-item'." @@ -1868,15 +1872,18 @@ their associated keys and their effects." (region (eq where 'region)) (here (eq where 'here)) diary-item) - (when copy - (cond - ((not (eq major-mode 'todo-mode)) - (user-error "You must be in Todo mode to copy a todo item")) - ((todo-done-item-p) - (user-error "You cannot copy a done item as a new todo item")) - ((looking-at "^$") - (user-error "Point must be on a todo item to copy it"))) - (setq diary-item (todo-diary-item-p))) + (when (and arg here) + (user-error "Here insertion only valid in current category")) + (when (and (or copy here) + (or (not (eq major-mode 'todo-mode)) (todo-done-item-p) + (when copy (looking-at "^$")) + (save-excursion + (beginning-of-line) + ;; Point is on done items separator. + (looking-at todo-category-done)))) + (user-error (concat "Item " (if copy "copying" "insertion") + " is not valid here"))) + (when copy (setq diary-item (todo-diary-item-p))) (when region (let (use-empty-active-region) (unless (and todo-use-only-highlighted-region (use-region-p)) @@ -1884,7 +1891,6 @@ their associated keys and their effects." (let* ((obuf (current-buffer)) (ocat (todo-current-category)) (opoint (point)) - (todo-mm (eq major-mode 'todo-mode)) (cat+file (cond ((equal arg '(4)) (todo-read-category "Insert in category: ")) ((equal arg '(16)) @@ -1902,7 +1908,10 @@ their associated keys and their effects." (new-item (cond (copy (todo-item-string)) (region (buffer-substring-no-properties (region-beginning) (region-end))) - (t (read-from-minibuffer "Todo item: ")))) + (t (if (eq major-mode 'todo-archive-mode) + (user-error (concat "Cannot insert a new Todo" + " item in an archive")) + (read-from-minibuffer "Todo item: "))))) (date-string (cond ((eq date-type 'date) (todo-read-date)) @@ -1923,7 +1932,7 @@ their associated keys and their effects." (calendar-current-date) t t)))) (time-string (or (and time (todo-read-time)) (and todo-always-add-time-string - (substring (current-time-string) 11 16))))) + (format-time-string "%H:%M"))))) (setq todo-date-from-calendar nil) (find-file-noselect file 'nowarn) (set-window-buffer (selected-window) @@ -1939,7 +1948,6 @@ their associated keys and their effects." (unless todo-global-current-todo-file (setq todo-global-current-todo-file todo-current-todo-file)) (let ((buffer-read-only nil) - (called-from-outside (not (and todo-mm (equal cat ocat)))) done-only item-added) (unless copy (setq new-item @@ -1963,14 +1971,8 @@ their associated keys and their effects." "\n\t" new-item nil nil 1))) (unwind-protect (progn - ;; Make sure the correct category is selected. There - ;; are two cases: (i) we just visited the file, so no - ;; category is selected yet, or (ii) we invoked - ;; insertion "here" from outside the category we want - ;; to insert in (with priority insertion, category - ;; selection is done by todo-set-item-priority). - (when (or (= (- (point-max) (point-min)) (buffer-size)) - (and here called-from-outside)) + ;; If we just visited the file, no category is selected yet. + (when (= (- (point-max) (point-min)) (buffer-size)) (todo-category-number cat) (todo-category-select)) ;; If only done items are displayed in category, @@ -1981,16 +1983,7 @@ their associated keys and their effects." (setq done-only t) (todo-toggle-view-done-only)) (if here - (progn - ;; If command was invoked with point in done - ;; items section or outside of the current - ;; category, can't insert "here", so to be - ;; useful give new item top priority. - (when (or (todo-done-item-section-p) - called-from-outside - done-only) - (goto-char (point-min))) - (todo-insert-with-overlays new-item)) + (todo-insert-with-overlays new-item) (todo-set-item-priority new-item cat t)) (setq item-added t)) ;; If user cancels before setting priority, restore @@ -2105,20 +2098,24 @@ the item at point." (setq todo-categories-with-marks (assq-delete-all cat todo-categories-with-marks))) (todo-update-categories-sexp) - (todo-prefix-overlays))) + (todo-prefix-overlays) + (when (and (zerop (todo-get-count 'diary)) + (save-excursion + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote todo-category-done)) + nil t))) + (let (todo-show-with-done) (todo-category-select))))) (if ov (delete-overlay ov))))) -(defvar todo-edit-item--param-key-alist) -(defvar todo-edit-done-item--param-key-alist) - (defun todo-edit-item (&optional arg) "Choose an editing operation for the current item and carry it out." (interactive "P") (let ((marked (assoc (todo-current-category) todo-categories-with-marks))) (cond ((and (todo-done-item-p) (not marked)) - (todo-edit-item--next-key todo-edit-done-item--param-key-alist)) + (todo-edit-item--next-key 'done arg)) ((or marked (todo-item-string)) - (todo-edit-item--next-key todo-edit-item--param-key-alist arg))))) + (todo-edit-item--next-key 'todo arg))))) (defun todo-edit-item--text (&optional arg) "Function providing the text editing facilities of `todo-edit-item'." @@ -2241,7 +2238,8 @@ made in the number or names of categories." (insert item)) (kill-buffer) (unless (eq (current-buffer) buf) - (set-window-buffer (selected-window) (set-buffer buf)))) + (set-window-buffer (selected-window) (set-buffer buf))) + (if transient-mark-mode (deactivate-mark))) ;; We got here via `F e'. (when (todo-check-format) ;; FIXME: separate out sexp check? @@ -2251,7 +2249,9 @@ made in the number or names of categories." ;; (todo-repair-categories-sexp) ;; Compare (todo-make-categories-list t) with sexp and if ;; different ask (todo-update-categories-sexp) ? - (todo-mode) + (if (equal (file-name-extension (buffer-file-name)) "toda") + (todo-archive-mode) + (todo-mode)) (let* ((cat-beg (concat "^" (regexp-quote todo-category-beg) "\\(.*\\)$")) (curline (buffer-substring-no-properties @@ -2274,8 +2274,8 @@ made in the number or names of categories." ;; `todo-edit-item' as e.g. `-' or `C-u'. (inc (prefix-numeric-value inc)) (buffer-read-only nil) - ndate ntime year monthname month day - dayname) ; Needed by calendar-date-display-form. + ndate ntime + year monthname month day dayname) (when marked (todo--user-error-if-marked-done-item)) (save-excursion (or (and marked (goto-char (point-min))) (todo-item-start)) @@ -2348,7 +2348,7 @@ made in the number or names of categories." ((or (string= omonth "*") (= mm 13)) (user-error "Cannot increment *")) (t - (let ((mminc (+ mm inc))) + (let ((mminc (+ mm inc (if (< inc 0) 12 0)))) ;; Increment or decrement month by INC ;; modulo 12. (setq mm (% mminc 12)) @@ -2416,7 +2416,15 @@ made in the number or names of categories." ;; If year, month or day date string components were ;; changed, rebuild the date string. (when (memq what '(year month day)) - (setq ndate (mapconcat #'eval calendar-date-display-form "")))) + (setq ndate + (calendar-dlet* + ;; Needed by calendar-date-display-form. + ((year year) + (monthname monthname) + (month month) + (day day) + (dayname dayname)) + (mapconcat #'eval calendar-date-display-form ""))))) (when ndate (replace-match ndate nil nil nil 1)) ;; Add new time string to the header, if it was supplied. (when ntime @@ -2549,7 +2557,11 @@ whose value can be either of the symbols `raise' or `lower', meaning to raise or lower the item's priority by one." (interactive) (unless (and (or (called-interactively-p 'any) (memq arg '(raise lower))) - (or (todo-done-item-p) (looking-at "^$"))) + ;; Noop if point is not on a todo (i.e. not done) item. + (or (todo-done-item-p) (looking-at "^$") + ;; On done items separator. + (save-excursion (beginning-of-line) + (looking-at todo-category-done)))) (let* ((item (or item (todo-item-string))) (marked (todo-marked-item-p)) (cat (or cat (cond ((eq major-mode 'todo-mode) @@ -2697,9 +2709,13 @@ section in the category moved to." (interactive "P") (let* ((cat1 (todo-current-category)) (marked (assoc cat1 todo-categories-with-marks))) - ;; Noop if point is not on an item and there are no marked items. - (unless (and (looking-at "^$") - (not marked)) + (unless + ;; Noop if point is not on an item and there are no marked items. + (and (or (looking-at "^$") + ;; On done items separator. + (save-excursion (beginning-of-line) + (looking-at todo-category-done))) + (not marked)) (let* ((buffer-read-only) (file1 todo-current-todo-file) (item (todo-item-string)) @@ -2856,14 +2872,17 @@ visible." (let* ((cat (todo-current-category)) (marked (assoc cat todo-categories-with-marks))) (when marked (todo--user-error-if-marked-done-item)) - (unless (and (not marked) - (or (todo-done-item-p) - ;; Point is between todo and done items. - (looking-at "^$"))) + (unless + ;; Noop if point is not on a todo (i.e. not done) item and + ;; there are no marked items. + (and (or (todo-done-item-p) (looking-at "^$") + ;; On done items separator. + (save-excursion (beginning-of-line) + (looking-at todo-category-done))) + (not marked)) (let* ((date-string (calendar-date-string (calendar-current-date) t t)) (time-string (if todo-always-add-time-string - (concat " " (substring (current-time-string) - 11 16)) + (format-time-string " %H:%M") "")) (done-prefix (concat "[" todo-done-string date-string time-string "] ")) @@ -3830,6 +3849,7 @@ face." (goto-char (point-min)) (while (not (eobp)) (setq match (re-search-forward regex nil t)) + (if (and match transient-mark-mode) (deactivate-mark)) (goto-char (line-beginning-position)) (unless (or (equal (point) 1) (looking-at (concat "^" (regexp-quote todo-category-beg)))) @@ -4028,19 +4048,22 @@ regexp items." (interactive "P") (todo-filter-items 'regexp arg t)) +(defvar todo--fifiles-history nil + "List of short file names used by todo-find-filtered-items-file.") + (defun todo-find-filtered-items-file () "Choose a filtered items file and visit it." (interactive) (let ((files (directory-files todo-directory t "\\.tod[rty]$" t)) falist file) (dolist (f files) - (let ((type (cond ((equal (file-name-extension f) "todr") "regexp") + (let ((sf-name (todo-short-file-name f)) + (type (cond ((equal (file-name-extension f) "todr") "regexp") ((equal (file-name-extension f) "todt") "top") ((equal (file-name-extension f) "tody") "diary")))) - (push (cons (concat (todo-short-file-name f) " (" type ")") f) - falist))) - (setq file (completing-read "Choose a filtered items file: " - falist nil t nil nil (car falist))) + (push (cons (concat sf-name " (" type ")") f) falist))) + (setq file (completing-read "Choose a filtered items file: " falist nil t nil + 'todo--fifiles-history (caar falist))) (setq file (cdr (assoc-string file falist))) (find-file file) (unless (derived-mode-p 'todo-filtered-items-mode) @@ -4050,25 +4073,27 @@ regexp items." (defun todo-go-to-source-item () "Display the file and category of the filtered item at point." (interactive) - (let* ((str (todo-item-string)) - (buf (current-buffer)) - (res (todo-find-item str)) - (found (nth 0 res)) - (file (nth 1 res)) - (cat (nth 2 res))) - (if (not found) - (message "Category %s does not contain this item." cat) - (kill-buffer buf) - (set-window-buffer (selected-window) - (set-buffer (find-buffer-visiting file))) - (setq todo-current-todo-file file) - (setq todo-category-number (todo-category-number cat)) - (let ((todo-show-with-done (if (or todo-filter-done-items - (eq (cdr found) 'done)) - t - todo-show-with-done))) - (todo-category-select)) - (goto-char (car found))))) + (unless (looking-at "^$") ; Empty line at EOB. + (let* ((str (todo-item-string)) + (buf (current-buffer)) + (res (todo-find-item str)) + (found (nth 0 res)) + (file (nth 1 res)) + (cat (nth 2 res))) + (if (not found) + (message "Category %s does not contain this item." cat) + (kill-buffer buf) + (set-window-buffer (selected-window) + (set-buffer (find-buffer-visiting file))) + (setq todo-current-todo-file file) + (setq todo-category-number (todo-category-number cat)) + (let ((todo-show-with-done (if (or todo-filter-done-items + (eq (cdr found) 'done)) + t + todo-show-with-done))) + (todo-category-select)) + (if transient-mark-mode (deactivate-mark)) + (goto-char (car found)))))) (defvar todo-multiple-filter-files nil "List of files selected from `todo-multiple-filter-files' widget.") @@ -4520,8 +4545,11 @@ its priority has changed, and `same' otherwise." (defun todo-save-filtered-items-buffer () "Save current Filtered Items buffer to a file. If the file already exists, overwrite it only on confirmation." - (let ((filename (or (buffer-file-name) (todo-filter-items-filename)))) - (write-file filename t))) + (let ((filename (or (buffer-file-name) (todo-filter-items-filename))) + (bufname (buffer-name))) + (write-file filename t) + (setq buffer-read-only t) + (rename-buffer bufname))) ;; ----------------------------------------------------------------------------- ;;; Printing Todo mode buffers @@ -4613,12 +4641,13 @@ strings built using the default value of (defun todo-convert-legacy-date-time () "Return converted date-time string. Helper function for `todo-convert-legacy-files'." - (let* ((year (match-string 1)) - (month (match-string 2)) - (monthname (calendar-month-name (string-to-number month) t)) - (day (match-string 3)) - (time (match-string 4)) - dayname) + (calendar-dlet* + ((year (match-string 1)) + (month (match-string 2)) + (monthname (calendar-month-name (string-to-number month) t)) + (day (match-string 3)) + (time (match-string 4)) + dayname) (replace-match "") (insert (mapconcat #'eval calendar-date-display-form "") (when time (concat " " time))))) @@ -5075,7 +5104,7 @@ again." (defun todo-check-format () "Signal an error if the current todo file is ill-formatted. -Otherwise return t. Display a message if the file is well-formed +Otherwise return t. Display a warning if the file is well-formed but the categories sexp differs from the current value of `todo-categories'." (save-excursion @@ -5109,12 +5138,14 @@ but the categories sexp differs from the current value of (forward-line))) ;; Warn user if categories sexp has changed. (unless (string= ssexp cats) - (message (concat "The sexp at the beginning of the file differs " - "from the value of `todo-categories'.\n" - "If the sexp is wrong, you can fix it with " - "M-x todo-repair-categories-sexp,\n" - "but note this reverts any changes you have " - "made in the order of the categories.")))))) + (display-warning 'todo "\ + +The sexp at the beginning of the file differs from the value of +`todo-categories'. If the sexp is wrong, you can fix it with +M-x todo-repair-categories-sexp, but note this reverts any +changes you have made in the order of the categories. +" + ))))) t) (defun todo-item-start () @@ -5131,6 +5162,8 @@ but the categories sexp differs from the current value of (forward-line) (looking-at (concat "^" (regexp-quote todo-category-done)))))) + ;; Point is on done items separator. + (save-excursion (beginning-of-line) (looking-at todo-category-done)) ;; Buffer is widened. (looking-at (regexp-quote todo-category-beg))) (goto-char (line-beginning-position)) @@ -5140,8 +5173,11 @@ but the categories sexp differs from the current value of (defun todo-item-end () "Move to end of current todo item and return its position." - ;; Items cannot end with a blank line. - (unless (looking-at "^$") + (unless (or + ;; Items cannot end with a blank line. + (looking-at "^$") + ;; Point is on done items separator. + (save-excursion (beginning-of-line) (looking-at todo-category-done))) (let* ((done (todo-done-item-p)) (to-lim nil) ;; For todo items, end is before the done items section, for done @@ -5292,6 +5328,7 @@ Overrides `diary-goto-entry'." nil t) (todo-category-number (match-string 1)) (todo-category-select) + (if transient-mark-mode (deactivate-mark)) (goto-char opoint)))))) (add-function :override diary-goto-entry-function #'todo-diary-goto-entry) @@ -5493,12 +5530,14 @@ of each other." ;;; Generating and applying item insertion and editing key sequences ;; ----------------------------------------------------------------------------- -;; Thanks to Stefan Monnier for suggesting dynamically generating item -;; insertion commands and their key bindings, and offering an elegant -;; implementation, which, however, relies on lexical scoping and so -;; cannot be used here until the Calendar code used by todo-mode.el is -;; converted to lexical binding. Hence, the following implementation -;; uses dynamic binding. +;; Thanks to Stefan Monnier for (i) not only suggesting dynamically +;; generating item insertion commands and their key bindings but also +;; offering an elegant implementation which, however, since it used +;; lexical binding, was at the time incompatible with the Calendar and +;; Diary code in todo-mode.el; and (ii) later making that code +;; compatible with lexical binding, so that his implementation, of +;; which the following is a somewhat expanded version, could be +;; realized in todo-mode.el. (defconst todo-insert-item--parameters '((default copy) (diary nonmarking) (calendar date dayname) time (here region)) @@ -5506,91 +5545,33 @@ of each other." Passed by `todo-insert-item' to `todo-insert-item--next-param' to dynamically create item insertion commands.") -(defconst todo-insert-item--param-key-alist - '((default . "i") - (copy . "p") - (diary . "y") - (nonmarking . "k") - (calendar . "c") - (date . "d") - (dayname . "n") - (time . "t") - (here . "h") - (region . "r")) - "List pairing item insertion parameters with their completion keys.") - -(defsubst todo-insert-item--keyof (param) - "Return key paired with item insertion PARAM." - (cdr (assoc param todo-insert-item--param-key-alist))) - -(defun todo-insert-item--argsleft (key list) - "Return sublist of LIST whose first member corresponds to KEY." - (let (l sym) - (mapc (lambda (m) - (when (consp m) - (catch 'found1 - (dolist (s m) - (when (equal key (todo-insert-item--keyof s)) - (throw 'found1 (setq sym s)))))) - (if sym - (progn - (push sym l) - (setq sym nil)) - (push m l))) - list) - (setq list (reverse l))) - (memq (catch 'found2 - (dolist (e todo-insert-item--param-key-alist) - (when (equal key (cdr e)) - (throw 'found2 (car e))))) - list)) - -(defsubst todo-insert-item--this-key () (char-to-string last-command-event)) - -(defvar todo-insert-item--keys-so-far "" - "String of item insertion keys so far entered for this command.") - -(defvar todo-insert-item--args nil) -(defvar todo-insert-item--argleft nil) -(defvar todo-insert-item--argsleft nil) -(defvar todo-insert-item--newargsleft nil) - -(defun todo-insert-item--apply-args () - "Build list of arguments for item insertion and apply them. -The list consists of item insertion parameters that can be passed -as insertion command arguments in fixed positions. If a position -in the list is not occupied by the corresponding parameter, it is -occupied by nil." - (let* ((arg (list (car todo-insert-item--args))) - (args (nconc (cdr todo-insert-item--args) - (list (car (todo-insert-item--argsleft - (todo-insert-item--this-key) - todo-insert-item--argsleft))))) - (arglist (if (= 4 (length args)) - args - (let ((v (make-vector 4 nil)) elt) - (while args - (setq elt (pop args)) - (cond ((memq elt '(diary nonmarking)) - (aset v 0 elt)) - ((memq elt '(calendar date dayname)) - (aset v 1 elt)) - ((eq elt 'time) - (aset v 2 elt)) - ((memq elt '(copy here region)) - (aset v 3 elt)))) - (append v nil))))) - (apply #'todo-insert-item--basic (nconc arg arglist)))) - -(defun todo-insert-item--next-param (last args argsleft) - "Build item insertion command from LAST, ARGS and ARGSLEFT and call it. -Dynamically generate key bindings, prompting with the keys -already entered and those still available." - (cl-assert argsleft) +(defun todo-insert-item--next-param (args params last keys-so-far) + "Generate and invoke an item insertion command. +Dynamically generate the command, its arguments ARGS and its key +binding by recursing through the list of parameters PARAMS, +taking the LAST from a sublist and prompting with KEYS-SO-FAR +keys already entered and those still available." + (cl-assert params) (let* ((map (make-sparse-keymap)) + (param-key-alist '((default . "i") + (copy . "p") + (diary . "y") + (nonmarking . "k") + (calendar . "c") + (date . "d") + (dayname . "n") + (time . "t") + (here . "h") + (region . "r"))) + ;; Return key paired with given item insertion parameter. + (key-of (lambda (param) (cdr (assoc param param-key-alist)))) + ;; The key just typed. + (this-key (lambda () (char-to-string last-command-event))) (prompt nil) - (addprompt - (lambda (k name) + ;; Add successively entered keys to the prompt and show what + ;; possibilities remain. + (add-to-prompt + (lambda (key name) (setq prompt (concat prompt (format @@ -5600,80 +5581,119 @@ already entered and those still available." "%s=>%s" (when (memq name '(copy nonmarking dayname region)) " }")) - (propertize k 'face 'todo-key-prompt) - name)))))) - (setq todo-insert-item--args args) - (setq todo-insert-item--argsleft argsleft) + (propertize key 'face 'todo-key-prompt) + name))))) + ;; Return the sublist of the given list of parameters whose + ;; first member is paired with the given key. + (get-params + (lambda (key lst) + (setq lst (if (consp lst) lst (list lst))) + (let (l sym) + (mapc (lambda (m) + (when (consp m) + (catch 'found1 + (dolist (s m) + (when (equal key (funcall key-of s)) + (throw 'found1 (setq sym s)))))) + (if sym + (progn + (push sym l) + (setq sym nil)) + (push m l))) + lst) + (setq lst (reverse l))) + (memq (catch 'found2 + (dolist (e param-key-alist) + (when (equal key (cdr e)) + (throw 'found2 (car e))))) + lst))) + ;; Build list of arguments for item insertion and then + ;; execute the basic insertion function. The list consists of + ;; item insertion parameters that can be passed as insertion + ;; command arguments in fixed positions. If a position in + ;; the list is not occupied by the corresponding parameter, + ;; it is occupied by nil. + (gen-and-exec + (lambda () + (let* ((arg (list (car args))) ; Possible prefix argument. + (rest (nconc (cdr args) + (list (car (funcall get-params + (funcall this-key) + params))))) + (parlist (if (= 4 (length rest)) + rest + (let ((v (make-vector 4 nil)) elt) + (while rest + (setq elt (pop rest)) + (cond ((memq elt '(diary nonmarking)) + (aset v 0 elt)) + ((memq elt '(calendar date dayname)) + (aset v 1 elt)) + ((eq elt 'time) + (aset v 2 elt)) + ((memq elt '(copy here region)) + (aset v 3 elt)))) + (append v nil))))) + (apply #'todo-insert-item--basic (nconc arg parlist))))) + ;; Operate on a copy of the parameter list so the original is + ;; not consumed, thus available for the next key typed. + (params0 params)) (when last (if (memq last '(default copy)) (progn - (setq todo-insert-item--argsleft nil) - (todo-insert-item--apply-args)) - (let ((k (todo-insert-item--keyof last))) - (funcall addprompt k (make-symbol (concat (symbol-name last) ":GO!"))) - (define-key map (todo-insert-item--keyof last) + (setq params0 nil) + (funcall gen-and-exec)) + (let ((key (funcall key-of last))) + (funcall add-to-prompt key (make-symbol + (concat (symbol-name last) ":GO!"))) + (define-key map (funcall key-of last) (lambda () (interactive) - (todo-insert-item--apply-args)))))) - (while todo-insert-item--argsleft - (let ((x (car todo-insert-item--argsleft))) - (setq todo-insert-item--newargsleft (cdr todo-insert-item--argsleft)) - (dolist (argleft (if (consp x) x (list x))) - (let ((k (todo-insert-item--keyof argleft))) - (funcall addprompt k argleft) - (define-key map k - (if (null todo-insert-item--newargsleft) - (lambda () (interactive) - (todo-insert-item--apply-args)) - (lambda () (interactive) - (setq todo-insert-item--keys-so-far - (concat todo-insert-item--keys-so-far " " - (todo-insert-item--this-key))) - (todo-insert-item--next-param - (car (todo-insert-item--argsleft - (todo-insert-item--this-key) - todo-insert-item--argsleft)) - (nconc todo-insert-item--args - (list (car (todo-insert-item--argsleft - (todo-insert-item--this-key) - todo-insert-item--argsleft)))) - (cdr (todo-insert-item--argsleft - (todo-insert-item--this-key) - todo-insert-item--argsleft))))))))) - (setq todo-insert-item--argsleft todo-insert-item--newargsleft)) - (when prompt (message "Press a key (so far `%s'): %s" - todo-insert-item--keys-so-far prompt)) + (funcall gen-and-exec)))))) + (while params0 + (let* ((x (car params0)) + (restparams (cdr params0))) + (dolist (param (if (consp x) x (list x))) + (let ((key (funcall key-of param))) + (funcall add-to-prompt key param) + (define-key map key + (if (null restparams) + (lambda () (interactive) + (funcall gen-and-exec)) + (lambda () (interactive) + (setq keys-so-far (concat keys-so-far " " (funcall this-key))) + (todo-insert-item--next-param + (nconc args (list (car (funcall get-params + (funcall this-key) param)))) + (cdr (funcall get-params (funcall this-key) params)) + (car (funcall get-params (funcall this-key) param)) + keys-so-far)))))) + (setq params0 restparams))) (set-transient-map map) - (setq todo-insert-item--argsleft argsleft))) - -(defconst todo-edit-item--param-key-alist - '((edit . "e") - (header . "h") - (multiline . "m") - (diary . "y") - (nonmarking . "k") - (date . "d") - (time . "t")) - "Alist of item editing parameters and their keys.") - -(defconst todo-edit-item--date-param-key-alist - '((full . "f") - (calendar . "c") - (today . "a") - (dayname . "n") - (year . "y") - (month . "m") - (daynum . "d")) - "Alist of item date editing parameters and their keys.") - -(defconst todo-edit-done-item--param-key-alist - '((add/edit . "c") - (delete . "d")) - "Alist of done item comment editing parameters and their keys.") - -(defvar todo-edit-item--prompt "Press a key (so far `e'): ") - -(defun todo-edit-item--next-key (params &optional arg) - (let* ((p->k (mapconcat (lambda (elt) + (when prompt (message "Press a key (so far `%s'): %s" keys-so-far prompt)) + (setq params0 params))) + +(defun todo-edit-item--next-key (type &optional arg) + (let* ((todo-param-key-alist '((edit . "e") + (header . "h") + (multiline . "m") + (diary . "y") + (nonmarking . "k") + (date . "d") + (time . "t"))) + (done-param-key-alist '((add/edit . "c") + (delete . "d"))) + (date-param-key-alist '((full . "f") + (calendar . "c") + (today . "a") + (dayname . "n") + (year . "y") + (month . "m") + (daynum . "d"))) + (params (pcase type + ('todo todo-param-key-alist) + ('done done-param-key-alist) + ('date date-param-key-alist))) + (p->k (mapconcat (lambda (elt) (format "%s=>%s" (propertize (cdr elt) 'face 'todo-key-prompt) @@ -5682,31 +5702,32 @@ already entered and those still available." '(add/edit delete)) " comment")))) params " ")) - (key-prompt (substitute-command-keys todo-edit-item--prompt)) + (key-prompt (substitute-command-keys + (concat "Press a key (so far `e" + (if (eq type 'date) " d" "") + "'): "))) (this-key (let ((key (read-key (concat key-prompt p->k)))) (and (characterp key) (char-to-string key)))) (this-param (car (rassoc this-key params)))) (pcase this-param - (`edit (todo-edit-item--text)) - (`header (todo-edit-item--text 'include-header)) - (`multiline (todo-edit-item--text 'multiline)) - (`add/edit (todo-edit-item--text 'comment-edit)) - (`delete (todo-edit-item--text 'comment-delete)) - (`diary (todo-edit-item--diary-inclusion)) - (`nonmarking (todo-edit-item--diary-inclusion 'nonmarking)) - (`date (let ((todo-edit-item--prompt "Press a key (so far `e d'): ")) - (todo-edit-item--next-key - todo-edit-item--date-param-key-alist arg))) - (`full (progn (todo-edit-item--header 'date) + ('edit (todo-edit-item--text)) + ('header (todo-edit-item--text 'include-header)) + ('multiline (todo-edit-item--text 'multiline)) + ('add/edit (todo-edit-item--text 'comment-edit)) + ('delete (todo-edit-item--text 'comment-delete)) + ('diary (todo-edit-item--diary-inclusion)) + ('nonmarking (todo-edit-item--diary-inclusion 'nonmarking)) + ('date (todo-edit-item--next-key 'date arg)) + ('full (progn (todo-edit-item--header 'date) (when todo-always-add-time-string (todo-edit-item--header 'time)))) - (`calendar (todo-edit-item--header 'calendar)) - (`today (todo-edit-item--header 'today)) - (`dayname (todo-edit-item--header 'dayname)) - (`year (todo-edit-item--header 'year arg)) - (`month (todo-edit-item--header 'month arg)) - (`daynum (todo-edit-item--header 'day arg)) - (`time (todo-edit-item--header 'time))))) + ('calendar (todo-edit-item--header 'calendar)) + ('today (todo-edit-item--header 'today)) + ('dayname (todo-edit-item--header 'dayname)) + ('year (todo-edit-item--header 'year arg)) + ('month (todo-edit-item--header 'month arg)) + ('daynum (todo-edit-item--header 'day arg)) + ('time (todo-edit-item--header 'time))))) ;; ----------------------------------------------------------------------------- ;;; Todo minibuffer utilities @@ -5990,8 +6011,8 @@ indicating an unspecified month, day, or year. When ARG is `day', non-nil arguments MO and YR determine the number of the last the day of the month." - (let (year monthname month day - dayname) ; Needed by calendar-date-display-form. + (calendar-dlet* + (year monthname month day dayname) ;Needed by calendar-date-display-form. (when (or (not arg) (eq arg 'year)) (while (if (natnump year) (< year 1) (not (eq year '*))) (setq year (read-from-minibuffer @@ -6070,7 +6091,7 @@ the empty string (i.e., no time string)." (while (not valid) (setq answer (read-string "Enter a clock time: " nil nil (when todo-always-add-time-string - (substring (current-time-string) 11 16)))) + (format-time-string "%H:%M")))) (when (or (string= "" answer) (string-match diary-time-regexp answer)) (setq valid t))) @@ -6368,8 +6389,7 @@ Filtered Items mode following todo (not done) items." ;; ----------------------------------------------------------------------------- (defvar todo-key-bindings-t - `( - ("Af" todo-find-archive) + '(("Af" todo-find-archive) ("Ac" todo-choose-archive) ("Ad" todo-archive-done-item) ("Cv" todo-toggle-view-done-items) @@ -6400,13 +6420,11 @@ Filtered Items mode following todo (not done) items." ("k" todo-delete-item) ("m" todo-move-item) ("u" todo-item-undone) - ([remap newline] newline-and-indent) - ) + ([remap newline] newline-and-indent)) "List of key bindings for Todo mode only.") (defvar todo-key-bindings-t+a+f - `( - ("C*" todo-mark-category) + '(("C*" todo-mark-category) ("Cu" todo-unmark-category) ("Fh" todo-toggle-item-header) ("h" todo-toggle-item-header) @@ -6418,33 +6436,27 @@ Filtered Items mode following todo (not done) items." ("N" todo-toggle-prefix-numbers) ("PB" todo-print-buffer) ("PF" todo-print-buffer-to-file) - ("b" todo-backward-category) - ("d" todo-item-done) - ("f" todo-forward-category) ("j" todo-jump-to-category) ("n" todo-next-item) ("p" todo-previous-item) ("q" todo-quit) ("s" todo-save) - ("t" todo-show) - ) + ("t" todo-show)) "List of key bindings for Todo, Archive, and Filtered Items modes.") (defvar todo-key-bindings-t+a - `( - ("Fc" todo-show-categories-table) + '(("Fc" todo-show-categories-table) ("S" todo-search) ("X" todo-clear-matches) - ("*" todo-toggle-mark-item) - ) + ("b" todo-backward-category) + ("f" todo-forward-category) + ("*" todo-toggle-mark-item)) "List of key bindings for Todo and Todo Archive modes.") (defvar todo-key-bindings-t+f - `( - ("l" todo-lower-item-priority) + '(("l" todo-lower-item-priority) ("r" todo-raise-item-priority) - ("#" todo-set-item-priority) - ) + ("#" todo-set-item-priority)) "List of key bindings for Todo and Todo Filtered Items modes.") (defvar todo-mode-map @@ -6703,32 +6715,19 @@ Added to `window-configuration-change-hook' in Todo mode." (setq-local todo-current-todo-file (file-truename (buffer-file-name))) (setq-local todo-show-done-only t)) -(defun todo-mode-external-set () - "Set `todo-categories' externally to `todo-current-todo-file'." - (setq-local todo-current-todo-file todo-global-current-todo-file) - (let ((cats (with-current-buffer - ;; Can't use find-buffer-visiting when - ;; `todo-show-categories-table' is called on first - ;; invocation of `todo-show', since there is then - ;; no buffer visiting the current file. - (find-file-noselect todo-current-todo-file 'nowarn) - (or todo-categories - ;; In Todo Edit mode todo-categories is now nil - ;; since it uses same buffer as Todo mode but - ;; doesn't have the latter's local variables. - (save-excursion - (goto-char (point-min)) - (read (buffer-substring-no-properties - (line-beginning-position) - (line-end-position)))))))) - (setq-local todo-categories cats))) - (define-derived-mode todo-edit-mode text-mode "Todo-Ed" "Major mode for editing multiline todo items. \\{todo-edit-mode-map}" (todo-modes-set-1) - (todo-mode-external-set) + (if (> (buffer-size) (- (point-max) (point-min))) + ;; Editing one item in an indirect buffer, so buffer-file-name is nil. + (setq-local todo-current-todo-file todo-global-current-todo-file) + ;; When editing archive file, make sure it is current todo file. + (setq-local todo-current-todo-file (file-truename (buffer-file-name))) + ;; Need this when editing the whole file to return to the category + ;; editing was invoked from. + (setq-local todo-categories (todo-set-categories))) (setq buffer-read-only nil)) (put 'todo-categories-mode 'mode-class 'special) @@ -6737,7 +6736,15 @@ Added to `window-configuration-change-hook' in Todo mode." "Major mode for displaying and editing todo categories. \\{todo-categories-mode-map}" - (todo-mode-external-set)) + (setq-local todo-current-todo-file todo-global-current-todo-file) + (setq-local todo-categories + ;; Can't use find-buffer-visiting when + ;; `todo-show-categories-table' is called on first + ;; invocation of `todo-show', since there is then no + ;; buffer visiting the current file. + (with-current-buffer (find-file-noselect + todo-current-todo-file 'nowarn) + todo-categories))) (put 'todo-filtered-items-mode 'mode-class 'special) diff --git a/lisp/cedet/cedet-files.el b/lisp/cedet/cedet-files.el index b378bcfc253..d3becd5c845 100644 --- a/lisp/cedet/cedet-files.el +++ b/lisp/cedet/cedet-files.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Package: cedet ;; This file is part of GNU Emacs. diff --git a/lisp/cedet/cedet-global.el b/lisp/cedet/cedet-global.el index 0a6604b8e97..e3cd7a852a8 100644 --- a/lisp/cedet/cedet-global.el +++ b/lisp/cedet/cedet-global.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Package: cedet ;; This file is part of GNU Emacs. diff --git a/lisp/cedet/cedet-idutils.el b/lisp/cedet/cedet-idutils.el index 7b8be0767f8..f2fbe193621 100644 --- a/lisp/cedet/cedet-idutils.el +++ b/lisp/cedet/cedet-idutils.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2009-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Old-Version: 0.2 ;; Keywords: OO, lisp ;; Package: cedet diff --git a/lisp/cedet/cedet.el b/lisp/cedet/cedet.el index 92fede9e76c..9260cfb47dc 100644 --- a/lisp/cedet/cedet.el +++ b/lisp/cedet/cedet.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2002-2019 Free Software Foundation, Inc. ;; Author: David Ponce <david@dponce.com> -;; Maintainer: Eric M. Ludlam <zappo@gnu.org> +;; Maintainer: Eric M. Ludlam <zappo@gnu.org> ;; Version: 2.0 ;; Keywords: OO, lisp @@ -30,9 +30,6 @@ ;; load them all by doing (require 'cedet). This is mostly for ;; compatibility with the upstream, stand-alone CEDET distribution. -(eval-when-compile - (require 'cl)) - (declare-function inversion-find-version "inversion") (defconst cedet-version "2.0" diff --git a/lisp/cedet/data-debug.el b/lisp/cedet/data-debug.el index ba312433d38..0debbef54b5 100644 --- a/lisp/cedet/data-debug.el +++ b/lisp/cedet/data-debug.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Old-Version: 0.2 ;; Keywords: OO, lisp ;; Package: cedet @@ -49,25 +49,9 @@ ;;; Compatibility ;; -(if (featurep 'xemacs) - (eval-and-compile - (defalias 'data-debug-overlay-properties 'extent-properties) - (defalias 'data-debug-overlay-p 'extentp) - (if (not (fboundp 'propertize)) - (defun dd-propertize (string &rest properties) - "Mimic `propertize' in from Emacs 23." - (add-text-properties 0 (length string) properties string) - string - ) - (defalias 'dd-propertize 'propertize)) - ) - ;; Regular Emacs - (eval-and-compile - (defalias 'data-debug-overlay-properties 'overlay-properties) - (defalias 'data-debug-overlay-p 'overlayp) - (defalias 'dd-propertize 'propertize) - ) - ) +(defalias 'data-debug-overlay-properties 'overlay-properties) +(defalias 'data-debug-overlay-p 'overlayp) +(defalias 'dd-propertize 'propertize) ;;; GENERIC STUFF ;; @@ -920,14 +904,14 @@ If PARENT is non-nil, it is somehow related as a parent to thing." (interactive) (forward-line 1) (beginning-of-line) - (skip-chars-forward " *-><[]" (point-at-eol))) + (skip-chars-forward "- *><[]" (point-at-eol))) (defun data-debug-prev () "Go to the previous line in the Ddebug buffer." (interactive) (forward-line -1) (beginning-of-line) - (skip-chars-forward " *-><[]" (point-at-eol))) + (skip-chars-forward "- *><[]" (point-at-eol))) (defun data-debug-next-expando () "Go to the next line in the Ddebug buffer. @@ -1014,7 +998,7 @@ Do nothing if already contracted." (data-debug-current-line-expanded-p)) (data-debug-contract-current-line) (data-debug-expand-current-line)) - (skip-chars-forward " *-><[]" (point-at-eol))) + (skip-chars-forward "- *><[]" (point-at-eol))) (defun data-debug-expand-or-contract-mouse (event) "Expand or contract anything at event EVENT." diff --git a/lisp/cedet/ede.el b/lisp/cedet/ede.el index ea3cd9972fc..d051510a994 100644 --- a/lisp/cedet/ede.el +++ b/lisp/cedet/ede.el @@ -475,9 +475,6 @@ To be used in hook functions." (define-minor-mode ede-minor-mode "Toggle EDE (Emacs Development Environment) minor mode. -With a prefix argument ARG, enable EDE minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -EDE minor mode if ARG is omitted or nil. If this file is contained, or could be contained in an EDE controlled project, then this mode is activated automatically @@ -563,9 +560,6 @@ Sets buffer local variables for EDE." ;;;###autoload (define-minor-mode global-ede-mode "Toggle global EDE (Emacs Development Environment) mode. -With a prefix argument ARG, enable global EDE mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. This global minor mode enables `ede-minor-mode' in all buffers in an EDE controlled project." @@ -797,7 +791,7 @@ Optional argument NAME is the name to give this project." )) (inits (oref obj initializers))) ;; Force the name to match for new objects. - (eieio-object-set-name-string nobj (oref nobj name)) + (setf (slot-value nobj 'object-name) (oref nobj name)) ;; Handle init args. (while inits (eieio-oset nobj (car inits) (car (cdr inits))) @@ -1095,6 +1089,7 @@ Flush the dead projects from the project cache." )) (defvar ede--disable-inode) ;Defined in ede/files.el. +(declare-function ede--project-inode "ede/files" (proj)) (defun ede-global-list-sanity-check () "Perform a sanity check to make sure there are no duplicate projects." diff --git a/lisp/cedet/ede/auto.el b/lisp/cedet/ede/auto.el index 4871d51bc64..099d60fffa7 100644 --- a/lisp/cedet/ede/auto.el +++ b/lisp/cedet/ede/auto.el @@ -31,6 +31,7 @@ (require 'eieio) (require 'cl-generic) +(require 'eieio-base) (declare-function ede-directory-safe-p "ede") (declare-function ede-add-project-to-global-list "ede") @@ -136,7 +137,7 @@ into memory.") (declare-function ede-directory-safe-p "ede") (declare-function ede-add-project-to-global-list "ede") -(defclass ede-project-autoload () +(defclass ede-project-autoload (eieio-named) ((name :initarg :name :documentation "Name of this project type") (file :initarg :file diff --git a/lisp/cedet/ede/base.el b/lisp/cedet/ede/base.el index 41ab17f078d..a4e2464fd8d 100644 --- a/lisp/cedet/ede/base.el +++ b/lisp/cedet/ede/base.el @@ -46,7 +46,7 @@ ;; The TARGET is an entity in a project that knows about files ;; and features of those files. -(defclass ede-target (eieio-speedbar-directory-button) +(defclass ede-target (eieio-speedbar-directory-button eieio-named) ((buttonface :initform speedbar-file-face) ;override for superclass (name :initarg :name :type string @@ -628,15 +628,15 @@ instead of the current project." The other slot will be used to calculate values. PROJECT-FILE-NAME is a name of project file (short name, like `pom.xml', etc." (when (and (or (not (slot-boundp this :file)) - (not (oref this :file))) + (not (oref this file))) (slot-boundp this :directory) - (oref this :directory)) - (oset this :file (expand-file-name project-file-name (oref this :directory)))) + (oref this directory)) + (oset this file (expand-file-name project-file-name (oref this directory)))) (when (and (or (not (slot-boundp this :directory)) - (not (oref this :directory))) + (not (oref this directory))) (slot-boundp this :file) - (oref this :file)) - (oset this :directory (file-name-directory (oref this :file)))) + (oref this file)) + (oset this directory (file-name-directory (oref this file)))) ) diff --git a/lisp/cedet/ede/config.el b/lisp/cedet/ede/config.el index 285951cacc3..c8bf7f33bae 100644 --- a/lisp/cedet/ede/config.el +++ b/lisp/cedet/ede/config.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2014-2019 Free Software Foundation, Inc. -;; Author: Eric Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -55,6 +55,7 @@ ;;; Code: (require 'ede) +(require 'semantic/db) ;;; CONFIG ;; @@ -138,7 +139,7 @@ the directory isn't on the `safe' list, ask to add it to the safe list." (setq config nil)) (when (not config) - (let* ((top (oref proj :directory)) + (let* ((top (oref proj directory)) (fname (expand-file-name (oref proj config-file-basename) top)) (class (oref proj config-class)) (ignore-type nil)) @@ -257,7 +258,7 @@ programs from a project.") "Run the current project derived from TARGET in a debugger." (let* ((proj (ede-target-parent target)) (config (ede-config-get-configuration proj t)) - (debug (oref config :debug-command)) + (debug (oref config debug-command)) (cmd (read-from-minibuffer "Debug Command: " debug)) @@ -274,7 +275,7 @@ programs from a project.") "Run the current project derived from TARGET." (let* ((proj (ede-target-parent target)) (config (ede-config-get-configuration proj t)) - (run (concat "./" (oref config :run-command))) + (run (concat "./" (oref config run-command))) (cmd (read-from-minibuffer "Run (like this): " run))) (ede-shell-run-something target cmd))) @@ -305,7 +306,7 @@ This class brings in method overloads for for building.") "Compile the entire current project PROJ. Argument COMMAND is the command to use when compiling." (let* ((config (ede-config-get-configuration proj t)) - (comp (oref config :build-command))) + (comp (oref config build-command))) (compile comp))) (cl-defmethod project-compile-target ((obj ede-target-with-config-build) &optional command) @@ -360,11 +361,6 @@ parsed again.")) This target brings in methods used by Semantic to query the preprocessor map, and include paths.") -(declare-function semanticdb-file-table-object "semantic/db" - (file &optional dontload)) -(declare-function semanticdb-needs-refresh-p "semantic/db" (arg &rest args)) -(declare-function semanticdb-refresh-table "semantic/db" (arg &rest args)) - (cl-defmethod ede-preprocessor-map ((this ede-target-with-config-c)) "Get the pre-processor map for some generic C code." (require 'semantic/sb) @@ -374,7 +370,7 @@ the preprocessor map, and include paths.") filemap ) ;; Preprocessor files - (dolist (G (oref config :c-preprocessor-files)) + (dolist (G (oref config c-preprocessor-files)) (let ((table (semanticdb-file-table-object (ede-expand-filename root G)))) (when table @@ -383,7 +379,7 @@ the preprocessor map, and include paths.") (setq filemap (append filemap (oref table lexical-table))) ))) ;; The core table - (setq filemap (append filemap (oref config :c-preprocessor-table))) + (setq filemap (append filemap (oref config c-preprocessor-table))) filemap )) @@ -410,9 +406,14 @@ java class path.") () "Class to mix into a project to support java.") +(eieio-declare-slots classpath) + (cl-defmethod ede-java-classpath ((proj ede-project-with-config-java)) "Return the classpath for this project." - (oref (ede-config-get-configuration proj) :classpath)) + ;; The `classpath' slot only exists in the Java parts of cedet, and + ;; those have not been merged into Emacs. Suppress the warning + ;; about the unknown slot by using `intern'. + (oref (ede-config-get-configuration proj) classpath)) ;; Local variables: ;; generated-autoload-file: "loaddefs.el" diff --git a/lisp/cedet/ede/cpp-root.el b/lisp/cedet/ede/cpp-root.el index f715187f4b3..0a77692dd71 100644 --- a/lisp/cedet/ede/cpp-root.el +++ b/lisp/cedet/ede/cpp-root.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -150,12 +150,10 @@ ;; up the differences (the "include summary" reported the same include paths). (require 'ede) +(require 'semantic/db) (defvar semantic-lex-spp-project-macro-symbol-obarray) (declare-function semantic-lex-make-spp-table "semantic/lex-spp") -(declare-function semanticdb-file-table-object "semantic/db") -(declare-function semanticdb-needs-refresh-p "semantic/db") -(declare-function semanticdb-refresh-table "semantic/db") ;;; Code: @@ -281,7 +279,7 @@ Each directory needs a project file to control it.") "Make sure the :file is fully expanded." ;; Add ourselves to the master list (cl-call-next-method) - (let ((f (expand-file-name (oref this :file)))) + (let ((f (expand-file-name (oref this file)))) ;; Remove any previous entries from the main list. (let ((old (eieio-instance-tracker-find (file-name-directory f) :directory 'ede-cpp-root-project-list))) @@ -294,8 +292,8 @@ Each directory needs a project file to control it.") (file-directory-p f)) (delete-instance this) (error ":file for ede-cpp-root-project must be a file")) - (oset this :file f) - (oset this :directory (file-name-directory f)) + (oset this file f) + (oset this directory (file-name-directory f)) (ede-project-directory-remove-hash (file-name-directory f)) ;; NOTE: We must add to global list here because these classes are not ;; created via the typical loader, but instead via calls from a .emacs @@ -303,7 +301,7 @@ Each directory needs a project file to control it.") (ede-add-project-to-global-list this) (unless (slot-boundp this 'targets) - (oset this :targets nil)) + (oset this targets nil)) )) ;;; SUBPROJ Management. @@ -457,8 +455,8 @@ This is for project include paths and spp source files." "Compile the entire current project PROJ. Argument COMMAND is the command to use when compiling." ;; we need to be in the proj root dir for this to work - (let* ((cmd (oref proj :compile-command)) - (ov (oref proj :local-variables)) + (let* ((cmd (oref proj compile-command)) + (ov (oref proj local-variables)) (lcmd (when ov (cdr (assoc 'compile-command ov)))) (cmd-str (cond ((stringp cmd) cmd) @@ -472,8 +470,8 @@ Argument COMMAND is the command to use when compiling." (cl-defmethod project-compile-target ((obj ede-cpp-root-target) &optional command) "Compile the current target OBJ. Argument COMMAND is the command to use for compiling the target." - (when (oref obj :project) - (project-compile-project (oref obj :project) command))) + (when (oref obj project) + (project-compile-project (oref obj project) command))) (cl-defmethod project-rescan ((this ede-cpp-root-project)) diff --git a/lisp/cedet/ede/detect.el b/lisp/cedet/ede/detect.el index 73058ea6bce..3dfb84803b7 100644 --- a/lisp/cedet/ede/detect.el +++ b/lisp/cedet/ede/detect.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2014-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -195,11 +195,10 @@ Return a cons cell: "Run a quick test for autodetecting on BUFFER." (interactive) (let ((start (current-time)) - (ans (ede-detect-directory-for-project default-directory)) - (end (current-time))) + (ans (ede-detect-directory-for-project default-directory))) (if ans (message "Project found in %d sec @ %s of type %s" - (float-time (time-subtract end start)) + (encode-time (time-since start) 'integer) (car ans) (eieio-object-name-string (cdr ans))) (message "No Project found.") ))) diff --git a/lisp/cedet/ede/dired.el b/lisp/cedet/ede/dired.el index cf62d470bab..7fe88091ef1 100644 --- a/lisp/cedet/ede/dired.el +++ b/lisp/cedet/ede/dired.el @@ -27,12 +27,13 @@ ;; This provides a dired interface to EDE, allowing users to modify ;; their project file by adding files (or whatever) directly from a ;; dired buffer. -(eval-when-compile (require 'cl)) + +;;; Code: + (require 'easymenu) (require 'dired) (require 'ede) -;;; Code: (defvar ede-dired-keymap (let ((map (make-sparse-keymap))) (define-key map ".a" 'ede-dired-add-to-target) @@ -58,9 +59,7 @@ ;;;###autoload (define-minor-mode ede-dired-minor-mode - "A minor mode that should only be activated in DIRED buffers. -If ARG is nil or a positive number, force on, if -negative, force off." + "A minor mode that should only be activated in DIRED buffers." :lighter " EDE" :keymap ede-dired-keymap (unless (derived-mode-p 'dired-mode) (setq ede-dired-minor-mode nil) diff --git a/lisp/cedet/ede/emacs.el b/lisp/cedet/ede/emacs.el index 19400c77bff..600ec87ea4d 100644 --- a/lisp/cedet/ede/emacs.el +++ b/lisp/cedet/ede/emacs.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -33,9 +33,7 @@ ;; * Add website (require 'ede) -(declare-function semanticdb-file-table-object "semantic/db") -(declare-function semanticdb-needs-refresh-p "semantic/db") -(declare-function semanticdb-refresh-table "semantic/db") +(require 'semantic/db) ;;; Code: diff --git a/lisp/cedet/ede/files.el b/lisp/cedet/ede/files.el index 2372ace807f..a6a0af100f5 100644 --- a/lisp/cedet/ede/files.el +++ b/lisp/cedet/ede/files.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -113,14 +113,14 @@ of the anchor file for the project." (if ede--disable-inode (ede--put-inode-dir-hash dir 0) (let ((fattr (file-attributes dir))) - (ede--put-inode-dir-hash dir (nth 10 fattr)) + (ede--put-inode-dir-hash dir (file-attribute-inode-number fattr)) ))))) (cl-defmethod ede--project-inode ((proj ede-project-placeholder)) "Get the inode of the directory project PROJ is in." (if (slot-boundp proj 'dirinode) (oref proj dirinode) - (oset proj dirinode (ede--inode-for-dir (oref proj :directory))))) + (oset proj dirinode (ede--inode-for-dir (oref proj directory))))) (defun ede--inode-get-toplevel-open-project (inode) "Return an already open toplevel project that is managing INODE. @@ -159,7 +159,8 @@ If DIR is the root project, then it is the same." (when rootreturn (set rootreturn proj)) ;; Find subprojects. (when (and proj (if ede--disable-inode - (not (string= ft (expand-file-name (oref proj :directory)))) + (not (string= ft (expand-file-name + (oref proj directory)))) (not (equal inode (ede--project-inode proj))))) (setq ans (ede-find-subproject-for-directory proj ft))) ans)) @@ -175,8 +176,7 @@ If optional EXACT is non-nil, only return exact matches for DIR." (shortans nil)) (while (and all (not ans)) ;; Do the check. - (let ((pd (expand-file-name (oref (car all) :directory))) - ) + (let ((pd (expand-file-name (oref (car all) directory)))) (cond ;; Exact text match. ((string= pd ft) @@ -187,7 +187,7 @@ If optional EXACT is non-nil, only return exact matches for DIR." (setq shortans (car all)) ;; We already have a short answer, so see if pd (the match we found) ;; is longer. If it is longer, then it is more precise. - (when (< (length (oref shortans :directory)) + (when (< (length (oref shortans directory)) (length pd)) (setq shortans (car all)))) ) @@ -208,7 +208,7 @@ If optional EXACT is non-nil, only return exact matches for DIR." (setq shortans (car all)) ;; We already have a short answer, so see if pd (the match we found) ;; is longer. If it is longer, then it is more precise. - (when (< (length (expand-file-name (oref shortans :directory))) + (when (< (length (expand-file-name (oref shortans directory))) (length pd)) (setq shortans (car all)))) ))) @@ -228,7 +228,7 @@ If optional EXACT is non-nil, only return exact matches for DIR." proj (lambda (SP) (when (not ans) - (if (string= fulldir (file-truename (oref SP :directory))) + (if (string= fulldir (file-truename (oref SP directory))) (setq ans SP) (ede-find-subproject-for-directory SP dir))))) ans) @@ -358,11 +358,11 @@ If DIR is not part of a project, return nil." ((and (string= dir default-directory) ede-object-root-project) ;; Try the local buffer cache first. - (oref ede-object-root-project :directory)) + (oref ede-object-root-project directory)) ;; See if there is an existing project in DIR. ((setq ans (ede-directory-get-toplevel-open-project dir)) - (oref ans :directory)) + (oref ans directory)) ;; Detect using our file system detector. ((setq ans (ede-detect-directory-for-project dir)) diff --git a/lisp/cedet/ede/generic.el b/lisp/cedet/ede/generic.el index 075c4ce0a19..3706daf082b 100644 --- a/lisp/cedet/ede/generic.el +++ b/lisp/cedet/ede/generic.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2010-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. diff --git a/lisp/cedet/ede/linux.el b/lisp/cedet/ede/linux.el index 471286bb860..424a20dec4d 100644 --- a/lisp/cedet/ede/linux.el +++ b/lisp/cedet/ede/linux.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -32,14 +32,10 @@ ;; * Add texinfo lookup options. ;; * Add website -(eval-when-compile (require 'cl)) - (require 'ede) (require 'ede/make) - -(declare-function semanticdb-file-table-object "semantic/db") -(declare-function semanticdb-needs-refresh-p "semantic/db") -(declare-function semanticdb-refresh-table "semantic/db") +(require 'semantic/db) +(eval-when-compile (require 'cl-lib)) ;;; Code: (defgroup project-linux nil @@ -116,7 +112,7 @@ If DIR has not been used as a build directory, fall back to ;; detected build on source directory (and (file-exists-p (expand-file-name ".config" dir)) dir) ;; use configuration - (case project-linux-build-directory-default + (cl-case project-linux-build-directory-default (same dir) (ask (read-directory-name "Select Linux' build directory: " dir))))) @@ -165,7 +161,7 @@ Uses `ede-linux--detect-architecture' for the auto-detection. If the result is `ask', let the user choose from architectures found in DIR." (let ((arch (ede-linux--detect-architecture bdir))) - (case arch + (cl-case arch (ask (completing-read "Select target architecture: " (ede-linux--get-archs dir))) @@ -176,7 +172,7 @@ in DIR." "Returns a list with include directories. Returned directories might not exist, since they are not created until Linux is built for the first time." - (map 'list + (cl-map 'list (lambda (elem) (format (concat (car elem) "/" (cdr elem)) arch)) ;; XXX: taken from the output of "make V=1" (list (cons dir "arch/%s/include") diff --git a/lisp/cedet/ede/locate.el b/lisp/cedet/ede/locate.el index 866dce6ede5..d0904c0c155 100644 --- a/lisp/cedet/ede/locate.el +++ b/lisp/cedet/ede/locate.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. diff --git a/lisp/cedet/ede/make.el b/lisp/cedet/ede/make.el index 3eb11d52bfd..d3777ca7d64 100644 --- a/lisp/cedet/ede/make.el +++ b/lisp/cedet/ede/make.el @@ -2,7 +2,7 @@ ;;; Copyright (C) 2009-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. diff --git a/lisp/cedet/ede/makefile-edit.el b/lisp/cedet/ede/makefile-edit.el index 7d8a44bd9aa..ac3f1e9f513 100644 --- a/lisp/cedet/ede/makefile-edit.el +++ b/lisp/cedet/ede/makefile-edit.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2009-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -105,7 +105,7 @@ STOP-BEFORE is a regular expression matching a file name." (let ((e (save-excursion (makefile-end-of-command) (point)))) - (while (re-search-forward "\\s-**\\([-a-zA-Z0-9./_@$%(){}]+\\)\\s-*" e t) + (while (re-search-forward "\\s-*\\([-a-zA-Z0-9./_@$%(){}]+\\)\\s-*" e t) (let ((var nil)(varexp nil) (match (buffer-substring-no-properties (match-beginning 1) diff --git a/lisp/cedet/ede/pconf.el b/lisp/cedet/ede/pconf.el index b9712036822..4b6da4440a5 100644 --- a/lisp/cedet/ede/pconf.el +++ b/lisp/cedet/ede/pconf.el @@ -135,7 +135,9 @@ don't do it. A value of nil means to just do it.") (with-current-buffer "*compilation*" (goto-char (point-max)) - (when (not (string= mode-line-process ":exit [0]")) + ;; FIXME: Use `compilation-finish-functions' or similar to + ;; avoid relying on exact format of `mode-line-process'. + (when (not (string= (car mode-line-process) ":exit [0]")) (error "Configure failed!")) ;; The Makefile is now recreated by configure? diff --git a/lisp/cedet/ede/pmake.el b/lisp/cedet/ede/pmake.el index aa720a7e3e4..db5a33e9031 100644 --- a/lisp/cedet/ede/pmake.el +++ b/lisp/cedet/ede/pmake.el @@ -43,7 +43,6 @@ ;; 1) Insert distribution source variables for targets ;; 2) Insert user requested rules -(eval-when-compile (require 'cl)) (require 'ede/proj) (require 'ede/proj-obj) (require 'ede/proj-comp) diff --git a/lisp/cedet/ede/proj-archive.el b/lisp/cedet/ede/proj-archive.el index 81d2b767ad9..d071e422872 100644 --- a/lisp/cedet/ede/proj-archive.el +++ b/lisp/cedet/ede/proj-archive.el @@ -34,7 +34,6 @@ (defvar ede-archive-linker (ede-linker - "ede-archive-linker" :name "ar" :variables '(("AR" . "ar") ("AR_CMD" . "$(AR) cr")) diff --git a/lisp/cedet/ede/proj-aux.el b/lisp/cedet/ede/proj-aux.el index 8b3aec3e532..1b037229933 100644 --- a/lisp/cedet/ede/proj-aux.el +++ b/lisp/cedet/ede/proj-aux.el @@ -34,8 +34,7 @@ "This target consists of aux files such as READMEs and COPYING.") (defvar ede-aux-source - (ede-sourcecode "ede-aux-source-txt" - :name "Auxiliary Text" + (ede-sourcecode :name "Auxiliary Text" :sourcepattern "^[A-Z]+$\\|\\.txt$") "Miscellaneous fields definition.") diff --git a/lisp/cedet/ede/proj-comp.el b/lisp/cedet/ede/proj-comp.el index 7431191dc41..aa6baf3e340 100644 --- a/lisp/cedet/ede/proj-comp.el +++ b/lisp/cedet/ede/proj-comp.el @@ -44,7 +44,6 @@ ;; To write a method that inserts a variable or rule for a compiler ;; based object, wrap the body of your call in `ede-compiler-only-once' -(eval-when-compile (require 'cl)) (require 'ede) ;source object (require 'ede/autoconf-edit) diff --git a/lisp/cedet/ede/proj-elisp.el b/lisp/cedet/ede/proj-elisp.el index f69dbba690c..c8e920aa94e 100644 --- a/lisp/cedet/ede/proj-elisp.el +++ b/lisp/cedet/ede/proj-elisp.el @@ -77,21 +77,18 @@ For Emacs Lisp, return addsuffix command on source files." (ede-proj-makefile-sourcevar this))) (defvar ede-source-emacs - (ede-sourcecode "ede-emacs-source" - :name "Emacs Lisp" + (ede-sourcecode :name "Emacs Lisp" :sourcepattern "\\.el$" :garbagepattern '("*.elc")) "Emacs Lisp source code definition.") (defvar ede-emacs-compiler (ede-compiler - "ede-emacs-compiler" :name "emacs" :variables '(("EMACS" . "emacs") ("EMACSFLAGS" . "-batch --no-site-file --eval '(setq debug-on-error t)'") ("require" . "$(foreach r,$(1),(require (quote $(r))))")) :rules (list (ede-makefile-rule - "elisp-inference-rule" :target "%.elc" :dependencies "%.el" :rules '("$(EMACS) $(EMACSFLAGS) $(addprefix -L ,$(LOADPATH)) \ @@ -103,7 +100,7 @@ For Emacs Lisp, return addsuffix command on source files." "Compile Emacs Lisp programs.") (defvar ede-xemacs-compiler - (clone ede-emacs-compiler "ede-xemacs-compiler" + (clone ede-emacs-compiler :name "xemacs" :variables '(("EMACS" . "xemacs"))) "Compile Emacs Lisp programs with XEmacs.") @@ -324,7 +321,6 @@ Lays claim to all .elc files that match .el files in this target." ;; Compilers (defvar ede-emacs-cedet-autogen-compiler (ede-compiler - "ede-emacs-autogen-compiler" :name "emacs" :variables '(("EMACS" . "emacs") ("EMACSFLAGS" . "-batch --no-site-file --eval '(setq debug-on-error t)'") @@ -333,7 +329,7 @@ Lays claim to all .elc files that match .el files in this target." '("$(EMACS) $(EMACSFLAGS) $(addprefix -L ,$(LOADPATH)) \ --eval '(setq generated-autoload-file \"$(abspath $(LOADDEFS))\")' \ -f batch-update-autoloads $(abspath $(LOADDIRS))") - :rules (list (ede-makefile-rule "clean-autoloads" :target "clean-autoloads" :phony t :rules '("rm -f $(LOADDEFS)"))) + :rules (list (ede-makefile-rule :target "clean-autoloads" :phony t :rules '("rm -f $(LOADDEFS)"))) :sourcetype '(ede-source-emacs) ) "Build an autoloads file.") diff --git a/lisp/cedet/ede/proj-info.el b/lisp/cedet/ede/proj-info.el index 27a11a30f32..1a2f1074182 100644 --- a/lisp/cedet/ede/proj-info.el +++ b/lisp/cedet/ede/proj-info.el @@ -43,15 +43,13 @@ All other sources should be included independently.")) "Target for a single info file.") (defvar ede-makeinfo-source - (ede-sourcecode "ede-makeinfo-source" - :name "Texinfo" + (ede-sourcecode :name "Texinfo" :sourcepattern "\\.texi?$" :garbagepattern '("*.info*" "*.html")) "Texinfo source code definition.") (defvar ede-makeinfo-compiler (ede-compiler - "ede-makeinfo-compiler" :name "makeinfo" :variables '(("MAKEINFO" . "makeinfo")) :commands '("$(MAKEINFO) $<") @@ -62,7 +60,6 @@ All other sources should be included independently.")) (defvar ede-texi2html-compiler (ede-compiler - "ede-texi2html-compiler" :name "texi2html" :variables '(("TEXI2HTML" . "makeinfo -html")) :commands '("makeinfo -o $@ $<") diff --git a/lisp/cedet/ede/proj-misc.el b/lisp/cedet/ede/proj-misc.el index 10021a5e50a..c9be119b4eb 100644 --- a/lisp/cedet/ede/proj-misc.el +++ b/lisp/cedet/ede/proj-misc.el @@ -26,7 +26,6 @@ ;; This misc target lets the user link in custom makefiles to an EDE ;; project. -(eval-when-compile (require 'cl)) (require 'ede/pmake) (require 'ede/proj-comp) @@ -49,14 +48,12 @@ A user-written makefile is used to build this target. All listed sources are included in the distribution.") (defvar ede-misc-source - (ede-sourcecode "ede-misc-source" - :name "Miscellaneous" + (ede-sourcecode :name "Miscellaneous" :sourcepattern ".*") "Miscellaneous field definition.") (defvar ede-misc-compile - (ede-compiler "ede-misc-compile" - :name "Sub Makefile" + (ede-compiler :name "Sub Makefile" :commands '( ) diff --git a/lisp/cedet/ede/proj-obj.el b/lisp/cedet/ede/proj-obj.el index c5ea81b83ea..45e874037a7 100644 --- a/lisp/cedet/ede/proj-obj.el +++ b/lisp/cedet/ede/proj-obj.el @@ -26,7 +26,6 @@ ;; Handles a superclass of target types which create object code in ;; and EDE Project file. -(eval-when-compile (require 'cl)) (require 'ede/proj) (declare-function ede-pmake-varname "ede/pmake") @@ -83,8 +82,7 @@ file.") ;;; C/C++ Compilers and Linkers ;; (defvar ede-source-c - (ede-sourcecode "ede-source-c" - :name "C" + (ede-sourcecode :name "C" :sourcepattern "\\.c$" :auxsourcepattern "\\.h$" :garbagepattern '("*.o" "*.obj" ".deps/*.P" ".lo")) @@ -92,14 +90,12 @@ file.") (defvar ede-gcc-compiler (ede-object-compiler - "ede-c-compiler-gcc" :name "gcc" :dependencyvar '("C_DEPENDENCIES" . "-Wp,-MD,.deps/$(*F).P") :variables '(("CC" . "gcc") ("C_COMPILE" . "$(CC) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)")) :rules (list (ede-makefile-rule - "c-inference-rule" :target "%.o" :dependencies "%.c" :rules '("@echo '$(C_COMPILE) -c $<'; \\" @@ -115,7 +111,6 @@ file.") (defvar ede-cc-linker (ede-linker - "ede-cc-linker" :name "cc" :sourcetype '(ede-source-c) :variables '(("C_LINK" . "$(CC) $(CFLAGS) $(LDFLAGS) -L.")) @@ -124,8 +119,7 @@ file.") "Linker for C sourcecode.") (defvar ede-source-c++ - (ede-sourcecode "ede-source-c++" - :name "C++" + (ede-sourcecode :name "C++" :sourcepattern "\\.\\(c\\(pp?\\|c\\|xx\\|++\\)\\|C\\(PP\\)?\\)$" :auxsourcepattern "\\.\\(hpp?\\|hh?\\|hxx\\|H\\)$" :garbagepattern '("*.o" "*.obj" ".deps/*.P" ".lo")) @@ -133,7 +127,6 @@ file.") (defvar ede-g++-compiler (ede-object-compiler - "ede-c-compiler-g++" :name "g++" :dependencyvar '("CXX_DEPENDENCIES" . "-Wp,-MD,.deps/$(*F).P") :variables '(("CXX" "g++") @@ -141,7 +134,6 @@ file.") "$(CXX) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)") ) :rules (list (ede-makefile-rule - "c++-inference-rule" :target "%.o" :dependencies "%.cpp" :rules '("@echo '$(CXX_COMPILE) -c $<'; \\" @@ -157,7 +149,6 @@ file.") (defvar ede-g++-linker (ede-linker - "ede-g++-linker" :name "g++" ;; Only use this linker when c++ exists. :sourcetype '(ede-source-c++) @@ -169,15 +160,13 @@ file.") ;;; LEX (defvar ede-source-lex - (ede-sourcecode "ede-source-lex" - :name "lex" + (ede-sourcecode :name "lex" :sourcepattern "\\.l\\(l\\|pp\\|++\\)") "Lex source code definition. No garbage pattern since it creates C or C++ code.") (defvar ede-lex-compiler (ede-object-compiler - "ede-lex-compiler" ;; Can we support regular makefiles too?? :autoconf '("AC_PROG_LEX") :sourcetype '(ede-source-lex)) @@ -185,15 +174,13 @@ No garbage pattern since it creates C or C++ code.") ;;; YACC (defvar ede-source-yacc - (ede-sourcecode "ede-source-yacc" - :name "yacc" + (ede-sourcecode :name "yacc" :sourcepattern "\\.y\\(y\\|pp\\|++\\)") "Yacc source code definition. No garbage pattern since it creates C or C++ code.") (defvar ede-yacc-compiler (ede-object-compiler - "ede-yacc-compiler" ;; Can we support regular makefiles too?? :autoconf '("AC_PROG_YACC") :sourcetype '(ede-source-yacc)) @@ -203,16 +190,14 @@ No garbage pattern since it creates C or C++ code.") ;; ;; Contributed by David Engster (defvar ede-source-f90 - (ede-sourcecode "ede-source-f90" - :name "Fortran 90/95" + (ede-sourcecode :name "Fortran 90/95" :sourcepattern "\\.[fF]9[05]$" :auxsourcepattern "\\.incf$" :garbagepattern '("*.o" "*.mod" ".deps/*.P")) "Fortran 90/95 source code definition.") (defvar ede-source-f77 - (ede-sourcecode "ede-source-f77" - :name "Fortran 77" + (ede-sourcecode :name "Fortran 77" :sourcepattern "\\.\\([fF]\\|for\\)$" :auxsourcepattern "\\.incf$" :garbagepattern '("*.o" ".deps/*.P")) @@ -220,14 +205,12 @@ No garbage pattern since it creates C or C++ code.") (defvar ede-gfortran-compiler (ede-object-compiler - "ede-f90-compiler-gfortran" :name "gfortran" :dependencyvar '("F90_DEPENDENCIES" . "-Wp,-MD,.deps/$(*F).P") :variables '(("F90" . "gfortran") ("F90_COMPILE" . "$(F90) $(DEFS) $(INCLUDES) $(F90FLAGS)")) :rules (list (ede-makefile-rule - "f90-inference-rule" :target "%.o" :dependencies "%.f90" :rules '("@echo '$(F90_COMPILE) -c $<'; \\" @@ -242,7 +225,6 @@ No garbage pattern since it creates C or C++ code.") (defvar ede-gfortran-module-compiler (clone ede-gfortran-compiler - "ede-f90-module-compiler-gfortran" :name "gfortranmod" :sourcetype '(ede-source-f90) :commands '("$(F90_COMPILE) -c $^") @@ -253,7 +235,6 @@ No garbage pattern since it creates C or C++ code.") (defvar ede-gfortran-linker (ede-linker - "ede-gfortran-linker" :name "gfortran" :sourcetype '(ede-source-f90 ede-source-f77) :variables '(("F90_LINK" . "$(F90) $(CFLAGS) $(LDFLAGS) -L.")) @@ -265,7 +246,6 @@ No garbage pattern since it creates C or C++ code.") ;; (defvar ede-ld-linker (ede-linker - "ede-ld-linker" :name "ld" :variables '(("LD" . "ld") ("LD_LINK" . "$(LD) $(LDFLAGS) -L.")) diff --git a/lisp/cedet/ede/proj-prog.el b/lisp/cedet/ede/proj-prog.el index a7450361b17..8299b721acc 100644 --- a/lisp/cedet/ede/proj-prog.el +++ b/lisp/cedet/ede/proj-prog.el @@ -25,7 +25,6 @@ ;; ;; Handle building programs from object files in and EDE Project file. -(eval-when-compile (require 'cl)) (require 'ede/pmake) (require 'ede/proj-obj) diff --git a/lisp/cedet/ede/proj-shared.el b/lisp/cedet/ede/proj-shared.el index b21c617252a..47fb453ac13 100644 --- a/lisp/cedet/ede/proj-shared.el +++ b/lisp/cedet/ede/proj-shared.el @@ -75,7 +75,6 @@ Use ldlibs to add addition libraries.") ("LTLINK" . "$(LIBTOOL) --mode=link $(CC) $(CFLAGS) $(LDFLAGS) -L. -o $@") ) :rules (list (ede-makefile-rule - "cc-inference-rule-libtool" :target "%.o" :dependencies "%.c" :rules '("@echo '$(LTCOMPILE) -o $@ $<'; \\" @@ -122,7 +121,6 @@ Use ldlibs to add addition libraries.") ("LTCOMPILE" . "$(LIBTOOL) --tag=CXX --mode=compile $(CXX) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)") ) :rules (list (ede-makefile-rule - "c++-inference-rule-libtool" :target "%.o" :dependencies "%.cpp" :rules '("@echo '$(LTCOMPILE) -o $@ $<'; \\" diff --git a/lisp/cedet/ede/project-am.el b/lisp/cedet/ede/project-am.el index 12db0a43ce7..fbbbe6871b6 100644 --- a/lisp/cedet/ede/project-am.el +++ b/lisp/cedet/ede/project-am.el @@ -491,7 +491,7 @@ This is used when subprojects are made in named subdirectories." :version ver :mailinglist (or bug "") :file fn))) - (oset ampf :directory (file-name-directory fn)) + (oset ampf directory (file-name-directory fn)) (oset ampf configureoutputfiles cof) (make-local-variable 'ede-object) (setq ede-object ampf) @@ -659,11 +659,11 @@ Strip out duplicates, and recurse on variables." (mapc (lambda (sp) (let* ((subdir (file-name-as-directory (expand-file-name - sp (file-name-directory (oref this :file))))) + sp (file-name-directory (oref this file))))) (submake (expand-file-name "Makefile.am" subdir))) - (if (string= submake (oref this :file)) + (if (string= submake (oref this file)) nil ;; don't recurse.. please! ;; For each project id found, see if we need to recycle, ;; and if we do not, then make a new one. Check the deep @@ -694,45 +694,46 @@ Strip out duplicates, and recurse on variables." (cl-defmethod project-rescan ((this project-am-program)) "Rescan object THIS." - (oset this :source (makefile-macro-file-list (project-am-macro this))) - (unless (oref this :source) - (oset this :source (list (concat (oref this :name) ".c")))) - (oset this :ldadd (makefile-macro-file-list - (concat (oref this :name) "_LDADD")))) + (oset this source (makefile-macro-file-list (project-am-macro this))) + (unless (oref this source) + (oset this source (list (concat (oref this name) ".c")))) + (oset this ldadd (makefile-macro-file-list + (concat (oref this name) "_LDADD")))) (cl-defmethod project-rescan ((this project-am-lib)) "Rescan object THIS." - (oset this :source (makefile-macro-file-list (project-am-macro this))) - (unless (oref this :source) - (oset this :source (list (concat (file-name-sans-extension (oref this :name)) ".c"))))) + (oset this source (makefile-macro-file-list (project-am-macro this))) + (unless (oref this source) + (oset this source (list (concat (file-name-sans-extension + (oref this name)) ".c"))))) (cl-defmethod project-rescan ((this project-am-texinfo)) "Rescan object THIS." - (oset this :include (makefile-macro-file-list (project-am-macro this)))) + (oset this include (makefile-macro-file-list (project-am-macro this)))) (cl-defmethod project-rescan ((this project-am-man)) "Rescan object THIS." - (oset this :source (makefile-macro-file-list (project-am-macro this)))) + (oset this source (makefile-macro-file-list (project-am-macro this)))) (cl-defmethod project-rescan ((this project-am-lisp)) "Rescan the lisp sources." - (oset this :source (makefile-macro-file-list (project-am-macro this)))) + (oset this source (makefile-macro-file-list (project-am-macro this)))) (cl-defmethod project-rescan ((this project-am-header)) "Rescan the Header sources for object THIS." - (oset this :source (makefile-macro-file-list (project-am-macro this)))) + (oset this source (makefile-macro-file-list (project-am-macro this)))) (cl-defmethod project-rescan ((this project-am-built-src)) "Rescan built sources for object THIS." - (oset this :source (makefile-macro-file-list "BUILT_SOURCES"))) + (oset this source (makefile-macro-file-list "BUILT_SOURCES"))) (cl-defmethod project-rescan ((this project-am-extra-dist)) "Rescan object THIS." - (oset this :source (makefile-macro-file-list "EXTRA_DIST"))) + (oset this source (makefile-macro-file-list "EXTRA_DIST"))) (cl-defmethod project-am-macro ((this project-am-objectcode)) "Return the default macro to `edit' for this object type." - (concat (subst-char-in-string ?- ?_ (oref this :name)) "_SOURCES")) + (concat (subst-char-in-string ?- ?_ (oref this name)) "_SOURCES")) (cl-defmethod project-am-macro ((this project-am-header-noinst)) "Return the default macro to `edit' for this object." @@ -752,11 +753,11 @@ Strip out duplicates, and recurse on variables." (cl-defmethod project-am-macro ((this project-am-texinfo)) "Return the default macro to `edit' for this object type." - (concat (file-name-sans-extension (oref this :name)) "_TEXINFOS")) + (concat (file-name-sans-extension (oref this name)) "_TEXINFOS")) (cl-defmethod project-am-macro ((this project-am-man)) "Return the default macro to `edit' for this object type." - (oref this :name)) + (oref this name)) (cl-defmethod project-am-macro ((this project-am-lisp)) "Return the default macro to `edit' for this object." @@ -784,7 +785,7 @@ nil means that this buffer belongs to no-one." (cl-defmethod ede-buffer-mine ((this project-am-makefile) buffer) "Return t if object THIS lays claim to the file in BUFFER." (let ((efn (expand-file-name (buffer-file-name buffer)))) - (or (string= (oref this :file) efn) + (or (string= (oref this file) efn) (string-match "/configure\\.ac$" efn) (string-match "/configure\\.in$" efn) (string-match "/configure$" efn) @@ -798,25 +799,25 @@ nil means that this buffer belongs to no-one." (cl-defmethod ede-buffer-mine ((this project-am-objectcode) buffer) "Return t if object THIS lays claim to the file in BUFFER." - (member (file-relative-name (buffer-file-name buffer) (oref this :path)) - (oref this :source))) + (member (file-relative-name (buffer-file-name buffer) (oref this path)) + (oref this source))) (cl-defmethod ede-buffer-mine ((this project-am-texinfo) buffer) "Return t if object THIS lays claim to the file in BUFFER." (let ((bfn (file-relative-name (buffer-file-name buffer) - (oref this :path)))) - (or (string= (oref this :name) bfn) - (member bfn (oref this :include))))) + (oref this path)))) + (or (string= (oref this name) bfn) + (member bfn (oref this include))))) (cl-defmethod ede-buffer-mine ((this project-am-man) buffer) "Return t if object THIS lays claim to the file in BUFFER." - (string= (oref this :name) - (file-relative-name (buffer-file-name buffer) (oref this :path)))) + (string= (oref this name) + (file-relative-name (buffer-file-name buffer) (oref this path)))) (cl-defmethod ede-buffer-mine ((this project-am-lisp) buffer) "Return t if object THIS lays claim to the file in BUFFER." - (member (file-relative-name (buffer-file-name buffer) (oref this :path)) - (oref this :source))) + (member (file-relative-name (buffer-file-name buffer) (oref this path)) + (oref this source))) (cl-defmethod project-am-subtree ((ampf project-am-makefile) subdir) "Return the sub project in AMPF specified by SUBDIR." @@ -829,11 +830,11 @@ nil means that this buffer belongs to no-one." (cl-defmethod project-compile-target-command ((this project-am-objectcode)) "Default target to use when compiling an object code target." - (oref this :name)) + (oref this name)) (cl-defmethod project-compile-target-command ((this project-am-texinfo)) "Default target t- use when compiling a texinfo file." - (let ((n (oref this :name))) + (let ((n (oref this name))) (if (string-match "\\.texi?\\(nfo\\)?" n) (setq n (replace-match ".info" t t n))) n)) @@ -993,7 +994,7 @@ Kill the Configure buffer if it was not already in a buffer." "Get the package information for directory topmost project dir over DIR. Calculates the info with `project-am-extract-package-info'." (let ((top (ede-toplevel))) - (when top (setq dir (oref top :directory))) + (when top (setq dir (oref top directory))) (project-am-extract-package-info dir))) ;; for simple per project include path extension diff --git a/lisp/cedet/ede/shell.el b/lisp/cedet/ede/shell.el index a20046c817c..3641803e1e0 100644 --- a/lisp/cedet/ede/shell.el +++ b/lisp/cedet/ede/shell.el @@ -2,7 +2,7 @@ ;; ;; Copyright (C) 2009-2019 Free Software Foundation, Inc. ;; -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -38,7 +38,7 @@ COMMAND is a text string representing the thing to be run." (let* ((buff (ede-shell-buffer target)) (cp (ede-target-parent target)) - (dd (oref cp :directory))) + (dd (oref cp directory))) ;; Show the new buffer. (when (not (get-buffer-window buff)) (switch-to-buffer-other-window buff t)) diff --git a/lisp/cedet/ede/simple.el b/lisp/cedet/ede/simple.el index 5b1c14bcd74..80b19027fc4 100644 --- a/lisp/cedet/ede/simple.el +++ b/lisp/cedet/ede/simple.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -46,7 +46,7 @@ ;;; Code: (add-to-list 'ede-project-class-files - (ede-project-autoload "simple-overlay" + (ede-project-autoload :name "Simple" :file 'ede/simple :proj-file 'ede-simple-projectfile-for-dir :load-type 'ede-simple-load diff --git a/lisp/cedet/ede/source.el b/lisp/cedet/ede/source.el index ece99f59917..8105af0d6a4 100644 --- a/lisp/cedet/ede/source.el +++ b/lisp/cedet/ede/source.el @@ -156,14 +156,12 @@ Used to guess header files, but uses the auxsource regular expression." ;; ;; This must appear at the end so that the init method will work. (defvar ede-source-scheme - (ede-sourcecode "ede-source-scheme" - :name "Scheme" + (ede-sourcecode :name "Scheme" :sourcepattern "\\.scm$") "Scheme source code definition.") ;;(defvar ede-source- -;; (ede-sourcecode "ede-source-" -;; :name "" +;; (ede-sourcecode :name "" ;; :sourcepattern "\\.$" ;; :garbagepattern '("*.")) ;; " source code definition.") diff --git a/lisp/cedet/ede/speedbar.el b/lisp/cedet/ede/speedbar.el index e471bb6f957..a5ccb666644 100644 --- a/lisp/cedet/ede/speedbar.el +++ b/lisp/cedet/ede/speedbar.el @@ -28,7 +28,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'speedbar) (require 'eieio-speedbar) (require 'ede) @@ -277,7 +276,7 @@ INDENT is the current indentation level." Etags does not support this feature. TEXT will be the button string. TOKEN will be the list, and INDENT is the current indentation level." - (cond ((string-match "+" text) ;we have to expand this file + (cond ((string-match "\\+" text) ;we have to expand this file (speedbar-change-expand-button-char ?-) (speedbar-with-writable (save-excursion diff --git a/lisp/cedet/ede/srecode.el b/lisp/cedet/ede/srecode.el index 5217e2d6753..2d3636006f9 100644 --- a/lisp/cedet/ede/srecode.el +++ b/lisp/cedet/ede/srecode.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. diff --git a/lisp/cedet/ede/util.el b/lisp/cedet/ede/util.el index 29b8fbffade..37d6b18233f 100644 --- a/lisp/cedet/ede/util.el +++ b/lisp/cedet/ede/util.el @@ -41,8 +41,8 @@ Argument NEWVERSION is the version number to use in the current project." v nil v)))) (let ((ede-object (ede-toplevel))) ;; Don't update anything if there was no change. - (unless (string= (oref ede-object :version) newversion) - (oset ede-object :version newversion) + (unless (string= (oref ede-object version) newversion) + (oset ede-object version newversion) (project-update-version ede-object) (ede-update-version-in-source ede-object newversion)))) diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el index 4ce156d832b..3d2fe45fcb1 100644 --- a/lisp/cedet/mode-local.el +++ b/lisp/cedet/mode-local.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2004-2005, 2007-2019 Free Software Foundation, Inc. ;; ;; Author: David Ponce <david@dponce.com> -;; Maintainer: David Ponce <david@dponce.com> ;; Created: 27 Apr 2004 ;; Keywords: syntax @@ -46,8 +45,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'find-func) ;; For find-function-regexp-alist. It is tempting to replace this ;; ‘require’ by (defvar find-function-regexp-alist) and @@ -299,8 +296,7 @@ Elements are (SYMBOL . PREVIOUS-VALUE), describing one variable." ;; Hack - ;; do not do this if we are inside set-auto-mode as we may be in ;; an initialization race condition. - (if (or (and (featurep 'emacs) (boundp 'keep-mode-if-same)) - (and (featurep 'xemacs) (boundp 'just-from-file-name))) + (if (boundp 'keep-mode-if-same) ;; We are inside set-auto-mode, as this is an argument that is ;; vaguely unique. diff --git a/lisp/cedet/pulse.el b/lisp/cedet/pulse.el index bfd0f0c8e8f..bd3687ab550 100644 --- a/lisp/cedet/pulse.el +++ b/lisp/cedet/pulse.el @@ -2,7 +2,7 @@ ;;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 1.0 ;; This file is part of GNU Emacs. @@ -196,11 +196,11 @@ Optional argument FACE specifies the face to do the highlighting." (pulse-reset-face face) (setq pulse-momentary-timer (run-with-timer 0 pulse-delay #'pulse-tick - (time-add (current-time) + (time-add nil (* pulse-delay pulse-iterations))))))) (defun pulse-tick (stop-time) - (if (time-less-p (current-time) stop-time) + (if (time-less-p nil stop-time) (pulse-lighten-highlight) (pulse-momentary-unhighlight))) diff --git a/lisp/cedet/semantic.el b/lisp/cedet/semantic.el index 05272117879..8ffdbf0ff2a 100644 --- a/lisp/cedet/semantic.el +++ b/lisp/cedet/semantic.el @@ -225,37 +225,37 @@ during a flush when the cache is given a new value of nil.") "Indicate that the current buffer is unparseable. It is also true that the parse tree will need either updating or a rebuild. This state will be changed when the user edits the buffer." - `(setq semantic-parse-tree-state 'unparseable)) + '(setq semantic-parse-tree-state 'unparseable)) (defmacro semantic-parse-tree-unparseable-p () "Return non-nil if the current buffer has been marked unparseable." - `(eq semantic-parse-tree-state 'unparseable)) + '(eq semantic-parse-tree-state 'unparseable)) (defmacro semantic-parse-tree-set-needs-update () "Indicate that the current parse tree needs to be updated. The parse tree can be updated by `semantic-parse-changes'." - `(setq semantic-parse-tree-state 'needs-update)) + '(setq semantic-parse-tree-state 'needs-update)) (defmacro semantic-parse-tree-needs-update-p () "Return non-nil if the current parse tree needs to be updated." - `(eq semantic-parse-tree-state 'needs-update)) + '(eq semantic-parse-tree-state 'needs-update)) (defmacro semantic-parse-tree-set-needs-rebuild () "Indicate that the current parse tree needs to be rebuilt. The parse tree must be rebuilt by `semantic-parse-region'." - `(setq semantic-parse-tree-state 'needs-rebuild)) + '(setq semantic-parse-tree-state 'needs-rebuild)) (defmacro semantic-parse-tree-needs-rebuild-p () "Return non-nil if the current parse tree needs to be rebuilt." - `(eq semantic-parse-tree-state 'needs-rebuild)) + '(eq semantic-parse-tree-state 'needs-rebuild)) (defmacro semantic-parse-tree-set-up-to-date () "Indicate that the current parse tree is up to date." - `(setq semantic-parse-tree-state nil)) + '(setq semantic-parse-tree-state nil)) (defmacro semantic-parse-tree-up-to-date-p () "Return non-nil if the current parse tree is up to date." - `(null semantic-parse-tree-state)) + '(null semantic-parse-tree-state)) ;;; Interfacing with the system ;; @@ -389,10 +389,9 @@ the output buffer." (if clear (semantic-clear-toplevel-cache)) (if (eq clear '-) (setq clear -1)) (let* ((start (current-time)) - (out (semantic-fetch-tags)) - (end (current-time))) + (out (semantic-fetch-tags))) (message "Retrieving tags took %.2f seconds." - (semantic-elapsed-time start end)) + (semantic-elapsed-time start nil)) (when (or (null clear) (not (listp clear)) (and (numberp clear) (< 0 clear))) (pop-to-buffer "*Parser Output*") @@ -511,7 +510,7 @@ is requested." (semantic-clear-parser-warnings) ;; Nuke all semantic overlays. This is faster than deleting based ;; on our data structure. - (let ((l (semantic-overlay-lists))) + (let ((l (overlay-lists))) (mapc 'semantic-delete-overlay-maybe (car l)) (mapc 'semantic-delete-overlay-maybe (cdr l)) ) @@ -1097,9 +1096,6 @@ The following modes are more targeted at people who want to see ;;;###autoload (define-minor-mode semantic-mode "Toggle parser features (Semantic mode). -With a prefix argument ARG, enable Semantic mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -Semantic mode if ARG is omitted or nil. In Semantic mode, Emacs parses the buffers you visit for their semantic content. This information is used by a variety of @@ -1172,57 +1168,6 @@ Semantic mode. ;; re-activated. (setq semantic-new-buffer-fcn-was-run nil))) -;;; Completion At Point functions -(defun semantic-analyze-completion-at-point-function () - "Return possible analysis completions at point. -The completions provided are via `semantic-analyze-possible-completions'. -This function can be used by `completion-at-point-functions'." - (when (semantic-active-p) - (let* ((ctxt (semantic-analyze-current-context)) - (possible (semantic-analyze-possible-completions ctxt))) - - ;; The return from this is either: - ;; nil - not applicable here. - ;; A list: (START END COLLECTION . PROPS) - (when possible - (list (car (oref ctxt bounds)) - (cdr (oref ctxt bounds)) - possible)) - ))) - -(defun semantic-analyze-notc-completion-at-point-function () - "Return possible analysis completions at point. -The completions provided are via `semantic-analyze-possible-completions', -but with the `no-tc' option passed in, which means constraints based -on what is being assigned to are ignored. -This function can be used by `completion-at-point-functions'." - (when (semantic-active-p) - (let* ((ctxt (semantic-analyze-current-context)) - (possible (semantic-analyze-possible-completions ctxt 'no-tc))) - - (when possible - (list (car (oref ctxt bounds)) - (cdr (oref ctxt bounds)) - possible)) - ))) - -(defun semantic-analyze-nolongprefix-completion-at-point-function () - "Return possible analysis completions at point. -The completions provided are via `semantic-analyze-possible-completions', -but with the `no-tc' and `no-longprefix' option passed in, which means -constraints resulting in a long multi-symbol dereference are ignored. -This function can be used by `completion-at-point-functions'." - (when (semantic-active-p) - (let* ((ctxt (semantic-analyze-current-context)) - (possible (semantic-analyze-possible-completions - ctxt 'no-tc 'no-longprefix))) - - (when possible - (list (car (oref ctxt bounds)) - (cdr (oref ctxt bounds)) - possible)) - ))) - ;;; Autoload some functions that are not in semantic/loaddefs (autoload 'global-semantic-idle-completions-mode "semantic/idle" @@ -1263,6 +1208,16 @@ Call `semantic-symref-hits-in-region' to identify local references." t nil) (autoload 'srecode-template-setup-parser "srecode/srecode-template" "Set up buffer for parsing SRecode template files." t nil) +(autoload 'semantic-analyze-completion-at-point-function "semantic/analyze" + "Return possible analysis completions at point.") + +(autoload 'semantic-analyze-notc-completion-at-point-function "semantic/analyze" + "Return possible analysis completions at point.") + +(autoload 'semantic-analyze-nolongprefix-completion-at-point-function + "semantic/analyze" + "Return possible analysis completions at point.") + (provide 'semantic) ;; Semantic-util is a part of the semantic API. Include it last diff --git a/lisp/cedet/semantic/analyze.el b/lisp/cedet/semantic/analyze.el index d68098b5b9a..6851ad556a7 100644 --- a/lisp/cedet/semantic/analyze.el +++ b/lisp/cedet/semantic/analyze.el @@ -63,7 +63,6 @@ ;; constant. These need to be returned as there would be no ;; other possible completions. -(eval-when-compile (require 'cl)) (require 'semantic) (require 'semantic/format) (require 'semantic/ctxt) @@ -202,7 +201,7 @@ Optional argument DESIRED-TYPE may be a non-type tag to analyze." (cl-defmethod semantic-analyze-interesting-tag ((context semantic-analyze-context)) "Return a tag from CONTEXT that would be most interesting to a user." - (let ((prefix (reverse (oref context :prefix)))) + (let ((prefix (reverse (oref context prefix)))) ;; Go back through the prefix until we find a tag we can return. (while (and prefix (not (semantic-tag-p (car prefix)))) (setq prefix (cdr prefix))) @@ -212,12 +211,12 @@ Optional argument DESIRED-TYPE may be a non-type tag to analyze." (cl-defmethod semantic-analyze-interesting-tag ((context semantic-analyze-context-functionarg)) "Try the base, and if that fails, return what we are assigning into." - (or (cl-call-next-method) (car-safe (oref context :function)))) + (or (cl-call-next-method) (car-safe (oref context function)))) (cl-defmethod semantic-analyze-interesting-tag ((context semantic-analyze-context-assignment)) "Try the base, and if that fails, return what we are assigning into." - (or (cl-call-next-method) (car-safe (oref context :assignee)))) + (or (cl-call-next-method) (car-safe (oref context assignee)))) ;;; ANALYSIS ;; @@ -440,12 +439,11 @@ to provide a large number of non-cached analysis for filtering symbols." (defun semantic-analyze-current-symbol-default (analyzehookfcn position) "Call ANALYZEHOOKFCN on the analyzed symbol at POSITION." (let* ((semantic-analyze-error-stack nil) - (LLstart (current-time)) + ;; (LLstart (current-time)) (prefixandbounds (semantic-ctxt-current-symbol-and-bounds (or position (point)))) (prefix (car prefixandbounds)) (bounds (nth 2 prefixandbounds)) (scope (semantic-calculate-scope position)) - (end nil) ) ;; Only do work if we have bounds (meaning a prefix to complete) (when bounds @@ -464,15 +462,13 @@ to provide a large number of non-cached analysis for filtering symbols." prefix scope 'prefixtypes)) (error (semantic-analyze-push-error err)))) - (setq end (current-time)) - ;;(message "Analysis took %.2f sec" (semantic-elapsed-time LLstart end)) + ;;(message "Analysis took %.2f sec" (semantic-elapsed-time LLstart nil)) ) (when prefix (prog1 (funcall analyzehookfcn (car bounds) (cdr bounds) prefix) - ;;(setq end (current-time)) - ;;(message "hookfcn took %.5f sec" (semantic-elapsed-time LLstart end)) + ;;(message "hookfcn took %.5f sec" (semantic-elapsed-time LLstart nil)) ) ))) @@ -645,7 +641,6 @@ Returns an object based on symbol `semantic-analyze-context'." ;; for the argument. (setq context-return (semantic-analyze-context-functionarg - "functionargument" :buffer (current-buffer) :function fntag :index arg @@ -668,7 +663,6 @@ Returns an object based on symbol `semantic-analyze-context'." (setq context-return (semantic-analyze-context-assignment - "assignment" :buffer (current-buffer) :assignee asstag :scope scope @@ -686,7 +680,6 @@ Returns an object based on symbol `semantic-analyze-context'." ;; Nothing in particular (setq context-return (semantic-analyze-context - "context" :buffer (current-buffer) :scope scope :bounds bounds @@ -723,12 +716,11 @@ Optional argument CTXT is the context to show." (interactive) (require 'data-debug) (let ((start (current-time)) - (ctxt (or ctxt (semantic-analyze-current-context))) - (end (current-time))) + (ctxt (or ctxt (semantic-analyze-current-context)))) (if (not ctxt) (message "No Analyzer Results") (message "Analysis took %.2f seconds." - (semantic-elapsed-time start end)) + (semantic-elapsed-time start nil)) (semantic-analyze-pulse ctxt) (if ctxt (progn @@ -746,8 +738,8 @@ Optional argument CTXT is the context to show." (cl-defmethod semantic-analyze-pulse ((context semantic-analyze-context)) "Pulse the region that CONTEXT affects." (require 'pulse) - (with-current-buffer (oref context :buffer) - (let ((bounds (oref context :bounds))) + (with-current-buffer (oref context buffer) + (let ((bounds (oref context bounds))) (when bounds (pulse-momentary-highlight-region (car bounds) (cdr bounds)))))) @@ -827,6 +819,58 @@ CONTEXT's content is described in `semantic-analyze-current-context'." (get-buffer-window "*Semantic Context Analysis*")) ) + +;;; Completion At Point functions +(defun semantic-analyze-completion-at-point-function () + "Return possible analysis completions at point. +The completions provided are via `semantic-analyze-possible-completions'. +This function can be used by `completion-at-point-functions'." + (when (semantic-active-p) + (let* ((ctxt (semantic-analyze-current-context)) + (possible (semantic-analyze-possible-completions ctxt))) + + ;; The return from this is either: + ;; nil - not applicable here. + ;; A list: (START END COLLECTION . PROPS) + (when possible + (list (car (oref ctxt bounds)) + (cdr (oref ctxt bounds)) + possible)) + ))) + +(defun semantic-analyze-notc-completion-at-point-function () + "Return possible analysis completions at point. +The completions provided are via `semantic-analyze-possible-completions', +but with the `no-tc' option passed in, which means constraints based +on what is being assigned to are ignored. +This function can be used by `completion-at-point-functions'." + (when (semantic-active-p) + (let* ((ctxt (semantic-analyze-current-context)) + (possible (semantic-analyze-possible-completions ctxt 'no-tc))) + + (when possible + (list (car (oref ctxt bounds)) + (cdr (oref ctxt bounds)) + possible)) + ))) + +(defun semantic-analyze-nolongprefix-completion-at-point-function () + "Return possible analysis completions at point. +The completions provided are via `semantic-analyze-possible-completions', +but with the `no-tc' and `no-longprefix' option passed in, which means +constraints resulting in a long multi-symbol dereference are ignored. +This function can be used by `completion-at-point-functions'." + (when (semantic-active-p) + (let* ((ctxt (semantic-analyze-current-context)) + (possible (semantic-analyze-possible-completions + ctxt 'no-tc 'no-longprefix))) + + (when possible + (list (car (oref ctxt bounds)) + (cdr (oref ctxt bounds)) + possible)) + ))) + (provide 'semantic/analyze) ;; Local variables: diff --git a/lisp/cedet/semantic/analyze/complete.el b/lisp/cedet/semantic/analyze/complete.el index 7d31ec7fc07..b471c0d1a13 100644 --- a/lisp/cedet/semantic/analyze/complete.el +++ b/lisp/cedet/semantic/analyze/complete.el @@ -89,7 +89,7 @@ in a buffer." ;;(semantic-refresh-tags-safe) (if (semantic-active-p) (with-syntax-table semantic-lex-syntax-table - (let* ((context (if (semantic-analyze-context-child-p context) + (let* ((context (if (cl-typep context 'semantic-analyze-context) context (semantic-analyze-current-context context))) (ans (if (not context) diff --git a/lisp/cedet/semantic/analyze/debug.el b/lisp/cedet/semantic/analyze/debug.el index c9927d29f08..1bb97ce9b83 100644 --- a/lisp/cedet/semantic/analyze/debug.el +++ b/lisp/cedet/semantic/analyze/debug.el @@ -28,6 +28,7 @@ (require 'semantic/analyze) (require 'semantic/analyze/complete) (require 'semantic/db-typecache) +(require 'pulse) ;; For semantic-find-tags-by-class: (eval-when-compile (require 'semantic/find)) @@ -408,16 +409,16 @@ or implementing a version specific to ") (princ (substitute-command-keys "\n\nThis file's project include search is handled by the EDE object:\n")) (princ " Buffer Target: ") - (princ (object-print edeobj)) + (princ (cl-prin1-to-string edeobj)) (princ "\n") (when (not (eq edeobj edeproj)) (princ " Buffer Project: ") - (princ (object-print edeproj)) + (princ (cl-prin1-to-string edeproj)) (princ "\n")) (when edeproj (let ((loc (ede-get-locator-object edeproj))) (princ " Backup Locator: ") - (princ (object-print loc)) + (princ (cl-prin1-to-string loc)) (princ "\n"))) ) @@ -478,7 +479,7 @@ variable `semantic-dependency-system-include-path'.")) (defun semantic-analyzer-debug-describe-scope (ctxt &optional classconstraint) "Describe the scope in CTXT for finding a global symbol. Optional argument CLASSCONSTRAINT says to output to tags of that class." - (let* ((scope (oref ctxt :scope)) + (let* ((scope (oref ctxt scope)) (parents (oref scope parents)) (cc (or classconstraint (oref ctxt prefixclass))) ) @@ -558,19 +559,19 @@ PARENT is a possible parent (by nesting) tag." 'mouse-face 'custom-button-pressed-face 'tag tag 'action - `(lambda (button) - (let ((buff nil) - (pnt nil)) - (save-excursion - (semantic-go-to-tag - (button-get button 'tag)) - (setq buff (current-buffer)) - (setq pnt (point))) - (if (get-buffer-window buff) - (select-window (get-buffer-window buff)) - (pop-to-buffer buff t)) - (goto-char pnt) - (pulse-line-hook-function))) + (lambda (button) + (let ((buff nil) + (pnt nil)) + (save-excursion + (semantic-go-to-tag + (button-get button 'tag)) + (setq buff (current-buffer)) + (setq pnt (point))) + (if (get-buffer-window buff) + (select-window (get-buffer-window buff)) + (pop-to-buffer buff t)) + (goto-char pnt) + (pulse-line-hook-function))) )) (princ "\"") (princ str) diff --git a/lisp/cedet/semantic/analyze/refs.el b/lisp/cedet/semantic/analyze/refs.el index 309500b0adb..179aa5f3d62 100644 --- a/lisp/cedet/semantic/analyze/refs.el +++ b/lisp/cedet/semantic/analyze/refs.el @@ -104,7 +104,7 @@ Use `semantic-analyze-current-tag' to debug this fcn." "Return the implementations derived in the reference analyzer REFS. Optional argument IN-BUFFER indicates that the returned tag should be in an active buffer." (let ((allhits (oref refs rawsearchdata)) - (tag (oref refs :tag)) + (tag (oref refs tag)) (impl nil) ) (semanticdb-find-result-mapc @@ -129,7 +129,7 @@ Optional argument IN-BUFFER indicates that the returned tag should be in an acti "Return the prototypes derived in the reference analyzer REFS. Optional argument IN-BUFFER indicates that the returned tag should be in an active buffer." (let ((allhits (oref refs rawsearchdata)) - (tag (oref refs :tag)) + (tag (oref refs tag)) (proto nil)) (semanticdb-find-result-mapc (lambda (T DB) @@ -317,9 +317,8 @@ Only works for tags in the global namespace." (let* ((tag (semantic-current-tag)) (start (current-time)) (sac (semantic-analyze-tag-references tag)) - (end (current-time)) ) - (message "Analysis took %.2f seconds." (semantic-elapsed-time start end)) + (message "Analysis took %.2f seconds." (semantic-elapsed-time start nil)) (if sac (progn (require 'eieio-datadebug) @@ -347,6 +346,8 @@ Only works for tags in the global namespace." (if (semantic-tag-prototype-p tag) "implementation" "prototype"))) (push-mark) + (when (fboundp 'xref-push-marker-stack) + (xref-push-marker-stack)) (semantic-go-to-tag target) (pop-to-buffer-same-window (current-buffer)) (semantic-momentary-highlight-tag target)) diff --git a/lisp/cedet/semantic/bovine.el b/lisp/cedet/semantic/bovine.el index b185765df76..7a9556f7846 100644 --- a/lisp/cedet/semantic/bovine.el +++ b/lisp/cedet/semantic/bovine.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1999-2004, 2006-2007, 2009-2019 Free Software ;; Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -72,7 +72,7 @@ The return list is a lambda expression to be used in a bovine table." "Return the current nonterminal symbol. Part of the grammar source debugger. Depends on the existing environment of `semantic-bovinate-stream'." - `(if nt-stack + '(if nt-stack (car (aref (car nt-stack) 2)) nonterminal)) diff --git a/lisp/cedet/semantic/bovine/c.el b/lisp/cedet/semantic/bovine/c.el index 2b2cac11783..b05082c60ef 100644 --- a/lisp/cedet/semantic/bovine/c.el +++ b/lisp/cedet/semantic/bovine/c.el @@ -1990,7 +1990,7 @@ have to be wrapped in that namespace." (list (semantic-tag-new-type inside-ns "namespace" tags nil))) ;; Create new semantic-table for the wrapped tags, since we don't want ;; the namespace to actually be a part of the header file. - (setq newtable (semanticdb-table "include with context")) + (setq newtable (semanticdb-table)) (oset newtable tags newtags) (oset newtable parent-db (oref inctable parent-db)) (oset newtable file (oref inctable file))) @@ -2183,7 +2183,7 @@ actually in their parent which is not accessible.") (list ede-object)))) (dolist (O objs) (princ " EDE : ") - (princ (object-print O)) + (princ 0) (let ((ipath (ede-system-include-path O))) (if (not ipath) (princ "\n with NO specified system include path.\n") @@ -2221,7 +2221,7 @@ actually in their parent which is not accessible.") (princ " in table: ") (let ((fto (semanticdb-file-table-object file))) (if fto - (princ (object-print fto)) + (princ (cl-prin1-to-string fto)) (princ "No Table"))) (princ "\n") )) @@ -2251,7 +2251,7 @@ actually in their parent which is not accessible.") (princ "\n Project symbol map:\n") (when (and (boundp 'ede-object) ede-object) (princ " Your project symbol map is also derived from the EDE object:\n ") - (princ (object-print ede-object))) + (princ (cl-prin1-to-string ede-object))) (princ "\n\n") (if (obarrayp semantic-lex-spp-project-macro-symbol-obarray) (let ((macros nil)) diff --git a/lisp/cedet/semantic/bovine/debug.el b/lisp/cedet/semantic/bovine/debug.el index d4f04253dcb..3464e25787f 100644 --- a/lisp/cedet/semantic/bovine/debug.el +++ b/lisp/cedet/semantic/bovine/debug.el @@ -73,8 +73,7 @@ The RULE is for \"thing\" is 1. The MATCH for \"thing\" is 1. COLLECTION is a list of `things' that have been matched so far. LEXTOKEN, is a token returned by the lexer which is being matched." - (let ((frame (semantic-bovine-debug-frame "frame" - :nonterm nonterm + (let ((frame (semantic-bovine-debug-frame :nonterm nonterm :rule rule :match match :collection collection @@ -119,8 +118,7 @@ LEXTOKEN, is a token returned by the lexer which is being matched." (defun semantic-create-bovine-debug-error-frame (condition) "Create an error frame for bovine debugger. Argument CONDITION is the thrown error condition." - (let ((frame (semantic-bovine-debug-error-frame "frame" - :condition condition))) + (let ((frame (semantic-bovine-debug-error-frame :condition condition))) (semantic-debug-set-frame semantic-debug-current-interface frame) frame)) diff --git a/lisp/cedet/semantic/bovine/gcc.el b/lisp/cedet/semantic/bovine/gcc.el index e04efb30b79..e5f85599fec 100644 --- a/lisp/cedet/semantic/bovine/gcc.el +++ b/lisp/cedet/semantic/bovine/gcc.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. diff --git a/lisp/cedet/semantic/bovine/grammar.el b/lisp/cedet/semantic/bovine/grammar.el index 529958a8075..7c25b79db86 100644 --- a/lisp/cedet/semantic/bovine/grammar.el +++ b/lisp/cedet/semantic/bovine/grammar.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2002-2019 Free Software Foundation, Inc. ;; ;; Author: David Ponce <david@dponce.com> -;; Maintainer: David Ponce <david@dponce.com> ;; Created: 26 Aug 2002 ;; Keywords: syntax @@ -475,6 +474,7 @@ Menu items are appended to the common grammar menu.") ;; This is with-demoted-errors. (condition-case err (with-current-buffer (find-file-noselect infile) + (setq infile buffer-file-name) (if outdir (setq default-directory outdir)) (semantic-grammar-create-package nil t)) (error (message "%s" (error-message-string err)) nil))) @@ -509,8 +509,12 @@ Menu items are appended to the common grammar menu.") ;;; Commentary: ;; -;; This file was generated from admin/grammars/" - lang ".by. +;; This file was generated from " + (if (string-match "\\(admin/grammars/.*\\.by\\)\\'" infile) + (match-string 1 infile) + (concat "admin/grammars/" + (if (string-equal lang "scm") "scheme" lang) ".by")) +". ;;; Code: ") diff --git a/lisp/cedet/semantic/bovine/make.el b/lisp/cedet/semantic/bovine/make.el index 4fe33345d73..3676c6972f2 100644 --- a/lisp/cedet/semantic/bovine/make.el +++ b/lisp/cedet/semantic/bovine/make.el @@ -181,10 +181,10 @@ Uses default implementation, and also gets a list of filenames." (require 'semantic/analyze/complete) (with-current-buffer (oref context buffer) (let* ((normal (semantic-analyze-possible-completions-default context)) - (classes (oref context :prefixclass)) + (classes (oref context prefixclass)) (filetags nil)) (when (memq 'filename classes) - (let* ((prefix (car (oref context :prefix))) + (let* ((prefix (car (oref context prefix))) (completetext (cond ((semantic-tag-p prefix) (semantic-tag-name prefix)) ((stringp prefix) diff --git a/lisp/cedet/semantic/chart.el b/lisp/cedet/semantic/chart.el index 02da145ca5b..c02588d68b9 100644 --- a/lisp/cedet/semantic/chart.el +++ b/lisp/cedet/semantic/chart.el @@ -29,6 +29,8 @@ (require 'chart) (require 'semantic/db) (require 'semantic/find) +(require 'semantic/db-typecache) +(require 'semantic/scope) ;;; Code: @@ -140,14 +142,9 @@ items are charted. TAGTABLE is passed to nums "Complexity (Lines of code)") )) -(declare-function semanticdb-get-typecache "semantic/db-typecache") -(declare-function semantic-calculate-scope "semantic/scope") - (defun semantic-chart-analyzer () "Chart the extent of the context analysis." (interactive) - (require 'semantic/db-typecache) - (require 'semantic/scope) (let* ((p (semanticdb-find-translate-path nil nil)) (plen (length p)) (tab semanticdb-current-table) diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el index 1e7bbbd813c..b438a1c6e22 100644 --- a/lisp/cedet/semantic/complete.el +++ b/lisp/cedet/semantic/complete.el @@ -72,17 +72,17 @@ ;; plain name format, a postfix name such as method:class, or a ;; prefix name such as class.method. ;; -;; DISPLAYORS +;; DISPLAYERS ;; -;; A displayor is in charge if showing the user interesting things +;; A displayer is in charge if showing the user interesting things ;; about available completions, and can optionally provide a focus. ;; The simplest display just lists all available names in a separate ;; window. It may even choose to show short names when there are ;; many to choose from, or long names when there are fewer. ;; -;; A complex displayor could opt to help the user 'focus' on some +;; A complex displayer could opt to help the user 'focus' on some ;; range. For example, if 4 tags all have the same name, subsequent -;; calls to the displayor may opt to show each tag one at a time in +;; calls to the displayer may opt to show each tag one at a time in ;; the buffer. When the user likes one, selection would cause the ;; 'focus' item to be selected. ;; @@ -106,7 +106,6 @@ ;; `semantic-complete-inline-tag-engine' will complete text in ;; a buffer. -(eval-when-compile (require 'cl)) (require 'semantic) (require 'eieio-opt) (require 'semantic/analyze) @@ -128,8 +127,8 @@ (defun semantic-completion-inline-active-p () "Non-nil if inline completion is active." (when (and semantic-complete-inline-overlay - (not (semantic-overlay-live-p semantic-complete-inline-overlay))) - (semantic-overlay-delete semantic-complete-inline-overlay) + (not (overlay-buffer semantic-complete-inline-overlay))) + (delete-overlay semantic-complete-inline-overlay) (setq semantic-complete-inline-overlay nil)) semantic-complete-inline-overlay) @@ -191,22 +190,22 @@ Keeps STRINGS only in the history.") (defvar semantic-complete-active-default) (defvar semantic-complete-current-matched-tag) -(defun semantic-complete-read-tag-engine (collector displayor prompt +(defun semantic-complete-read-tag-engine (collector displayer prompt default-tag initial-input history) "Read a semantic tag, and return a tag for the selection. Argument COLLECTOR is an object which can be used to calculate a list of possible hits. See `semantic-completion-collector-engine' for details on COLLECTOR. -Argument DISPLAYOR is an object used to display a list of possible +Argument DISPLAYER is an object used to display a list of possible completions for a given prefix. See`semantic-completion-display-engine' -for details on DISPLAYOR. +for details on DISPLAYER. PROMPT is a string to prompt with. DEFAULT-TAG is a semantic tag or string to use as the default value. If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. HISTORY is a symbol representing a variable to story the history in." (let* ((semantic-completion-collector-engine collector) - (semantic-completion-display-engine displayor) + (semantic-completion-display-engine displayer) (semantic-complete-active-default nil) (semantic-complete-current-matched-tag nil) (default-as-tag (semantic-complete-default-to-tag default-tag)) @@ -242,7 +241,7 @@ HISTORY is a symbol representing a variable to story the history in." 'semantic-completion-default-history) default-tag) (semantic-collector-cleanup semantic-completion-collector-engine) - (semantic-displayor-cleanup semantic-completion-display-engine) + (semantic-displayer-cleanup semantic-completion-display-engine) ) ;; ;; Extract the tag from the completion machinery. @@ -313,10 +312,10 @@ HISTORY is a symbol representing a variable to story the history in." (defvar semantic-complete-current-matched-tag nil "Variable used to pass the tags being matched to the prompt.") -;; semantic-displayor-focus-abstract-child-p is part of the -;; semantic-displayor-focus-abstract class, defined later in this +;; semantic-displayer-focus-abstract-child-p is part of the +;; semantic-displayer-focus-abstract class, defined later in this ;; file. -(declare-function semantic-displayor-focus-abstract-child-p "semantic/complete" +(declare-function semantic-displayer-focus-abstract-child-p "semantic/complete" t t) (defun semantic-complete-current-match () @@ -328,7 +327,7 @@ Return value can be: string - a message to show in the minibuffer." ;; Query the environment for an active completion. (let ((collector semantic-completion-collector-engine) - (displayor semantic-completion-display-engine) + (displayer semantic-completion-display-engine) (contents (semantic-completion-text)) matchlist answer) @@ -340,20 +339,20 @@ Return value can be: (semantic-collector-calculate-completions collector contents nil)) (semantic-complete-try-completion) (cond - ;; Input match displayor focus entry - ((setq answer (semantic-displayor-current-focus displayor)) + ;; Input match displayer focus entry + ((setq answer (semantic-displayer-current-focus displayer)) ;; We have answer, continue ) ;; One match from the collector ((setq matchlist (semantic-collector-current-exact-match collector)) (if (= (semanticdb-find-result-length matchlist) 1) (setq answer (semanticdb-find-result-nth-in-buffer matchlist 0)) - (if (semantic-displayor-focus-abstract-child-p displayor) - ;; For focusing displayors, we can claim this is + (if (semantic-displayer-focus-abstract-child-p displayer) + ;; For focusing displayers, we can claim this is ;; not unique. Multiple focuses can choose the correct ;; one. (setq answer "Not Unique") - ;; If we don't have a focusing displayor, we need to do something + ;; If we don't have a focusing displayer, we need to do something ;; graceful. First, see if all the matches have the same name. (let ((allsame t) (firstname (semantic-tag-name @@ -494,7 +493,7 @@ If PARTIAL, do partial completion stopping at spaces." If PARTIAL, do partial completion stopping at spaces. if INLINE, then completion is happening inline in a buffer." (let* ((collector semantic-completion-collector-engine) - (displayor semantic-completion-display-engine) + (displayer semantic-completion-display-engine) (contents (semantic-completion-text)) (ans nil)) @@ -515,8 +514,8 @@ if INLINE, then completion is happening inline in a buffer." ;; We need to display the completions. ;; Set the completions into the display engine ((or (eq na 'display) (eq na 'displayend)) - (semantic-displayor-set-completions - displayor + (semantic-displayer-set-completions + displayer (or ;; For the below - This caused problems for Chong Yidong ;; when experimenting with the completion engine. I don't @@ -527,14 +526,14 @@ if INLINE, then completion is happening inline in a buffer." ;; (semantic-collector-current-exact-match collector)) (semantic-collector-all-completions collector contents)) contents) - ;; Ask the displayor to display them. - (semantic-displayor-show-request displayor)) + ;; Ask the displayer to display them. + (semantic-displayer-show-request displayer)) ((eq na 'scroll) - (semantic-displayor-scroll-request displayor) + (semantic-displayer-scroll-request displayer) ) ((eq na 'focus) - (semantic-displayor-focus-next displayor) - (semantic-displayor-focus-request displayor) + (semantic-displayer-focus-next displayer) + (semantic-displayer-focus-request displayer) ) ((eq na 'empty) (semantic-completion-message " [No Match]")) @@ -575,8 +574,8 @@ The face is used in `semantic-complete-inline-tag-engine'." (defun semantic-complete-inline-text () "Return the text that is being completed inline. Similar to `minibuffer-contents' when completing in the minibuffer." - (let ((s (semantic-overlay-start semantic-complete-inline-overlay)) - (e (semantic-overlay-end semantic-complete-inline-overlay))) + (let ((s (overlay-start semantic-complete-inline-overlay)) + (e (overlay-end semantic-complete-inline-overlay))) (if (= s e) "" (buffer-substring-no-properties s e )))) @@ -584,14 +583,14 @@ Similar to `minibuffer-contents' when completing in the minibuffer." (defun semantic-complete-inline-delete-text () "Delete the text currently being completed in the current buffer." (delete-region - (semantic-overlay-start semantic-complete-inline-overlay) - (semantic-overlay-end semantic-complete-inline-overlay))) + (overlay-start semantic-complete-inline-overlay) + (overlay-end semantic-complete-inline-overlay))) (defun semantic-complete-inline-done () "This completion thing is DONE, OR, insert a newline." (interactive) - (let* ((displayor semantic-completion-display-engine) - (tag (semantic-displayor-current-focus displayor))) + (let* ((displayer semantic-completion-display-engine) + (tag (semantic-displayer-current-focus displayer))) (if tag (let ((txt (semantic-completion-text))) (insert (substring (semantic-tag-name tag) @@ -628,14 +627,14 @@ Similar to `minibuffer-contents' when completing in the minibuffer." (when semantic-completion-collector-engine (semantic-collector-cleanup semantic-completion-collector-engine)) (when semantic-completion-display-engine - (semantic-displayor-cleanup semantic-completion-display-engine)) + (semantic-displayer-cleanup semantic-completion-display-engine)) (when semantic-complete-inline-overlay - (let ((wc (semantic-overlay-get semantic-complete-inline-overlay + (let ((wc (overlay-get semantic-complete-inline-overlay 'window-config-start)) - (buf (semantic-overlay-buffer semantic-complete-inline-overlay)) + (buf (overlay-buffer semantic-complete-inline-overlay)) ) - (semantic-overlay-delete semantic-complete-inline-overlay) + (delete-overlay semantic-complete-inline-overlay) (setq semantic-complete-inline-overlay nil) ;; DONT restore the window configuration if we just ;; switched windows! @@ -681,10 +680,10 @@ a reasonable distance." ;;(message "Inline Hook installed, but overlay deleted.") (semantic-complete-inline-exit)) ;; Exit if commands caused us to exit the area of interest - (let ((os (semantic-overlay-get semantic-complete-inline-overlay 'semantic-original-start)) - (s (semantic-overlay-start semantic-complete-inline-overlay)) - (e (semantic-overlay-end semantic-complete-inline-overlay)) - (b (semantic-overlay-buffer semantic-complete-inline-overlay)) + (let ((os (overlay-get semantic-complete-inline-overlay 'semantic-original-start)) + (s (overlay-start semantic-complete-inline-overlay)) + (e (overlay-end semantic-complete-inline-overlay)) + (b (overlay-buffer semantic-complete-inline-overlay)) (txt nil) ) (cond @@ -726,29 +725,29 @@ DO NOT CALL THIS IF THE INLINE COMPLETION ENGINE IS NOT ACTIVE." (condition-case e (save-excursion (let ((collector semantic-completion-collector-engine) - (displayor semantic-completion-display-engine) + (displayer semantic-completion-display-engine) (contents (semantic-completion-text))) (when collector (semantic-collector-calculate-completions collector contents nil) - (semantic-displayor-set-completions - displayor + (semantic-displayer-set-completions + displayer (semantic-collector-all-completions collector contents) contents) - ;; Ask the displayor to display them. - (semantic-displayor-show-request displayor)) + ;; Ask the displayer to display them. + (semantic-displayer-show-request displayer)) )) (error (message "Bug Showing Completions: %S" e)))) (defun semantic-complete-inline-tag-engine - (collector displayor buffer start end) + (collector displayer buffer start end) "Perform completion based on semantic tags in a buffer. Argument COLLECTOR is an object which can be used to calculate a list of possible hits. See `semantic-completion-collector-engine' for details on COLLECTOR. -Argument DISPLAYOR is an object used to display a list of possible +Argument DISPLAYER is an object used to display a list of possible completions for a given prefix. See`semantic-completion-display-engine' -for details on DISPLAYOR. +for details on DISPLAYER. BUFFER is the buffer in which completion will take place. START is a location for the start of the full symbol. If the symbol being completed is \"foo.ba\", then START @@ -756,20 +755,20 @@ is on the \"f\" character. END is at the end of the current symbol being completed." ;; Set us up for doing completion (setq semantic-completion-collector-engine collector - semantic-completion-display-engine displayor) + semantic-completion-display-engine displayer) ;; Create an overlay (setq semantic-complete-inline-overlay - (semantic-make-overlay start end buffer nil t)) - (semantic-overlay-put semantic-complete-inline-overlay - 'face - 'semantic-complete-inline-face) - (semantic-overlay-put semantic-complete-inline-overlay - 'window-config-start - (current-window-configuration)) + (make-overlay start end buffer nil t)) + (overlay-put semantic-complete-inline-overlay + 'face + 'semantic-complete-inline-face) + (overlay-put semantic-complete-inline-overlay + 'window-config-start + (current-window-configuration)) ;; Save the original start. We need to exit completion if START ;; moves. - (semantic-overlay-put semantic-complete-inline-overlay - 'semantic-original-start start) + (overlay-put semantic-complete-inline-overlay + 'semantic-original-start start) ;; Install our command hooks (add-hook 'pre-command-hook 'semantic-complete-pre-command-hook) (add-hook 'post-command-hook 'semantic-complete-post-command-hook) @@ -792,19 +791,19 @@ END is at the end of the current symbol being completed." ) (defun semantic-complete-inline-down() - "Focus forwards through the displayor." + "Focus forwards through the displayer." (interactive) - (let ((displayor semantic-completion-display-engine)) - (semantic-displayor-focus-next displayor) - (semantic-displayor-focus-request displayor) + (let ((displayer semantic-completion-display-engine)) + (semantic-displayer-focus-next displayer) + (semantic-displayer-focus-request displayer) )) (defun semantic-complete-inline-up () - "Focus backwards through the displayor." + "Focus backwards through the displayer." (interactive) - (let ((displayor semantic-completion-display-engine)) - (semantic-displayor-focus-previous displayor) - (semantic-displayor-focus-request displayor) + (let ((displayer semantic-completion-display-engine)) + (semantic-displayer-focus-previous displayer) + (semantic-displayer-focus-request displayer) )) @@ -812,13 +811,13 @@ END is at the end of the current symbol being completed." ;;; Interactions between collection and displaying ;; ;; Functional routines used to help collectors communicate with -;; the current displayor, or for the previous section. +;; the current displayer, or for the previous section. (defun semantic-complete-next-action (partial) "Determine what the next completion action should be. PARTIAL is non-nil if we are doing partial completion. First, the collector can determine if we should perform a completion or not. -If there is nothing to complete, then the displayor determines if we are +If there is nothing to complete, then the displayer determines if we are to show a completion list, scroll, or perhaps do a focus (if it is capable.) Expected return values are: done -> We have a singular match @@ -828,21 +827,21 @@ Expected return values are: display -> Show the list of completions scroll -> The completions have been shown, and the user keeps hitting the complete button. If possible, scroll the completions - focus -> The displayor knows how to shift focus among possible completions. + focus -> The displayer knows how to shift focus among possible completions. Let it do that. - displayend -> Whatever options the displayor had for repeating options, there + displayend -> Whatever options the displayer had for repeating options, there are none left. Try something new." (let ((ans1 (semantic-collector-next-action semantic-completion-collector-engine partial)) - (ans2 (semantic-displayor-next-action + (ans2 (semantic-displayer-next-action semantic-completion-display-engine)) ) (cond - ;; No collector answer, use displayor answer. + ;; No collector answer, use displayer answer. ((not ans1) ans2) - ;; Displayor selection of 'scroll, 'display, or 'focus trumps + ;; Displayer selection of 'scroll, 'display, or 'focus trumps ;; 'done ((and (eq ans1 'done) ans2) ans2) @@ -910,7 +909,7 @@ When tokens are matched, they are added to this list.") ) "Root class for completion engines. The baseclass provides basic functionality for interacting with -a completion displayor object, and tracking the current progress +a completion displayer object, and tracking the current progress of a completion." :abstract t) @@ -963,7 +962,7 @@ PARTIAL indicates if we are doing a partial completion." (cond ((and cem (= cemlen 1) cac (> caclen 1) (eq last-command this-command)) - ;; Defer to the displayor... + ;; Defer to the displayer... nil) ((and cem (= cemlen 1)) 'done) @@ -1177,8 +1176,8 @@ with that name." These collectors track themselves on a per-buffer basis." :abstract t) -(cl-defmethod constructor ((this (subclass semantic-collector-buffer-abstract)) - newname &rest fields) +(cl-defmethod make-instance ((this (subclass semantic-collector-buffer-abstract)) + &rest args) "Reuse previously created objects of this type in buffer." (let ((old nil) (bl semantic-collector-per-buffer-list)) @@ -1282,7 +1281,7 @@ Uses semanticdb for searching all tags in the current project." (localstuff (oref scope scope))) (list (cons - (oref scope :table) + (oref scope table) (semantic-find-tags-for-completion prefix localstuff))))) ;(semanticdb-brute-deep-find-tags-for-completion prefix (oref obj path)))) @@ -1290,44 +1289,48 @@ Uses semanticdb for searching all tags in the current project." ;;; ------------------------------------------------------------ ;;; Tag List Display Engines ;; -;; A typical displayor accepts a pre-determined list of completions +;; A typical displayer accepts a pre-determined list of completions ;; generated by a collector. This format is in semanticdb search ;; form. This vaguely standard form is a bit challenging to navigate ;; because the tags do not contain buffer info, but the file associated ;; with the tags precedes the tag in the list. ;; -;; Basic displayors don't care, and can strip the results. -;; Advanced highlighting displayors need to know when they need +;; Basic displayers don't care, and can strip the results. +;; Advanced highlighting displayers need to know when they need ;; to load a file so that the tag in question can be highlighted. ;; -;; Key interface methods to a displayor are: -;; * semantic-displayor-next-action -;; * semantic-displayor-set-completions -;; * semantic-displayor-current-focus -;; * semantic-displayor-show-request -;; * semantic-displayor-scroll-request -;; * semantic-displayor-focus-request - -(defclass semantic-displayor-abstract () +;; Key interface methods to a displayer are: +;; * semantic-displayer-next-action +;; * semantic-displayer-set-completions +;; * semantic-displayer-current-focus +;; * semantic-displayer-show-request +;; * semantic-displayer-scroll-request +;; * semantic-displayer-focus-request + +(defclass semantic-displayer-abstract () ((table :type (or null semanticdb-find-result-with-nil) :initform nil :protection :protected - :documentation "List of tags this displayor is showing.") + :documentation "List of tags this displayer is showing.") (last-prefix :type string :protection :protected :documentation "Prefix associated with slot `table'") ) - "Abstract displayor baseclass. + "Abstract displayer baseclass. Manages the display of some number of tags. -Provides the basics for a displayor, including interacting with +Provides the basics for a displayer, including interacting with a collector, and tracking tables of completion to display." :abstract t) -(cl-defmethod semantic-displayor-cleanup ((obj semantic-displayor-abstract)) - "Clean up any mess this displayor may have." +(define-obsolete-function-alias 'semantic-displayor-cleanup + #'semantic-displayer-cleanup "27.1") +(cl-defmethod semantic-displayer-cleanup ((obj semantic-displayer-abstract)) + "Clean up any mess this displayer may have." nil) -(cl-defmethod semantic-displayor-next-action ((obj semantic-displayor-abstract)) +(define-obsolete-function-alias 'semantic-displayor-next-action + #'semantic-displayer-next-action "27.1") +(cl-defmethod semantic-displayer-next-action ((obj semantic-displayer-abstract)) "The next action to take on the minibuffer related to display." (if (and (slot-boundp obj 'last-prefix) (or (eq this-command 'semantic-complete-inline-TAB) @@ -1336,65 +1339,82 @@ a collector, and tracking tables of completion to display." 'scroll 'display)) -(cl-defmethod semantic-displayor-set-completions ((obj semantic-displayor-abstract) +(define-obsolete-function-alias 'semantic-displayor-set-completions + #'semantic-displayer-set-completions "27.1") +(cl-defmethod semantic-displayer-set-completions ((obj semantic-displayer-abstract) table prefix) "Set the list of tags to be completed over to TABLE." (oset obj table table) (oset obj last-prefix prefix)) -(cl-defmethod semantic-displayor-show-request ((obj semantic-displayor-abstract)) +(define-obsolete-function-alias 'semantic-displayor-show-request + #'semantic-displayer-show-request "27.1") +(cl-defmethod semantic-displayer-show-request ((obj semantic-displayer-abstract)) "A request to show the current tags table." (ding)) -(cl-defmethod semantic-displayor-focus-request ((obj semantic-displayor-abstract)) - "A request to for the displayor to focus on some tag option." +(define-obsolete-function-alias 'semantic-displayor-focus-request + #'semantic-displayer-focus-request "27.1") +(cl-defmethod semantic-displayer-focus-request ((obj semantic-displayer-abstract)) + "A request to for the displayer to focus on some tag option." (ding)) -(cl-defmethod semantic-displayor-scroll-request ((obj semantic-displayor-abstract)) - "A request to for the displayor to scroll the completion list (if needed)." +(define-obsolete-function-alias 'semantic-displayor-scroll-request + #'semantic-displayer-scroll-request "27.1") +(cl-defmethod semantic-displayer-scroll-request ((obj semantic-displayer-abstract)) + "A request to for the displayer to scroll the completion list (if needed)." (scroll-other-window)) -(cl-defmethod semantic-displayor-focus-previous ((obj semantic-displayor-abstract)) +(define-obsolete-function-alias 'semantic-displayor-focus-previous + #'semantic-displayer-focus-previous "27.1") +(cl-defmethod semantic-displayer-focus-previous ((obj semantic-displayer-abstract)) "Set the current focus to the previous item." nil) -(cl-defmethod semantic-displayor-focus-next ((obj semantic-displayor-abstract)) +(define-obsolete-function-alias 'semantic-displayor-focus-next + #'semantic-displayer-focus-next "27.1") +(cl-defmethod semantic-displayer-focus-next ((obj semantic-displayer-abstract)) "Set the current focus to the next item." nil) -(cl-defmethod semantic-displayor-current-focus ((obj semantic-displayor-abstract)) +(define-obsolete-function-alias 'semantic-displayor-current-focus + #'semantic-displayer-current-focus "27.1") +(cl-defmethod semantic-displayer-current-focus ((obj semantic-displayer-abstract)) "Return a single tag currently in focus. This object type doesn't do focus, so will never have a focus object." nil) -;; Traditional displayor -(defcustom semantic-completion-displayor-format-tag-function + +;; Traditional displayer +(defcustom semantic-completion-displayer-format-tag-function #'semantic-format-tag-name "A Tag format function to use when showing completions." :group 'semantic :type semantic-format-tag-custom-list) -(defclass semantic-displayor-traditional (semantic-displayor-abstract) +(defclass semantic-displayer-traditional (semantic-displayer-abstract) () "Display options in *Completions* buffer. Traditional display mechanism for a list of possible completions. Completions are showin in a new buffer and listed with the ability to click on the items to aid in completion.") -(cl-defmethod semantic-displayor-show-request ((obj semantic-displayor-traditional)) +(define-obsolete-function-alias 'semantic-displayor-show-request + #'semantic-displayer-show-request "27.1") +(cl-defmethod semantic-displayer-show-request ((obj semantic-displayer-traditional)) "A request to show the current tags table." ;; NOTE TO SELF. Find the character to type next, and emphasize it. (with-output-to-temp-buffer "*Completions*" (display-completion-list - (mapcar semantic-completion-displayor-format-tag-function + (mapcar semantic-completion-displayer-format-tag-function (semanticdb-strip-find-results (oref obj table)))) ) ) -;;; Abstract baseclass for any displayor which supports focus -(defclass semantic-displayor-focus-abstract (semantic-displayor-abstract) +;;; Abstract baseclass for any displayer which supports focus +(defclass semantic-displayer-focus-abstract (semantic-displayer-abstract) ((focus :type number :protection :protected :documentation "A tag index from `table' which has focus. @@ -1406,13 +1426,15 @@ given tag, by highlighting its location.") :documentation "Non-nil if focusing requires a tag's buffer be in memory.") ) - "Abstract displayor supporting `focus'. -A displayor which has the ability to focus in on one tag. + "Abstract displayer supporting `focus'. +A displayer which has the ability to focus in on one tag. Focusing is a way of differentiating among multiple tags which have the same name." :abstract t) -(cl-defmethod semantic-displayor-next-action ((obj semantic-displayor-focus-abstract)) +(define-obsolete-function-alias 'semantic-displayor-next-action + #'semantic-displayer-next-action "27.1") +(cl-defmethod semantic-displayer-next-action ((obj semantic-displayer-focus-abstract)) "The next action to take on the minibuffer related to display." (if (and (slot-boundp obj 'last-prefix) (string= (oref obj last-prefix) (semantic-completion-text)) @@ -1428,13 +1450,17 @@ which have the same name." 'focus) 'display)) -(cl-defmethod semantic-displayor-set-completions ((obj semantic-displayor-focus-abstract) +(define-obsolete-function-alias 'semantic-displayor-set-completions + #'semantic-displayer-set-completions "27.1") +(cl-defmethod semantic-displayer-set-completions ((obj semantic-displayer-focus-abstract) table prefix) "Set the list of tags to be completed over to TABLE." (cl-call-next-method) (slot-makeunbound obj 'focus)) -(cl-defmethod semantic-displayor-focus-previous ((obj semantic-displayor-focus-abstract)) +(define-obsolete-function-alias 'semantic-displayor-focus-previous + #'semantic-displayer-focus-previous "27.1") +(cl-defmethod semantic-displayer-focus-previous ((obj semantic-displayer-focus-abstract)) "Set the current focus to the previous item. Not meaningful return value." (when (and (slot-boundp obj 'table) (oref obj table)) @@ -1446,7 +1472,9 @@ Not meaningful return value." ) ))) -(cl-defmethod semantic-displayor-focus-next ((obj semantic-displayor-focus-abstract)) +(define-obsolete-function-alias 'semantic-displayor-focus-next + #'semantic-displayer-focus-next "27.1") +(cl-defmethod semantic-displayer-focus-next ((obj semantic-displayer-focus-abstract)) "Set the current focus to the next item. Not meaningful return value." (when (and (slot-boundp obj 'table) (oref obj table)) @@ -1459,13 +1487,17 @@ Not meaningful return value." (oset obj focus 0)) ))) -(cl-defmethod semantic-displayor-focus-tag ((obj semantic-displayor-focus-abstract)) +(define-obsolete-function-alias 'semantic-displayor-focus-tag + #'semantic-displayer-focus-tag "27.1") +(cl-defmethod semantic-displayer-focus-tag ((obj semantic-displayer-focus-abstract)) "Return the next tag OBJ should focus on." (when (and (slot-boundp obj 'table) (oref obj table)) (with-slots (table) obj (semanticdb-find-result-nth table (oref obj focus))))) -(cl-defmethod semantic-displayor-current-focus ((obj semantic-displayor-focus-abstract)) +(define-obsolete-function-alias 'semantic-displayor-current-focus + #'semantic-displayer-current-focus "27.1") +(cl-defmethod semantic-displayer-current-focus ((obj semantic-displayer-focus-abstract)) "Return the tag currently in focus, or call parent method." (if (and (slot-boundp obj 'focus) (slot-boundp obj 'table) @@ -1483,24 +1515,26 @@ Not meaningful return value." ;; Do whatever (cl-call-next-method))) -;;; Simple displayor which performs traditional display completion, +;;; Simple displayer which performs traditional display completion, ;; and also focuses with highlighting. -(defclass semantic-displayor-traditional-with-focus-highlight - (semantic-displayor-focus-abstract semantic-displayor-traditional) +(defclass semantic-displayer-traditional-with-focus-highlight + (semantic-displayer-focus-abstract semantic-displayer-traditional) ((find-file-focus :initform t)) "Display completions in *Completions* buffer, with focus highlight. -A traditional displayor which can focus on a tag by showing it. -Same as `semantic-displayor-traditional', but with selection between +A traditional displayer which can focus on a tag by showing it. +Same as `semantic-displayer-traditional', but with selection between multiple tags with the same name done by focusing on the source location of the different tags to differentiate them.") -(cl-defmethod semantic-displayor-focus-request - ((obj semantic-displayor-traditional-with-focus-highlight)) +(define-obsolete-function-alias 'semantic-displayor-focus-request + #'semantic-displayer-focus-request "27.1") +(cl-defmethod semantic-displayer-focus-request + ((obj semantic-displayer-traditional-with-focus-highlight)) "Focus in on possible tag completions. Focus is performed by cycling through the tags and highlighting one in the source buffer." (let* ((tablelength (semanticdb-find-result-length (oref obj table))) - (focus (semantic-displayor-focus-tag obj)) + (focus (semantic-displayer-focus-tag obj)) ;; Raw tag info. (rtag (car focus)) (rtable (cdr focus)) @@ -1552,29 +1586,29 @@ one in the source buffer." ;;; Tooltip completion lister ;; -;; Written and contributed by Masatake YAMATO <jet@gyve.org> +;; Written and contributed by Masatake YAMATO <yamato@redhat.com> ;; ;; Modified by Eric Ludlam for ;; * Safe compatibility for tooltip free systems. ;; * Don't use 'avoid package for tooltip positioning. ;;;###autoload -(defcustom semantic-displayor-tooltip-mode 'standard +(defcustom semantic-displayer-tooltip-mode 'standard "Mode for the tooltip inline completion. -Standard: Show only `semantic-displayor-tooltip-initial-max-tags' +Standard: Show only `semantic-displayer-tooltip-initial-max-tags' number of completions initially. Pressing TAB will show the extended set. Quiet: Only show completions when we have narrowed all possibilities down to a maximum of -`semantic-displayor-tooltip-initial-max-tags' tags. Pressing TAB +`semantic-displayer-tooltip-initial-max-tags' tags. Pressing TAB multiple times will also show completions. Verbose: Always show all completions available. The absolute maximum number of completions for all mode is -determined through `semantic-displayor-tooltip-max-tags'." +determined through `semantic-displayer-tooltip-max-tags'." :group 'semantic :version "24.3" :type '(choice (const :tag "Standard" standard) @@ -1582,14 +1616,14 @@ determined through `semantic-displayor-tooltip-max-tags'." (const :tag "Verbose" verbose))) ;;;###autoload -(defcustom semantic-displayor-tooltip-initial-max-tags 5 +(defcustom semantic-displayer-tooltip-initial-max-tags 5 "Maximum number of tags to be displayed initially. -See doc-string of `semantic-displayor-tooltip-mode' for details." +See doc-string of `semantic-displayer-tooltip-mode' for details." :group 'semantic :version "24.3" :type 'integer) -(defcustom semantic-displayor-tooltip-max-tags 25 +(defcustom semantic-displayer-tooltip-max-tags 25 "The maximum number of tags to be displayed. Maximum number of completions where we have activated the extended completion list through typing TAB or SPACE multiple @@ -1607,17 +1641,17 @@ This will not happen if you directly set this variable via `setq'." (setcdr x-max-tooltip-size (max (1+ var) (cdr x-max-tooltip-size)))))) -(defclass semantic-displayor-tooltip (semantic-displayor-traditional) +(defclass semantic-displayer-tooltip (semantic-displayer-traditional) ((mode :initarg :mode :initform - (symbol-value 'semantic-displayor-tooltip-mode) + (symbol-value 'semantic-displayer-tooltip-mode) :documentation - "See `semantic-displayor-tooltip-mode'.") + "See `semantic-displayer-tooltip-mode'.") (max-tags-initial :initarg max-tags-initial :initform - (symbol-value 'semantic-displayor-tooltip-initial-max-tags) + (symbol-value 'semantic-displayer-tooltip-initial-max-tags) :documentation - "See `semantic-displayor-tooltip-initial-max-tags'.") + "See `semantic-displayer-tooltip-initial-max-tags'.") (typing-count :type integer :initform 0 :documentation @@ -1630,7 +1664,7 @@ This will not happen if you directly set this variable via `setq'." "Display completions options in a tooltip. Display mechanism using tooltip for a list of possible completions.") -(cl-defmethod initialize-instance :after ((obj semantic-displayor-tooltip) &rest args) +(cl-defmethod initialize-instance :after ((obj semantic-displayer-tooltip) &rest args) "Make sure we have tooltips required." (condition-case nil (require 'tooltip) @@ -1639,7 +1673,9 @@ Display mechanism using tooltip for a list of possible completions.") (defvar tooltip-mode) -(cl-defmethod semantic-displayor-show-request ((obj semantic-displayor-tooltip)) +(define-obsolete-function-alias 'semantic-displayor-show-request + #'semantic-displayer-show-request "27.1") +(cl-defmethod semantic-displayer-show-request ((obj semantic-displayer-tooltip)) "A request to show the current tags table." (if (or (not (featurep 'tooltip)) (not tooltip-mode)) ;; If we cannot use tooltips, then go to the normal mode with @@ -1647,7 +1683,7 @@ Display mechanism using tooltip for a list of possible completions.") (cl-call-next-method) (let* ((tablelong (semanticdb-strip-find-results (oref obj table))) (table (semantic-unique-tag-table-by-name tablelong)) - (completions (mapcar semantic-completion-displayor-format-tag-function table)) + (completions (mapcar semantic-completion-displayer-format-tag-function table)) (numcompl (length completions)) (typing-count (oref obj typing-count)) (mode (oref obj mode)) @@ -1672,15 +1708,15 @@ Display mechanism using tooltip for a list of possible completions.") (setq msg "..."))) ((eq mode 'verbose) ;; Always show extended match set. - (oset obj max-tags-initial semantic-displayor-tooltip-max-tags) - (setq max-tags semantic-displayor-tooltip-max-tags))) + (oset obj max-tags-initial semantic-displayer-tooltip-max-tags) + (setq max-tags semantic-displayer-tooltip-max-tags))) (unless msg (oset obj shown t) (cond ((> numcompl max-tags) ;; We have too many items, be brave and truncate 'completions'. (setcdr (nthcdr (1- max-tags) completions) nil) - (if (= max-tags semantic-displayor-tooltip-initial-max-tags) + (if (= max-tags semantic-displayer-tooltip-initial-max-tags) (setq msg-tail (concat "\n[<TAB> " (number-to-string (- numcompl max-tags)) " more]")) (setq msg-tail (concat "\n[<n/a> " (number-to-string (- numcompl max-tags)) " more]")) (when (>= (oref obj typing-count) 2) @@ -1703,12 +1739,12 @@ Display mechanism using tooltip for a list of possible completions.") (setq msg (concat msg msg-tail)) ;; Display tooltip. (when (not (eq msg "")) - (semantic-displayor-tooltip-show msg))))) + (semantic-displayer-tooltip-show msg))))) ;;; Compatibility ;; -(defun semantic-displayor-point-position () +(defun semantic-displayer-point-position () "Return the location of POINT as positioned on the selected frame. Return a cons cell (X . Y)" (let* ((frame (selected-frame)) @@ -1730,9 +1766,9 @@ Return a cons cell (X . Y)" (defvar tooltip-frame-parameters) (declare-function tooltip-show "tooltip" (text &optional use-echo-area)) -(defun semantic-displayor-tooltip-show (text) +(defun semantic-displayer-tooltip-show (text) "Display a tooltip with TEXT near cursor." - (let ((point-pix-pos (semantic-displayor-point-position)) + (let ((point-pix-pos (semantic-displayer-point-position)) (tooltip-frame-parameters (append tooltip-frame-parameters nil))) (push @@ -1743,19 +1779,21 @@ Return a cons cell (X . Y)" tooltip-frame-parameters) (tooltip-show text))) -(cl-defmethod semantic-displayor-scroll-request ((obj semantic-displayor-tooltip)) - "A request to for the displayor to scroll the completion list (if needed)." +(define-obsolete-function-alias 'semantic-displayor-scroll-request + #'semantic-displayer-scroll-request "27.1") +(cl-defmethod semantic-displayer-scroll-request ((obj semantic-displayer-tooltip)) + "A request to for the displayer to scroll the completion list (if needed)." ;; Do scrolling in the tooltip. (oset obj max-tags-initial 30) - (semantic-displayor-show-request obj) + (semantic-displayer-show-request obj) ) -;; End code contributed by Masatake YAMATO <jet@gyve.org> +;; End code contributed by Masatake YAMATO <yamato@redhat.com> -;;; Ghost Text displayor +;;; Ghost Text displayer ;; -(defclass semantic-displayor-ghost (semantic-displayor-focus-abstract) +(defclass semantic-displayer-ghost (semantic-displayer-focus-abstract) ((ghostoverlay :type overlay :documentation @@ -1765,11 +1803,13 @@ Return a cons cell (X . Y)" "Non nil if we have not seen our first show request.") ) "Cycle completions inline with ghost text. -Completion displayor using ghost chars after point for focus options. +Completion displayer using ghost chars after point for focus options. Whichever completion is currently in focus will be displayed as ghost text using overlay options.") -(cl-defmethod semantic-displayor-next-action ((obj semantic-displayor-ghost)) +(define-obsolete-function-alias 'semantic-displayor-next-action + #'semantic-displayer-next-action "27.1") +(cl-defmethod semantic-displayer-next-action ((obj semantic-displayer-ghost)) "The next action to take on the inline completion related to display." (let ((ans (cl-call-next-method)) (table (when (slot-boundp obj 'table) @@ -1781,28 +1821,34 @@ text using overlay options.") nil ans))) -(cl-defmethod semantic-displayor-cleanup ((obj semantic-displayor-ghost)) - "Clean up any mess this displayor may have." +(define-obsolete-function-alias 'semantic-displayor-cleanup + #'semantic-displayer-cleanup "27.1") +(cl-defmethod semantic-displayer-cleanup ((obj semantic-displayer-ghost)) + "Clean up any mess this displayer may have." (when (slot-boundp obj 'ghostoverlay) - (semantic-overlay-delete (oref obj ghostoverlay))) + (delete-overlay (oref obj ghostoverlay))) ) -(cl-defmethod semantic-displayor-set-completions ((obj semantic-displayor-ghost) +(define-obsolete-function-alias 'semantic-displayor-set-completions + #'semantic-displayer-set-completions "27.1") +(cl-defmethod semantic-displayer-set-completions ((obj semantic-displayer-ghost) table prefix) "Set the list of tags to be completed over to TABLE." (cl-call-next-method) - (semantic-displayor-cleanup obj) + (semantic-displayer-cleanup obj) ) -(cl-defmethod semantic-displayor-show-request ((obj semantic-displayor-ghost)) +(define-obsolete-function-alias 'semantic-displayor-show-request + #'semantic-displayer-show-request "27.1") +(cl-defmethod semantic-displayer-show-request ((obj semantic-displayer-ghost)) "A request to show the current tags table." ; (if (oref obj first-show) ; (progn ; (oset obj first-show nil) - (semantic-displayor-focus-next obj) - (semantic-displayor-focus-request obj) + (semantic-displayer-focus-next obj) + (semantic-displayer-focus-request obj) ; ) ;; Only do the traditional thing if the first show request ;; has been seen. Use the first one to start doing the ghost @@ -1811,13 +1857,15 @@ text using overlay options.") ; ) ) -(cl-defmethod semantic-displayor-focus-request - ((obj semantic-displayor-ghost)) +(define-obsolete-function-alias 'semantic-displayor-focus-request + #'semantic-displayer-focus-request "27.1") +(cl-defmethod semantic-displayer-focus-request + ((obj semantic-displayer-ghost)) "Focus in on possible tag completions. Focus is performed by cycling through the tags and showing a possible completion text in ghost text." (let* ((tablelength (semanticdb-find-result-length (oref obj table))) - (focus (semantic-displayor-focus-tag obj)) + (focus (semantic-displayer-focus-tag obj)) (tag (car focus)) ) (if (not tag) @@ -1825,9 +1873,9 @@ completion text in ghost text." ;; Display the focus completion as ghost text after the current ;; inline text. (when (or (not (slot-boundp obj 'ghostoverlay)) - (not (semantic-overlay-live-p (oref obj ghostoverlay)))) + (not (overlay-buffer (oref obj ghostoverlay)))) (oset obj ghostoverlay - (semantic-make-overlay (point) (1+ (point)) (current-buffer) t))) + (make-overlay (point) (1+ (point)) (current-buffer) t))) (let* ((lp (semantic-completion-text)) (os (substring (semantic-tag-name tag) (length lp))) @@ -1836,7 +1884,7 @@ completion text in ghost text." (put-text-property 0 (length os) 'face 'region os) - (semantic-overlay-put + (overlay-put ol 'display (concat os (buffer-substring (point) (1+ (point))))) ) ;; Calculate text difference between contents and the focus item. @@ -1864,14 +1912,14 @@ completion text in ghost text." (list 'const :tag doc1 C))) - (eieio-build-class-alist 'semantic-displayor-abstract t)) + (eieio-build-class-alist 'semantic-displayer-abstract t)) ) - "Possible options for inline completion displayors. + "Possible options for inline completion displayers. Use this to enable custom editing.") -(defcustom semantic-complete-inline-analyzer-displayor-class - 'semantic-displayor-traditional - "Class for displayor to use with inline completion." +(defcustom semantic-complete-inline-analyzer-displayer-class + 'semantic-displayer-traditional + "Class for displayer to use with inline completion." :group 'semantic :type semantic-complete-inline-custom-type ) @@ -1890,8 +1938,8 @@ If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. HISTORY is a symbol representing a variable to store the history in." (semantic-complete-read-tag-engine (semantic-collector-buffer-deep prompt :buffer (current-buffer)) - (semantic-displayor-traditional-with-focus-highlight "simple") - ;;(semantic-displayor-tooltip "simple") + (semantic-displayer-traditional-with-focus-highlight) + ;;(semantic-displayer-tooltip) prompt default-tag initial-input @@ -1912,8 +1960,8 @@ If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. HISTORY is a symbol representing a variable to store the history in." (semantic-complete-read-tag-engine (semantic-collector-local-members prompt :buffer (current-buffer)) - (semantic-displayor-traditional-with-focus-highlight "simple") - ;;(semantic-displayor-tooltip "simple") + (semantic-displayer-traditional-with-focus-highlight) + ;;(semantic-displayer-tooltip) prompt default-tag initial-input @@ -1937,7 +1985,7 @@ HISTORY is a symbol representing a variable to store the history in." :buffer (current-buffer) :path (current-buffer) ) - (semantic-displayor-traditional-with-focus-highlight "simple") + (semantic-displayer-traditional-with-focus-highlight) prompt default-tag initial-input @@ -1949,12 +1997,11 @@ HISTORY is a symbol representing a variable to store the history in." This is similar to `semantic-complete-read-tag-project', except that the completion interaction is in the buffer where the context was calculated from. -Customize `semantic-complete-inline-analyzer-displayor-class' +Customize `semantic-complete-inline-analyzer-displayer-class' to control how completion options are displayed. See `semantic-complete-inline-tag-engine' for details on how completion works." (let* ((collector (semantic-collector-project-brutish - "inline" :buffer (current-buffer) :path (current-buffer))) (sbounds (semantic-ctxt-current-symbol-and-bounds)) @@ -1984,9 +2031,8 @@ completion works." ;; There are several options. Do the completion. (semantic-complete-inline-tag-engine collector - (funcall semantic-complete-inline-analyzer-displayor-class - "inline displayor") - ;;(semantic-displayor-tooltip "simple") + (funcall semantic-complete-inline-analyzer-displayer-class) + ;;(semantic-displayer-tooltip) (current-buffer) start end)) ))) @@ -2013,7 +2059,7 @@ prompts. these are calculated from the CONTEXT variable passed in." prompt :buffer (oref context buffer) :context context) - (semantic-displayor-traditional-with-focus-highlight "simple") + (semantic-displayer-traditional-with-focus-highlight) (with-current-buffer (oref context buffer) (goto-char (cdr (oref context bounds))) (concat prompt (mapconcat 'identity syms ".") @@ -2029,7 +2075,7 @@ This is similar to `semantic-complete-read-tag-analyze', except that the completion interaction is in the buffer where the context was calculated from. CONTEXT is the semantic analyzer context to start with. -Customize `semantic-complete-inline-analyzer-displayor-class' +Customize `semantic-complete-inline-analyzer-displayer-class' to control how completion options are displayed. See `semantic-complete-inline-tag-engine' for details on how @@ -2037,7 +2083,6 @@ completion works." (if (not context) (setq context (semantic-analyze-current-context (point)))) (if (not context) (error "Nothing to complete on here")) (let* ((collector (semantic-collector-analyze-completions - "inline" :buffer (oref context buffer) :context context)) (syms (semantic-ctxt-current-symbol (point))) @@ -2064,18 +2109,17 @@ completion works." ;; There are several options. Do the completion. (semantic-complete-inline-tag-engine collector - (funcall semantic-complete-inline-analyzer-displayor-class - "inline displayor") - ;;(semantic-displayor-tooltip "simple") + (funcall semantic-complete-inline-analyzer-displayer-class) + ;;(semantic-displayer-tooltip) (oref context buffer) (car (oref context bounds)) (cdr (oref context bounds)) )) ))) -(defcustom semantic-complete-inline-analyzer-idle-displayor-class - 'semantic-displayor-ghost - "Class for displayor to use with inline completion at idle time." +(defcustom semantic-complete-inline-analyzer-idle-displayer-class + 'semantic-displayer-ghost + "Class for displayer to use with inline completion at idle time." :group 'semantic :type semantic-complete-inline-custom-type ) @@ -2086,13 +2130,13 @@ CONTEXT is the semantic analyzer context to start with. This function is used from `semantic-idle-completions-mode'. This is the same as `semantic-complete-inline-analyzer', except that -it uses `semantic-complete-inline-analyzer-idle-displayor-class' +it uses `semantic-complete-inline-analyzer-idle-displayer-class' to control how completions are displayed. See `semantic-complete-inline-tag-engine' for details on how completion works." - (let ((semantic-complete-inline-analyzer-displayor-class - semantic-complete-inline-analyzer-idle-displayor-class)) + (let ((semantic-complete-inline-analyzer-displayer-class + semantic-complete-inline-analyzer-idle-displayer-class)) (semantic-complete-inline-analyzer context) )) @@ -2105,6 +2149,8 @@ completion works." (let ((tag (semantic-complete-read-tag-buffer-deep "Jump to symbol: "))) (when (semantic-tag-p tag) (push-mark) + (when (fboundp 'xref-push-marker-stack) + (xref-push-marker-stack)) (goto-char (semantic-tag-start tag)) (semantic-momentary-highlight-tag tag) (message "%S: %s " @@ -2119,6 +2165,8 @@ completion works." (let* ((tag (semantic-complete-read-tag-project "Jump to symbol: "))) (when (semantic-tag-p tag) (push-mark) + (when (fboundp 'xref-push-marker-stack) + (xref-push-marker-stack)) (semantic-go-to-tag tag) (pop-to-buffer-same-window (current-buffer)) (semantic-momentary-highlight-tag tag) @@ -2138,6 +2186,8 @@ completion works." (unless start (error "Tag %s has no location" (semantic-format-tag-prototype tag))) (push-mark) + (when (fboundp 'xref-push-marker-stack) + (xref-push-marker-stack)) (goto-char start) (semantic-momentary-highlight-tag tag) (message "%S: %s " @@ -2167,7 +2217,7 @@ The result is inserted as a replacement of the text that was there." possible values. The function returns immediately, leaving the buffer in a mode that will perform the completion. -Configure `semantic-complete-inline-analyzer-displayor-class' to change +Configure `semantic-complete-inline-analyzer-displayer-class' to change how completion options are displayed." (interactive) ;; Only do this if we are not already completing something. @@ -2189,7 +2239,7 @@ how completion options are displayed." possible values. The function returns immediately, leaving the buffer in a mode that will perform the completion. -Configure `semantic-complete-inline-analyzer-idle-displayor-class' +Configure `semantic-complete-inline-analyzer-idle-displayer-class' to change how completion options are displayed." (interactive) ;; Only do this if we are not already completing something. diff --git a/lisp/cedet/semantic/db-debug.el b/lisp/cedet/semantic/db-debug.el index bfc2c98044e..7635c649c23 100644 --- a/lisp/cedet/semantic/db-debug.el +++ b/lisp/cedet/semantic/db-debug.el @@ -2,7 +2,7 @@ ;;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -74,7 +74,7 @@ (defun semanticdb-table-oob-sanity-check (cache) "Validate that CACHE tags do not have any overlays in them." (while cache - (when (semantic-overlay-p (semantic-tag-overlay cache)) + (when (overlayp (semantic-tag-overlay cache)) (message "Tag %s has an erroneous overlay!" (semantic-format-tag-summarize (car cache)))) (semanticdb-table-oob-sanity-check diff --git a/lisp/cedet/semantic/db-el.el b/lisp/cedet/semantic/db-el.el index 5375623c132..39d61fe789b 100644 --- a/lisp/cedet/semantic/db-el.el +++ b/lisp/cedet/semantic/db-el.el @@ -53,10 +53,13 @@ It does not need refreshing." "Return nil, we never need a refresh." nil) -(cl-defmethod object-print ((obj semanticdb-table-emacs-lisp) &rest strings) - "Pretty printer extension for `semanticdb-table-emacs-lisp'. -Adds the number of tags in this file to the object print name." - (apply #'cl-call-next-method obj (cons " (proxy)" strings))) +(cl-defmethod semanticdb-debug-info ((obj semanticdb-table-emacs-lisp)) + (list "(proxy)")) + +(cl-defmethod cl-print-object ((obj semanticdb-table-emacs-lisp) stream) + "Pretty printer extension for `semanticdb-table-emacs-lisp'." + (princ (eieio-object-name obj (semanticdb-debug-info obj)) + stream)) (defclass semanticdb-project-database-emacs-lisp (semanticdb-project-database eieio-singleton) @@ -67,14 +70,19 @@ Adds the number of tags in this file to the object print name." ) "Database representing Emacs core.") -(cl-defmethod object-print ((obj semanticdb-project-database-emacs-lisp) &rest strings) - "Pretty printer extension for `semanticdb-table-emacs-lisp'. -Adds the number of tags in this file to the object print name." +(cl-defmethod semanticdb-debug-info ((obj + semanticdb-project-database-emacs-lisp)) (let ((count 0)) (mapatoms (lambda (_sym) (setq count (1+ count)))) - (apply #'cl-call-next-method obj (cons - (format " (%d known syms)" count) - strings)))) + (append (cl-call-next-method obj) + (list (format "(%d known syms)" count))))) + +(cl-defmethod cl-print-object ((obj semanticdb-project-database-emacs-lisp) + stream) + "Pretty printer extension for `semanticdb-table-emacs-lisp'. +Adds the number of tags in this file to the object print name." + (princ (eieio-object-name obj (semanticdb-debug-info obj)) + stream)) ;; Create the database, and add it to searchable databases for Emacs Lisp mode. (defvar-mode-local emacs-lisp-mode semanticdb-project-system-databases diff --git a/lisp/cedet/semantic/db-file.el b/lisp/cedet/semantic/db-file.el index 496d0a59d24..8dbb337ee55 100644 --- a/lisp/cedet/semantic/db-file.el +++ b/lisp/cedet/semantic/db-file.el @@ -307,8 +307,8 @@ Argument OBJ is the object to write." ;; Make sure that the file size and other attributes are ;; up to date. (let ((fattr (file-attributes (semanticdb-full-filename obj)))) - (oset obj fsize (nth 7 fattr)) - (oset obj lastmodtime (nth 5 fattr)) + (oset obj fsize (file-attribute-size fattr)) + (oset obj lastmodtime (file-attribute-modification-time fattr)) ) ;; Do it! diff --git a/lisp/cedet/semantic/db-find.el b/lisp/cedet/semantic/db-find.el index 81691fbbeea..54935c3a7c7 100644 --- a/lisp/cedet/semantic/db-find.el +++ b/lisp/cedet/semantic/db-find.el @@ -362,7 +362,7 @@ Default action as described in `semanticdb-find-translate-path'." "Are there any incomplete entries in CACHE?" (let ((ans nil)) (dolist (tab cache) - (when (and (semanticdb-table-child-p tab) + (when (and (cl-typep tab 'semanticdb-table) (not (number-or-marker-p (oref tab pointmax)))) (setq ans t)) ) @@ -399,10 +399,10 @@ Default action as described in `semanticdb-find-translate-path'." (let ((table (cond ((null path) semanticdb-current-table) ((bufferp path) - (semantic-buffer-local-value 'semanticdb-current-table path)) + (buffer-local-value 'semanticdb-current-table path)) ((and (stringp path) (file-exists-p path)) (semanticdb-file-table-object path t)) - ((semanticdb-abstract-table-child-p path) + ((cl-typep path 'semanticdb-abstract-table) path) (t nil)))) (if table @@ -910,7 +910,7 @@ This query only really tests the first entry in the list that is RESULTP, but should be good enough for debugging assertions." (and (listp resultp) (listp (car resultp)) - (semanticdb-abstract-table-child-p (car (car resultp))) + (cl-typep (car (car resultp)) 'semanticdb-abstract-table) (or (semantic-tag-p (car (cdr (car resultp)))) (null (car (cdr (car resultp))))))) @@ -938,7 +938,7 @@ but should be good enough for debugging assertions." (and (listp resultp) (listp (car resultp)) (let ((tag-to-test (car-safe (cdr (car resultp))))) - (or (and (semanticdb-abstract-table-child-p (car (car resultp))) + (or (and (cl-typep (car (car resultp)) 'semanticdb-abstract-table) (or (semantic-tag-p tag-to-test) (null tag-to-test))) (and (null (car (car resultp))) @@ -1085,7 +1085,7 @@ Returns result." "Log that TABLE has been searched and RESULT was found." (when semanticdb-find-log-flag (with-current-buffer semanticdb-find-log-buffer-name - (insert "Table: " (object-print table) + (insert "Table: " (cl-prin1-to-string table) " Result: " (int-to-string (length result)) " tags" "\n") ) @@ -1333,6 +1333,9 @@ Returns a table of all matching tags." (semantic-find-tags-included (or tags (semanticdb-get-tags table))) (semantic-find-tags-by-class class (or tags (semanticdb-get-tags table))))) +(declare-function semantic-find-tags-external-children-of-type + "semantic/find" (type &optional table)) + (cl-defmethod semanticdb-find-tags-external-children-of-type-method ((table semanticdb-abstract-table) parent &optional tags) "In TABLE, find all occurrences of tags whose parent is the PARENT type. Optional argument TAGS is a list of tags to search. @@ -1340,6 +1343,9 @@ Returns a table of all matching tags." (require 'semantic/find) (semantic-find-tags-external-children-of-type parent (or tags (semanticdb-get-tags table)))) +(declare-function semantic-find-tags-subclasses-of-type + "semantic/find" (type &optional table)) + (cl-defmethod semanticdb-find-tags-subclasses-of-type-method ((table semanticdb-abstract-table) parent &optional tags) "In TABLE, find all occurrences of tags whose parent is the PARENT type. Optional argument TAGS is a list of tags to search. diff --git a/lisp/cedet/semantic/db-global.el b/lisp/cedet/semantic/db-global.el index 7592b004e4e..0fff96d0c6a 100644 --- a/lisp/cedet/semantic/db-global.el +++ b/lisp/cedet/semantic/db-global.el @@ -114,10 +114,14 @@ if optional DONT-ERR-IF-NOT-AVAILABLE is non-nil; else throw an error." ) "A table for returning search results from GNU Global.") -(cl-defmethod object-print ((obj semanticdb-table-global) &rest strings) +(cl-defmethod semanticdb-debug-info ((obj semanticdb-table-global)) + (list "(proxy)")) + +(cl-defmethod cl-print-object ((obj semanticdb-table-global) stream) "Pretty printer extension for `semanticdb-table-global'. Adds the number of tags in this file to the object print name." - (apply #'cl-call-next-method obj (cons " (proxy)" strings))) + (princ (eieio-object-name obj (semanticdb-debug-info obj)) + stream)) (cl-defmethod semanticdb-equivalent-mode ((table semanticdb-table-global) &optional buffer) "Return t, pretend that this table's mode is equivalent to BUFFER. diff --git a/lisp/cedet/semantic/db-javascript.el b/lisp/cedet/semantic/db-javascript.el index 230fbfd84ed..5622594a5c3 100644 --- a/lisp/cedet/semantic/db-javascript.el +++ b/lisp/cedet/semantic/db-javascript.el @@ -98,7 +98,7 @@ See bottom of this file for instructions on managing this list.") ;; Create the database, and add it to searchable databases for javascript mode. (defvar-mode-local javascript-mode semanticdb-project-system-databases (list - (semanticdb-project-database-javascript "Javascript")) + (semanticdb-project-database-javascript)) "Search javascript for symbols.") ;; NOTE: Be sure to modify this to the best advantage of your @@ -115,13 +115,13 @@ the omniscience database.") "For a javascript database, there are no explicit tables. Create one of our special tables that can act as an intermediary." ;; NOTE: This method overrides an accessor for the `tables' slot in - ;; a database. You can either construct your own (like tmp here + ;; a database. You can either construct your own (like newtable here ;; or you can manage any number of tables. ;; We need to return something since there is always the "master table" ;; The table can then answer file name type questions. (when (not (slot-boundp obj 'tables)) - (let ((newtable (semanticdb-table-javascript "tmp"))) + (let ((newtable (semanticdb-table-javascript))) (oset obj tables (list newtable)) (oset newtable parent-db obj) (oset newtable tags nil) diff --git a/lisp/cedet/semantic/db-mode.el b/lisp/cedet/semantic/db-mode.el index c2dd906e8e2..949413d9682 100644 --- a/lisp/cedet/semantic/db-mode.el +++ b/lisp/cedet/semantic/db-mode.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -50,10 +50,12 @@ (member (car (car semanticdb-hooks)) (symbol-value (car (cdr (car semanticdb-hooks)))))) +(defvaralias 'semanticdb-mode-hook 'global-semanticdb-minor-mode-hook) +(defvaralias 'semanticdb-global-mode 'global-semanticdb-minor-mode) + ;;;###autoload (define-minor-mode global-semanticdb-minor-mode "Toggle Semantic DB mode. -With ARG, turn Semantic DB mode on if ARG is positive, off otherwise. In Semantic DB mode, Semantic parsers store results in a database, which can be saved for future Emacs sessions." @@ -67,8 +69,6 @@ database, which can be saved for future Emacs sessions." (dolist (elt semanticdb-hooks) (remove-hook (cadr elt) (car elt))))) -(defvaralias 'semanticdb-mode-hook 'global-semanticdb-minor-mode-hook) -(defvaralias 'semanticdb-global-mode 'global-semanticdb-minor-mode) (semantic-varalias-obsolete 'semanticdb-mode-hooks 'global-semanticdb-minor-mode-hook "23.2") @@ -178,8 +178,9 @@ handle it later if need be." (let ((fattr (file-attributes (semanticdb-full-filename semanticdb-current-table)))) - (oset semanticdb-current-table fsize (nth 7 fattr)) - (oset semanticdb-current-table lastmodtime (nth 5 fattr)) + (oset semanticdb-current-table fsize (file-attribute-size fattr)) + (oset semanticdb-current-table lastmodtime + (file-attribute-modification-time fattr)) (oset semanticdb-current-table buffer nil) )) ;; If this messes up, just clear the system diff --git a/lisp/cedet/semantic/db-ref.el b/lisp/cedet/semantic/db-ref.el index 366fb15cf28..eb32d0dc63e 100644 --- a/lisp/cedet/semantic/db-ref.el +++ b/lisp/cedet/semantic/db-ref.el @@ -2,7 +2,7 @@ ;;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -88,7 +88,7 @@ refers to DBT will be removed." (while refs (let* ((ok t) (db (car refs)) - (f (when (semanticdb-table-child-p db) + (f (when (cl-typep db 'semanticdb-table) (semanticdb-full-filename db))) ) @@ -162,8 +162,7 @@ refreshed before dumping the result." (let* ((tab semanticdb-current-table) (myrefs (oref tab db-refs)) (myinc (semanticdb-includes-in-table tab)) - (adbc (semanticdb-ref-adebug "DEBUG" - :i-depend-on myrefs + (adbc (semanticdb-ref-adebug :i-depend-on myrefs :local-table tab :i-include myinc))) (data-debug-new-buffer "*References ADEBUG*") diff --git a/lisp/cedet/semantic/db-typecache.el b/lisp/cedet/semantic/db-typecache.el index 8de3cc49a95..7e0f52fe0b3 100644 --- a/lisp/cedet/semantic/db-typecache.el +++ b/lisp/cedet/semantic/db-typecache.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -114,7 +114,7 @@ Said object must support `semantic-reset' methods.") (defun semanticdb-typecache-length (thing) "How long is THING? Debugging function." - (cond ((semanticdb-typecache-child-p thing) + (cond ((cl-typep thing 'semanticdb-typecache) (length (oref thing stream))) ((semantic-tag-p thing) (length (semantic-tag-type-members thing))) @@ -554,7 +554,7 @@ If there isn't one, create it. (stream nil) ) (dolist (table (semanticdb-get-database-tables db)) - (when (eq lmode (oref table :major-mode)) + (when (eq lmode (oref table major-mode)) (setq stream (semanticdb-typecache-merge-streams stream diff --git a/lisp/cedet/semantic/db.el b/lisp/cedet/semantic/db.el index a04d0777aca..33ad4701769 100644 --- a/lisp/cedet/semantic/db.el +++ b/lisp/cedet/semantic/db.el @@ -171,18 +171,6 @@ based on whichever technique used. This method provides a hook for them to convert TAG into a more complete form." (cons obj tag)) -(cl-defmethod object-print ((obj semanticdb-abstract-table) &rest strings) - "Pretty printer extension for `semanticdb-abstract-table'. -Adds the number of tags in this file to the object print name." - (if (or (not strings) - (and (= (length strings) 1) (stringp (car strings)) - (string= (car strings) ""))) - ;; Else, add a tags quantifier. - (cl-call-next-method obj (format " (%d tags)" (length (semanticdb-get-tags obj)))) - ;; Pass through. - (apply #'cl-call-next-method obj strings) - )) - ;;; Index Cache ;; (defclass semanticdb-abstract-search-index () @@ -321,13 +309,18 @@ If OBJ's file is not loaded, read it in first." (oset obj dirty t) ) -(cl-defmethod object-print ((obj semanticdb-table) &rest strings) +(cl-defmethod semanticdb-debug-info ((obj semanticdb-table)) + (list (format "(%d tags)%s" + (length (semanticdb-get-tags obj)) + (if (oref obj dirty) + ", DIRTY" + "")))) + +(cl-defmethod cl-print-object ((obj semanticdb-table) stream) "Pretty printer extension for `semanticdb-table'. Adds the number of tags in this file to the object print name." - (apply #'cl-call-next-method obj - (format " (%d tags)" (length (semanticdb-get-tags obj))) - (if (oref obj dirty) ", DIRTY" "") - strings)) + (princ (eieio-object-name obj (semanticdb-debug-info obj)) + stream)) ;;; DATABASE BASE CLASS ;; @@ -380,16 +373,17 @@ where it may need to resynchronize with some persistent storage." (setq tabs (cdr tabs))) dirty)) -(cl-defmethod object-print ((obj semanticdb-project-database) &rest strings) +(cl-defmethod semanticdb-debug-info ((obj semanticdb-project-database)) + (list (format "(%d tables%s)" + (length (semanticdb-get-database-tables obj)) + (if (semanticdb-dirty-p obj) + " DIRTY" "")))) + +(cl-defmethod cl-print-object ((obj semanticdb-project-database) stream) "Pretty printer extension for `semanticdb-project-database'. Adds the number of tables in this file to the object print name." - (apply #'cl-call-next-method obj - (format " (%d tables%s)" - (length (semanticdb-get-database-tables obj)) - (if (semanticdb-dirty-p obj) - " DIRTY" "") - ) - strings)) + (princ (eieio-object-name obj (semanticdb-debug-info obj)) + stream)) (cl-defmethod semanticdb-create-database ((dbc (subclass semanticdb-project-database)) directory) "Create a new semantic database of class DBC for DIRECTORY and return it. @@ -611,8 +605,8 @@ The file associated with OBJ does not need to be in a buffer." ;; Buffer isn't loaded. The only clue we have is if the file ;; is somehow different from our mark in the semanticdb table. (let* ((stats (file-attributes ff)) - (actualsize (nth 7 stats)) - (actualmod (nth 5 stats)) + (actualsize (file-attribute-size stats)) + (actualmod (file-attribute-modification-time stats)) ) (or (not (slot-boundp obj 'tags)) @@ -631,8 +625,8 @@ The file associated with OBJ does not need to be in a buffer." (oset table tags new-tags) (oset table pointmax (point-max)) (let ((fattr (file-attributes (semanticdb-full-filename table)))) - (oset table fsize (nth 7 fattr)) - (oset table lastmodtime (nth 5 fattr)) + (oset table fsize (file-attribute-size fattr)) + (oset table lastmodtime (file-attribute-modification-time fattr)) ) ;; Assume it is now up to date. (oset table unmatched-syntax semantic-unmatched-syntax-cache) diff --git a/lisp/cedet/semantic/debug.el b/lisp/cedet/semantic/debug.el index e4fe243302b..1b1639cbf14 100644 --- a/lisp/cedet/semantic/debug.el +++ b/lisp/cedet/semantic/debug.el @@ -36,7 +36,6 @@ ;; Each parser must implement the interface and override any methods as needed. ;; -(eval-when-compile (require 'cl)) (require 'semantic) (require 'eieio) (require 'cl-generic) @@ -171,7 +170,7 @@ These buffers are brought into view when layout occurs.") (cl-defmethod semantic-debug-highlight-lexical-token ((iface semantic-debug-interface) token) "For IFACE, highlight TOKEN in the source buffer . TOKEN is a lexical token." - (set-buffer (oref iface :source-buffer)) + (set-buffer (oref iface source-buffer)) (object-add-to-list iface 'overlays (semantic-lex-highlight-token token)) @@ -184,7 +183,7 @@ TOKEN is a lexical token." NONTERM is the name of the rule currently being processed that shows up as a nonterminal (or tag) in the source buffer. If RULE and MATCH indices are specified, highlight those also." - (set-buffer (oref iface :parser-buffer)) + (set-buffer (oref iface parser-buffer)) (let* ((rules (semantic-find-tags-by-class 'nonterminal (current-buffer))) (nt (semantic-find-first-tag-by-name nonterm rules)) @@ -194,12 +193,12 @@ If RULE and MATCH indices are specified, highlight those also." ;; I know it is the first symbol appearing in the body of this token. (goto-char (semantic-tag-start nt)) - (setq o (semantic-make-overlay (point) (progn (forward-sexp 1) (point)))) - (semantic-overlay-put o 'face 'highlight) + (setq o (make-overlay (point) (progn (forward-sexp 1) (point)))) + (overlay-put o 'face 'highlight) (object-add-to-list iface 'overlays o) - (semantic-debug-set-parser-location iface (semantic-overlay-start o)) + (semantic-debug-set-parser-location iface (overlay-start o)) (when (and rule match) @@ -216,20 +215,20 @@ If RULE and MATCH indices are specified, highlight those also." (setq match (1- match))) ;; Now highlight the thingy we find there. - (setq o (semantic-make-overlay (point) (progn (forward-sexp 1) (point)))) - (semantic-overlay-put o 'face 'highlight) + (setq o (make-overlay (point) (progn (forward-sexp 1) (point)))) + (overlay-put o 'face 'highlight) (object-add-to-list iface 'overlays o) ;; If we have a match for a sub-rule, have the parser position ;; move so we can see it in the output window for very long rules. - (semantic-debug-set-parser-location iface (semantic-overlay-start o)) + (semantic-debug-set-parser-location iface (overlay-start o)) )))) (cl-defmethod semantic-debug-unhighlight ((iface semantic-debug-interface)) "Remove all debugging overlays." - (mapc 'semantic-overlay-delete (oref iface overlays)) + (mapc #'delete-overlay (oref iface overlays)) (oset iface overlays nil)) ;; Call from the parser at a breakpoint @@ -361,7 +360,6 @@ Argument ONOFF is non-nil when we are entering debug mode. (semantic-debug-current-interface (let ((parserb (semantic-debug-find-parser-source))) (semantic-debug-interface - "Debug Interface" :parser-buffer parserb :parser-local-map (with-current-buffer parserb (current-local-map)) diff --git a/lisp/cedet/semantic/decorate.el b/lisp/cedet/semantic/decorate.el index 07e393fec59..1a7cd77d1e0 100644 --- a/lisp/cedet/semantic/decorate.el +++ b/lisp/cedet/semantic/decorate.el @@ -38,17 +38,16 @@ "Specify that TAG should be highlighted. Optional FACE specifies the face to use." (let ((o (semantic-tag-overlay tag))) - (semantic-overlay-put o 'old-face - (cons (semantic-overlay-get o 'face) - (semantic-overlay-get o 'old-face))) - (semantic-overlay-put o 'face (or face 'semantic-tag-highlight-face)) - )) + (overlay-put o 'old-face + (cons (overlay-get o 'face) + (overlay-get o 'old-face))) + (overlay-put o 'face (or face 'semantic-tag-highlight-face)))) (defun semantic-unhighlight-tag (tag) "Unhighlight TAG, restoring its previous face." (let ((o (semantic-tag-overlay tag))) - (semantic-overlay-put o 'face (car (semantic-overlay-get o 'old-face))) - (semantic-overlay-put o 'old-face (cdr (semantic-overlay-get o 'old-face))) + (overlay-put o 'face (car (overlay-get o 'old-face))) + (overlay-put o 'old-face (cdr (overlay-get o 'old-face))) )) ;;; Momentary Highlighting - One line @@ -66,7 +65,7 @@ Optional argument FACE specifies the face to do the highlighting." Optional argument FACE is the face to use for highlighting. If FACE is not specified, then `highlight' will be used." (when (semantic-tag-with-position-p tag) - (if (not (semantic-overlay-p (semantic-tag-overlay tag))) + (if (not (overlayp (semantic-tag-overlay tag))) ;; No overlay, but a position. Highlight the first line only. (semantic-momentary-highlight-one-tag-line tag face) ;; The tag has an overlay, highlight the whole thing @@ -76,17 +75,17 @@ If FACE is not specified, then `highlight' will be used." (defun semantic-set-tag-face (tag face) "Specify that TAG should use FACE for display." - (semantic-overlay-put (semantic-tag-overlay tag) 'face face)) + (overlay-put (semantic-tag-overlay tag) 'face face)) (defun semantic-set-tag-invisible (tag &optional visible) "Enable the text in TAG to be made invisible. If VISIBLE is non-nil, make the text visible." - (semantic-overlay-put (semantic-tag-overlay tag) 'invisible - (not visible))) + (overlay-put (semantic-tag-overlay tag) 'invisible + (not visible))) (defun semantic-tag-invisible-p (tag) "Return non-nil if TAG is invisible." - (semantic-overlay-get (semantic-tag-overlay tag) 'invisible)) + (overlay-get (semantic-tag-overlay tag) 'invisible)) (defun semantic-overlay-signal-read-only (overlay after start end &optional len) @@ -95,8 +94,8 @@ Allows deletion of the entire text. Argument OVERLAY, AFTER, START, END, and LEN are passed in by the system." ;; Stolen blithely from cpp.el in Emacs 21.1 (if (and (not after) - (or (< (semantic-overlay-start overlay) start) - (> (semantic-overlay-end overlay) end))) + (or (< (overlay-start overlay) start) + (> (overlay-end overlay) end))) (error "This text is read only"))) (defun semantic-set-tag-read-only (tag &optional writable) @@ -104,22 +103,16 @@ Argument OVERLAY, AFTER, START, END, and LEN are passed in by the system." Optional argument WRITABLE should be non-nil to make the text writable instead of read-only." (let ((o (semantic-tag-overlay tag)) - (hook (if writable nil '(semantic-overlay-signal-read-only)))) - (if (featurep 'xemacs) - ;; XEmacs extents have a 'read-only' property. - (semantic-overlay-put o 'read-only (not writable)) - (semantic-overlay-put o 'modification-hooks hook) - (semantic-overlay-put o 'insert-in-front-hooks hook) - (semantic-overlay-put o 'insert-behind-hooks hook)))) + (hook (if writable nil '(overlay-signal-read-only)))) + (overlay-put o 'modification-hooks hook) + (overlay-put o 'insert-in-front-hooks hook) + (overlay-put o 'insert-behind-hooks hook))) (defun semantic-tag-read-only-p (tag) "Return non-nil if the current TAG is marked read only." (let ((o (semantic-tag-overlay tag))) - (if (featurep 'xemacs) - ;; XEmacs extents have a 'read-only' property. - (semantic-overlay-get o 'read-only) - (member 'semantic-overlay-signal-read-only - (semantic-overlay-get o 'modification-hooks))))) + (member 'semantic-overlay-signal-read-only + (overlay-get o 'modification-hooks)))) ;;; Secondary overlays ;; @@ -144,12 +137,12 @@ generated secondary overlay." nil (let* ((os (semantic-tag-start tag)) (oe (semantic-tag-end tag)) - (o (semantic-make-overlay os oe (semantic-tag-buffer tag) t)) + (o (make-overlay os oe (semantic-tag-buffer tag) t)) (attr (semantic-tag-secondary-overlays tag)) ) (semantic--tag-put-property tag 'secondary-overlays (cons o attr)) - (semantic-overlay-put o 'semantic-secondary t) - (semantic-overlay-put o 'semantic-link-hook link-hook) + (overlay-put o 'semantic-secondary t) + (overlay-put o 'semantic-link-hook link-hook) (semantic-tag-add-hook tag 'link-hook 'semantic--tag-link-secondary-overlays) (semantic-tag-add-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays) (semantic-tag-add-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays) @@ -162,7 +155,7 @@ PROPERTY is a symbol and all overlays with that symbol are returned.." (let* ((olsearch (semantic-tag-secondary-overlays tag)) (o nil)) (while olsearch - (when (semantic-overlay-get (car olsearch) property) + (when (overlay-get (car olsearch) property) (setq o (cons (car olsearch) o))) (setq olsearch (cdr olsearch))) o)) @@ -172,16 +165,16 @@ PROPERTY is a symbol and all overlays with that symbol are returned.." If OVERLAY-OR-PROPERTY is an overlay, delete that overlay. If OVERLAY-OR-PROPERTY is a symbol, find the overlay with that property." (let* ((o overlay-or-property)) - (if (semantic-overlay-p o) + (if (overlayp o) (setq o (list o)) (setq o (semantic-tag-get-secondary-overlay tag overlay-or-property))) - (while (semantic-overlay-p (car o)) + (while (overlayp (car o)) ;; We don't really need to worry about the hooks. ;; They will clean themselves up eventually ?? (semantic--tag-put-property tag 'secondary-overlays (delete (car o) (semantic-tag-secondary-overlays tag))) - (semantic-overlay-delete (car o)) + (delete-overlay (car o)) (setq o (cdr o))))) (defun semantic--tag-unlink-copy-secondary-overlays (tag) @@ -206,10 +199,10 @@ from them in TAG." (let ((ol (semantic-tag-secondary-overlays tag)) (nl nil)) (while ol - (if (semantic-overlay-get (car ol) 'semantic-link-hook) + (if (overlay-get (car ol) 'semantic-link-hook) ;; Only put in a proxy if there is a link-hook. If there is no link-hook ;; the decorating mode must know when tags are unlinked on its own. - (setq nl (cons (semantic-overlay-get (car ol) 'semantic-link-hook) + (setq nl (cons (overlay-get (car ol) 'semantic-link-hook) nl)) ;; Else, remove all traces of ourself from the tag ;; Note to self: Does this prevent multiple types of secondary @@ -218,7 +211,7 @@ from them in TAG." (semantic-tag-remove-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays) (semantic-tag-remove-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays) ) - (semantic-overlay-delete (car ol)) + (delete-overlay (car ol)) (setq ol (cdr ol))) (semantic--tag-put-property tag 'secondary-overlays (nreverse nl)) )) @@ -251,21 +244,20 @@ nil implies the tag should be fully shown." ;; Add the foldn (setq o (semantic-tag-create-secondary-overlay tag)) ;; mark as folded - (semantic-overlay-put o 'semantic-folded t) + (overlay-put o 'semantic-folded t) ;; Move to cover end of tag (save-excursion (goto-char (semantic-tag-start tag)) (end-of-line) - (semantic-overlay-move o (point) (semantic-tag-end tag))) + (move-overlay o (point) (semantic-tag-end tag))) ;; We need to modify the invisibility spec for this to ;; work. (if (or (eq buffer-invisibility-spec t) (not (assoc 'semantic-fold buffer-invisibility-spec))) (add-to-invisibility-spec '(semantic-fold . t))) - (semantic-overlay-put o 'invisible 'semantic-fold) + (overlay-put o 'invisible 'semantic-fold) (overlay-put o 'isearch-open-invisible - 'semantic-set-tag-folded-isearch))) - )) + 'semantic-set-tag-folded-isearch))))) (declare-function semantic-current-tag "semantic/find") diff --git a/lisp/cedet/semantic/decorate/include.el b/lisp/cedet/semantic/decorate/include.el index 4412a4c18ac..aa870b663c0 100644 --- a/lisp/cedet/semantic/decorate/include.el +++ b/lisp/cedet/semantic/decorate/include.el @@ -42,7 +42,7 @@ ;;; Code: ;;; FACES AND KEYMAPS -(defvar semantic-decoration-mouse-3 (if (featurep 'xemacs) [ button3 ] [ mouse-3 ]) +(defvar semantic-decoration-mouse-3 [ mouse-3 ] "The keybinding Lisp object to use for binding the right mouse button.") ;;; Includes that are in a happy state! @@ -69,47 +69,35 @@ Used by the decoration style: `semantic-decoration-on-includes'." "Include Menu" (list "Include" - (semantic-menu-item - ["What Is This?" semantic-decoration-include-describe - :active t - :help "Describe why this include has been marked this way." ]) - (semantic-menu-item - ["Visit This Include" semantic-decoration-include-visit - :active t - :help "Visit this include file." ]) + ["What Is This?" semantic-decoration-include-describe + :active t + :help "Describe why this include has been marked this way." ] + ["Visit This Include" semantic-decoration-include-visit + :active t + :help "Visit this include file." ] "---" - (semantic-menu-item - ["Summarize includes current buffer" semantic-decoration-all-include-summary - :active t - :help "Show a summary for the current buffer containing this include." ]) - (semantic-menu-item - ["List found includes (load unparsed)" semanticdb-find-test-translate-path - :active t - :help "List all includes found for this file, and parse unparsed files." ]) - (semantic-menu-item - ["List found includes (no loading)" semanticdb-find-test-translate-path-no-loading - :active t - :help "List all includes found for this file, do not parse unparsed files." ]) - (semantic-menu-item - ["List all unknown includes" semanticdb-find-adebug-lost-includes - :active t - :help "Show a list of all includes semantic cannot find for this file." ]) + ["Summarize includes current buffer" semantic-decoration-all-include-summary + :active t + :help "Show a summary for the current buffer containing this include." ] + ["List found includes (load unparsed)" semanticdb-find-test-translate-path + :active t + :help "List all includes found for this file, and parse unparsed files." ] + ["List found includes (no loading)" semanticdb-find-test-translate-path-no-loading + :active t + :help "List all includes found for this file, do not parse unparsed files." ] + ["List all unknown includes" semanticdb-find-adebug-lost-includes + :active t + :help "Show a list of all includes semantic cannot find for this file." ] "---" - (semantic-menu-item - ["Customize System Include Path" semantic-customize-system-include-path - :active (get 'semantic-dependency-system-include-path major-mode) - :help "Run customize for the system include path for this major mode." ]) - (semantic-menu-item - ["Add a System Include Path" semantic-add-system-include - :active t - :help "Add an include path for this session." ]) - (semantic-menu-item - ["Remove a System Include Path" semantic-remove-system-include - :active t - :help "Add an include path for this session." ]) - ;;["" semantic-decoration-include- - ;; :active t - ;; :help "" ] + ["Customize System Include Path" semantic-customize-system-include-path + :active (get 'semantic-dependency-system-include-path major-mode) + :help "Run customize for the system include path for this major mode." ] + ["Add a System Include Path" semantic-add-system-include + :active t + :help "Add an include path for this session." ] + ["Remove a System Include Path" semantic-remove-system-include + :active t + :help "Add an include path for this session." ] )) ;;; Unknown Includes! @@ -139,40 +127,32 @@ Used by the decoration style: `semantic-decoration-on-unknown-includes'." "Unknown Include Menu" (list "Unknown Include" - (semantic-menu-item - ["What Is This?" semantic-decoration-unknown-include-describe - :active t - :help "Describe why this include has been marked this way." ]) - (semantic-menu-item - ["List all unknown includes" semanticdb-find-adebug-lost-includes - :active t - :help "Show a list of all includes semantic cannot find for this file." ]) + ["What Is This?" semantic-decoration-unknown-include-describe + :active t + :help "Describe why this include has been marked this way." ] + ["List all unknown includes" semanticdb-find-adebug-lost-includes + :active t + :help "Show a list of all includes semantic cannot find for this file." ] "---" - (semantic-menu-item - ["Summarize includes current buffer" semantic-decoration-all-include-summary - :active t - :help "Show a summary for the current buffer containing this include." ]) - (semantic-menu-item - ["List found includes (load unparsed)" semanticdb-find-test-translate-path - :active t - :help "List all includes found for this file, and parse unparsed files." ]) - (semantic-menu-item - ["List found includes (no loading)" semanticdb-find-test-translate-path-no-loading - :active t - :help "List all includes found for this file, do not parse unparsed files." ]) + ["Summarize includes current buffer" semantic-decoration-all-include-summary + :active t + :help "Show a summary for the current buffer containing this include." ] + ["List found includes (load unparsed)" semanticdb-find-test-translate-path + :active t + :help "List all includes found for this file, and parse unparsed files." ] + ["List found includes (no loading)" semanticdb-find-test-translate-path-no-loading + :active t + :help "List all includes found for this file, do not parse unparsed files." ] "---" - (semantic-menu-item - ["Customize System Include Path" semantic-customize-system-include-path - :active (get 'semantic-dependency-system-include-path major-mode) - :help "Run customize for the system include path for this major mode." ]) - (semantic-menu-item - ["Add a System Include Path" semantic-add-system-include - :active t - :help "Add an include path for this session." ]) - (semantic-menu-item - ["Remove a System Include Path" semantic-remove-system-include - :active t - :help "Add an include path for this session." ]) + ["Customize System Include Path" semantic-customize-system-include-path + :active (get 'semantic-dependency-system-include-path major-mode) + :help "Run customize for the system include path for this major mode." ] + ["Add a System Include Path" semantic-add-system-include + :active t + :help "Add an include path for this session." ] + ["Remove a System Include Path" semantic-remove-system-include + :active t + :help "Add an include path for this session." ] )) ;;; Includes with no file, but a table @@ -202,40 +182,32 @@ Used by the decoration style: `semantic-decoration-on-fileless-includes'." "Fileless Include Menu" (list "Fileless Include" - (semantic-menu-item - ["What Is This?" semantic-decoration-fileless-include-describe - :active t - :help "Describe why this include has been marked this way." ]) - (semantic-menu-item - ["List all unknown includes" semanticdb-find-adebug-lost-includes - :active t - :help "Show a list of all includes semantic cannot find for this file." ]) + ["What Is This?" semantic-decoration-fileless-include-describe + :active t + :help "Describe why this include has been marked this way." ] + ["List all unknown includes" semanticdb-find-adebug-lost-includes + :active t + :help "Show a list of all includes semantic cannot find for this file." ] "---" - (semantic-menu-item - ["Summarize includes current buffer" semantic-decoration-all-include-summary - :active t - :help "Show a summary for the current buffer containing this include." ]) - (semantic-menu-item - ["List found includes (load unparsed)" semanticdb-find-test-translate-path - :active t - :help "List all includes found for this file, and parse unparsed files." ]) - (semantic-menu-item - ["List found includes (no loading)" semanticdb-find-test-translate-path-no-loading - :active t - :help "List all includes found for this file, do not parse unparsed files." ]) + ["Summarize includes current buffer" semantic-decoration-all-include-summary + :active t + :help "Show a summary for the current buffer containing this include." ] + ["List found includes (load unparsed)" semanticdb-find-test-translate-path + :active t + :help "List all includes found for this file, and parse unparsed files." ] + ["List found includes (no loading)" semanticdb-find-test-translate-path-no-loading + :active t + :help "List all includes found for this file, do not parse unparsed files." ] "---" - (semantic-menu-item - ["Customize System Include Path" semantic-customize-system-include-path - :active (get 'semantic-dependency-system-include-path major-mode) - :help "Run customize for the system include path for this major mode." ]) - (semantic-menu-item - ["Add a System Include Path" semantic-add-system-include - :active t - :help "Add an include path for this session." ]) - (semantic-menu-item - ["Remove a System Include Path" semantic-remove-system-include - :active t - :help "Add an include path for this session." ]) + ["Customize System Include Path" semantic-customize-system-include-path + :active (get 'semantic-dependency-system-include-path major-mode) + :help "Run customize for the system include path for this major mode." ] + ["Add a System Include Path" semantic-add-system-include + :active t + :help "Add an include path for this session." ] + ["Remove a System Include Path" semantic-remove-system-include + :active t + :help "Add an include path for this session." ] )) ;;; Includes that need to be parsed. @@ -265,56 +237,41 @@ Used by the decoration style: `semantic-decoration-on-unparsed-includes'." "Unparsed Include Menu" (list "Unparsed Include" - (semantic-menu-item - ["What Is This?" semantic-decoration-unparsed-include-describe - :active t - :help "Describe why this include has been marked this way." ]) - (semantic-menu-item - ["Visit This Include" semantic-decoration-include-visit - :active t - :help "Visit this include file so that header file's tags can be used." ]) - (semantic-menu-item - ["Parse This Include" semantic-decoration-unparsed-include-parse-include - :active t - :help "Parse this include file so that header file's tags can be used." ]) - (semantic-menu-item - ["Parse All Includes" semantic-decoration-unparsed-include-parse-all-includes - :active t - :help "Parse all the includes so the contents can be used." ]) + ["What Is This?" semantic-decoration-unparsed-include-describe + :active t + :help "Describe why this include has been marked this way." ] + ["Visit This Include" semantic-decoration-include-visit + :active t + :help "Visit this include file so that header file's tags can be used." ] + ["Parse This Include" semantic-decoration-unparsed-include-parse-include + :active t + :help "Parse this include file so that header file's tags can be used." ] + ["Parse All Includes" semantic-decoration-unparsed-include-parse-all-includes + :active t + :help "Parse all the includes so the contents can be used." ] "---" - (semantic-menu-item - ["Summarize includes current buffer" semantic-decoration-all-include-summary - :active t - :help "Show a summary for the current buffer containing this include." ]) - (semantic-menu-item - ["List found includes (load unparsed)" semanticdb-find-test-translate-path - :active t - :help "List all includes found for this file, and parse unparsed files." ]) - (semantic-menu-item - ["List found includes (no loading)" semanticdb-find-test-translate-path-no-loading - :active t - :help "List all includes found for this file, do not parse unparsed files." ]) - (semantic-menu-item - ["List all unknown includes" semanticdb-find-adebug-lost-includes - :active t - :help "Show a list of all includes semantic cannot find for this file." ]) + ["Summarize includes current buffer" semantic-decoration-all-include-summary + :active t + :help "Show a summary for the current buffer containing this include." ] + ["List found includes (load unparsed)" semanticdb-find-test-translate-path + :active t + :help "List all includes found for this file, and parse unparsed files." ] + ["List found includes (no loading)" semanticdb-find-test-translate-path-no-loading + :active t + :help "List all includes found for this file, do not parse unparsed files." ] + ["List all unknown includes" semanticdb-find-adebug-lost-includes + :active t + :help "Show a list of all includes semantic cannot find for this file." ] "---" - (semantic-menu-item - ["Customize System Include Path" semantic-customize-system-include-path - :active (get 'semantic-dependency-system-include-path major-mode) - :help "Run customize for the system include path for this major mode." ]) - (semantic-menu-item - ["Add a System Include Path" semantic-add-system-include - :active t - :help "Add an include path for this session." ]) - (semantic-menu-item - ["Remove a System Include Path" semantic-remove-system-include - :active t - :help "Add an include path for this session." ]) - ;;["" semantic-decoration-unparsed-include- - ;; :active t - ;; :help "" ] - )) + ["Customize System Include Path" semantic-customize-system-include-path + :active (get 'semantic-dependency-system-include-path major-mode) + :help "Run customize for the system include path for this major mode." ] + ["Add a System Include Path" semantic-add-system-include + :active t + :help "Add an include path for this session." ] + ["Remove a System Include Path" semantic-remove-system-include + :active t + :help "Add an include path for this session." ])) ;;; MODES @@ -379,13 +336,10 @@ This mode provides a nice context menu on the include statements." (let ((ol (semantic-decorate-tag tag (semantic-tag-start tag) (semantic-tag-end tag) - face)) - ) - (semantic-overlay-put ol 'mouse-face 'highlight) - (semantic-overlay-put ol 'keymap map) - (semantic-overlay-put ol 'help-echo - "Header File : mouse-3 - Context menu") - )))) + face))) + (overlay-put ol 'mouse-face 'highlight) + (overlay-put ol 'keymap map) + (overlay-put ol 'help-echo "Header File : mouse-3 - Context menu"))))) ;;; Regular Include Functions ;; @@ -437,11 +391,11 @@ its contents. ;; Get the semanticdb statement, and display it's contents. (princ "\nDetails for header file...\n") (princ "\nMajor Mode: ") - (princ (oref table :major-mode)) + (princ (oref table major-mode)) (princ "\nTags: ") - (princ (format "%s entries" (length (oref table :tags)))) + (princ (format "%s entries" (length (oref table tags)))) (princ "\nFile Size: ") - (princ (format "%s chars" (oref table :pointmax))) + (princ (format "%s chars" (oref table pointmax))) (princ "\nSave State: ") (cond ((oref table dirty) (princ "Table needs to be saved.")) @@ -484,7 +438,7 @@ Argument EVENT describes the event that caused this function to be called." ;(goto-char (window-start win)) (mouse-set-point event) (sit-for 0) - (semantic-popup-menu semantic-decoration-on-include-menu) + (popup-menu semantic-decoration-on-include-menu) ) (select-window startwin))) @@ -568,7 +522,7 @@ Argument EVENT describes the event that caused this function to be called." ;(goto-char (window-start win)) (mouse-set-point event) (sit-for 0) - (semantic-popup-menu semantic-decoration-on-unknown-include-menu) + (popup-menu semantic-decoration-on-unknown-include-menu) ) (select-window startwin))) @@ -595,7 +549,7 @@ on disk, but a database table of tags has been associated with it. This means that the include will still be used to find tags for searches, but you cannot visit this include.\n\n") (princ "This Header is now represented by the following database table:\n\n ") - (princ (object-print table)) + (princ (cl-prin1-to-string table)) ))) (defun semantic-decoration-fileless-include-menu (event) @@ -611,7 +565,7 @@ Argument EVENT describes the event that caused this function to be called." ;(goto-char (window-start win)) (mouse-set-point event) (sit-for 0) - (semantic-popup-menu semantic-decoration-on-fileless-include-menu) + (popup-menu semantic-decoration-on-fileless-include-menu) ) (select-window startwin))) @@ -675,7 +629,7 @@ Argument EVENT describes the event that caused this function to be called." ;(goto-char (window-start win)) (mouse-set-point event) (sit-for 0) - (semantic-popup-menu semantic-decoration-on-unparsed-include-menu) + (popup-menu semantic-decoration-on-unparsed-include-menu) ) (select-window startwin))) @@ -749,17 +703,17 @@ Argument EVENT describes the event that caused this function to be called." (princ (substitute-command-keys " This file's project include search is handled by the EDE object:\n")) (princ " Buffer Target: ") - (princ (object-print ede-object)) + (princ (cl-prin1-to-string ede-object)) (princ "\n") (when (not (eq ede-object ede-object-project)) (princ " Buffer Project: ") - (princ (object-print ede-object-project)) + (princ (cl-prin1-to-string ede-object-project)) (princ "\n") ) (when ede-object-project (let ((loc (ede-get-locator-object ede-object-project))) (princ " Backup in-project Locator: ") - (princ (object-print loc)) + (princ (cl-prin1-to-string loc)) (princ "\n"))) (let ((syspath (ede-system-include-path ede-object-project))) (if (not syspath) diff --git a/lisp/cedet/semantic/decorate/mode.el b/lisp/cedet/semantic/decorate/mode.el index d4345a9ab0b..4e3ca2c6ee3 100644 --- a/lisp/cedet/semantic/decorate/mode.el +++ b/lisp/cedet/semantic/decorate/mode.el @@ -35,7 +35,7 @@ ;; ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'semantic) (require 'semantic/decorate) (require 'semantic/tag-ls) @@ -76,20 +76,20 @@ add items to this list." ;; (defsubst semantic-decoration-p (object) "Return non-nil if OBJECT is a tag decoration." - (and (semantic-overlay-p object) - (semantic-overlay-get object 'semantic-decoration))) + (and (overlayp object) + (overlay-get object 'semantic-decoration))) (defsubst semantic-decoration-set-property (deco property value) "Set the DECO decoration's PROPERTY to VALUE. Return DECO." - (assert (semantic-decoration-p deco)) - (semantic-overlay-put deco property value) + (cl-assert (semantic-decoration-p deco)) + (overlay-put deco property value) deco) (defsubst semantic-decoration-get-property (deco property) "Return the DECO decoration's PROPERTY value." - (assert (semantic-decoration-p deco)) - (semantic-overlay-get deco property)) + (cl-assert (semantic-decoration-p deco)) + (overlay-get deco property)) (defsubst semantic-decoration-set-face (deco face) "Set the face of the decoration DECO to FACE. @@ -103,7 +103,7 @@ Return DECO." (defsubst semantic-decoration-set-priority (deco priority) "Set the priority of the decoration DECO to PRIORITY. Return DECO." - (assert (natnump priority)) + (cl-assert (natnump priority)) (semantic-decoration-set-property deco 'priority priority)) (defsubst semantic-decoration-priority (deco) @@ -113,8 +113,8 @@ Return DECO." (defsubst semantic-decoration-move (deco begin end) "Move the decoration DECO on the region between BEGIN and END. Return DECO." - (assert (semantic-decoration-p deco)) - (semantic-overlay-move deco begin end) + (cl-assert (semantic-decoration-p deco)) + (move-overlay deco begin end) deco) ;;; Tag decoration @@ -127,7 +127,7 @@ Return the overlay that makes up the new decoration." (let ((deco (semantic-tag-create-secondary-overlay tag))) ;; We do not use the unlink property because we do not want to ;; save the highlighting information in the DB. - (semantic-overlay-put deco 'semantic-decoration t) + (overlay-put deco 'semantic-decoration t) (semantic-decoration-move deco begin end) (semantic-decoration-set-face deco face) deco)) @@ -135,7 +135,7 @@ Return the overlay that makes up the new decoration." (defun semantic-decorate-clear-tag (tag &optional deco) "Remove decorations from TAG. If optional argument DECO is non-nil, remove only that decoration." - (assert (or (null deco) (semantic-decoration-p deco))) + (cl-assert (or (null deco) (semantic-decoration-p deco))) ;; Clear primary decorations. ;; For now, just unhighlight the tag. How to deal with other ;; primary decorations like invisibility, etc. ? Maybe just @@ -156,9 +156,9 @@ BUFFER defaults to the current buffer. Should be used to flush decorations that might remain in BUFFER, for example, after tags have been refreshed." (with-current-buffer (or buffer (current-buffer)) - (dolist (o (semantic-overlays-in (point-min) (point-max))) + (dolist (o (overlays-in (point-min) (point-max))) (and (semantic-decoration-p o) - (semantic-overlay-delete o))))) + (delete-overlay o))))) (defun semantic-decorate-clear-decorations (tag-list) "Remove decorations found in tags in TAG-LIST." @@ -249,13 +249,13 @@ by `semantic-decoration-styles'." (define-minor-mode semantic-decoration-mode "Minor mode for decorating tags. -Decorations are specified in `semantic-decoration-styles'. -You can define new decoration styles with +Decorations are specified in `semantic-decoration-styles'. You +can define new decoration styles with `define-semantic-decoration-style'. -With prefix argument ARG, turn on if positive, otherwise off. The -minor mode can be turned on only if semantic feature is available and -the current buffer was set up for parsing. Return non-nil if the -minor mode is enabled." + +The minor mode can be turned on only if semantic feature is +available and the current buffer was set up for parsing. Return +non-nil if the minor mode is enabled." ;; ;;\\{semantic-decoration-map}" nil nil nil diff --git a/lisp/cedet/semantic/dep.el b/lisp/cedet/semantic/dep.el index 5dacc28d9e7..84bb2285b4e 100644 --- a/lisp/cedet/semantic/dep.el +++ b/lisp/cedet/semantic/dep.el @@ -56,7 +56,7 @@ reparsed, the cache will be reset. TODO: use ffap.el to locate such items? NOTE: Obsolete this, or use as special user") -(make-variable-buffer-local `semantic-dependency-include-path) +(make-variable-buffer-local 'semantic-dependency-include-path) (defvar semantic-dependency-system-include-path nil "Defines the system include path. @@ -71,7 +71,7 @@ When searching for a file associated with a name found in a tag of class include, this path will be inspected for includes of type `system'. Some include tags are agnostic to this setting and will check both the project and system directories.") -(make-variable-buffer-local `semantic-dependency-system-include-path) +(make-variable-buffer-local 'semantic-dependency-system-include-path) (defmacro defcustom-mode-local-semantic-dependency-system-include-path (mode name value &optional docstring) diff --git a/lisp/cedet/semantic/doc.el b/lisp/cedet/semantic/doc.el index 5611629c14d..4f98cf41027 100644 --- a/lisp/cedet/semantic/doc.el +++ b/lisp/cedet/semantic/doc.el @@ -103,7 +103,8 @@ If NOSNARF is `lex', then return the lex token." nil ;; ok, try to clean the text up. ;; Comment start thingy - (while (string-match (concat "^\\s-*" comment-start-skip) ct) + (while (string-match (concat "^\\s-*\\(?:" comment-start-skip "\\)") + ct) (setq ct (concat (substring ct 0 (match-beginning 0)) (substring ct (match-end 0))))) ;; Arbitrary punctuation at the beginning of each line. diff --git a/lisp/cedet/semantic/ede-grammar.el b/lisp/cedet/semantic/ede-grammar.el index 6e02394f156..4ced6fa80ef 100644 --- a/lisp/cedet/semantic/ede-grammar.el +++ b/lisp/cedet/semantic/ede-grammar.el @@ -67,8 +67,7 @@ For Emacs Lisp, return addsuffix command on source files." (ede-proj-makefile-sourcevar this)))))) (defvar semantic-ede-source-grammar-wisent - (ede-sourcecode "semantic-ede-grammar-source-wisent" - :name "Wisent Grammar" + (ede-sourcecode :name "Wisent Grammar" :sourcepattern "\\.wy$" :garbagepattern '("*-wy.el") ) @@ -80,13 +79,11 @@ For Emacs Lisp, return addsuffix command on source files." (defvar semantic-ede-grammar-compiler-wisent (semantic-ede-grammar-compiler-class - "ede-emacs-wisent-compiler" :name "emacs" :variables '(("EMACS" . "emacs") ("EMACSFLAGS" . "-batch --no-site-file --eval '(setq debug-on-error t)'") ("require" . "$(foreach r,$(1),(require (quote $(r))))")) :rules (list (ede-makefile-rule - "elisp-inference-rule" :target "%-wy.el" :dependencies "%.wy" :rules '("$(EMACS) $(EMACSFLAGS) $(addprefix -L ,$(LOADPATH)) \ @@ -98,8 +95,7 @@ For Emacs Lisp, return addsuffix command on source files." (defvar semantic-ede-source-grammar-bovine - (ede-sourcecode "semantic-ede-grammar-source-bovine" - :name "Bovine Grammar" + (ede-sourcecode :name "Bovine Grammar" :sourcepattern "\\.by$" :garbagepattern '("*-by.el") ) @@ -107,13 +103,11 @@ For Emacs Lisp, return addsuffix command on source files." (defvar semantic-ede-grammar-compiler-bovine (semantic-ede-grammar-compiler-class - "ede-emacs-wisent-compiler" :name "emacs" :variables '(("EMACS" . "emacs") ("EMACSFLAGS" . "-batch --no-site-file --eval '(setq debug-on-error t)'") ("require" . "$(foreach r,$(1),(require (quote $(r))))")) :rules (list (ede-makefile-rule - "elisp-inference-rule" :target "%-by.el" :dependencies "%.by" :rules '("$(EMACS) $(EMACSFLAGS) $(addprefix -L ,$(LOADPATH)) \ diff --git a/lisp/cedet/semantic/edit.el b/lisp/cedet/semantic/edit.el index 122549212dc..2a25bb5db1c 100644 --- a/lisp/cedet/semantic/edit.el +++ b/lisp/cedet/semantic/edit.el @@ -150,15 +150,15 @@ Argument START, END, and LENGTH specify the bounds of the change." Optional argument BUFFER is the buffer to search for changes in." (save-excursion (if buffer (set-buffer buffer)) - (let ((ol (semantic-overlays-in (max start (point-min)) - (min end (point-max)))) + (let ((ol (overlays-in (max start (point-min)) + (min end (point-max)))) (ret nil)) (while ol - (when (semantic-overlay-get (car ol) 'semantic-change) + (when (overlay-get (car ol) 'semantic-change) (setq ret (cons (car ol) ret))) (setq ol (cdr ol))) - (sort ret #'(lambda (a b) (< (semantic-overlay-start a) - (semantic-overlay-start b))))))) + (sort ret #'(lambda (a b) (< (overlay-start a) + (overlay-start b))))))) (defun semantic-edits-change-function-handle-changes (start end length) "Run whenever a buffer controlled by `semantic-mode' change. @@ -171,8 +171,8 @@ Argument START, END, and LENGTH specify the bounds of the change." ) (semantic-parse-tree-set-needs-update) (if (not changes-in-change) - (let ((o (semantic-make-overlay start end))) - (semantic-overlay-put o 'semantic-change t) + (let ((o (make-overlay start end))) + (overlay-put o 'semantic-change t) ;; Run the hooks safely. When hooks blow it, our dirty ;; function will be removed from the list of active change ;; functions. @@ -182,13 +182,13 @@ Argument START, END, and LENGTH specify the bounds of the change." (let ((tmp changes-in-change)) ;; Find greatest bounds of all changes (while tmp - (when (< (semantic-overlay-start (car tmp)) start) - (setq start (semantic-overlay-start (car tmp)))) - (when (> (semantic-overlay-end (car tmp)) end) - (setq end (semantic-overlay-end (car tmp)))) + (when (< (overlay-start (car tmp)) start) + (setq start (overlay-start (car tmp)))) + (when (> (overlay-end (car tmp)) end) + (setq end (overlay-end (car tmp)))) (setq tmp (cdr tmp))) ;; Move the first found overlay, recycling that overlay. - (semantic-overlay-move (car changes-in-change) start end) + (move-overlay (car changes-in-change) start end) (condition-case nil (run-hook-with-args 'semantic-edits-move-change-hooks (car changes-in-change)) @@ -200,7 +200,7 @@ Argument START, END, and LENGTH specify the bounds of the change." (run-hook-with-args 'semantic-edits-delete-change-functions (car changes-in-change)) (error nil)) - (semantic-overlay-delete (car changes-in-change)) + (delete-overlay (car changes-in-change)) (setq changes-in-change (cdr changes-in-change)))) ))) @@ -210,7 +210,7 @@ Argument START, END, and LENGTH specify the bounds of the change." (run-hook-with-args 'semantic-edits-delete-change-functions change) (error nil)) - (semantic-overlay-delete change)) + (delete-overlay change)) (defun semantic-edits-flush-changes () "Flush the changes in the current buffer." @@ -225,9 +225,9 @@ Argument START, END, and LENGTH specify the bounds of the change." HITS is the list of tags that CHANGE is in. It can have more than one tag in it if the leaf tag is within a parent tag." (and (< (semantic-tag-start (car hits)) - (semantic-overlay-start change)) + (overlay-start change)) (> (semantic-tag-end (car hits)) - (semantic-overlay-end change)) + (overlay-end change)) ;; Recurse on the rest. If this change is inside all ;; of these tags, then they are all leaves or parents ;; of the smallest tag. @@ -245,12 +245,12 @@ one tag in it if the leaf tag is within a parent tag." ;; at point and mark (via comments I assume.) (defsubst semantic-edits-os (change) "For testing: Start of CHANGE, or smaller of (point) and (mark)." - (if change (semantic-overlay-start change) + (if change (overlay-start change) (if (< (point) (mark)) (point) (mark)))) (defsubst semantic-edits-oe (change) "For testing: End of CHANGE, or larger of (point) and (mark)." - (if change (semantic-overlay-end change) + (if change (overlay-end change) (if (> (point) (mark)) (point) (mark)))) (defun semantic-edits-change-leaf-tag (change) @@ -562,7 +562,7 @@ This function is for internal use by `semantic-edits-incremental-parser'." ;; encompassed within the bounds of tags ;; modified by the previous iteration's ;; change. - (< (semantic-overlay-start (car changes)) + (< (overlay-start (car changes)) parse-end))) ;; REMOVE LATER @@ -607,7 +607,7 @@ This function is for internal use by `semantic-edits-incremental-parser'." ;; our change, meaning there is nothing before ;; the change. ((> (semantic-tag-start (car cache-list)) - (semantic-overlay-end (car changes))) + (overlay-end (car changes))) (setq last-cond "Beginning of buffer") (setq parse-start ;; Don't worry about parents since @@ -621,13 +621,13 @@ This function is for internal use by `semantic-edits-incremental-parser'." ) ;; A change stuck on the first surrounding tag. ((= (semantic-tag-end (car cache-list)) - (semantic-overlay-start (car changes))) + (overlay-start (car changes))) (setq last-cond "Beginning of Tag") ;; Reparse that first tag. (setq parse-start (semantic-tag-start (car cache-list)) parse-end - (semantic-overlay-end (car changes)) + (overlay-end (car changes)) tags (list (car cache-list))) (semantic-edits-assert-valid-region) @@ -671,7 +671,7 @@ This function is for internal use by `semantic-edits-incremental-parser'." (if end-marker (setq parse-end (semantic-tag-start end-marker)) - (setq parse-end (semantic-overlay-end + (setq parse-end (overlay-end (car changes)))) (semantic-edits-assert-valid-region) ) @@ -690,7 +690,7 @@ This function is for internal use by `semantic-edits-incremental-parser'." ;; list of tags. Only possible if END ;; already matches the end of that tag. (setq parse-end - (semantic-overlay-end (car changes))))) + (overlay-end (car changes))))) (semantic-edits-assert-valid-region) )) @@ -700,7 +700,7 @@ This function is for internal use by `semantic-edits-incremental-parser'." )) ;; Is this change inside the previous parse group? ;; We already checked start. - ((< (semantic-overlay-end (car changes)) parse-end) + ((< (overlay-end (car changes)) parse-end) (setq last-cond "in bounds") nil) ;; This change extends the current parse group. @@ -947,9 +947,9 @@ When this routine returns, OLDTAG is raw, and the data will be lost if not transferred into NEWTAG." (let* ((oo (semantic-tag-overlay oldtag)) (o (semantic-tag-overlay newtag)) - (oo-props (semantic-overlay-properties oo))) + (oo-props (overlay-properties oo))) (while oo-props - (semantic-overlay-put o (car oo-props) (car (cdr oo-props))) + (overlay-put o (car oo-props) (car (cdr oo-props))) (setq oo-props (cdr (cdr oo-props))) ) ;; Free the old overlay(s) @@ -963,7 +963,7 @@ lost if not transferred into NEWTAG." ;; OLDTAG is now pointing to NEWTAG, but the NEWTAG ;; cell is about to be abandoned. Here we update our overlay ;; to point at the updated state of the world. - (semantic-overlay-put o 'semantic oldtag) + (overlay-put o 'semantic oldtag) )) (add-hook 'semantic-before-toplevel-cache-flush-hook diff --git a/lisp/cedet/semantic/find.el b/lisp/cedet/semantic/find.el index 57a296dfa94..ec38a37295f 100644 --- a/lisp/cedet/semantic/find.el +++ b/lisp/cedet/semantic/find.el @@ -70,10 +70,10 @@ from largest to smallest via the start location." (set-buffer (marker-buffer positionormarker)) (if (bufferp buffer) (set-buffer buffer)))) - (let ((ol (semantic-overlays-at (or positionormarker (point)))) + (let ((ol (overlays-at (or positionormarker (point)))) (ret nil)) (while ol - (let ((tmp (semantic-overlay-get (car ol) 'semantic))) + (let ((tmp (overlay-get (car ol) 'semantic))) (when (and tmp ;; We don't need with-position because no tag w/out ;; a position could exist in an overlay. @@ -90,10 +90,10 @@ Uses overlays to determine position. Optional BUFFER argument specifies the buffer to use." (save-excursion (if buffer (set-buffer buffer)) - (let ((ol (semantic-overlays-in start end)) + (let ((ol (overlays-in start end)) (ret nil)) (while ol - (let ((tmp (semantic-overlay-get (car ol) 'semantic))) + (let ((tmp (overlay-get (car ol) 'semantic))) (when (and tmp ;; See above about position (semantic-tag-p tmp)) @@ -112,22 +112,22 @@ not the current tag." (if (not start) (setq start (point))) (let ((os start) (ol nil)) (while (and os (< os (point-max)) (not ol)) - (setq os (semantic-overlay-next-change os)) + (setq os (next-overlay-change os)) (when os ;; Get overlays at position - (setq ol (semantic-overlays-at os)) + (setq ol (overlays-at os)) ;; find the overlay that belongs to semantic ;; and starts at the found position. (while (and ol (listp ol)) - (if (and (semantic-overlay-get (car ol) 'semantic) + (if (and (overlay-get (car ol) 'semantic) (semantic-tag-p - (semantic-overlay-get (car ol) 'semantic)) - (= (semantic-overlay-start (car ol)) os)) + (overlay-get (car ol) 'semantic)) + (= (overlay-start (car ol)) os)) (setq ol (car ol))) (when (listp ol) (setq ol (cdr ol)))))) ;; convert ol to a tag - (when (and ol (semantic-tag-p (semantic-overlay-get ol 'semantic))) - (semantic-overlay-get ol 'semantic))))) + (when (and ol (semantic-tag-p (overlay-get ol 'semantic))) + (overlay-get ol 'semantic))))) ;;;###autoload (defun semantic-find-tag-by-overlay-prev (&optional start buffer) @@ -139,25 +139,25 @@ not the current tag." (if (not start) (setq start (point))) (let ((os start) (ol nil)) (while (and os (> os (point-min)) (not ol)) - (setq os (semantic-overlay-previous-change os)) + (setq os (previous-overlay-change os)) (when os ;; Get overlays at position - (setq ol (semantic-overlays-at (1- os))) + (setq ol (overlays-at (1- os))) ;; find the overlay that belongs to semantic ;; and ENDS at the found position. ;; ;; Use end because we are going backward. (while (and ol (listp ol)) - (if (and (semantic-overlay-get (car ol) 'semantic) + (if (and (overlay-get (car ol) 'semantic) (semantic-tag-p - (semantic-overlay-get (car ol) 'semantic)) - (= (semantic-overlay-end (car ol)) os)) + (overlay-get (car ol) 'semantic)) + (= (overlay-end (car ol)) os)) (setq ol (car ol))) (when (listp ol) (setq ol (cdr ol)))))) ;; convert ol to a tag (when (and ol - (semantic-tag-p (semantic-overlay-get ol 'semantic))) - (semantic-overlay-get ol 'semantic))))) + (semantic-tag-p (overlay-get ol 'semantic))) + (overlay-get ol 'semantic))))) ;;;###autoload (defun semantic-find-tag-parent-by-overlay (tag) diff --git a/lisp/cedet/semantic/format.el b/lisp/cedet/semantic/format.el index 7d040fd84af..b576ad5e210 100644 --- a/lisp/cedet/semantic/format.el +++ b/lisp/cedet/semantic/format.el @@ -67,7 +67,7 @@ COLOR indicates that the generated text should be colored using (defvar semantic-format-tag-custom-list (append '(radio) - (mapcar (lambda (f) (list 'const f)) + (mapcar (lambda (f) (list 'function-item f)) semantic-format-tag-functions) '(function)) "A List used by customizable variables to choose a tag to text function. @@ -92,12 +92,8 @@ Images can be used as icons instead of some types of text strings." (variable . font-lock-variable-name-face) (type . font-lock-type-face) ;; These are different between Emacsen. - (include . ,(if (featurep 'xemacs) - 'font-lock-preprocessor-face - 'font-lock-constant-face)) - (package . ,(if (featurep 'xemacs) - 'font-lock-preprocessor-face - 'font-lock-constant-face)) + (include . ,'font-lock-constant-face) + (package . , 'font-lock-constant-face) ;; Not a tag, but instead a feature of output (label . font-lock-string-face) (comment . font-lock-comment-face) @@ -135,26 +131,23 @@ See that variable for details on adding new types." FACE-CLASS is a tag type found in `semantic-formatface-alist'. See that variable for details on adding new types." (let ((face (cdr-safe (assoc face-class semantic-format-face-alist))) - (newtext (concat precoloredtext)) - ) - (if (featurep 'xemacs) - (add-text-properties 0 (length newtext) (list 'face face) newtext) - (alter-text-property 0 (length newtext) 'face - (lambda (current-face) - (let ((cf - (cond ((facep current-face) - (list current-face)) - ((listp current-face) - current-face) - (t nil))) - (nf - (cond ((facep face) - (list face)) - ((listp face) - face) - (t nil)))) - (append cf nf))) - newtext)) + (newtext (concat precoloredtext))) + (alter-text-property 0 (length newtext) 'face + (lambda (current-face) + (let ((cf + (cond ((facep current-face) + (list current-face)) + ((listp current-face) + current-face) + (t nil))) + (nf + (cond ((facep face) + (list face)) + ((listp face) + face) + (t nil)))) + (append cf nf))) + newtext) newtext)) ;;; Function Arguments diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el index 6719e626f08..0dd0a932188 100644 --- a/lisp/cedet/semantic/fw.el +++ b/lisp/cedet/semantic/fw.el @@ -34,132 +34,58 @@ ;;; Compatibility ;; -(eval-and-compile - (if (featurep 'xemacs) - (progn - (defalias 'semantic-buffer-local-value 'symbol-value-in-buffer) - ;; FIXME: Why not just (require 'overlay)? - (defalias 'semantic-overlay-live-p - (lambda (o) - (and (extent-live-p o) - (not (extent-detached-p o)) - (bufferp (extent-buffer o))))) - (defalias 'semantic-make-overlay - (lambda (beg end &optional buffer &rest rest) - "Xemacs `make-extent', supporting the front/rear advance options." - (let ((ol (make-extent beg end buffer))) - (when rest - (set-extent-property ol 'start-open (car rest)) - (setq rest (cdr rest))) - (when rest - (set-extent-property ol 'end-open (car rest))) - ol))) - (defalias 'semantic-overlay-put 'set-extent-property) - (defalias 'semantic-overlay-get 'extent-property) - (defalias 'semantic-overlay-properties 'extent-properties) - (defalias 'semantic-overlay-move 'set-extent-endpoints) - (defalias 'semantic-overlay-delete 'delete-extent) - (defalias 'semantic-overlays-at - (lambda (pos) - (condition-case nil - (extent-list nil pos pos) - (error nil)) - )) - (defalias 'semantic-overlays-in - (lambda (beg end) (extent-list nil beg end))) - (defalias 'semantic-overlay-buffer 'extent-buffer) - (defalias 'semantic-overlay-start 'extent-start-position) - (defalias 'semantic-overlay-end 'extent-end-position) - (defalias 'semantic-overlay-size 'extent-length) - (defalias 'semantic-overlay-next-change 'next-extent-change) - (defalias 'semantic-overlay-previous-change 'previous-extent-change) - (defalias 'semantic-overlay-lists - (lambda () (list (extent-list)))) - (defalias 'semantic-overlay-p 'extentp) - (defalias 'semantic-event-window 'event-window) - (defun semantic-read-event () - (let ((event (next-command-event))) - (if (key-press-event-p event) - (let ((c (event-to-character event))) - (if (char-equal c (quit-char)) - (keyboard-quit) - c))) - event)) - (defun semantic-popup-menu (menu) - "Blocking version of `popup-menu'" - (popup-menu menu) - ;; Wait... - (while (popup-up-p) (dispatch-event (next-event)))) - ) - ;; Emacs Bindings - (defalias 'semantic-overlay-live-p 'overlay-buffer) - (defalias 'semantic-make-overlay 'make-overlay) - (defalias 'semantic-overlay-put 'overlay-put) - (defalias 'semantic-overlay-get 'overlay-get) - (defalias 'semantic-overlay-properties 'overlay-properties) - (defalias 'semantic-overlay-move 'move-overlay) - (defalias 'semantic-overlay-delete 'delete-overlay) - (defalias 'semantic-overlays-at 'overlays-at) - (defalias 'semantic-overlays-in 'overlays-in) - (defalias 'semantic-overlay-buffer 'overlay-buffer) - (defalias 'semantic-overlay-start 'overlay-start) - (defalias 'semantic-overlay-end 'overlay-end) - (defalias 'semantic-overlay-next-change 'next-overlay-change) - (defalias 'semantic-overlay-previous-change 'previous-overlay-change) - (defalias 'semantic-overlay-lists 'overlay-lists) - (defalias 'semantic-overlay-p 'overlayp) - (defalias 'semantic-read-event 'read-event) - (defalias 'semantic-popup-menu 'popup-menu) - (defun semantic-event-window (event) - "Extract the window from EVENT." - (car (car (cdr event)))) - - (defalias 'semantic-buffer-local-value 'buffer-local-value) - - ) - - - (defalias 'semantic-make-local-hook - (if (featurep 'emacs) - #'identity #'make-local-hook)) - - (defalias 'semantic-mode-line-update - (if (featurep 'xemacs) #'redraw-modeline #'force-mode-line-update)) - - ;; Since Emacs 22 major mode functions should use `run-mode-hooks' to - ;; run major mode hooks. - (defalias 'semantic-run-mode-hooks - (if (fboundp 'run-mode-hooks) - 'run-mode-hooks - 'run-hooks)) +(define-obsolete-function-alias 'semantic-overlay-live-p 'overlay-buffer "27.1") +(define-obsolete-function-alias 'semantic-make-overlay 'make-overlay "27.1") +(define-obsolete-function-alias 'semantic-overlay-put 'overlay-put "27.1") +(define-obsolete-function-alias 'semantic-overlay-get 'overlay-get "27.1") +(define-obsolete-function-alias 'semantic-overlay-properties + 'overlay-properties "27.1") +(define-obsolete-function-alias 'semantic-overlay-move 'move-overlay "27.1") +(define-obsolete-function-alias 'semantic-overlay-delete 'delete-overlay "27.1") +(define-obsolete-function-alias 'semantic-overlays-at 'overlays-at "27.1") +(define-obsolete-function-alias 'semantic-overlays-in 'overlays-in "27.1") +(define-obsolete-function-alias 'semantic-overlay-buffer 'overlay-buffer "27.1") +(define-obsolete-function-alias 'semantic-overlay-start 'overlay-start "27.1") +(define-obsolete-function-alias 'semantic-overlay-end 'overlay-end "27.1") +(define-obsolete-function-alias 'semantic-overlay-next-change + 'next-overlay-change "27.1") +(define-obsolete-function-alias 'semantic-overlay-previous-change + 'previous-overlay-change "27.1") +(define-obsolete-function-alias 'semantic-overlay-lists 'overlay-lists "27.1") +(define-obsolete-function-alias 'semantic-overlay-p 'overlayp "27.1") +(define-obsolete-function-alias 'semantic-read-event 'read-event "27.1") +(define-obsolete-function-alias 'semantic-popup-menu 'popup-menu "27.1") +(define-obsolete-function-alias 'semantic-buffer-local-value + 'buffer-local-value "27.1") + +(defun semantic-event-window (event) + "Extract the window from EVENT." + (car (car (cdr event)))) + +(defalias 'semantic-make-local-hook + (if (featurep 'emacs) + #'identity #'make-local-hook)) + +(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. +(defalias 'semantic-run-mode-hooks + (if (fboundp 'run-mode-hooks) + 'run-mode-hooks + 'run-hooks)) ;; Fancy compat usage now handled in cedet-compat - (defalias 'semantic-subst-char-in-string 'subst-char-in-string) - ) +(defalias 'semantic-subst-char-in-string 'subst-char-in-string) (defun semantic-delete-overlay-maybe (overlay) "Delete OVERLAY if it is a semantic token overlay." - (if (semantic-overlay-get overlay 'semantic) - (semantic-overlay-delete overlay))) + (if (overlay-get overlay 'semantic) + (delete-overlay overlay))) ;;; Menu Item compatibility ;; -(defun semantic-menu-item (item) - "Build an XEmacs compatible menu item from vector ITEM. -That is remove the unsupported :help stuff." - (if (featurep 'xemacs) - (let ((n (length item)) - (i 0) - slot l) - (while (< i n) - (setq slot (aref item i)) - (if (and (keywordp slot) - (eq slot :help)) - (setq i (1+ i)) - (setq l (cons slot l))) - (setq i (1+ i))) - (apply #'vector (nreverse l))) - item)) +(define-obsolete-function-alias 'semantic-menu-item #'identity "27.1") ;;; Positional Data Cache ;; @@ -182,10 +108,10 @@ Possible Lifespans are: (or (memq lifespan '(end-of-command exit-cache-zone)) (error "semantic-cache-data-to-buffer: Unknown LIFESPAN: %s" lifespan)) - (let ((o (semantic-make-overlay start end buffer))) - (semantic-overlay-put o 'cache-name name) - (semantic-overlay-put o 'cached-value value) - (semantic-overlay-put o 'lifespan lifespan) + (let ((o (make-overlay start end buffer))) + (overlay-put o 'cache-name name) + (overlay-put o 'cached-value value) + (overlay-put o 'lifespan lifespan) (setq semantic-cache-data-overlays (cons o semantic-cache-data-overlays)) ;;(message "Adding to cache: %s" o) @@ -199,14 +125,14 @@ Remove self from `post-command-hook' if it is empty." (oldcache semantic-cache-data-overlays)) (while oldcache (let* ((o (car oldcache)) - (life (semantic-overlay-get o 'lifespan)) + (life (overlay-get o 'lifespan)) ) (if (or (eq life 'end-of-command) (and (eq life 'exit-cache-zone) - (not (member o (semantic-overlays-at (point)))))) + (not (member o (overlays-at (point)))))) (progn ;;(message "Removing from cache: %s" o) - (semantic-overlay-delete o) + (delete-overlay o) ) (setq newcache (cons o newcache)))) (setq oldcache (cdr oldcache))) @@ -221,14 +147,14 @@ Remove self from `post-command-hook' if it is empty." "Get cached data with NAME from optional POINT." (save-excursion (if point (goto-char point)) - (let ((o (semantic-overlays-at (point))) + (let ((o (overlays-at (point))) (ans nil)) (while (and (not ans) o) - (if (equal (semantic-overlay-get (car o) 'cache-name) name) + (if (equal (overlay-get (car o) 'cache-name) name) (setq ans (car o)) (setq o (cdr o)))) (when ans - (semantic-overlay-get ans 'cached-value))))) + (overlay-get ans 'cached-value))))) (defun semantic-test-data-cache () "Test the data cache." @@ -406,8 +332,7 @@ Use this when referencing a file that will be soon deleted. FILE, NOWARN, RAWFILE, and WILDCARDS are passed into `find-file-noselect'" ;; Hack - ;; Check if we are in set-auto-mode, and if so, warn about this. - (when (or (and (featurep 'emacs) (boundp 'keep-mode-if-same)) - (and (featurep 'xemacs) (boundp 'just-from-file-name))) + (when (boundp 'keep-mode-if-same) (let ((filename (or (and (boundp 'filename) filename) "(unknown)"))) (message "WARNING: semantic-find-file-noselect called for \ @@ -439,10 +364,7 @@ into `mode-local-init-hook'." file filename) (enable-local-eval nil) ) (save-match-data - (if (featurep 'xemacs) - (find-file-noselect file nowarn rawfile) - (find-file-noselect file nowarn rawfile wildcards))) - )) + (find-file-noselect file nowarn rawfile wildcards)))) ;;; Database restriction settings ;; diff --git a/lisp/cedet/semantic/grammar-wy.el b/lisp/cedet/semantic/grammar-wy.el index cc5942fa323..b5066d3d27b 100644 --- a/lisp/cedet/semantic/grammar-wy.el +++ b/lisp/cedet/semantic/grammar-wy.el @@ -41,6 +41,7 @@ '(("%default-prec" . DEFAULT-PREC) ("%no-default-prec" . NO-DEFAULT-PREC) ("%keyword" . KEYWORD) + ("%expectedconflicts" . EXPECTEDCONFLICTS) ("%languagemode" . LANGUAGEMODE) ("%left" . LEFT) ("%nonassoc" . NONASSOC) @@ -110,7 +111,7 @@ (eval-when-compile (require 'semantic/wisent/comp)) (wisent-compile-grammar - '((DEFAULT-PREC NO-DEFAULT-PREC KEYWORD LANGUAGEMODE LEFT NONASSOC PACKAGE PROVIDE PREC PUT QUOTEMODE RIGHT SCOPESTART START TOKEN TYPE USE-MACROS STRING SYMBOL PERCENT_PERCENT CHARACTER PREFIXED_LIST SEXP PROLOGUE EPILOGUE PAREN_BLOCK BRACE_BLOCK LPAREN RPAREN LBRACE RBRACE COLON SEMI OR LT GT) + '((DEFAULT-PREC NO-DEFAULT-PREC KEYWORD LANGUAGEMODE EXPECTEDCONFLICTS LEFT NONASSOC PACKAGE PROVIDE PREC PUT QUOTEMODE RIGHT SCOPESTART START TOKEN TYPE USE-MACROS STRING SYMBOL PERCENT_PERCENT CHARACTER PREFIXED_LIST SEXP PROLOGUE EPILOGUE PAREN_BLOCK BRACE_BLOCK LPAREN RPAREN LBRACE RBRACE COLON SEMI OR LT GT) nil (grammar ((prologue)) @@ -133,6 +134,7 @@ ((default_prec_decl)) ((no_default_prec_decl)) ((languagemode_decl)) + ((expectedconflicts_decl)) ((package_decl)) ((provide_decl)) ((precedence_decl)) @@ -159,6 +161,11 @@ `(wisent-raw-tag (semantic-tag ',(car $2) 'languagemode :rest ',(cdr $2))))) + (expectedconflicts_decl + ((EXPECTEDCONFLICTS symbols) + `(wisent-raw-tag + (semantic-tag ',(car $2) + 'expectedconflicts :rest ',(cdr $2))))) (package_decl ((PACKAGE SYMBOL) `(wisent-raw-tag diff --git a/lisp/cedet/semantic/grammar.el b/lisp/cedet/semantic/grammar.el index 9851280e14a..4237f9cef11 100644 --- a/lisp/cedet/semantic/grammar.el +++ b/lisp/cedet/semantic/grammar.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2002-2005, 2007-2019 Free Software Foundation, Inc. ;; Author: David Ponce <david@dponce.com> -;; Maintainer: David Ponce <david@dponce.com> ;; This file is part of GNU Emacs. @@ -38,9 +37,9 @@ (require 'semantic/grammar-wy) (require 'semantic/idle) (require 'help-fns) +(require 'semantic/analyze) (declare-function semantic-momentary-highlight-tag "semantic/decorate") -(declare-function semantic-analyze-context "semantic/analyze") (declare-function semantic-analyze-tags-of-class-list "semantic/analyze/complete") @@ -210,11 +209,7 @@ That is tag names plus names defined in tag attribute `:rest'." (defsubst semantic-grammar-item-value (item) "Return symbol or character value of ITEM string." (if (string-match semantic-grammar-lex-c-char-re item) - (let ((c (read (concat "?" (substring item 1 -1))))) - (if (featurep 'xemacs) - ;; Handle characters as integers in XEmacs like in GNU Emacs. - (char-int c) - c)) + (read (concat "?" (substring item 1 -1))) (intern item))) (defun semantic-grammar-prologue () @@ -278,6 +273,10 @@ foo.by it is foo-by." (i (string-match (format "\\([.]\\)%s\\'" ext) file))) (concat (substring file 0 i) "-" ext)))) +(defun semantic-grammar-expected-conflicts () + "Return the number of expected shift/reduce conflicts in the package." + (semantic-grammar-tag-symbols 'expectedconflicts)) + (defsubst semantic-grammar-languagemode () "Return the %languagemode value as a list of symbols or nil." (semantic-grammar-tag-symbols 'languagemode)) @@ -534,6 +533,14 @@ Also load the specified macro libraries." (goto-char start) (indent-sexp)))) +(defun semantic-grammar-insert-defconst-with-eval (name value docstring) + "Insert declaration of constant NAME with VALUE and DOCSTRING." + (let ((start (point))) + (insert (format "(eval-and-compile (defconst %s\n%s%S))\n\n" name value docstring)) + (save-excursion + (goto-char start) + (indent-sexp)))) + (defun semantic-grammar-insert-defun (name body docstring) "Insert declaration of function NAME with BODY and DOCSTRING." (let ((start (point))) @@ -822,12 +829,6 @@ Block definitions are read from the current table of lexical types." :group 'semantic :type 'regexp) -(defsubst semantic-grammar-noninteractive () - "Return non-nil if running without interactive terminal." - (if (featurep 'xemacs) - (noninteractive) - noninteractive)) - (defun semantic-grammar-create-package (&optional force uptodate) "Create package Lisp code from grammar in current buffer. If the Lisp code seems up to date, do nothing (if UPTODATE @@ -891,6 +892,12 @@ Lisp code." (insert "\n;;; Declarations\n;;\n") + (semantic-grammar-insert-defconst-with-eval + (concat semantic--grammar-package "--expected-conflicts") + (with-current-buffer semantic--grammar-input-buffer + (format "%s\n" (car (semantic-grammar-expected-conflicts)))) + "The number of expected shift/reduce conflicts in this grammar.") + ;; `eval-defun' is not necessary to reset `defconst' values. (semantic-grammar-insert-defconst (semantic-grammar-keywordtable) @@ -934,7 +941,7 @@ Lisp code." ;; If running in batch mode, there is nothing more to do. ;; Save the generated file and quit. - (if (semantic-grammar-noninteractive) + (if noninteractive (let ((version-control t) (delete-old-versions t) (make-backup-files t) @@ -988,7 +995,7 @@ Return non-nil if there were no errors, nil if errors." (vc-handled-backends nil)) (setq semanticdb-new-database-class 'semanticdb-project-database) (semantic-mode 1) - (semantic-grammar-create-package))) + (semantic-grammar-create-package t))) (error (message "%s" (error-message-string err)) nil)))) @@ -1015,7 +1022,7 @@ For example, to process grammar files in current directory, invoke: \"emacs -batch -f semantic-grammar-batch-build-packages .\". See also the variable `semantic-grammar-file-regexp'." - (or (semantic-grammar-noninteractive) + (or noninteractive (error "\ `semantic-grammar-batch-build-packages' must be used with -batch" )) @@ -1264,10 +1271,8 @@ common grammar menu." "Setup a mode local grammar menu. MODE-MENU is an optional specific menu whose items are appended to the common grammar menu." - (let ((menu (intern (format "%s-menu" major-mode)))) - (if (featurep 'xemacs) - (semantic-grammar-setup-menu-xemacs menu mode-menu) - (semantic-grammar-setup-menu-emacs menu mode-menu)))) + (semantic-grammar-setup-menu-emacs + (intern (format "%s-menu" major-mode)) mode-menu)) (defsubst semantic-grammar-in-lisp-p () "Return non-nil if point is in Lisp code." @@ -1287,9 +1292,9 @@ the change bounds to encompass the whole nonterminal tag." (semantic-edits-os overlay) (semantic-edits-oe overlay))))) (if (semantic-tag-of-class-p outer 'nonterminal) - (semantic-overlay-move overlay - (semantic-tag-start outer) - (semantic-tag-end outer))))) + (move-overlay overlay + (semantic-tag-start outer) + (semantic-tag-end outer))))) (define-derived-mode semantic-grammar-mode fundamental-mode "Semantic Grammar Framework" @@ -1611,7 +1616,7 @@ Select the buffer containing the tag's definition, and move point there." ;; (defvar semantic-grammar-syntax-help - `( + '( ;; Lexical Symbols ("symbol" . "Syntax: A symbol of alpha numeric and symbol characters") ("number" . "Syntax: Numeric characters.") @@ -1879,7 +1884,6 @@ Optional argument COLOR determines if color is added to the text." (define-mode-local-override semantic-analyze-current-context semantic-grammar-mode (point) "Provide a semantic analysis object describing a context in a grammar." - (require 'semantic/analyze) (if (semantic-grammar-in-lisp-p) (with-mode-local emacs-lisp-mode (semantic-analyze-current-context point)) @@ -1900,7 +1904,6 @@ Optional argument COLOR determines if color is added to the text." (setq context-return (semantic-analyze-context - "context-for-semantic-grammar" :buffer (current-buffer) :scope nil :bounds bounds @@ -1921,7 +1924,7 @@ Optional argument COLOR determines if color is added to the text." (with-mode-local emacs-lisp-mode (semantic-analyze-possible-completions context)) (with-current-buffer (oref context buffer) - (let* ((prefix (car (oref context :prefix))) + (let* ((prefix (car (oref context prefix))) (completetext (cond ((semantic-tag-p prefix) (semantic-tag-name prefix)) ((stringp prefix) diff --git a/lisp/cedet/semantic/ia.el b/lisp/cedet/semantic/ia.el index 1549f52925f..68c6e4279cf 100644 --- a/lisp/cedet/semantic/ia.el +++ b/lisp/cedet/semantic/ia.el @@ -316,8 +316,8 @@ This helper manages the mark, buffer switching, and pulsing." ;; 1) Push the mark, so you can pop global mark back, or ;; use semantic-mru-bookmark mode to do so. (push-mark) - (when (fboundp 'push-tag-mark) - (push-tag-mark)) + (when (fboundp 'xref-push-marker-stack) + (xref-push-marker-stack)) ;; 2) Visits the tag. (semantic-go-to-tag dest) ;; 3) go-to-tag doesn't switch the buffer in the current window, @@ -385,8 +385,8 @@ origin of the code at point." ;; Push the mark, so you can pop global mark back, or ;; use semantic-mru-bookmark mode to do so. (push-mark) - (when (fboundp 'push-tag-mark) - (push-tag-mark)) + (when (fboundp 'xref-push-marker-stack) + (xref-push-marker-stack)) (semantic-decoration-include-visit) ) diff --git a/lisp/cedet/semantic/idle.el b/lisp/cedet/semantic/idle.el index bb06de25985..09af66658fa 100644 --- a/lisp/cedet/semantic/idle.el +++ b/lisp/cedet/semantic/idle.el @@ -40,6 +40,7 @@ (require 'semantic/ctxt) (require 'semantic/format) (require 'semantic/tag) +(require 'semantic/analyze) (require 'timer) ;;(require 'working) @@ -48,7 +49,6 @@ (defvar eldoc-last-message) (declare-function eldoc-message "eldoc") -(declare-function semantic-analyze-interesting-tag "semantic/analyze") (declare-function semantic-analyze-unsplit-name "semantic/analyze/fcn") (declare-function semantic-complete-analyze-inline-idle "semantic/complete") (declare-function semanticdb-deep-find-tags-by-name "semantic/db-find") @@ -172,11 +172,9 @@ some command requests the list of available tokens. When idle-scheduler is enabled, Emacs periodically checks to see if the buffer is out of date, and reparses while the user is idle (not typing.) -With prefix argument ARG, turn on if positive, otherwise off. The -minor mode can be turned on only if semantic feature is available and -the current buffer was set up for parsing. Return non-nil if the -minor mode is enabled." - nil nil nil +The minor mode can be turned on only if semantic feature is +available and the current buffer was set up for parsing. Return +non-nil if the minor mode is enabled." nil nil nil (if semantic-idle-scheduler-mode (if (not (and (featurep 'semantic) (semantic-active-p))) (progn @@ -684,7 +682,6 @@ Use the semantic analyzer to find the symbol information." (semantic-analyze-current-context (point)) (error nil)))) (when analysis - (require 'semantic/analyze) (semantic-analyze-interesting-tag analysis)))) (defun semantic-idle-summary-current-symbol-info-default () @@ -776,8 +773,6 @@ current tag to display information." (define-minor-mode semantic-idle-summary-mode "Toggle Semantic Idle Summary mode. -With ARG, turn Semantic Idle Summary mode on if ARG is positive, -off otherwise. When this minor mode is enabled, the echo area displays a summary of the lexical token at point whenever Emacs is idle." @@ -812,8 +807,6 @@ of the lexical token at point whenever Emacs is idle." (define-minor-mode global-semantic-idle-summary-mode "Toggle Global Semantic Idle Summary mode. -With ARG, turn Global Semantic Idle Summary mode on if ARG is -positive, off otherwise. When this minor mode is enabled, `semantic-idle-summary-mode' is turned on in every Semantic-supported buffer." @@ -856,18 +849,18 @@ visible, then highlight it." ;; just the stable version. (pulse-flag nil) ) - (cond ((semantic-overlay-p region) - (with-current-buffer (semantic-overlay-buffer region) + (cond ((overlayp region) + (with-current-buffer (overlay-buffer region) (save-excursion - (goto-char (semantic-overlay-start region)) + (goto-char (overlay-start region)) (when (pos-visible-in-window-p (point) (get-buffer-window (current-buffer) 'visible)) - (if (< (semantic-overlay-end region) (point-at-eol)) + (if (< (overlay-end region) (point-at-eol)) (pulse-momentary-highlight-overlay region semantic-idle-symbol-highlight-face) ;; Not the same (pulse-momentary-highlight-region - (semantic-overlay-start region) + (overlay-start region) (point-at-eol) semantic-idle-symbol-highlight-face)))) )) @@ -931,9 +924,10 @@ Call `semantic-symref-hits-in-region' to identify local references." ;;;###autoload (define-minor-mode global-semantic-idle-scheduler-mode "Toggle global use of option `semantic-idle-scheduler-mode'. -The idle scheduler will automatically reparse buffers in idle time, -and then schedule other jobs setup with `semantic-idle-scheduler-add'. -If ARG is positive or nil, enable, if it is negative, disable." + +The idle scheduler will automatically reparse buffers in idle +time, and then schedule other jobs setup with +`semantic-idle-scheduler-add'." :global t :group 'semantic :group 'semantic-modes @@ -986,7 +980,7 @@ This minor mode only takes effect if Semantic is active and When enabled, Emacs displays a list of possible completions at idle time. The method for displaying completions is given by -`semantic-complete-inline-analyzer-idle-displayor-class'; the +`semantic-complete-inline-analyzer-idle-displayer-class'; the default is to show completions inline. While a completion is displayed, RET accepts the completion; M-n @@ -1080,7 +1074,7 @@ be called." (let ((old-window (selected-window)) (window (semantic-event-window event))) (select-window window t) - (semantic-popup-menu semantic-idle-breadcrumbs-popup-menu) + (popup-menu semantic-idle-breadcrumbs-popup-menu) (select-window old-window))) (defmacro semantic-idle-breadcrumbs--tag-function (function) @@ -1120,65 +1114,61 @@ be called." "Semantic Breadcrumbs Mode Menu" (list "Breadcrumb Tag" - (semantic-menu-item - (vector - "Go to Tag" - (semantic-idle-breadcrumbs--tag-function - semantic-go-to-tag) - :active t - :help "Jump to this tag")) + (vector + "Go to Tag" + (semantic-idle-breadcrumbs--tag-function + semantic-go-to-tag) + :active t + :help "Jump to this tag") ;; TODO these entries need minor changes (optional tag argument) in ;; senator-copy-tag etc - ;; (semantic-menu-item - ;; (vector - ;; "Copy Tag" - ;; (semantic-idle-breadcrumbs--tag-function - ;; senator-copy-tag) - ;; :active t - ;; :help "Copy this tag")) - ;; (semantic-menu-item - ;; (vector - ;; "Kill Tag" - ;; (semantic-idle-breadcrumbs--tag-function - ;; senator-kill-tag) - ;; :active t - ;; :help "Kill tag text to the kill ring, and copy the tag to - ;; the tag ring")) - ;; (semantic-menu-item - ;; (vector - ;; "Copy Tag to Register" - ;; (semantic-idle-breadcrumbs--tag-function - ;; senator-copy-tag-to-register) - ;; :active t - ;; :help "Copy this tag")) - ;; (semantic-menu-item - ;; (vector - ;; "Narrow to Tag" - ;; (semantic-idle-breadcrumbs--tag-function - ;; senator-narrow-to-defun) - ;; :active t - ;; :help "Narrow to the bounds of the current tag")) - ;; (semantic-menu-item - ;; (vector - ;; "Fold Tag" - ;; (semantic-idle-breadcrumbs--tag-function - ;; senator-fold-tag-toggle) - ;; :active t - ;; :style 'toggle - ;; :selected '(let ((tag (semantic-current-tag))) - ;; (and tag (semantic-tag-folded-p tag))) - ;; :help "Fold the current tag to one line")) - "---" - (semantic-menu-item - (vector - "About this Header Line" - (lambda () - (interactive) - (describe-function 'semantic-idle-breadcrumbs-mode)) - :active t - :help "Display help about this header line.")) - ) - ) + ;; (semantic-menu-item + ;; (vector + ;; "Copy Tag" + ;; (semantic-idle-breadcrumbs--tag-function + ;; senator-copy-tag) + ;; :active t + ;; :help "Copy this tag")) + ;; (semantic-menu-item + ;; (vector + ;; "Kill Tag" + ;; (semantic-idle-breadcrumbs--tag-function + ;; senator-kill-tag) + ;; :active t + ;; :help "Kill tag text to the kill ring, and copy the tag to + ;; the tag ring")) + ;; (semantic-menu-item + ;; (vector + ;; "Copy Tag to Register" + ;; (semantic-idle-breadcrumbs--tag-function + ;; senator-copy-tag-to-register) + ;; :active t + ;; :help "Copy this tag")) + ;; (semantic-menu-item + ;; (vector + ;; "Narrow to Tag" + ;; (semantic-idle-breadcrumbs--tag-function + ;; senator-narrow-to-defun) + ;; :active t + ;; :help "Narrow to the bounds of the current tag")) + ;; (semantic-menu-item + ;; (vector + ;; "Fold Tag" + ;; (semantic-idle-breadcrumbs--tag-function + ;; senator-fold-tag-toggle) + ;; :active t + ;; :style 'toggle + ;; :selected '(let ((tag (semantic-current-tag))) + ;; (and tag (semantic-tag-folded-p tag))) + ;; :help "Fold the current tag to one line")) + "---" + (vector + "About this Header Line" + (lambda () + (interactive) + (describe-function 'semantic-idle-breadcrumbs-mode)) + :active t + :help "Display help about this header line."))) (define-semantic-idle-service semantic-idle-breadcrumbs "Display breadcrumbs for the tag under point and its parents." diff --git a/lisp/cedet/semantic/imenu.el b/lisp/cedet/semantic/imenu.el index 0fb9eca7536..009d04dbd75 100644 --- a/lisp/cedet/semantic/imenu.el +++ b/lisp/cedet/semantic/imenu.el @@ -4,7 +4,6 @@ ;; Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Maintainer: Eric Ludlam ;; This file is part of GNU Emacs. @@ -156,7 +155,7 @@ By default, a `type' has interesting children. In Texinfo, however, a If TAG doesn't have an overlay, and instead as a vector of positions, concoct a combination of file name, and position." (let ((o (semantic-tag-overlay tag))) - (if (not (semantic-overlay-p o)) + (if (not (overlayp o)) (let ((v (make-vector 3 nil))) (aset v 0 semantic-imenu-directory-current-file) (aset v 1 (aref o 0)) @@ -171,9 +170,9 @@ Used to override function `imenu-default-goto-function' so that we can continue to use overlays to maintain the current position. Optional argument REST is some extra stuff." (require 'pulse) - (if (semantic-overlay-p position) - (let ((os (semantic-overlay-start position)) - (ob (semantic-overlay-buffer position))) + (if (overlayp position) + (let ((os (overlay-start position)) + (ob (overlay-buffer position))) (if os (progn (if (not (eq ob (current-buffer))) diff --git a/lisp/cedet/semantic/java.el b/lisp/cedet/semantic/java.el index 54cce965459..7f9c93b906f 100644 --- a/lisp/cedet/semantic/java.el +++ b/lisp/cedet/semantic/java.el @@ -51,7 +51,7 @@ "\\|" "\\<[0-9]+[eE][-+]?[0-9]+[fFdD]?\\>" "\\|" - "\\<0[xX][0-9a-fA-F]+[lL]?\\>" + "\\<0[xX][[:xdigit:]]+[lL]?\\>" "\\|" "\\<[0-9]+[lLfFdD]?\\>" "\\)" @@ -63,7 +63,7 @@ DECIMAL_LITERAL: [1-9][0-9]* ; HEX_LITERAL: - 0[xX][0-9a-fA-F]+ + 0[xX][[:xdigit:]]+ ; OCTAL_LITERAL: 0[0-7]* diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el index d491e332908..6fe33f93110 100644 --- a/lisp/cedet/semantic/lex-spp.el +++ b/lisp/cedet/semantic/lex-spp.el @@ -907,7 +907,7 @@ STR occurs in the current buffer between BEG and END." (push str semantic-lex-spp-expanded-macro-stack) ) - (semantic-lex-spp-anlyzer-do-replace sym val beg end)) + (semantic-lex-spp-analyzer-do-replace sym val beg end)) )) ;; Anything else. @@ -1092,7 +1092,7 @@ and variable state from the current buffer." ;; the originating buffer we are parsing. We need to do this every time ;; since the state changes. (dolist (V important-vars) - (set V (semantic-buffer-local-value V origbuff))) + (set V (buffer-local-value V origbuff))) (insert text) (goto-char (point-min)) diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el index 7bef6b8324d..a6ee869c037 100644 --- a/lisp/cedet/semantic/lex.el +++ b/lisp/cedet/semantic/lex.el @@ -596,7 +596,7 @@ may need to be overridden for some special languages.") "\\|" "\\<[0-9]+[eE][-+]?[0-9]+[fFdD]?\\>" "\\|" - "\\<0[xX][0-9a-fA-F]+[lL]?\\>" + "\\<0[xX][[:xdigit:]]+[lL]?\\>" "\\|" "\\<[0-9]+[lLfFdD]?\\>" "\\)" @@ -609,7 +609,7 @@ DECIMAL_LITERAL: [1-9][0-9]* ; HEX_LITERAL: - 0[xX][0-9a-fA-F]+ + 0[xX][[:xdigit:]]+ ; OCTAL_LITERAL: 0[0-7]* @@ -658,10 +658,9 @@ If universal argument ARG, then try the whole buffer." (let* ((start (current-time)) (result (semantic-lex (if arg (point-min) (point)) - (point-max))) - (end (current-time))) + (point-max)))) (message "Elapsed Time: %.2f seconds." - (semantic-elapsed-time start end)) + (semantic-elapsed-time start nil)) (pop-to-buffer "*Lexer Output*") (require 'pp) (erase-buffer) @@ -687,9 +686,9 @@ displayed in the minibuffer. Press SPC to move to the next lexical token." "Highlight the lexical TOKEN. TOKEN is a lexical token with a START And END position. Return the overlay." - (let ((o (semantic-make-overlay (semantic-lex-token-start token) - (semantic-lex-token-end token)))) - (semantic-overlay-put o 'face 'highlight) + (let ((o (make-overlay (semantic-lex-token-start token) + (semantic-lex-token-end token)))) + (overlay-put o 'face 'highlight) o)) ;;; Lexical analyzer creation @@ -753,11 +752,11 @@ a LOCAL option.") (progn (when token (setq o (semantic-lex-highlight-token token))) - (semantic-read-event + (read-event (format "%S :: Depth: %d :: SPC - continue" token semantic-lex-current-depth)) ) (when o - (semantic-overlay-delete o)))))) + (delete-overlay o)))))) (defmacro define-lex (name doc &rest analyzers) "Create a new lexical analyzer with NAME. @@ -811,7 +810,7 @@ analyzer which might mistake a number for as a symbol." tmp-start (car semantic-lex-token-stream))) (setq tmp-start semantic-lex-end-point) (goto-char semantic-lex-end-point) - ;;(when (> (semantic-elapsed-time starttime (current-time)) + ;;(when (> (semantic-elapsed-time starttime nil) ;; semantic-lex-timeout) ;; (error "Timeout during lex at char %d" (point))) (semantic-throw-on-input 'lex) diff --git a/lisp/cedet/semantic/mru-bookmark.el b/lisp/cedet/semantic/mru-bookmark.el index b9124d80d51..627c71a01b8 100644 --- a/lisp/cedet/semantic/mru-bookmark.el +++ b/lisp/cedet/semantic/mru-bookmark.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -45,7 +45,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'semantic) (require 'eieio-base) (require 'ring) @@ -166,7 +165,6 @@ We can't use the built-in ring data structure because we need to delete some items from the ring when we don't have the data.") (defvar semantic-mru-bookmark-ring (semantic-bookmark-ring - "Ring" :ring (make-ring 20)) "The MRU bookmark ring. This ring tracks the most recent active tags of interest.") @@ -254,8 +252,7 @@ been edited, and you can re-visit them with \\[semantic-mrub-switch-tags]." ;;;###autoload (define-minor-mode global-semantic-mru-bookmark-mode - "Toggle global use of option `semantic-mru-bookmark-mode'. -If ARG is positive or nil, enable, if it is negative, disable." + "Toggle global use of option `semantic-mru-bookmark-mode'." :global t :group 'semantic :group 'semantic-modes ;; Not needed because it's autoloaded instead. ;; :require 'semantic-util-modes @@ -280,10 +277,9 @@ been edited, and you can re-visit them with \\[semantic-mrub-switch-tags]. \\{semantic-mru-bookmark-mode-map} -With prefix argument ARG, turn on if positive, otherwise off. The -minor mode can be turned on only if semantic feature is available and -the current buffer was set up for parsing. Return non-nil if the -minor mode is enabled." +The minor mode can be turned on only if semantic feature is +available and the current buffer was set up for parsing. Return +non-nil if the minor mode is enabled." :keymap semantic-mru-bookmark-mode-map (if semantic-mru-bookmark-mode (if (not (and (featurep 'semantic) (semantic-active-p))) @@ -319,7 +315,7 @@ minor mode is enabled." (al nil)) (while (< idx len) (let ((r (ring-ref ring idx))) - (setq al (cons (cons (oref r :object-name) r) + (setq al (cons (cons (oref r object-name) r) al))) (setq idx (1+ idx))) (nreverse al))) diff --git a/lisp/cedet/semantic/sb.el b/lisp/cedet/semantic/sb.el index e4471be9aba..83d11e16583 100644 --- a/lisp/cedet/semantic/sb.el +++ b/lisp/cedet/semantic/sb.el @@ -279,7 +279,7 @@ Optional MODIFIERS is additional text needed for variables." (defun semantic-sb-show-extra (text token indent) "Display additional information about the token as an expansion. TEXT TOKEN and INDENT are the details." - (cond ((string-match "+" text) ;we have to expand this file + (cond ((string-match "\\+" text) ;we have to expand this file (speedbar-change-expand-button-char ?-) (speedbar-with-writable (save-excursion @@ -298,11 +298,7 @@ TEXT TOKEN and INDENT are the details." "Jump to the location specified in token. TEXT TOKEN and INDENT are the details." (let ((file - (or - (cond ((fboundp 'speedbar-line-path) - (speedbar-line-directory indent)) - ((fboundp 'speedbar-line-directory) - (speedbar-line-directory indent))) + (or (speedbar-line-directory indent) ;; If speedbar cannot figure this out, extract the filename from ;; the token. True for Analysis mode. (semantic-tag-file-name token))) @@ -329,7 +325,7 @@ TEXT TOKEN and INDENT are the details." (defun semantic-sb-expand-group (text token indent) "Expand a group which has semantic tokens. TEXT TOKEN and INDENT are the details." - (cond ((string-match "+" text) ;we have to expand this file + (cond ((string-match "\\+" text) ;we have to expand this file (speedbar-change-expand-button-char ?-) (speedbar-with-writable (save-excursion diff --git a/lisp/cedet/semantic/scope.el b/lisp/cedet/semantic/scope.el index ddb6185a4e9..3b38e8a61c3 100644 --- a/lisp/cedet/semantic/scope.el +++ b/lisp/cedet/semantic/scope.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -309,7 +309,7 @@ are from nesting data types." (list searchname))) (fullsearchname nil) - (miniscope (semantic-scope-cache "mini")) + (miniscope (semantic-scope-cache)) ptag) ;; Find the next entry in the referenced type for @@ -368,7 +368,7 @@ and PROTECTION is the level of protection offered by the relationship. Optional SCOPETYPES are additional scoped entities in which our parent might be found." (let ((lineage nil) - (miniscope (semantic-scope-cache "mini")) + (miniscope (semantic-scope-cache)) ) (oset miniscope parents parents) (oset miniscope scope scopetypes) @@ -644,7 +644,7 @@ whose tags can be searched when needed, OR it may be a scope object." ;; We need to make a mini scope, and only include the misc bits ;; that will help in finding the parent. We don't really need ;; to do any of the stuff related to variables and what-not. - (setq tmpscope (semantic-scope-cache "mini")) + (setq tmpscope (semantic-scope-cache)) (let* ( ;; Step 1: (scopetypes (cons type (semantic-analyze-scoped-types (point)))) (parents (semantic-analyze-scope-nested-tags (point) scopetypes)) diff --git a/lisp/cedet/semantic/senator.el b/lisp/cedet/semantic/senator.el index 2462662bbd8..f76d3328888 100644 --- a/lisp/cedet/semantic/senator.el +++ b/lisp/cedet/semantic/senator.el @@ -36,6 +36,7 @@ (require 'semantic/ctxt) (require 'semantic/decorate) (require 'semantic/format) +(require 'semantic/analyze) (eval-when-compile (require 'semantic/find)) @@ -43,7 +44,6 @@ (declare-function semantic-analyze-tag-references "semantic/analyze/refs") (declare-function semantic-analyze-refs-impl "semantic/analyze/refs") -(declare-function semantic-analyze-find-tag "semantic/analyze") (declare-function semantic-analyze-tag-type "semantic/analyze/fcn") (declare-function semantic-tag-external-class "semantic/sort") (declare-function imenu--mouse-menu "imenu") @@ -148,14 +148,14 @@ Return nil otherwise." "Return the tag before POS or one of its parent where to step." (let (ol tag) (while (and pos (> pos (point-min)) (not tag)) - (setq pos (semantic-overlay-previous-change pos)) + (setq pos (previous-overlay-change pos)) (when pos ;; Get overlays at position - (setq ol (semantic-overlays-at pos)) + (setq ol (overlays-at pos)) ;; find the overlay that belongs to semantic ;; and STARTS or ENDS at the found position. (while (and ol (not tag)) - (setq tag (semantic-overlay-get (car ol) 'semantic)) + (setq tag (overlay-get (car ol) 'semantic)) (unless (and tag (semantic-tag-p tag) (or (= (semantic-tag-start tag) pos) (= (semantic-tag-end tag) pos))) @@ -526,6 +526,8 @@ Some tags such as includes have other reference features." (if (not result) (error "No up reference found") (push-mark) + (when (fboundp 'xref-push-marker-stack) + (xref-push-marker-stack)) (cond ;; A tag ((semantic-tag-p result) @@ -594,7 +596,6 @@ Makes C/C++ language like assumptions." ;; Get the data type, and try to find that. ((semantic-tag-type tag) - (require 'semantic/analyze) (let ((scope (semantic-calculate-scope (point)))) (semantic-analyze-tag-type tag scope)) ) @@ -718,6 +719,22 @@ yanked to." (message "Use C-y to recover the yank the text of %s." (semantic-tag-name ft)))))) +(cl-defstruct (senator-register + (:constructor nil) + (:constructor senator-make-register (foreign-tag))) + foreign-tag) + +(cl-defmethod register-val-jump-to ((data senator-register) _arg) + (let ((ft (senator-register-foreign-tag data))) + (switch-to-buffer (semantic-tag-buffer ft)) + (goto-char (semantic-tag-start ft)))) + +(cl-defmethod register-val-describe ((data senator-register) _verbose) + (cl-prin1-to-string (senator-register-foreign-tag data))) + +(cl-defmethod register-val-insert ((data senator-register)) + (semantic-insert-foreign-tag (senator-register-foreign-tag data))) + ;;;###autoload (defun senator-copy-tag-to-register (register &optional kill-flag) "Copy the current tag into REGISTER. @@ -733,13 +750,7 @@ if available." (semantic-fetch-tags) (let ((ft (semantic-obtain-foreign-tag))) (when ft - (set-register - register (registerv-make - ft - :insert-func #'semantic-insert-foreign-tag - :jump-func (lambda (v) - (switch-to-buffer (semantic-tag-buffer v)) - (goto-char (semantic-tag-start v))))) + (set-register register (senator-make-register ft)) (if kill-flag (kill-region (semantic-tag-start ft) (semantic-tag-end ft)))))) diff --git a/lisp/cedet/semantic/symref.el b/lisp/cedet/semantic/symref.el index b005199da05..00403d4d52c 100644 --- a/lisp/cedet/semantic/symref.el +++ b/lisp/cedet/semantic/symref.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. diff --git a/lisp/cedet/semantic/symref/cscope.el b/lisp/cedet/semantic/symref/cscope.el index 53e62a4170b..39f86611316 100644 --- a/lisp/cedet/semantic/symref/cscope.el +++ b/lisp/cedet/semantic/symref/cscope.el @@ -2,7 +2,7 @@ ;;; Copyright (C) 2009-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -51,14 +51,11 @@ See the function `cedet-cscope-search' for more details.") default-directory)) ;; CScope has to be run from the project root where ;; cscope.out is. - (b (cedet-cscope-search (oref tool :searchfor) - (oref tool :searchtype) - (oref tool :resulttype) - (oref tool :searchscope) - )) - ) - (semantic-symref-parse-tool-output tool b) - )) + (b (cedet-cscope-search (oref tool searchfor) + (oref tool searchtype) + (oref tool resulttype) + (oref tool searchscope)))) + (semantic-symref-parse-tool-output tool b))) (defconst semantic-symref-cscope--line-re "^\\([^ ]+\\) [^ ]+ \\([0-9]+\\) ") @@ -66,22 +63,22 @@ See the function `cedet-cscope-search' for more details.") (cl-defmethod semantic-symref-parse-tool-output-one-line ((tool semantic-symref-tool-cscope)) "Parse one line of grep output, and return it as a match list. Moves cursor to end of the match." - (cond ((eq (oref tool :resulttype) 'file) + (cond ((eq (oref tool resulttype) 'file) ;; Search for files (when (re-search-forward "^\\([^\n]+\\)$" nil t) (match-string 1))) - ((eq (oref tool :searchtype) 'tagcompletions) + ((eq (oref tool searchtype) 'tagcompletions) ;; Search for files (when (re-search-forward "^[^ ]+ [^ ]+ [^ ]+ \\(.*\\)$" nil t) (let ((subtxt (match-string 1)) - (searchtxt (oref tool :searchfor))) + (searchtxt (oref tool searchfor))) (if (string-match (concat "\\<" searchtxt "\\(\\w\\|\\s_\\)*\\>") subtxt) (match-string 0 subtxt) ;; We have to return something at this point. subtxt))) ) - ((eq (oref tool :resulttype) 'line-and-text) + ((eq (oref tool resulttype) 'line-and-text) (when (re-search-forward semantic-symref-cscope--line-re nil t) (list (string-to-number (match-string 2)) (expand-file-name (match-string 1)) diff --git a/lisp/cedet/semantic/symref/filter.el b/lisp/cedet/semantic/symref/filter.el index 99a629319da..f23d751955c 100644 --- a/lisp/cedet/semantic/symref/filter.el +++ b/lisp/cedet/semantic/symref/filter.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2009-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -103,7 +103,7 @@ tag that contains point, and return that." (when (called-interactively-p 'interactive) (message "Found %d occurrences of %s in %.2f seconds" Lcount (semantic-tag-name target) - (semantic-elapsed-time start (current-time)))) + (semantic-elapsed-time start nil))) Lcount))) (defun semantic-symref-rename-local-variable () diff --git a/lisp/cedet/semantic/symref/global.el b/lisp/cedet/semantic/symref/global.el index 9bc24fbbd4e..d1ea921302f 100644 --- a/lisp/cedet/semantic/symref/global.el +++ b/lisp/cedet/semantic/symref/global.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -40,14 +40,11 @@ See the function `cedet-gnu-global-search' for more details.") (cl-defmethod semantic-symref-perform-search ((tool semantic-symref-tool-global)) "Perform a search with GNU Global." - (let ((b (cedet-gnu-global-search (oref tool :searchfor) - (oref tool :searchtype) - (oref tool :resulttype) - (oref tool :searchscope) - )) - ) - (semantic-symref-parse-tool-output tool b) - )) + (let ((b (cedet-gnu-global-search (oref tool searchfor) + (oref tool searchtype) + (oref tool resulttype) + (oref tool searchscope)))) + (semantic-symref-parse-tool-output tool b))) (defconst semantic-symref-global--line-re "^\\([^ ]+\\) +\\([0-9]+\\) \\([^ ]+\\) ") @@ -55,12 +52,12 @@ See the function `cedet-gnu-global-search' for more details.") (cl-defmethod semantic-symref-parse-tool-output-one-line ((tool semantic-symref-tool-global)) "Parse one line of grep output, and return it as a match list. Moves cursor to end of the match." - (cond ((or (eq (oref tool :resulttype) 'file) - (eq (oref tool :searchtype) 'tagcompletions)) + (cond ((or (eq (oref tool resulttype) 'file) + (eq (oref tool searchtype) 'tagcompletions)) ;; Search for files (when (re-search-forward "^\\([^\n]+\\)$" nil t) (match-string 1))) - ((eq (oref tool :resulttype) 'line-and-text) + ((eq (oref tool resulttype) 'line-and-text) (when (re-search-forward semantic-symref-global--line-re nil t) (list (string-to-number (match-string 2)) (match-string 3) diff --git a/lisp/cedet/semantic/symref/grep.el b/lisp/cedet/semantic/symref/grep.el index 3653aa9a1e9..d8dbfca05d5 100644 --- a/lisp/cedet/semantic/symref/grep.el +++ b/lisp/cedet/semantic/symref/grep.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -173,14 +173,16 @@ This shell should support pipe redirect syntax." ;; find . -type f -print0 | xargs -0 -e grep -nH -e ;; Note : I removed -e as it is not posix, nor necessary it seems. - (let ((cmd (concat "find " default-directory " -type f " filepattern " -print0 " + (let ((cmd (concat "find " (file-local-name rootdir) + " -type f " filepattern " -print0 " "| xargs -0 grep -H " grepflags "-e " greppat))) ;;(message "Old command: %s" cmd) - (call-process semantic-symref-grep-shell nil b nil + (process-file semantic-symref-grep-shell nil b nil shell-command-switch cmd) ) - (let ((cmd (semantic-symref-grep-use-template rootdir filepattern grepflags greppat))) - (call-process semantic-symref-grep-shell nil b nil + (let ((cmd (semantic-symref-grep-use-template + (file-local-name rootdir) filepattern grepflags greppat))) + (process-file semantic-symref-grep-shell nil b nil shell-command-switch cmd)) )) (setq ans (semantic-symref-parse-tool-output tool b)) diff --git a/lisp/cedet/semantic/symref/idutils.el b/lisp/cedet/semantic/symref/idutils.el index 58cf12af2e3..489bcec060d 100644 --- a/lisp/cedet/semantic/symref/idutils.el +++ b/lisp/cedet/semantic/symref/idutils.el @@ -2,7 +2,7 @@ ;;; Copyright (C) 2009-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -40,14 +40,11 @@ See the function `cedet-idutils-search' for more details.") (cl-defmethod semantic-symref-perform-search ((tool semantic-symref-tool-idutils)) "Perform a search with IDUtils." - (let ((b (cedet-idutils-search (oref tool :searchfor) - (oref tool :searchtype) - (oref tool :resulttype) - (oref tool :searchscope) - )) - ) - (semantic-symref-parse-tool-output tool b) - )) + (let ((b (cedet-idutils-search (oref tool searchfor) + (oref tool searchtype) + (oref tool resulttype) + (oref tool searchscope)))) + (semantic-symref-parse-tool-output tool b))) (defconst semantic-symref-idutils--line-re "^\\(\\(?:[a-zA-Z]:\\)?[^:\n]+\\):\\([0-9]+\\):") @@ -55,14 +52,14 @@ See the function `cedet-idutils-search' for more details.") (cl-defmethod semantic-symref-parse-tool-output-one-line ((tool semantic-symref-tool-idutils)) "Parse one line of grep output, and return it as a match list. Moves cursor to end of the match." - (cond ((eq (oref tool :resulttype) 'file) + (cond ((eq (oref tool resulttype) 'file) ;; Search for files (when (re-search-forward "^\\([^\n]+\\)$" nil t) (match-string 1))) - ((eq (oref tool :searchtype) 'tagcompletions) + ((eq (oref tool searchtype) 'tagcompletions) (when (re-search-forward "^\\([^ ]+\\) " nil t) (match-string 1))) - ((eq (oref tool :resulttype) 'line-and-text) + ((eq (oref tool resulttype) 'line-and-text) (when (re-search-forward semantic-symref-idutils--line-re nil t) (list (string-to-number (match-string 2)) (expand-file-name (match-string 1) default-directory) diff --git a/lisp/cedet/semantic/symref/list.el b/lisp/cedet/semantic/symref/list.el index 007e86c77d6..133356ec625 100644 --- a/lisp/cedet/semantic/symref/list.el +++ b/lisp/cedet/semantic/symref/list.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -114,7 +114,7 @@ Display the references in `semantic-symref-results-mode'." (define-key km "+" 'semantic-symref-list-toggle-showing) (define-key km "n" 'semantic-symref-list-next-line) (define-key km "p" 'semantic-symref-list-prev-line) - (define-key km "q" 'semantic-symref-hide-buffer) + (define-key km "q" 'quit-window) (define-key km "\C-c\C-e" 'semantic-symref-list-expand-all) (define-key km "\C-c\C-r" 'semantic-symref-list-contract-all) (define-key km "R" 'semantic-symref-list-rename-open-hits) @@ -126,31 +126,23 @@ Display the references in `semantic-symref-results-mode'." (defvar semantic-symref-list-menu-entries (list "Symref" - (semantic-menu-item - ["Toggle Line Open" - semantic-symref-list-toggle-showing - :active t - :help "Toggle the current line open or closed." - ]) - (semantic-menu-item - ["Expand All Entries" - semantic-symref-list-expand-all - :active t - :help "Expand every expandable entry." - ]) - (semantic-menu-item - ["Contract All Entries" - semantic-symref-list-contract-all - :active t - :help "Close every expandable entry." - ]) - (semantic-menu-item - ["Rename Symbol in Open hits" - semantic-symref-list-rename-open-hits - :active t - :help "Rename the searched for symbol in all hits that are currently open." - ]) - ) + ["Toggle Line Open" + semantic-symref-list-toggle-showing + :active t + :help "Toggle the current line open or closed." ] + ["Expand All Entries" + semantic-symref-list-expand-all + :active t + :help "Expand every expandable entry." ] + ["Contract All Entries" + semantic-symref-list-contract-all + :active t + :help "Close every expandable entry." ] + ["Rename Symbol in Open hits" + semantic-symref-list-rename-open-hits + :active t + :help "Rename the searched for symbol in all hits that are currently open." + ]) "Menu entries for the Semantic Symref list mode.") (defvar semantic-symref-list-menu nil @@ -193,11 +185,6 @@ Display the references in `semantic-symref-results-mode'." (set (make-local-variable 'font-lock-global-modes) nil) (font-lock-mode -1)) -(defun semantic-symref-hide-buffer () - "Hide buffer with semantic-symref results." - (interactive) - (bury-buffer)) - (defcustom semantic-symref-results-summary-function 'semantic-format-tag-prototype "Function to use when creating items in Imenu. Some useful functions are found in `semantic-format-tag-functions'." @@ -210,7 +197,7 @@ Some useful functions are found in `semantic-format-tag-functions'." (erase-buffer) ;; Insert the contents. (let ((lastfile nil)) - (dolist (T (oref results :hit-tags)) + (dolist (T (oref results hit-tags)) (unless (equal lastfile (semantic-tag-file-name T)) (setq lastfile (semantic-tag-file-name T)) (insert-button lastfile @@ -392,8 +379,8 @@ BUTTON is the button that was clicked." Hits are the line of code from the buffer, not the tag summar or file lines." (save-excursion (end-of-line) - (let* ((ol (car (semantic-overlays-at (1- (point)))))) ;; trust this for now - (when ol (semantic-overlay-get ol 'line))))) + (let* ((ol (car (overlays-at (1- (point)))))) ;; trust this for now + (when ol (overlay-get ol 'line))))) ;;; Keyboard Macros on a Hit @@ -407,13 +394,13 @@ cursor to the beginning of that symbol, then record a macro as if {kmacro-end-macro} to end the macro, and return to the symbol found list." (interactive) (let* ((oldsym (oref (oref semantic-symref-current-results - :created-by) - :searchfor)) + created-by) + searchfor)) (ol (save-excursion (end-of-line) - (car (semantic-overlays-at (1- (point)))))) - (tag (when ol (semantic-overlay-get ol 'tag))) - (line (when ol (semantic-overlay-get ol 'line)))) + (car (overlays-at (1- (point)))))) + (tag (when ol (overlay-get ol 'tag))) + (line (when ol (overlay-get ol 'line)))) (when (not line) (error "Cannot create macro on a non-hit line")) ;; Go there, and do something useful. @@ -453,8 +440,8 @@ Closed items will be skipped." (interactive (list (read-string "Rename to: " (oref (oref semantic-symref-current-results - :created-by) - :searchfor)))) + created-by) + searchfor)))) (let ((count (semantic-symref-list-map-open-hits (lambda () (replace-match newname nil t))))) (semantic-symref-list-update-open-hits) @@ -474,16 +461,16 @@ Return the number of occurrences FUNCTION was operated upon." ;; class members. (Not Done) (let ((oldsym (oref (oref semantic-symref-current-results - :created-by) - :searchfor)) + created-by) + searchfor)) (count 0)) (save-excursion (goto-char (point-min)) (while (not (eobp)) ;; Is this line a "hit" line? - (let* ((ol (car (semantic-overlays-at (1- (point))))) ;; trust this for now - (tag (when ol (semantic-overlay-get ol 'tag))) - (line (when ol (semantic-overlay-get ol 'line)))) + (let* ((ol (car (overlays-at (1- (point))))) ;; trust this for now + (tag (when ol (overlay-get ol 'tag))) + (line (when ol (overlay-get ol 'line)))) (when line ;; The "line" means we have an open hit. (with-current-buffer (semantic-tag-buffer tag) @@ -506,8 +493,8 @@ Return the number of occurrences FUNCTION was operated upon." (goto-char (point-min)) (while (re-search-forward "\\[-\\]" nil t) (end-of-line) - (let* ((ol (car (semantic-overlays-at (1- (point))))) ;; trust this for now - (tag (when ol (semantic-overlay-get ol 'tag)))) + (let* ((ol (car (overlays-at (1- (point))))) ;; trust this for now + (tag (when ol (overlay-get ol 'tag)))) ;; If there is a tag, then close/open it. (when tag (semantic-symref-list-toggle-showing) diff --git a/lisp/cedet/semantic/tag-write.el b/lisp/cedet/semantic/tag-write.el index bb79775411d..679a15b6033 100644 --- a/lisp/cedet/semantic/tag-write.el +++ b/lisp/cedet/semantic/tag-write.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. diff --git a/lisp/cedet/semantic/tag.el b/lisp/cedet/semantic/tag.el index 1011d1c3689..ec8a800ec41 100644 --- a/lisp/cedet/semantic/tag.el +++ b/lisp/cedet/semantic/tag.el @@ -148,15 +148,15 @@ That function is for internal use only." (defsubst semantic-tag-start (tag) "Return the start location of TAG." (let ((o (semantic-tag-overlay tag))) - (if (semantic-overlay-p o) - (semantic-overlay-start o) + (if (overlayp o) + (overlay-start o) (aref o 0)))) (defsubst semantic-tag-end (tag) "Return the end location of TAG." (let ((o (semantic-tag-overlay tag))) - (if (semantic-overlay-p o) - (semantic-overlay-end o) + (if (overlayp o) + (overlay-end o) (aref o 1)))) (defsubst semantic-tag-bounds (tag) @@ -167,8 +167,8 @@ That function is for internal use only." (defun semantic-tag-set-bounds (tag start end) "In TAG, set the START and END location of data it describes." (let ((o (semantic-tag-overlay tag))) - (if (semantic-overlay-p o) - (semantic-overlay-move o start end) + (if (overlayp o) + (move-overlay o start end) (semantic--tag-set-overlay tag (vector start end))))) (defun semantic-tag-in-buffer-p (tag) @@ -176,9 +176,9 @@ That function is for internal use only." If a tag is not in a buffer, return nil." (let ((o (semantic-tag-overlay tag))) ;; TAG is currently linked to a buffer, return it. - (when (and (semantic-overlay-p o) - (semantic-overlay-live-p o)) - (semantic-overlay-buffer o)))) + (when (and (overlayp o) + (overlay-buffer o)) + (overlay-buffer o)))) (defsubst semantic--tag-get-property (tag property) "From TAG, extract the value of PROPERTY. @@ -344,8 +344,8 @@ struct or union." "Return non-nil if TAG has positional information." (and (semantic-tag-p tag) (let ((o (semantic-tag-overlay tag))) - (or (and (semantic-overlay-p o) - (semantic-overlay-live-p o)) + (or (and (overlayp o) + (overlay-buffer o)) (arrayp o))))) (defun semantic-equivalent-tag-p (tag1 tag2) @@ -647,7 +647,7 @@ This runs the tag hook `unlink-copy-hook'." ;; Call the unlink-copy hook. This should tell tools that ;; this tag is not part of any buffer. - (when (semantic-overlay-p (semantic-tag-overlay tag)) + (when (overlayp (semantic-tag-overlay tag)) (semantic--tag-run-hooks copy 'unlink-copy-hook)) ) copy)) @@ -1114,11 +1114,11 @@ This function is for internal use only." This function is for internal use only." (when (semantic-tag-p tag) (let ((o (semantic-tag-overlay tag))) - (when (semantic-overlay-p o) + (when (overlayp o) (semantic--tag-set-overlay - tag (vector (semantic-overlay-start o) - (semantic-overlay-end o))) - (semantic-overlay-delete o)) + tag (vector (overlay-start o) + (overlay-end o))) + (delete-overlay o)) ;; Look for a link hook on TAG. (semantic--tag-run-hooks tag 'unlink-hook) ;; Fix the sub-tags which contain overlays. @@ -1136,10 +1136,9 @@ This function is for internal use only." (when (semantic-tag-p tag) (let ((o (semantic-tag-overlay tag))) (when (and (vectorp o) (= (length o) 2)) - (setq o (semantic-make-overlay (aref o 0) (aref o 1) - (current-buffer))) + (setq o (make-overlay (aref o 0) (aref o 1) (current-buffer))) (semantic--tag-set-overlay tag o) - (semantic-overlay-put o 'semantic tag) + (overlay-put o 'semantic tag) ;; Clear the :filename property (semantic--tag-put-property tag :filename nil)) ;; Look for a link hook on TAG. diff --git a/lisp/cedet/semantic/texi.el b/lisp/cedet/semantic/texi.el index f07ab2636e0..3a0050b920c 100644 --- a/lisp/cedet/semantic/texi.el +++ b/lisp/cedet/semantic/texi.el @@ -365,6 +365,8 @@ Optional argument POINT is where to look for the environment." (eval-when-compile (require 'semantic/analyze)) +(declare-function semantic-analyze-context "semantic/analyze") + (define-mode-local-override semantic-analyze-current-context texinfo-mode (point) "Analysis context makes no sense for texinfo. Return nil." @@ -376,7 +378,6 @@ Optional argument POINT is where to look for the environment." (when prefix (require 'semantic/analyze) (semantic-analyze-context - "Context-for-texinfo" :buffer (current-buffer) :scope nil :bounds bounds @@ -418,9 +419,9 @@ Since texinfo is not a programming language the default version is not useful. Instead, look at the current symbol. If it is a command do primitive texinfo built ins. If not, use ispell to lookup words that start with that symbol." - (let ((prefix (car (oref context :prefix))) + (let ((prefix (car (oref context prefix))) ) - (cond ((member 'function (oref context :prefixclass)) + (cond ((member 'function (oref context prefixclass)) ;; Do completion for texinfo commands (let* ((cmd (substring prefix 1)) (lst (all-completions @@ -428,7 +429,7 @@ that start with that symbol." (mapcar (lambda (f) (semantic-tag (concat "@" f) 'function)) lst)) ) - ((member 'word (oref context :prefixclass)) + ((member 'word (oref context prefixclass)) ;; Do completion for words via ispell. (require 'ispell) (let ((word-list (ispell-lookup-words prefix))) diff --git a/lisp/cedet/semantic/util-modes.el b/lisp/cedet/semantic/util-modes.el index 39885627fb9..954181c2cd9 100644 --- a/lisp/cedet/semantic/util-modes.el +++ b/lisp/cedet/semantic/util-modes.el @@ -170,8 +170,7 @@ too an interactive function used to toggle the mode." ;;;###autoload (define-minor-mode global-semantic-highlight-edits-mode - "Toggle global use of option `semantic-highlight-edits-mode'. -If ARG is positive or nil, enable, if it is negative, disable." + "Toggle global use of option `semantic-highlight-edits-mode'." :global t :group 'semantic :group 'semantic-modes (semantic-toggle-minor-mode-globally 'semantic-highlight-edits-mode @@ -195,7 +194,7 @@ If ARG is positive or nil, enable, if it is negative, disable." "Function set into `semantic-edits-new-change-hook'. Argument OVERLAY is the overlay created to mark the change. This function will set the face property on this overlay." - (semantic-overlay-put overlay 'face 'semantic-highlight-edits-face)) + (overlay-put overlay 'face 'semantic-highlight-edits-face)) (defvar semantic-highlight-edits-mode-map (let ((km (make-sparse-keymap))) @@ -209,10 +208,10 @@ Changes are tracked by semantic so that the incremental parser can work properly. This mode will highlight those changes as they are made, and clear them when the incremental parser accounts for those edits. -With prefix argument ARG, turn on if positive, otherwise off. The -minor mode can be turned on only if semantic feature is available and -the current buffer was set up for parsing. Return non-nil if the -minor mode is enabled." + +The minor mode can be turned on only if semantic feature is +available and the current buffer was set up for parsing. Return +non-nil if the minor mode is enabled." :keymap semantic-highlight-edits-mode-map (if semantic-highlight-edits-mode (if (not (and (featurep 'semantic) (semantic-active-p))) @@ -237,8 +236,7 @@ minor mode is enabled." ;;;###autoload (define-minor-mode global-semantic-show-unmatched-syntax-mode - "Toggle global use of option `semantic-show-unmatched-syntax-mode'. -If ARG is positive or nil, enable, if it is negative, disable." + "Toggle global use of option `semantic-show-unmatched-syntax-mode'." :global t :group 'semantic :group 'semantic-modes ;; Not needed because it's autoloaded instead. ;; :require 'semantic/util-modes @@ -262,11 +260,11 @@ The face is used in `semantic-show-unmatched-syntax-mode'." (defsubst semantic-unmatched-syntax-overlay-p (overlay) "Return non-nil if OVERLAY is an unmatched syntax one." - (eq (semantic-overlay-get overlay 'semantic) 'unmatched)) + (eq (overlay-get overlay 'semantic) 'unmatched)) (defun semantic-showing-unmatched-syntax-p () "Return non-nil if an unmatched syntax overlay was found in buffer." - (let ((ol (semantic-overlays-in (point-min) (point-max))) + (let ((ol (overlays-in (point-min) (point-max))) found) (while (and ol (not found)) (setq found (semantic-unmatched-syntax-overlay-p (car ol)) @@ -277,13 +275,13 @@ The face is used in `semantic-show-unmatched-syntax-mode'." "Fetch a list of unmatched lexical tokens from the current buffer. Uses the overlays which have accurate bounds, and rebuilds what was originally passed in." - (let ((ol (semantic-overlays-in (point-min) (point-max))) + (let ((ol (overlays-in (point-min) (point-max))) (ustc nil)) (while ol (if (semantic-unmatched-syntax-overlay-p (car ol)) (setq ustc (cons (cons 'thing - (cons (semantic-overlay-start (car ol)) - (semantic-overlay-end (car ol)))) + (cons (overlay-start (car ol)) + (overlay-end (car ol)))) ustc))) (setq ol (cdr ol))) (nreverse ustc)) @@ -291,10 +289,10 @@ originally passed in." (defun semantic-clean-unmatched-syntax-in-region (beg end) "Remove all unmatched syntax overlays between BEG and END." - (let ((ol (semantic-overlays-in beg end))) + (let ((ol (overlays-in beg end))) (while ol (if (semantic-unmatched-syntax-overlay-p (car ol)) - (semantic-overlay-delete (car ol))) + (delete-overlay (car ol))) (setq ol (cdr ol))))) (defsubst semantic-clean-unmatched-syntax-in-buffer () @@ -319,10 +317,10 @@ This will highlight elements in SYNTAX as unmatched syntax." (if syntax (let (o) (while syntax - (setq o (semantic-make-overlay (semantic-lex-token-start (car syntax)) - (semantic-lex-token-end (car syntax)))) - (semantic-overlay-put o 'semantic 'unmatched) - (semantic-overlay-put o 'face 'semantic-unmatched-syntax-face) + (setq o (make-overlay (semantic-lex-token-start (car syntax)) + (semantic-lex-token-end (car syntax)))) + (overlay-put o 'semantic 'unmatched) + (overlay-put o 'face 'semantic-unmatched-syntax-face) (setq syntax (cdr syntax)))) )) @@ -333,10 +331,10 @@ Do not search past BOUND if non-nil." (goto-char point) (let ((os point) (ol nil)) (while (and os (< os (or bound (point-max))) (not ol)) - (setq os (semantic-overlay-next-change os)) + (setq os (next-overlay-change os)) (when os ;; Get overlays at position - (setq ol (semantic-overlays-at os)) + (setq ol (overlays-at os)) ;; find the overlay that belongs to semantic ;; and starts at the found position. (while (and ol (listp ol)) @@ -360,10 +358,9 @@ parser rules. These text characters are considered unmatched syntax. Often time, the display of unmatched syntax can expose coding problems before the compiler is run. -With prefix argument ARG, turn on if positive, otherwise off. The -minor mode can be turned on only if semantic feature is available and -the current buffer was set up for parsing. Return non-nil if the -minor mode is enabled. +The minor mode can be turned on only if semantic feature is +available and the current buffer was set up for parsing. Return +non-nil if the minor mode is enabled. \\{semantic-show-unmatched-syntax-mode-map}" :keymap semantic-show-unmatched-syntax-mode-map @@ -401,7 +398,7 @@ minor mode is enabled. (interactive) (let ((o (semantic-next-unmatched-syntax (point)))) (if o - (goto-char (semantic-overlay-start o))))) + (goto-char (overlay-start o))))) ;;;; @@ -410,8 +407,7 @@ minor mode is enabled. ;;;###autoload (define-minor-mode global-semantic-show-parser-state-mode - "Toggle global use of option `semantic-show-parser-state-mode'. -If ARG is positive or nil, enable, if it is negative, disable." + "Toggle global use of option `semantic-show-parser-state-mode'." :global t :group 'semantic ;; Not needed because it's autoloaded instead. ;; :require 'semantic/util-modes @@ -440,10 +436,10 @@ The state is indicated in the modeline with the following characters: `~' -> The cache needs to be incrementally parsed. `%' -> The cache is not currently parsable. `@' -> Auto-parse in progress (not set here.) -With prefix argument ARG, turn on if positive, otherwise off. The -minor mode can be turned on only if semantic feature is available and -the current buffer was set up for parsing. Return non-nil if the -minor mode is enabled." + +The minor mode can be turned on only if semantic feature is +available and the current buffer was set up for parsing. Return +non-nil if the minor mode is enabled." :keymap semantic-show-parser-state-mode-map (if semantic-show-parser-state-mode (if (not (and (featurep 'semantic) (semantic-active-p))) @@ -557,8 +553,7 @@ to indicate a parse in progress." ;;;###autoload (define-minor-mode global-semantic-stickyfunc-mode - "Toggle global use of option `semantic-stickyfunc-mode'. -If ARG is positive or nil, enable, if it is negative, disable." + "Toggle global use of option `semantic-stickyfunc-mode'." :global t :group 'semantic :group 'semantic-modes ;; Not needed because it's autoloaded instead. ;; :require 'semantic/util-modes @@ -612,7 +607,7 @@ If ARG is positive or nil, enable, if it is negative, disable." ) (defcustom semantic-stickyfunc-indent-string - (if (and window-system (not (featurep 'xemacs))) + (if window-system (concat (condition-case nil ;; Test scroll bar location @@ -682,13 +677,10 @@ when it lands in the sticky line." "Value of the header line when entering stickyfunc mode.") (defconst semantic-stickyfunc-header-line-format - (cond ((featurep 'xemacs) - nil) - (t - '(:eval (list - ;; Magic bit I found on emacswiki. - (propertize " " 'display '((space :align-to 0))) - (semantic-stickyfunc-fetch-stickyline))))) + '(:eval (list + ;; Magic bit I found on emacswiki. + (propertize " " 'display '((space :align-to 0))) + (semantic-stickyfunc-fetch-stickyline))) "The header line format used by stickyfunc mode.") ;;;###autoload @@ -700,10 +692,9 @@ A function (or other tag class specified by first line which describes the rest of the construct. This first line is what is displayed in the header line. -With prefix argument ARG, turn on if positive, otherwise off. The -minor mode can be turned on only if semantic feature is available and -the current buffer was set up for parsing. Return non-nil if the -minor mode is enabled." +The minor mode can be turned on only if semantic feature is +available and the current buffer was set up for parsing. Return +non-nil if the minor mode is enabled." ;; Don't need indicator. It's quite visible :keymap semantic-stickyfunc-mode-map (if semantic-stickyfunc-mode @@ -837,8 +828,7 @@ Argument EVENT describes the event that caused this function to be called." ;;;###autoload (define-minor-mode global-semantic-highlight-func-mode - "Toggle global use of option `semantic-highlight-func-mode'. -If ARG is positive or nil, enable, if it is negative, disable." + "Toggle global use of option `semantic-highlight-func-mode'." :global t :group 'semantic :group 'semantic-modes ;; Not needed because it's autoloaded instead. ;; :require 'semantic/util-modes @@ -852,10 +842,8 @@ If ARG is positive or nil, enable, if it is negative, disable." :type 'hook) (defvar semantic-highlight-func-mode-map - (let ((km (make-sparse-keymap)) - (m3 (if (featurep 'xemacs) [ button3 ] [ mouse-3 ])) - ) - (define-key km m3 'semantic-highlight-func-menu) + (let ((km (make-sparse-keymap))) + (define-key km [mouse-3] 'semantic-highlight-func-menu) km) "Keymap for highlight-func minor mode.") @@ -904,7 +892,7 @@ Argument EVENT describes the event that caused this function to be called." ;(goto-char (window-start win)) (mouse-set-point event) (sit-for 0) - (semantic-popup-menu semantic-highlight-func-popup-menu) + (popup-menu semantic-highlight-func-popup-menu) ) (select-window startwin))) @@ -933,10 +921,9 @@ See `semantic-stickyfunc-mode' for putting a function in the header line. This mode recycles the stickyfunc configuration classes list. -With prefix argument ARG, turn on if positive, otherwise off. The -minor mode can be turned on only if semantic feature is available and -the current buffer was set up for parsing. Return non-nil if the -minor mode is enabled." +The minor mode can be turned on only if semantic feature is +available and the current buffer was set up for parsing. Return +non-nil if the minor mode is enabled." :lighter nil ;; Don't need indicator. It's quite visible. (if semantic-highlight-func-mode (progn @@ -959,19 +946,19 @@ If the current tag for this buffer is different from the last time this function was called, move the overlay." (when (and (not (minibufferp)) (or (not semantic-highlight-func-ct-overlay) - (eq (semantic-overlay-buffer + (eq (overlay-buffer semantic-highlight-func-ct-overlay) (current-buffer)))) (let* ((tag (semantic-stickyfunc-tag-to-stick)) (ol semantic-highlight-func-ct-overlay)) (when (not ol) ;; No overlay in this buffer. Make one. - (setq ol (semantic-make-overlay (point-min) (point-min) - (current-buffer) t nil)) - (semantic-overlay-put ol 'highlight-func t) - (semantic-overlay-put ol 'face 'semantic-highlight-func-current-tag-face) - (semantic-overlay-put ol 'keymap semantic-highlight-func-mode-map) - (semantic-overlay-put ol 'help-echo + (setq ol (make-overlay (point-min) (point-min) + (current-buffer) t nil)) + (overlay-put ol 'highlight-func t) + (overlay-put ol 'face 'semantic-highlight-func-current-tag-face) + (overlay-put ol 'keymap semantic-highlight-func-mode-map) + (overlay-put ol 'help-echo "Current Function : mouse-3 - Context menu") (setq semantic-highlight-func-ct-overlay ol) ) @@ -980,20 +967,16 @@ function was called, move the overlay." (if (or (not tag) disable) ;; No tag, make the overlay go away. (progn - (semantic-overlay-put ol 'tag nil) - (semantic-overlay-move ol (point-min) (point-min) (current-buffer)) - ) + (overlay-put ol 'tag nil) + (move-overlay ol (point-min) (point-min) (current-buffer))) ;; We have a tag, if it is the same, do nothing. - (unless (eq (semantic-overlay-get ol 'tag) tag) + (unless (eq (overlay-get ol 'tag) tag) (save-excursion (goto-char (semantic-tag-start tag)) (search-forward (semantic-tag-name tag) nil t) - (semantic-overlay-put ol 'tag tag) - (semantic-overlay-move ol (point-at-bol) (point-at-eol)) - ) - ) - ))) + (overlay-put ol 'tag tag) + (move-overlay ol (point-at-bol) (point-at-eol))))))) nil) (semantic-add-minor-mode 'semantic-highlight-func-mode diff --git a/lisp/cedet/semantic/util.el b/lisp/cedet/semantic/util.el index 6b13c41cfe2..6cae8a8bdf9 100644 --- a/lisp/cedet/semantic/util.el +++ b/lisp/cedet/semantic/util.el @@ -54,6 +54,8 @@ Equivalent modes share a parser, and a set of override methods. A value of nil means that the current major mode is the only one.") (make-variable-buffer-local 'semantic-equivalent-major-modes) +(declare-function semanticdb-file-stream "semantic/db" (file)) + ;; These semanticdb calls will throw warnings in the byte compiler. ;; Doing the right thing to make them available at compile time ;; really messes up the compilation sequence. @@ -80,6 +82,11 @@ If FILE is not loaded, and semanticdb is not available, find the file (semantic-alias-obsolete 'semantic-file-token-stream 'semantic-file-tag-table "23.2") +(declare-function semanticdb-abstract-table-child-p "semantic/db" (obj) t) +(declare-function semanticdb-refresh-table "semantic/db") +(declare-function semanticdb-get-tags "semantic/db" (arg &rest args) t) +(declare-function semanticdb-find-results-p "semantic/db-find" (resultp)) + (defun semantic-something-to-tag-table (something) "Convert SOMETHING into a semantic tag table. Something can be a tag with a valid BUFFER property, a tag table, a @@ -112,7 +119,7 @@ buffer, or a filename. If SOMETHING is nil return nil." ((and (featurep 'semantic/db) (require 'semantic/db-mode) (semanticdb-minor-mode-p) - (semanticdb-abstract-table-child-p something)) + (cl-typep something 'semanticdb-abstract-table)) (semanticdb-refresh-table something) (semanticdb-get-tags something)) ;; Semanticdb find-results @@ -140,6 +147,11 @@ buffer, or a filename. If SOMETHING is nil return nil." (defvar semantic-read-symbol-history nil "History for a symbol read.") +(declare-function semantic-brute-find-tag-by-function + "semantic/find" + (function streamorbuffer + &optional search-parts search-includes)) + (defun semantic-read-symbol (prompt &optional default stream filter) "Read a symbol name from the user for the current buffer. PROMPT is the prompt to use. @@ -154,6 +166,7 @@ FILTER must be a function to call on each element." (setq stream (if filter (semantic--find-tags-by-function filter stream) + (require 'semantic/find) (semantic-brute-find-tag-standard stream))) (if (and default (string-match ":" prompt)) (setq prompt @@ -315,8 +328,8 @@ If TAG is not specified, use the tag at point." (if (semantic-tag-p tok) (if (semantic-tag-with-position-p tok) (let ((o (semantic-tag-overlay tok))) - (if (and (semantic-overlay-p o) - (not (semantic-overlay-live-p o))) + (if (and (overlayp o) + (not (overlay-buffer o))) (let ((debug-on-error t)) (error "Tag %s is invalid!" (semantic-tag-name tok))) ;; else, tag is OK. @@ -335,7 +348,7 @@ NOTFIRST indicates that this was not the first call in the recursive use." (interactive) (if (and (not cache) (not over) (not notfirst)) (setq cache semantic--buffer-cache - over (semantic-overlays-in (point-min) (point-max)))) + over (overlays-in (point-min) (point-max)))) (while cache (let ((chil (semantic-tag-components-with-overlays (car cache)))) (if (not (memq (semantic-tag-overlay (car cache)) over)) @@ -348,8 +361,8 @@ NOTFIRST indicates that this was not the first call in the recursive use." ;; Strip out all overlays which aren't semantic overlays (let ((o nil)) (while over - (when (and (semantic-overlay-get (car over) 'semantic) - (not (eq (semantic-overlay-get (car over) 'semantic) + (when (and (overlay-get (car over) 'semantic) + (not (eq (overlay-get (car over) 'semantic) 'unmatched))) (setq o (cons (car over) o))) (setq over (cdr over))) @@ -367,6 +380,11 @@ NOTFIRST indicates that this was not the first call in the recursive use." ;; Symbol completion +(declare-function semanticdb-fast-strip-find-results + "semantic/db-find" (results)) +(declare-function semanticdb-deep-find-tags-for-completion + "semantic/db-find" (prefix &optional path find-file-match)) + (defun semantic-find-tag-for-completion (prefix) "Find all tags with name starting with PREFIX. This uses `semanticdb' when available." diff --git a/lisp/cedet/semantic/wisent.el b/lisp/cedet/semantic/wisent.el index 6bb771054df..122b5d399c0 100644 --- a/lisp/cedet/semantic/wisent.el +++ b/lisp/cedet/semantic/wisent.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2001-2007, 2009-2019 Free Software Foundation, Inc. ;; Author: David Ponce <david@dponce.com> -;; Maintainer: David Ponce <david@dponce.com> ;; Created: 30 Aug 2001 ;; Keywords: syntax diff --git a/lisp/cedet/semantic/wisent/comp.el b/lisp/cedet/semantic/wisent/comp.el index 4f6f5b02ba4..a73cdfa2f8f 100644 --- a/lisp/cedet/semantic/wisent/comp.el +++ b/lisp/cedet/semantic/wisent/comp.el @@ -4,7 +4,6 @@ ;; Software Foundation, Inc. ;; Author: David Ponce <david@dponce.com> -;; Maintainer: David Ponce <david@dponce.com> ;; Created: 30 January 2002 ;; Keywords: syntax @@ -41,7 +40,7 @@ ;;; Code: (require 'semantic/wisent) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;;;; ------------------- ;;;; Misc. useful things @@ -139,14 +138,7 @@ If optional LEFT is non-nil insert spaces on left." ;;;; Environment dependencies ;;;; ------------------------ -(defconst wisent-BITS-PER-WORD - (let ((i 1) - (do-shift (if (boundp 'most-positive-fixnum) - (lambda (i) (lsh most-positive-fixnum (- i))) - (lambda (i) (lsh 1 i))))) - (while (not (zerop (funcall do-shift i))) - (setq i (1+ i))) - i)) +(defconst wisent-BITS-PER-WORD (logcount most-positive-fixnum)) (defsubst wisent-WORDSIZE (n) "(N + BITS-PER-WORD - 1) / BITS-PER-WORD." @@ -156,24 +148,18 @@ If optional LEFT is non-nil insert spaces on left." "X[I/BITS-PER-WORD] |= 1 << (I % BITS-PER-WORD)." (let ((k (/ i wisent-BITS-PER-WORD))) (aset x k (logior (aref x k) - (lsh 1 (% i wisent-BITS-PER-WORD)))))) + (ash 1 (% i wisent-BITS-PER-WORD)))))) (defsubst wisent-RESETBIT (x i) "X[I/BITS-PER-WORD] &= ~(1 << (I % BITS-PER-WORD))." (let ((k (/ i wisent-BITS-PER-WORD))) (aset x k (logand (aref x k) - (lognot (lsh 1 (% i wisent-BITS-PER-WORD))))))) + (lognot (ash 1 (% i wisent-BITS-PER-WORD))))))) (defsubst wisent-BITISSET (x i) "(X[I/BITS-PER-WORD] & (1 << (I % BITS-PER-WORD))) != 0." (not (zerop (logand (aref x (/ i wisent-BITS-PER-WORD)) - (lsh 1 (% i wisent-BITS-PER-WORD)))))) - -(defsubst wisent-noninteractive () - "Return non-nil if running without interactive terminal." - (if (featurep 'xemacs) - (noninteractive) - noninteractive)) + (ash 1 (% i wisent-BITS-PER-WORD)))))) (defvar wisent-debug-flag nil "Non-nil means enable some debug stuff.") @@ -203,11 +189,11 @@ If optional LEFT is non-nil insert spaces on left." (defmacro wisent-log-buffer () "Return the log buffer. Its name is defined in constant `wisent-log-buffer-name'." - `(get-buffer-create wisent-log-buffer-name)) + '(get-buffer-create wisent-log-buffer-name)) (defmacro wisent-clear-log () "Delete the entire contents of the log buffer." - `(with-current-buffer (wisent-log-buffer) + '(with-current-buffer (wisent-log-buffer) (erase-buffer))) (defvar byte-compile-current-file) @@ -2271,26 +2257,34 @@ warning is given if there are either more or fewer conflicts, or if there are any reduce/reduce conflicts." :group 'wisent :type '(choice (const nil) integer)) +(make-obsolete-variable 'wisent-expected-conflicts + "use %expectedconflicts in the .wy file instead" + "27.1") (defun wisent-total-conflicts () "Report the total number of conflicts." - (unless (and (zerop rrc-total) - (or (zerop src-total) - (= src-total (or wisent-expected-conflicts 0)))) - (let* ((src (wisent-source)) - (src (if src (concat " in " src) "")) - (msg (format "Grammar%s contains" src))) - (if (> src-total 0) + (let* ((src (wisent-source)) + (symbol (intern (format "wisent-%s--expected-conflicts" + (replace-regexp-in-string "\\.el$" "" src)) + obarray))) + (when (or (not (zerop rrc-total)) + (and (not (zerop src-total)) + (not (= src-total (or wisent-expected-conflicts 0))) + (or (not (boundp symbol)) + (not (equal (symbol-value symbol) src-total))))) + (let* ((src (if src (concat " in " src) "")) + (msg (format "Grammar%s contains" src))) + (when (and (> src-total 0)) (setq msg (format "%s %d shift/reduce conflict%s" msg src-total (if (> src-total 1) "s" "")))) - (if (and (> src-total 0) (> rrc-total 0)) - (setq msg (format "%s and" msg))) - (if (> rrc-total 0) - (setq msg (format "%s %d reduce/reduce conflict%s" - msg rrc-total (if (> rrc-total 1) - "s" "")))) - (message msg)))) + (if (and (> src-total 0) (> rrc-total 0)) + (setq msg (format "%s and" msg))) + (if (> rrc-total 0) + (setq msg (format "%s %d reduce/reduce conflict%s" + msg rrc-total (if (> rrc-total 1) + "s" "")))) + (message msg))))) (defun wisent-print-conflicts () "Report conflicts." @@ -2662,7 +2656,7 @@ Report detailed information if `wisent-verbose-flag' or (wisent-print-grammar) (wisent-print-states)) ;; Append output to log file when running in batch mode - (when (wisent-noninteractive) + (when noninteractive (wisent-append-to-log-file) (wisent-clear-log))) @@ -2906,7 +2900,7 @@ references found in BODY, and XBODY is BODY expression with (progn (if (wisent-check-$N body n) ;; Accumulate $i symbol - (pushnew body found :test #'equal)) + (cl-pushnew body found :test #'equal)) (cons found body)) ;; BODY is a list, expand inside it (let (xbody sexpr) @@ -2926,7 +2920,7 @@ references found in BODY, and XBODY is BODY expression with ;; $i symbol ((wisent-check-$N sexpr n) ;; Accumulate $i symbol - (pushnew sexpr found :test #'equal)) + (cl-pushnew sexpr found :test #'equal)) ) ;; Accumulate expanded forms (setq xbody (nconc xbody (list sexpr)))) diff --git a/lisp/cedet/semantic/wisent/grammar.el b/lisp/cedet/semantic/wisent/grammar.el index d51e3f33113..d23e293552a 100644 --- a/lisp/cedet/semantic/wisent/grammar.el +++ b/lisp/cedet/semantic/wisent/grammar.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2002-2019 Free Software Foundation, Inc. ;; ;; Author: David Ponce <david@dponce.com> -;; Maintainer: David Ponce <david@dponce.com> ;; Created: 26 Aug 2002 ;; Keywords: syntax ;; This file is part of GNU Emacs. @@ -194,7 +193,7 @@ See also the function `wisent-skip-block'." "Expand call to SKIP-TOKEN grammar macro. Return the form to skip the lookahead token. See also the function `wisent-skip-token'." - `(wisent-skip-token)) + '(wisent-skip-token)) (defun wisent-grammar-assocs () "Return associativity and precedence level definitions." diff --git a/lisp/cedet/semantic/wisent/java-tags.el b/lisp/cedet/semantic/wisent/java-tags.el index 4bf7a8e2af4..87c3090bdbe 100644 --- a/lisp/cedet/semantic/wisent/java-tags.el +++ b/lisp/cedet/semantic/wisent/java-tags.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2001-2006, 2009-2019 Free Software Foundation, Inc. ;; Author: David Ponce <david@dponce.com> -;; Maintainer: David Ponce <david@dponce.com> ;; Created: 15 Dec 2001 ;; Keywords: syntax diff --git a/lisp/cedet/semantic/wisent/javascript.el b/lisp/cedet/semantic/wisent/javascript.el index 05040b3a95e..7722c953609 100644 --- a/lisp/cedet/semantic/wisent/javascript.el +++ b/lisp/cedet/semantic/wisent/javascript.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2005, 2009-2019 Free Software Foundation, Inc. -;; Author: Eric Ludlam <zappo@gnu.org> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Keywords: syntax ;; This file is part of GNU Emacs. diff --git a/lisp/cedet/semantic/wisent/python.el b/lisp/cedet/semantic/wisent/python.el index 1edbc05a3a9..f0e294efa62 100644 --- a/lisp/cedet/semantic/wisent/python.el +++ b/lisp/cedet/semantic/wisent/python.el @@ -2,8 +2,7 @@ ;; Copyright (C) 2002, 2004, 2006-2019 Free Software Foundation, Inc. -;; Author: Richard Kim <emacs18@gmail.com> -;; Maintainer: Richard Kim <emacs18@gmail.com> +;; Author: Richard Kim <emacs18@gmail.com> ;; Created: June 2002 ;; Keywords: syntax @@ -41,9 +40,6 @@ (require 'semantic/ctxt) (require 'semantic/format) -(eval-when-compile - (require 'cl)) - ;;; Customization ;; @@ -358,7 +354,7 @@ Set attributes for constructors, special, private and static methods." ;; + first argument is self (when (and (> (length (semantic-tag-function-arguments tag)) 0) (string= (semantic-tag-name - (first (semantic-tag-function-arguments tag))) + (car (semantic-tag-function-arguments tag))) "self")) (semantic-tag-put-attribute tag :parent "dummy")) diff --git a/lisp/cedet/semantic/wisent/wisent.el b/lisp/cedet/semantic/wisent/wisent.el index 21082429a24..401b404fee5 100644 --- a/lisp/cedet/semantic/wisent/wisent.el +++ b/lisp/cedet/semantic/wisent/wisent.el @@ -3,7 +3,6 @@ ;;; Copyright (C) 2002-2007, 2009-2019 Free Software Foundation, Inc. ;; Author: David Ponce <david@dponce.com> -;; Maintainer: David Ponce <david@dponce.com> ;; Created: 30 January 2002 ;; Keywords: syntax diff --git a/lisp/cedet/srecode/args.el b/lisp/cedet/srecode/args.el index e8a1a2c2153..086f369b7f2 100644 --- a/lisp/cedet/srecode/args.el +++ b/lisp/cedet/srecode/args.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -174,8 +174,8 @@ do not contain any text from preceding or following text." (srecode-dictionary-set-value dict "PROJECT_FILENAME" relfname) (srecode-dictionary-set-value dict "PROJECT_DIRECTORY" reldir) (srecode-dictionary-set-value dict "PROJECT_NAME" (ede-name (ede-toplevel))) - (srecode-dictionary-set-value dict "PROJECT_VERSION" (oref (ede-toplevel) :version)) - ) + (srecode-dictionary-set-value dict "PROJECT_VERSION" + (oref (ede-toplevel) version))) ;; If there is no EDE project, then put in some base values. (srecode-dictionary-set-value dict "PROJECT_FILENAME" bfn) (srecode-dictionary-set-value dict "PROJECT_DIRECTORY" dir) diff --git a/lisp/cedet/srecode/compile.el b/lisp/cedet/srecode/compile.el index d2e2807b248..80b267b8c23 100644 --- a/lisp/cedet/srecode/compile.el +++ b/lisp/cedet/srecode/compile.el @@ -31,7 +31,6 @@ ;; The output are a series of EIEIO objects which represent the ;; templates in a way that could be inserted later. -(eval-when-compile (require 'cl)) (require 'semantic) (require 'eieio) (require 'cl-generic) @@ -132,18 +131,6 @@ STATE is the current compilation state." "For the template inserter INS, apply information from STATE." nil) -(cl-defmethod srecode-inserter-prin-example ((ins (subclass srecode-template-inserter)) - escape-start escape-end) - "Insert an example using inserter INS. -Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." - (princ " ") - (princ escape-start) - (when (and (slot-exists-p ins 'key) (oref ins key)) - (princ (format "%c" (oref ins key)))) - (princ "VARNAME") - (princ escape-end) - (terpri) - ) ;;; Compile State @@ -547,8 +534,8 @@ A list of defined variables VARS provides a variable table." (while lp - (let* ((objname (oref (car lp) :object-name)) - (context (oref (car lp) :context)) + (let* ((objname (oref (car lp) object-name)) + (context (oref (car lp) context)) (globalname (concat context ":" objname)) ) @@ -583,7 +570,7 @@ A list of defined variables VARS provides a variable table." (tmpl (oref table templates))) ;; Loop over all the templates, and xref. (while tmpl - (oset (car tmpl) :table table) + (oset (car tmpl) table table) (setq tmpl (cdr tmpl)))) )) @@ -629,7 +616,7 @@ Argument INDENT specifies the indentation level for the list." (princ ") ") (cond ((stringp (car code)) (prin1 (car code))) - ((srecode-template-inserter-child-p (car code)) + ((cl-typep (car code) 'srecode-template-inserter) (srecode-dump (car code) indent)) (t (princ "Unknown Code: ") @@ -644,9 +631,9 @@ Argument INDENT specifies the indentation level for the list." "Dump the state of the SRecode template inserter INS." (princ "INS: \"") (princ (eieio-object-name-string ins)) - (when (oref ins :secondname) + (when (oref ins secondname) (princ "\" : \"") - (princ (oref ins :secondname))) + (princ (oref ins secondname))) (princ "\" type \"") (let* ((oc (symbol-name (eieio-object-class ins))) (junk (string-match "srecode-template-inserter-" oc)) diff --git a/lisp/cedet/srecode/cpp.el b/lisp/cedet/srecode/cpp.el index e6a55992336..306c60f1b61 100644 --- a/lisp/cedet/srecode/cpp.el +++ b/lisp/cedet/srecode/cpp.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007, 2009-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Jan Moringen <scymtym@users.sourceforge.net> ;; This file is part of GNU Emacs. @@ -122,7 +122,7 @@ specified in a C file." (srecode-semantic-apply-tag-to-dict-default tag-wrapper dict) ;; Pull out the tag for the individual pieces. - (let* ((tag (oref tag-wrapper :prime)) + (let* ((tag (oref tag-wrapper prime)) (class (semantic-tag-class tag))) ;; Add additional information based on the class of the tag. diff --git a/lisp/cedet/srecode/ctxt.el b/lisp/cedet/srecode/ctxt.el index 66f67790a9f..b20b9bc6417 100644 --- a/lisp/cedet/srecode/ctxt.el +++ b/lisp/cedet/srecode/ctxt.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -32,9 +32,7 @@ (require 'semantic) (require 'semantic/tag-ls) - -(declare-function srecode-dictionary-show-section "srecode/dictionary") -(declare-function srecode-dictionary-set-value "srecode/dictionary") +(require 'srecode/dictionary) ;;; Code: @@ -175,7 +173,6 @@ This might add the following: PURE - show a section if a function is pure virtual. PARENT - The name of a parent type for functions. PROTECTION - Show a protection section, and what the protection is." - (require 'srecode/dictionary) (when template (let ((name (oref template object-name)) diff --git a/lisp/cedet/srecode/dictionary.el b/lisp/cedet/srecode/dictionary.el index 6e7887f0530..1058024d457 100644 --- a/lisp/cedet/srecode/dictionary.el +++ b/lisp/cedet/srecode/dictionary.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -28,11 +28,11 @@ ;;; CLASSES -(eval-when-compile (require 'cl)) (require 'eieio) (require 'cl-generic) (require 'srecode) (require 'srecode/table) +(require 'srecode/fields) (eval-when-compile (require 'semantic)) (declare-function srecode-compile-parse-inserter "srecode/compile") @@ -42,7 +42,6 @@ (declare-function srecode-insert-code-stream "srecode/insert") (declare-function data-debug-new-buffer "data-debug") (declare-function data-debug-insert-object-slots "eieio-datadebug") -(declare-function srecode-field "srecode/fields") (defclass srecode-dictionary () ((namehash :initarg :namehash @@ -123,7 +122,7 @@ Makes sure that :value is compiled." (cl-call-next-method this (nreverse newfields)) (when (not (slot-boundp this 'compiled)) - (let ((val (oref this :value)) + (let ((val (oref this value)) (comp nil)) (while val (let ((nval (car val)) @@ -142,7 +141,7 @@ Makes sure that :value is compiled." (error "Don't know how to handle variable value %S" nval))) ) (setq val (cdr val))) - (oset this :compiled (nreverse comp)))))) + (oset this compiled (nreverse comp)))))) ;;; DICTIONARY METHODS ;; @@ -173,7 +172,7 @@ associated with a buffer or parent." initfrombuff t)) ;; Parent is another dictionary - ((srecode-dictionary-child-p buffer-or-parent) + ((cl-typep buffer-or-parent 'srecode-dictionary) (setq parent buffer-or-parent buffer (oref buffer-or-parent buffer) origin (concat (eieio-object-name buffer-or-parent) " in " @@ -224,7 +223,7 @@ TPL is an object representing a compiled template file." ;; Tables are sorted with highest priority first, useful for looking ;; up templates, but this means we need to install the variables in ;; reverse order so higher priority variables override lower ones. - (let ((tabs (reverse (oref tpl :tables)))) + (let ((tabs (reverse (oref tpl tables)))) (require 'srecode/find) ; For srecode-template-table-in-project-p (while tabs (when (srecode-template-table-in-project-p (car tabs)) @@ -357,7 +356,7 @@ values but STATE is nil." (srecode-dictionary-set-value dict name value)) ;; Value is a dictionary; insert as child dictionary. - ((srecode-dictionary-child-p value) + ((cl-typep value 'srecode-dictionary) (srecode-dictionary-merge (srecode-dictionary-add-section-dictionary dict name) value t)) @@ -506,7 +505,6 @@ inserted with a new editable field.") function dictionary) "Convert this field into an insertable string." - (require 'srecode/fields) ;; If we are not in a buffer, then this is not supported. (when (not (bufferp standard-output)) (error "FIELDS invoked while inserting template to non-buffer")) @@ -519,13 +517,13 @@ inserted with a new editable field.") (let* ((dv (oref cp defaultvalue)) (sti (oref cp firstinserter)) (start (point)) - (name (oref sti :object-name))) + (name (oref sti object-name))) (cond ;; No default value. ((not dv) (insert name)) ;; A compound value as the default? Recurse. - ((srecode-dictionary-compound-value-child-p dv) + ((cl-typep dv 'srecode-dictionary-compound-value) (srecode-compound-toString dv function dictionary)) ;; A string that is empty? Use the name. ((and (stringp dv) (string= dv "")) @@ -612,10 +610,9 @@ STATE is the current compiler state." (srecode-get-mode-table modesym)) (error "No table found for mode %S" modesym))) (dict (srecode-create-dictionary (current-buffer))) - (end (current-time)) ) (message "Creating a dictionary took %.2f seconds." - (semantic-elapsed-time start end)) + (semantic-elapsed-time start nil)) (data-debug-new-buffer "*SRECODE ADEBUG*") (data-debug-insert-object-slots dict "*"))) @@ -662,7 +659,7 @@ STATE is the current compiler state." )) (princ "\n") ) - ((srecode-dictionary-compound-value-child-p entry) + ((cl-typep entry 'srecode-dictionary-compound-value) (srecode-dump entry indent) (princ "\n") ) diff --git a/lisp/cedet/srecode/document.el b/lisp/cedet/srecode/document.el index 06fc262f879..ad15b3ef6fd 100644 --- a/lisp/cedet/srecode/document.el +++ b/lisp/cedet/srecode/document.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. diff --git a/lisp/cedet/srecode/el.el b/lisp/cedet/srecode/el.el index 348c8126c8e..33b75cad692 100644 --- a/lisp/cedet/srecode/el.el +++ b/lisp/cedet/srecode/el.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -86,7 +86,7 @@ Calls `srecode-semantic-apply-tag-to-dict-default' first." (srecode-semantic-apply-tag-to-dict-default tagobj dict) ;; Pull out the tag for the individual pieces. - (let* ((tag (oref tagobj :prime)) + (let* ((tag (oref tagobj prime)) (doc (semantic-tag-docstring tag))) ;; It is much more common to have doc on ELisp. diff --git a/lisp/cedet/srecode/expandproto.el b/lisp/cedet/srecode/expandproto.el index 7b5de0df6dd..10e304aa153 100644 --- a/lisp/cedet/srecode/expandproto.el +++ b/lisp/cedet/srecode/expandproto.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007, 2009-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. diff --git a/lisp/cedet/srecode/extract.el b/lisp/cedet/srecode/extract.el index 0086eeb6bd1..c46ff7e38f7 100644 --- a/lisp/cedet/srecode/extract.el +++ b/lisp/cedet/srecode/extract.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -88,7 +88,7 @@ the dictionary entries were for that block of text." (save-restriction (narrow-to-region start end) (let ((dict (srecode-create-dictionary t)) - (state (srecode-extract-state "state")) + (state (srecode-extract-state)) ) (goto-char start) (srecode-extract-method template dict state) @@ -161,10 +161,9 @@ Return nil as this inserter will extract nothing." Return t if something was extracted. Return nil if this inserter doesn't need to extract anything." (srecode-dictionary-set-value vdict - (oref ins :object-name) + (oref ins object-name) (buffer-substring-no-properties - start end) - ) + start end)) t) ;;; Section Inserter @@ -178,10 +177,9 @@ Return nil if this inserter doesn't need to extract anything." "Extract text from START/END and store in INDICT. Return the starting location of the first plain-text match. Return nil if nothing was extracted." - (let ((name (oref ins :object-name)) + (let ((name (oref ins object-name)) (subdict (srecode-create-dictionary indict)) - (allsubdict nil) - ) + (allsubdict nil)) ;; Keep extracting till we can extract no more. (while (condition-case nil @@ -217,10 +215,10 @@ Return nil if nothing was extracted." ;; There are two modes for includes. One is with no dict, ;; so it is inserted straight. If the dict has a name, then ;; we need to run once per dictionary occurrence. - (if (not (string= (oref ins :object-name) "")) + (if (not (string= (oref ins object-name) "")) ;; With a name, do the insertion. (let ((subdict (srecode-dictionary-add-section-dictionary - dict (oref ins :object-name)))) + dict (oref ins object-name)))) (error "Need to implement include w/ name extractor") ;; Recurse into the new template while no errors. (while (condition-case nil diff --git a/lisp/cedet/srecode/fields.el b/lisp/cedet/srecode/fields.el index 95caeb3118c..f4999827f7f 100644 --- a/lisp/cedet/srecode/fields.el +++ b/lisp/cedet/srecode/fields.el @@ -2,7 +2,7 @@ ;; ;; Copyright (C) 2009-2019 Free Software Foundation, Inc. ;; -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. diff --git a/lisp/cedet/srecode/filters.el b/lisp/cedet/srecode/filters.el index b9b037fb500..2ff7594c4b0 100644 --- a/lisp/cedet/srecode/filters.el +++ b/lisp/cedet/srecode/filters.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. diff --git a/lisp/cedet/srecode/find.el b/lisp/cedet/srecode/find.el index 68592265e10..23680937ea8 100644 --- a/lisp/cedet/srecode/find.el +++ b/lisp/cedet/srecode/find.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -27,8 +27,7 @@ (require 'srecode/ctxt) (require 'srecode/table) (require 'srecode/map) - -(declare-function srecode-compile-file "srecode/compile") +(require 'srecode/compile) ;;; Code: @@ -58,7 +57,6 @@ Templates are found in the SRecode Template Map. See `srecode-get-maps' for more. APPNAME is the name of an application. In this case, all template files for that application will be loaded." - (require 'srecode/compile) (let ((files (if appname (apply 'append @@ -100,7 +98,7 @@ all template files for that application will be loaded." "Return non-nil if the table TAB can be used in the current project. If TAB has a :project set, check that the directories match. If TAB is nil, then always return t." - (let ((proj (oref tab :project))) + (let ((proj (oref tab project))) ;; Return t if the project wasn't set. (if (not proj) t ;; If the project directory was set, let's check it. @@ -139,10 +137,10 @@ Optional argument APPLICATION restricts searches to only template tables belonging to a specific application. If APPLICATION is nil, then only tables that do not belong to an application will be searched." (let* ((mt tab) - (tabs (oref mt :tables)) + (tabs (oref mt tables)) (ans nil)) (while (and (not ans) tabs) - (let ((app (oref (car tabs) :application))) + (let ((app (oref (car tabs) application))) (when (or (and (not application) (null app)) (and application (eq app application))) (setq ans (srecode-template-get-table (car tabs) template-name @@ -150,7 +148,7 @@ tables that do not belong to an application will be searched." (setq tabs (cdr tabs)))) (or ans ;; Recurse to the default. - (when (not (equal (oref tab :major-mode) 'default)) + (when (not (equal (oref tab major-mode) 'default)) (srecode-template-get-table (srecode-get-mode-table 'default) template-name context application))))) @@ -199,10 +197,10 @@ Optional argument APPLICATION restricts searches to only template tables belonging to a specific application. If APPLICATION is nil, then only tables that do not belong to an application will be searched." (let* ((mt tab) - (tabs (oref mt :tables)) + (tabs (oref mt tables)) (ans nil)) (while (and (not ans) tabs) - (let ((app (oref (car tabs) :application))) + (let ((app (oref (car tabs) application))) (when (or (and (not application) (null app)) (and application (eq app application))) (setq ans (srecode-template-get-table-for-binding @@ -210,7 +208,7 @@ tables that do not belong to an application will be searched." (setq tabs (cdr tabs)))) (or ans ;; Recurse to the default. - (when (not (equal (oref tab :major-mode) 'default)) + (when (not (equal (oref tab major-mode) 'default)) (srecode-template-get-table-for-binding (srecode-get-mode-table 'default) binding context))))) ;;; Interactive @@ -241,10 +239,10 @@ templates." ;; Load up the hash table for our current mode. (let* ((mt (srecode-get-mode-table mmode)) - (tabs (when mt (oref mt :tables)))) + (tabs (when mt (oref mt tables)))) (dolist (tab tabs) ;; Exclude templates for a particular application. - (when (and (not (oref tab :application)) + (when (and (not (oref tab application)) (srecode-template-table-in-project-p tab)) (maphash (lambda (key temp) (when (or (not predicate) diff --git a/lisp/cedet/srecode/getset.el b/lisp/cedet/srecode/getset.el index cef4b9435b2..e5740964a49 100644 --- a/lisp/cedet/srecode/getset.el +++ b/lisp/cedet/srecode/getset.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. diff --git a/lisp/cedet/srecode/insert.el b/lisp/cedet/srecode/insert.el index 26af2ffe2ef..966cd485e82 100644 --- a/lisp/cedet/srecode/insert.el +++ b/lisp/cedet/srecode/insert.el @@ -1,4 +1,4 @@ -;;; srecode/insert.el --- Insert srecode templates to an output stream. +;;; srecode/insert.el --- Insert srecode templates to an output stream -*- lexical-binding:t -*- ;; Copyright (C) 2005, 2007-2019 Free Software Foundation, Inc. @@ -26,9 +26,6 @@ ;; Manage the insertion process for a template. ;; -(eval-when-compile - (require 'cl)) ;; for `lexical-let' - (require 'srecode/compile) (require 'srecode/find) (require 'srecode/dictionary) @@ -186,8 +183,7 @@ Buffer based features related to change hooks is handled one level up." ) (let ((reg ;; Create the field-driven editable area. - (srecode-template-inserted-region - "TEMPLATE" :start start :end (point)))) + (srecode-template-inserted-region :start start :end (point)))) (srecode-overlaid-activate reg)) ) ;; We return with 'point being the end of the template insertion @@ -467,19 +463,18 @@ If SECONDNAME is nil, return VALUE." (srecode-insert-report-error dictionary "Variable inserter %s: second argument `%s' is not a function" - (object-print sti) secondname))) + (cl-prin1-to-string sti) secondname))) value)) (cl-defmethod srecode-insert-method ((sti srecode-template-inserter-variable) dictionary) "Insert the STI inserter." ;; Convert the name into a name/fcn pair - (let* ((name (oref sti :object-name)) - (fcnpart (oref sti :secondname)) + (let* ((name (oref sti object-name)) + (fcnpart (oref sti secondname)) (val (srecode-dictionary-lookup-name dictionary name)) - (do-princ t) - ) + (do-princ t)) ;; Alert if a macro wasn't found. (when (not val) (message "Warning: macro %S was not found in the dictionary." name) @@ -548,12 +543,12 @@ Loop over the prompts to see if we have a match." ) (while prompts (when (string= (semantic-tag-name (car prompts)) - (oref ins :object-name)) - (oset ins :prompt + (oref ins object-name)) + (oset ins prompt (semantic-tag-get-attribute (car prompts) :text)) - (oset ins :defaultfcn + (oset ins defaultfcn (semantic-tag-get-attribute (car prompts) :default)) - (oset ins :read-fcn + (oset ins read-fcn (or (semantic-tag-get-attribute (car prompts) :read) 'read-string)) ) @@ -564,7 +559,7 @@ Loop over the prompts to see if we have a match." dictionary) "Insert the STI inserter." (let ((val (srecode-dictionary-lookup-name - dictionary (oref sti :object-name)))) + dictionary (oref sti object-name)))) (if val ;; Does some extra work. Oh well. (cl-call-next-method) @@ -580,7 +575,7 @@ Loop over the prompts to see if we have a match." ;; the user can use the same name again later. (srecode-dictionary-set-value (srecode-root-dictionary dictionary) - (oref sti :object-name) val) + (oref sti object-name) val) ;; Now that this value is safely stowed in the dictionary, ;; we can do what regular inserters do. @@ -590,7 +585,7 @@ Loop over the prompts to see if we have a match." dictionary) "Derive the default value for an askable inserter STI. DICTIONARY is used to derive some values." - (let ((defaultfcn (oref sti :defaultfcn))) + (let ((defaultfcn (oref sti defaultfcn))) (cond ((stringp defaultfcn) defaultfcn) @@ -617,13 +612,13 @@ DICTIONARY is used to derive some values." Use DICTIONARY to resolve values." (let* ((prompt (oref sti prompt)) (default (srecode-insert-ask-default sti dictionary)) - (reader (oref sti :read-fcn)) + (reader (oref sti read-fcn)) (val nil) ) (cond ((eq reader 'y-or-n-p) (if (y-or-n-p (or prompt (format "%s? " - (oref sti :object-name)))) + (oref sti object-name)))) (setq val default) (setq val ""))) ((eq reader 'read-char) @@ -631,14 +626,14 @@ Use DICTIONARY to resolve values." "%c" (read-char (or prompt (format "Char for %s: " - (oref sti :object-name)))))) + (oref sti object-name)))))) ) (t (save-excursion (setq val (funcall reader (or prompt (format "Specify %s: " - (oref sti :object-name))) + (oref sti object-name))) default ))))) ;; Return our derived value. @@ -651,7 +646,7 @@ Use DICTIONARY to resolve values." Use DICTIONARY to resolve values." (let* ((default (srecode-insert-ask-default sti dictionary)) (compound-value - (srecode-field-value (oref sti :object-name) + (srecode-field-value (oref sti object-name) :firstinserter sti :defaultvalue default)) ) @@ -819,12 +814,12 @@ Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." Loops over the embedded CODE which was saved here during compilation. The template to insert is stored in SLOT." (let ((dicts (srecode-dictionary-lookup-name - dictionary (oref sti :object-name)))) + dictionary (oref sti object-name)))) (when (not (listp dicts)) (srecode-insert-report-error dictionary "Cannot insert section %S from non-section variable." - (oref sti :object-name))) + (oref sti object-name))) ;; If there is no section dictionary, then don't output anything ;; from this section. (while dicts @@ -832,7 +827,7 @@ The template to insert is stored in SLOT." (srecode-insert-report-error dictionary "Cannot insert section %S from non-section variable." - (oref sti :object-name))) + (oref sti object-name))) (srecode-insert-subtemplate sti (car dicts) slot) (setq dicts (cdr dicts))))) @@ -863,7 +858,7 @@ applied to the text between the section start and the Shorten input until the END token is found. Return the remains of INPUT." (let* ((out (srecode-compile-split-code tag input STATE - (oref ins :object-name)))) + (oref ins object-name)))) (oset ins template (srecode-template (eieio-object-name-string ins) :context nil @@ -896,7 +891,7 @@ are treated specially.") (cl-defmethod srecode-match-end ((ins srecode-template-inserter-section-end) name) "For the template inserter INS, do I end a section called NAME?" - (string= name (oref ins :object-name))) + (string= name (oref ins object-name))) (defclass srecode-template-inserter-include (srecode-template-inserter-subtemplate) ((key :initform ?> @@ -927,13 +922,13 @@ Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." "For the template inserter STI, lookup the template to include. Finds the template with this macro function part and stores it in this template instance." - (let ((templatenamepart (oref sti :secondname))) + (let ((templatenamepart (oref sti secondname))) ;; If there was no template name, throw an error. (unless templatenamepart (srecode-insert-report-error dictionary "Include macro `%s' needs a template name" - (oref sti :object-name))) + (oref sti object-name))) ;; NOTE: We used to cache the template and not look it up a second time, ;; but changes in the template tables can change which template is @@ -971,14 +966,14 @@ this template instance." ) ;; Store the found template into this object for later use. - (oset sti :includedtemplate tmpl)) + (oset sti includedtemplate tmpl)) (unless (oref sti includedtemplate) ;; @todo - Call into a debugger to help find the template in question. (srecode-insert-report-error dictionary "No template \"%s\" found for include macro `%s'" - templatenamepart (oref sti :object-name))))) + templatenamepart (oref sti object-name))))) (cl-defmethod srecode-insert-method ((sti srecode-template-inserter-include) dictionary) @@ -988,7 +983,7 @@ with the dictionaries found in the dictionary." (srecode-insert-include-lookup sti dictionary) ;; Insert the template. ;; Our baseclass has a simple way to do this. - (if (srecode-dictionary-lookup-name dictionary (oref sti :object-name)) + (if (srecode-dictionary-lookup-name dictionary (oref sti object-name)) ;; If we have a value, then call the next method (srecode-insert-method-helper sti dictionary 'includedtemplate) ;; If we don't have a special dictionary, then just insert with the @@ -1049,25 +1044,37 @@ template where a ^ inserter occurs." ;; which implements the wrap insertion behavior in FUNCTION. The ;; maximum valid nesting depth is just the current depth + 1. (let ((srecode-template-inserter-point-override - (lexical-let ((inserter1 sti)) - (cons - ;; DEPTH - (+ (length (oref-default 'srecode-template active)) 1) - ;; FUNCTION - (lambda (dict) - (let ((srecode-template-inserter-point-override nil)) - (if (srecode-dictionary-lookup-name - dict (oref inserter1 :object-name)) - ;; Insert our sectional part with looping. - (srecode-insert-method-helper - inserter1 dict 'template) - ;; Insert our sectional part just once. - (srecode-insert-subtemplate - inserter1 dict 'template)))))))) + (cons + ;; DEPTH + (+ (length (oref-default 'srecode-template active)) 1) + ;; FUNCTION + (lambda (dict) + (let ((srecode-template-inserter-point-override nil)) + (if (srecode-dictionary-lookup-name + dict (oref sti object-name)) + ;; Insert our sectional part with looping. + (srecode-insert-method-helper + sti dict 'template) + ;; Insert our sectional part just once. + (srecode-insert-subtemplate + sti dict 'template))))))) ;; Do a regular insertion for an include, but with our override in ;; place. (cl-call-next-method))) +(cl-defmethod srecode-inserter-prin-example ((ins (subclass srecode-template-inserter)) + escape-start escape-end) + "Insert an example using inserter INS. +Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." + (princ " ") + (princ escape-start) + (when (and (slot-exists-p ins 'key) (oref ins key)) + (princ (format "%c" (oref ins key)))) + (princ "VARNAME") + (princ escape-end) + (terpri) + ) + (provide 'srecode/insert) ;; Local variables: diff --git a/lisp/cedet/srecode/java.el b/lisp/cedet/srecode/java.el index 85df930fede..43c207e9880 100644 --- a/lisp/cedet/srecode/java.el +++ b/lisp/cedet/srecode/java.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2009-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. diff --git a/lisp/cedet/srecode/map.el b/lisp/cedet/srecode/map.el index 01ed630a66c..08ff0e6305e 100644 --- a/lisp/cedet/srecode/map.el +++ b/lisp/cedet/srecode/map.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -224,10 +224,9 @@ Optional argument RESET forces a reset of the current map." (require 'data-debug) (let ((start (current-time)) (p (srecode-get-maps t)) ;; Time the reset. - (end (current-time)) ) (message "Updating the map took %.2f seconds." - (semantic-elapsed-time start end)) + (semantic-elapsed-time start nil)) (data-debug-new-buffer "*SRECODE ADEBUG*") (data-debug-insert-stuff-list p "*"))) @@ -271,7 +270,7 @@ if that file is NEW, otherwise assume the mode has not changed." (if (not srecode-map-save-file) ;; 0) Create a MAP when in no save file mode. (when (not srecode-current-map) - (setq srecode-current-map (srecode-map "SRecode Map")) + (setq srecode-current-map (srecode-map)) (message "SRecode map created in non-save mode.") ) @@ -291,8 +290,7 @@ if that file is NEW, otherwise assume the mode has not changed." (error "Change your SRecode map file")))) ;; Have a dir. Make the object. (setq srecode-current-map - (srecode-map "SRecode Map" - :file srecode-map-save-file))) + (srecode-map :file srecode-map-save-file))) ;; 2) Do we not have a current map? If so load. (when (not srecode-current-map) @@ -302,8 +300,7 @@ if that file is NEW, otherwise assume the mode has not changed." (error ;; There was an error loading the old map. Create a new one. (setq srecode-current-map - (srecode-map "SRecode Map" - :file srecode-map-save-file)))) + (srecode-map :file srecode-map-save-file)))) ) ) diff --git a/lisp/cedet/srecode/mode.el b/lisp/cedet/srecode/mode.el index c78f98bfc04..3a8fd91eb2d 100644 --- a/lisp/cedet/srecode/mode.el +++ b/lisp/cedet/srecode/mode.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -69,62 +69,44 @@ (defvar srecode-menu-bar (list "SRecoder" - (semantic-menu-item - ["Insert Template" - srecode-insert - :active t - :help "Insert a template by name." - ]) - (semantic-menu-item - ["Insert Template Again" - srecode-insert-again - :active t - :help "Run the same template as last time again." - ]) - (semantic-menu-item - ["Edit Template" - srecode-edit - :active t - :help "Edit a template for this language by name." - ]) + ["Insert Template" + srecode-insert + :active t + :help "Insert a template by name."] + ["Insert Template Again" + srecode-insert-again + :active t + :help "Run the same template as last time again."] + ["Edit Template" + srecode-edit + :active t + :help "Edit a template for this language by name."] "---" '( "Insert ..." :filter srecode-minor-mode-templates-menu ) - `( "Generate ..." :filter srecode-minor-mode-generate-menu ) + '( "Generate ..." :filter srecode-minor-mode-generate-menu ) "---" - (semantic-menu-item - ["Customize..." - (customize-group "srecode") - :active t - :help "Customize SRecode options" - ]) + ["Customize..." + (customize-group "srecode") + :active t + :help "Customize SRecode options"] (list "Debugging Tools..." - (semantic-menu-item - ["Dump Template MAP" - srecode-get-maps - :active t - :help "Calculate (if needed) and display the current template file map." - ]) - (semantic-menu-item - ["Dump Tables" - srecode-dump-templates - :active t - :help "Dump the current template table." - ]) - (semantic-menu-item - ["Dump Dictionary" - srecode-dictionary-dump - :active t - :help "Calculate and dump a dictionary for point." - ]) - (semantic-menu-item - ["Show Macro Help" - srecode-macro-help - :active t - :help "Display the different types of macros available." - ]) - ) - ) + ["Dump Template MAP" + srecode-get-maps + :active t + :help "Calculate (if needed) and display the current template file map."] + ["Dump Tables" + srecode-dump-templates + :active t + :help "Dump the current template table."] + ["Dump Dictionary" + srecode-dictionary-dump + :active t + :help "Calculate and dump a dictionary for point."] + ["Show Macro Help" + srecode-macro-help + :active t + :help "Display the different types of macros available."])) "Menu for srecode minor mode.") (defvar srecode-minor-menu nil @@ -148,10 +130,10 @@ ;;;###autoload (define-minor-mode srecode-minor-mode "Toggle srecode minor mode. -With prefix argument ARG, turn on if positive, otherwise off. The -minor mode can be turned on only if semantic feature is available and -the current buffer was set up for parsing. Return non-nil if the -minor mode is enabled. + +The minor mode can be turned on only if semantic feature is +available and the current buffer was set up for parsing. Return +non-nil if the minor mode is enabled. \\{srecode-mode-map}" :keymap srecode-mode-map @@ -176,8 +158,7 @@ minor mode is enabled. ;;;###autoload (define-minor-mode global-srecode-minor-mode - "Toggle global use of srecode minor mode. -If ARG is positive or nil, enable, if it is negative, disable." + "Toggle global use of srecode minor mode." :global t :group 'srecode ;; Not needed because it's autoloaded instead. ;; :require 'srecode/mode @@ -196,7 +177,7 @@ MENU-DEF is the menu to bind this into." ;;(srecode-load-tables-for-mode major-mode) (let* ((modetable (srecode-get-mode-table major-mode)) - (subtab (when modetable (oref modetable :tables))) + (subtab (when modetable (oref modetable tables))) (context nil) (active nil) (ltab nil) @@ -319,17 +300,17 @@ Template is chosen based on the mode of the starting buffer." (if (not temp) (error "No Template named %s" template-name)) ;; We need a template specific table, since tables chain. - (let ((tab (oref temp :table)) + (let ((tab (oref temp table)) (names nil) ) - (find-file (oref tab :file)) - (setq names (semantic-find-tags-by-name (oref temp :object-name) + (find-file (oref tab file)) + (setq names (semantic-find-tags-by-name (oref temp object-name) (current-buffer))) (cond ((= (length names) 1) (semantic-go-to-tag (car names)) (semantic-momentary-highlight-tag (car names))) ((> (length names) 1) - (let* ((ctxt (semantic-find-tags-by-name (oref temp :context) + (let* ((ctxt (semantic-find-tags-by-name (oref temp context) (current-buffer))) (cls (semantic-find-tags-by-class 'context ctxt)) ) diff --git a/lisp/cedet/srecode/semantic.el b/lisp/cedet/srecode/semantic.el index 93dcaff943c..1e1a60e0245 100644 --- a/lisp/cedet/srecode/semantic.el +++ b/lisp/cedet/srecode/semantic.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -63,10 +63,9 @@ If FUNCTION is non-nil, then FUNCTION is somehow applied to an aspect of the compound value." (if (not function) ;; Just format it in some handy dandy way. - (semantic-format-tag-prototype (oref cp :prime)) + (semantic-format-tag-prototype (oref cp prime)) ;; Otherwise, apply the function to the tag itself. - (funcall function (oref cp :prime)) - )) + (funcall function (oref cp prime)))) ;;; Managing the `current' tag @@ -106,7 +105,7 @@ variable default values, and other things." (srecode-dictionary-set-value dict "TAG" tagobj) ;; Pull out the tag for the individual pieces. - (let ((tag (oref tagobj :prime))) + (let ((tag (oref tagobj prime))) (srecode-dictionary-set-value dict "NAME" (semantic-tag-name tag)) (srecode-dictionary-set-value dict "TYPE" (semantic-format-tag-type tag nil)) diff --git a/lisp/cedet/srecode/srt-mode.el b/lisp/cedet/srecode/srt-mode.el index df97d6e55e5..5e7c7c111a3 100644 --- a/lisp/cedet/srecode/srt-mode.el +++ b/lisp/cedet/srecode/srt-mode.el @@ -33,6 +33,7 @@ (declare-function srecode-create-dictionary "srecode/dictionary") (declare-function srecode-resolve-argument-list "srecode/insert") +(declare-function srecode-inserter-prin-example "srecode/insert") ;;; Code: (defvar srecode-template-mode-syntax-table @@ -64,7 +65,7 @@ (defvar srecode-font-lock-keywords '( ;; Template - ("^\\(template\\)\\s-+\\(\\w*\\)\\(\\( \\(:\\w+\\)\\|\\)+\\)$" + ("^\\(template\\)\\s-+\\(\\w*\\)\\(\\( \\(:\\w+\\)\\)*\\)$" (1 font-lock-keyword-face) (2 font-lock-function-name-face) (3 font-lock-builtin-face )) @@ -228,10 +229,12 @@ we can tell font lock about them.") (insert ee)))) ) +(eieio-declare-slots key) (defun srecode-macro-help () "Provide help for working with macros in a template." (interactive) + (require 'srecode/insert) (let* ((root 'srecode-template-inserter) (chl (eieio-class-children root)) (ess (srecode-template-get-escape-start)) @@ -246,8 +249,7 @@ we can tell font lock about them.") (name (symbol-name C)) (key (when (slot-exists-p C 'key) (oref C key))) - (showexample t) - ) + (showexample t)) (setq chl (cdr chl)) (setq chl (append (eieio-class-children C) chl)) @@ -494,7 +496,7 @@ section or ? for an ask variable." (let* ((macroend (match-beginning 0)) (raw (buffer-substring-no-properties macrostart macroend)) - (STATE (srecode-compile-state "TMP")) + (STATE (srecode-compile-state)) (inserter (condition-case nil (srecode-compile-parse-inserter raw STATE) @@ -502,13 +504,14 @@ section or ? for an ask variable." ) (when inserter (let ((base - (cons (oref inserter :object-name) + (cons (oref inserter object-name) (if (and (slot-boundp inserter :secondname) - (oref inserter :secondname)) - (split-string (oref inserter :secondname) + (oref inserter secondname)) + (split-string (oref inserter secondname) ":") nil))) - (key (oref inserter key))) + (key (when (slot-exists-p inserter 'key) + (oref inserter key)))) (cond ((null key) ;; A plain variable (cons nil base)) @@ -605,7 +608,6 @@ section or ? for an ask variable." (setq context-return (semantic-analyze-context-functionarg - "context-for-srecode" :buffer (current-buffer) :scope scope :bounds bounds @@ -628,7 +630,7 @@ section or ? for an ask variable." srecode-template-mode (context) "Return a list of possible completions based on NONTEXT." (with-current-buffer (oref context buffer) - (let* ((prefix (car (last (oref context :prefix)))) + (let* ((prefix (car (last (oref context prefix)))) (prefixstr (cond ((stringp prefix) prefix) ((semantic-tag-p prefix) @@ -639,7 +641,7 @@ section or ? for an ask variable." ; prefix) ; ((stringp (car prefix)) ; (car prefix)))) - (argtype (car (oref context :argument))) + (argtype (car (oref context argument))) (matches nil)) ;; Depending on what the analyzer is, we have different ways diff --git a/lisp/cedet/srecode/srt.el b/lisp/cedet/srecode/srt.el index 0a6c732efda..dc6300ea79c 100644 --- a/lisp/cedet/srecode/srt.el +++ b/lisp/cedet/srecode/srt.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -25,7 +25,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'eieio) (require 'srecode/dictionary) (require 'srecode/insert) diff --git a/lisp/cedet/srecode/table.el b/lisp/cedet/srecode/table.el index 67e363499f4..7a0600c3f81 100644 --- a/lisp/cedet/srecode/table.el +++ b/lisp/cedet/srecode/table.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -187,8 +187,8 @@ INIT are the initialization parameters for the new template table." (new (apply 'srecode-template-table (file-name-nondirectory file) :file file - :filesize (nth 7 attr) - :filedate (nth 5 attr) + :filesize (file-attribute-size attr) + :filedate (file-attribute-modification-time attr) :major-mode mode init ))) @@ -201,8 +201,8 @@ INIT are the initialization parameters for the new template table." ;; into the search table first, allowing lower priority items ;; to be the items found in the search table. (object-sort-list mt 'modetables (lambda (a b) - (> (oref a :priority) - (oref b :priority)))) + (> (oref a priority) + (oref b priority)))) ;; Return it. new)) @@ -239,9 +239,9 @@ Use PREDICATE is the same as for the `sort' function." (cl-defmethod srecode-dump ((tab srecode-mode-table)) "Dump the contents of the SRecode mode table TAB." (princ "MODE TABLE FOR ") - (princ (oref tab :major-mode)) + (princ (oref tab major-mode)) (princ "\n--------------------------------------------\n\nNumber of tables: ") - (let ((subtab (oref tab :tables))) + (let ((subtab (oref tab tables))) (princ (length subtab)) (princ "\n\n") (while subtab @@ -254,17 +254,17 @@ Use PREDICATE is the same as for the `sort' function." (princ "Template Table for ") (princ (eieio-object-name-string tab)) (princ "\nPriority: ") - (prin1 (oref tab :priority)) - (when (oref tab :application) + (prin1 (oref tab priority)) + (when (oref tab application) (princ "\nApplication: ") - (princ (oref tab :application))) - (when (oref tab :framework) + (princ (oref tab application))) + (when (oref tab framework) (princ "\nFramework: ") - (princ (oref tab :framework))) - (when (oref tab :project) + (princ (oref tab framework))) + (when (oref tab project) (require 'srecode/find) ; For srecode-template-table-in-project-p (princ "\nProject Directory: ") - (princ (oref tab :project)) + (princ (oref tab project)) (when (not (srecode-template-table-in-project-p tab)) (princ "\n ** Not Usable in this file. **"))) (princ "\n\nVariables:\n") diff --git a/lisp/cedet/srecode/texi.el b/lisp/cedet/srecode/texi.el index 223cf28e12c..bb2b7c91316 100644 --- a/lisp/cedet/srecode/texi.el +++ b/lisp/cedet/srecode/texi.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -156,7 +156,7 @@ Adds the following: (error "No tag to insert for :texitag template argument")) ;; Extract the tag out of the compound object. - (setq tag (oref tag :prime)) + (setq tag (oref tag prime)) ;; Extract the doc string (setq doc (semantic-documentation-for-tag tag)) diff --git a/lisp/char-fold.el b/lisp/char-fold.el index c1f8c458f7e..d8d2ebc72ba 100644 --- a/lisp/char-fold.el +++ b/lisp/char-fold.el @@ -22,13 +22,32 @@ ;;; Code: -(eval-and-compile (put 'char-fold-table 'char-table-extra-slots 1)) +(eval-and-compile + (put 'char-fold-table 'char-table-extra-slots 1) + (defconst char-fold--default-include + '((?\" """ "“" "”" "”" "„" "⹂" "〞" "‟" "‟" "❞" "❝" "❠" "“" "„" "〝" "〟" "🙷" "🙶" "🙸" "«" "»") + (?' "❟" "❛" "❜" "‘" "’" "‚" "‛" "‚" "" "❮" "❯" "‹" "›") + (?` "❛" "‘" "‛" "" "❮" "‹") + (?ß "ss") ;; de + (?ι "ΐ") ;; el for (?ΐ "ΐ") decomposition + (?υ "ΰ") ;; el for (?ΰ "ΰ") decomposition + )) + (defconst char-fold--default-exclude + '( + (?и "й") ;; ru + )) + (defconst char-fold--default-symmetric nil) + (defvar char-fold--previous + (list char-fold--default-include + char-fold--default-exclude + char-fold--default-symmetric))) + -(defconst char-fold-table - (eval-when-compile - (let ((equiv (make-char-table 'char-fold-table)) - (equiv-multi (make-char-table 'char-fold-table)) - (table (unicode-property-table-internal 'decomposition))) +(eval-and-compile + (defun char-fold--make-table () + (let* ((equiv (make-char-table 'char-fold-table)) + (equiv-multi (make-char-table 'char-fold-table)) + (table (unicode-property-table-internal 'decomposition))) (set-char-table-extra-slot equiv 0 equiv-multi) ;; Ensure the table is populated. @@ -78,6 +97,25 @@ (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) + (when (symbolp (car next-decomp)) + (setq next-decomp (cdr next-decomp))) + (if (not (eq (car dec) + (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) @@ -97,23 +135,76 @@ (aref equiv (car simpler-decomp))))))))))) table) - ;; Add some manual entries. - (dolist (it '((?\" """ "“" "”" "”" "„" "⹂" "〞" "‟" "‟" "❞" "❝" "❠" "“" "„" "〝" "〟" "🙷" "🙶" "🙸" "«" "»") - (?' "❟" "❛" "❜" "‘" "’" "‚" "‛" "‚" "" "❮" "❯" "‹" "›") - (?` "❛" "‘" "‛" "" "❮" "‹"))) + ;; Add some entries to default decomposition + (dolist (it (or (bound-and-true-p char-fold-include) + char-fold--default-include)) (let ((idx (car it)) (chars (cdr it))) (aset equiv idx (append chars (aref equiv idx))))) + ;; Remove some entries from default decomposition + (dolist (it (or (bound-and-true-p char-fold-exclude) + char-fold--default-exclude)) + (let ((idx (car it)) + (chars (cdr it))) + (when (aref equiv idx) + (dolist (char chars) + (aset equiv idx (remove char (aref equiv idx))))))) + + ;; Add symmetric entries + (when (or (bound-and-true-p char-fold-symmetric) + char-fold--default-symmetric) + (let ((symmetric (make-hash-table :test 'eq))) + ;; Initialize hashes + (map-char-table + (lambda (char decomp-list) + (puthash char (make-hash-table :test 'equal) symmetric) + (dolist (decomp decomp-list) + (puthash (string-to-char decomp) (make-hash-table :test 'equal) symmetric))) + equiv) + + (map-char-table + (lambda (char decomp-list) + (dolist (decomp decomp-list) + (if (< (length decomp) 2) + ;; Add single-char symmetric pairs to hash + (let ((decomp-list (cons (char-to-string char) decomp-list)) + (decomp-hash (gethash (string-to-char decomp) symmetric))) + (dolist (decomp2 decomp-list) + (unless (equal decomp decomp2) + (puthash decomp2 t decomp-hash) + (puthash decomp t (gethash (string-to-char decomp2) symmetric))))) + ;; Add multi-char symmetric pairs to equiv-multi char-table + (let ((decomp-list (cons (char-to-string char) decomp-list)) + (prefix (string-to-char decomp)) + (suffix (substring decomp 1))) + (puthash decomp t (gethash char symmetric)) + (dolist (decomp2 decomp-list) + (if (< (length decomp2) 2) + (aset equiv-multi prefix + (cons (cons suffix (regexp-quote decomp2)) + (aref equiv-multi prefix))))))))) + equiv) + + ;; Update equiv char-table from hash + (maphash + (lambda (char decomp-hash) + (let (schars) + (maphash (lambda (schar _) (push schar schars)) decomp-hash) + (aset equiv char schars))) + symmetric))) + ;; Convert the lists of characters we compiled into regexps. (map-char-table - (lambda (char dec-list) - (let ((re (regexp-opt (cons (char-to-string char) dec-list)))) - (if (consp char) - (set-char-table-range equiv char re) - (aset equiv char re)))) + (lambda (char decomp-list) + (let ((re (regexp-opt (cons (char-to-string char) decomp-list)))) + (aset equiv char re))) equiv) - equiv)) + equiv))) + +(defconst char-fold-table + (eval-when-compile + (char-fold--make-table)) "Used for folding characters of the same group during search. This is a char-table with the `char-fold-table' subtype. @@ -136,6 +227,62 @@ For instance, the default alist for ?f includes: 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) + char-fold--default-include) + (or (bound-and-true-p char-fold-exclude) + char-fold--default-exclude) + (or (bound-and-true-p char-fold-symmetric) + char-fold--default-symmetric)))) + (unless (equal char-fold--previous new) + (setq char-fold-table (char-fold--make-table) + char-fold--previous new)))) + +(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." + :type '(alist :key-type (character :tag "Fold to character") + :value-type (repeat (string :tag "Fold from string"))) + :initialize #'custom-initialize-default + :set (lambda (sym val) + (custom-set-default sym val) + (char-fold-update-table)) + :group 'isearch + :version "27.1") + +(defcustom char-fold-exclude char-fold--default-exclude + "Character foldings to remove from default decompisitions. +Each entry is a list of a character and the strings to remove from folding." + :type '(alist :key-type (character :tag "Fold to character") + :value-type (repeat (string :tag "Fold from string"))) + :initialize #'custom-initialize-default + :set (lambda (sym val) + (custom-set-default sym val) + (char-fold-update-table)) + :group 'isearch + :version "27.1") + +(defcustom char-fold-symmetric char-fold--default-symmetric + "Non-nil means char-fold searching treats equivalent chars the same. +That is, use of any of a set of char-fold equivalent chars in a search +string finds any of them in the text being searched. + +If nil then only the \"base\" or \"canonical\" char of the set matches +any of them. The others match only themselves, even when char-folding +is turned on." + :type 'boolean + :initialize #'custom-initialize-default + :set (lambda (sym val) + (custom-set-default sym val) + (char-fold-update-table)) + :group 'isearch + :version "27.1") + +(char-fold-update-table) + + (defun char-fold--make-space-string (n) "Return a string that matches N spaces." (format "\\(?:%s\\|%s\\)" @@ -144,12 +291,18 @@ Exceptionally for the space character (32), ALIST is ignored.") (make-list n (or (aref char-fold-table ?\s) " "))))) ;;;###autoload -(defun char-fold-to-regexp (string &optional _lax from) +(defun char-fold-to-regexp (string &optional lax from) "Return a regexp matching anything that char-folds into STRING. Any character in STRING that has an entry in `char-fold-table' is replaced with that entry (which is a regexp) and other characters are `regexp-quote'd. +When LAX is non-nil, then the final character also matches ligatures +partially, for instance, the search string \"f\" will match \"fi\", +so when typing the search string in isearch while the cursor is on +a ligature, the search won't try to immediately advance to the next +complete match, but will stay on the partially matched ligature. + If the resulting regexp would be too long for Emacs to handle, just return the result of calling `regexp-quote' on STRING. @@ -170,7 +323,7 @@ from which to start." ;; need to keep them grouped together like this: "\\( \\|[ ...][ ...]\\)". (while (< i end) (pcase (aref string i) - (`?\s (setq spaces (1+ spaces))) + (?\s (setq spaces (1+ spaces))) (c (when (> spaces 0) (push (char-fold--make-space-string spaces) out) (setq spaces 0)) @@ -179,42 +332,46 @@ from which to start." ;; Long string. The regexp would probably be too long. (alist (unless (> end 50) (aref multi-char-table c)))) - (push (let ((matched-entries nil) - (max-length 0)) - (dolist (entry alist) - (let* ((suffix (car entry)) - (len-suf (length suffix))) - (when (eq (compare-strings suffix 0 nil - string (1+ i) (+ i 1 len-suf) - nil) - t) - (push (cons len-suf (cdr entry)) matched-entries) - (setq max-length (max max-length len-suf))))) - ;; If no suffixes matched, just go on. - (if (not matched-entries) - regexp + (push (if (and lax alist (= (1+ i) end)) + (concat "\\(?:" regexp "\\|" + (mapconcat (lambda (entry) + (cdr entry)) alist "\\|") "\\)") + (let ((matched-entries nil) + (max-length 0)) + (dolist (entry alist) + (let* ((suffix (car entry)) + (len-suf (length suffix))) + (when (eq (compare-strings suffix 0 nil + string (1+ i) (+ i 1 len-suf) + nil) + t) + (push (cons len-suf (cdr entry)) matched-entries) + (setq max-length (max max-length len-suf))))) + ;; If no suffixes matched, just go on. + (if (not matched-entries) + regexp ;;; If N suffixes match, we "branch" out into N+1 executions for the ;;; length of the longest match. This means "fix" will match "fix" but ;;; not "fⅸ", but it's necessary to keep the regexp size from scaling ;;; exponentially. See https://lists.gnu.org/r/emacs-devel/2015-11/msg02562.html - (let ((subs (substring string (1+ i) (+ i 1 max-length)))) - ;; `i' is still going to inc by 1 below. - (setq i (+ i max-length)) - (concat - "\\(?:" - (mapconcat (lambda (entry) - (let ((length (car entry)) - (suffix-regexp (cdr entry))) - (concat suffix-regexp - (char-fold-to-regexp subs nil length)))) - `((0 . ,regexp) . ,matched-entries) "\\|") - "\\)")))) + (let ((subs (substring string (1+ i) (+ i 1 max-length)))) + ;; `i' is still going to inc by 1 below. + (setq i (+ i max-length)) + (concat + "\\(?:" + (mapconcat (lambda (entry) + (let ((length (car entry)) + (suffix-regexp (cdr entry))) + (concat suffix-regexp + (char-fold-to-regexp subs nil length)))) + `((0 . ,regexp) . ,matched-entries) "\\|") + "\\)"))))) out)))) (setq i (1+ i))) (when (> spaces 0) (push (char-fold--make-space-string spaces) out)) (let ((regexp (apply #'concat (nreverse out)))) - ;; Limited by `MAX_BUF_SIZE' in `regex.c'. + ;; Limited by `MAX_BUF_SIZE' in `regex-emacs.c'. (if (> (length regexp) 5000) (regexp-quote string) regexp)))) diff --git a/lisp/chistory.el b/lisp/chistory.el index a8a69b8c245..59bdc00c674 100644 --- a/lisp/chistory.el +++ b/lisp/chistory.el @@ -125,8 +125,8 @@ The buffer is left in Command History mode." 'command-history-mode-map "24.1") (defvar command-history-mode-map (let ((map (make-sparse-keymap))) - (set-keymap-parent map lisp-mode-shared-map) - (suppress-keymap map) + (set-keymap-parent map (make-composed-keymap lisp-mode-shared-map + special-mode-map)) (define-key map "x" 'command-history-repeat) (define-key map "\n" 'next-line) (define-key map "\r" 'next-line) @@ -134,20 +134,23 @@ The buffer is left in Command History mode." map) "Keymap for `command-history-mode'.") -(define-derived-mode command-history-mode fundamental-mode "Command History" +(define-derived-mode command-history-mode special-mode "Command History" "Major mode for listing and repeating recent commands. Keybindings: \\{command-history-mode-map}" (lisp-mode-variables nil) - (set-syntax-table emacs-lisp-mode-syntax-table) - (setq buffer-read-only t)) + (set (make-local-variable 'revert-buffer-function) 'command-history-revert) + (set-syntax-table emacs-lisp-mode-syntax-table)) (defcustom command-history-hook nil "If non-nil, its value is called on entry to `command-history-mode'." :type 'hook :group 'chistory) +(defun command-history-revert (_ignore-auto _noconfirm) + (list-command-history)) + (defun command-history-repeat () "Repeat the command shown on the current line. The buffer for that command is the previous current buffer." diff --git a/lisp/comint.el b/lisp/comint.el index 56e38e24aca..049e9e71a79 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -78,7 +78,7 @@ ;; ;; Not bound by default in comint-mode (some are in shell mode) ;; comint-run Run a program under comint-mode -;; send-invisible Read a line w/o echo, and send to proc +;; comint-send-invisible Read a line w/o echo, and send to proc ;; comint-dynamic-complete-filename Complete filename at point. ;; comint-dynamic-list-filename-completions List completions in help buffer. ;; comint-replace-by-expanded-filename Expand and complete filename at point; @@ -263,6 +263,8 @@ See `comint-preinput-scroll-to-bottom'. This variable is buffer-local." (const this)) :group 'comint) +(defvaralias 'comint-scroll-to-bottom-on-output 'comint-move-point-for-output) + (defcustom comint-move-point-for-output nil "Controls whether interpreter output moves point to the end of the output. If nil, then output never moves point to the output. @@ -295,8 +297,6 @@ end of the current logical (not visual) line after insertion." (const :tag "Move to end of line" end-of-line)) :group 'comint) -(defvaralias 'comint-scroll-to-bottom-on-output 'comint-move-point-for-output) - (defcustom comint-scroll-show-maximum-output t "Controls how to scroll due to interpreter output. This variable applies when point is at the end of the buffer @@ -350,24 +350,26 @@ This variable is buffer-local." ;; Ubuntu's sudo prompts like `[sudo] password for user:' ;; Some implementations of passwd use "Password (again)" as the 2nd prompt. ;; Something called "perforce" uses "Enter password:". -;; See M-x comint-testsuite--test-comint-password-prompt-regexp. +;; OpenVPN prints a prompt like: "Enter Auth Password:". +;; See ert test `comint-test-password-regexp'. (defcustom comint-password-prompt-regexp (concat "\\(^ *\\|" (regexp-opt '("Enter" "enter" "Enter same" "enter same" "Enter the" "enter the" - "Old" "old" "New" "new" "'s" "login" + "Enter Auth" "enter auth" "Old" "old" "New" "new" "'s" "login" "Kerberos" "CVS" "UNIX" " SMB" "LDAP" "PEM" "SUDO" "[sudo]" "Repeat" "Bad" "Retype") t) - " +\\)" + ;; Allow for user name to precede password equivalent (Bug#31075). + " +.*\\)" "\\(?:" (regexp-opt password-word-equivalents) "\\|Response\\)" "\\(?:\\(?:, try\\)? *again\\| (empty for no passphrase)\\| (again)\\)?" ;; "[[:alpha:]]" used to be "for", which fails to match non-English. - "\\(?: [[:alpha:]]+ .+\\)?[::៖]\\s *\\'") + "\\(?: [[:alpha:]]+ .+\\)?[[:blank:]]*[::៖][[:blank:]]*\\'") "Regexp matching prompts for passwords in the inferior process. This is used by `comint-watch-for-password-prompt'." - :version "26.1" + :version "27.1" :type 'regexp :group 'comint) @@ -429,9 +431,6 @@ See `comint-send-input'." :type 'boolean :group 'comint) -(define-obsolete-variable-alias 'comint-use-prompt-regexp-instead-of-fields - 'comint-use-prompt-regexp "22.1") - ;; Note: If it is decided to purge comint-prompt-regexp from the source ;; entirely, searching for uses of this variable will help to identify ;; places that need attention. @@ -635,7 +634,7 @@ Input ring history expansion can be achieved with the commands Input ring expansion is controlled by the variable `comint-input-autoexpand', and addition is controlled by the variable `comint-input-ignoredups'. -Commands with no default key bindings include `send-invisible', +Commands with no default key bindings include `comint-send-invisible', `completion-at-point', `comint-dynamic-list-filename-completions', and `comint-magic-space'. @@ -761,16 +760,24 @@ Returns the (possibly newly created) process buffer." (apply #'make-comint-in-buffer name nil program startfile switches)) ;;;###autoload -(defun comint-run (program) - "Run PROGRAM in a Comint buffer and switch to it. +(defun comint-run (program &optional switches) + "Run PROGRAM in a Comint buffer and switch to that buffer. + +If SWITCHES are supplied, they are passed to PROGRAM. With prefix argument +\\[universal-argument] prompt for SWITCHES as well as PROGRAM. + The buffer name is made by surrounding the file name of PROGRAM with `*'s. The file name is used to make a symbol name, such as `comint-sh-hook', and any hooks on this symbol are run in the buffer. + See `make-comint' and `comint-exec'." (declare (interactive-only make-comint)) - (interactive "sRun program: ") + (interactive + (list (read-string "Run program: ") + (and (consp current-prefix-arg) + (split-string-and-unquote (read-string "Switches: "))))) (let ((name (file-name-nondirectory program))) - (switch-to-buffer (make-comint name program)) + (switch-to-buffer (apply #'make-comint name program nil switches)) (run-hooks (intern-soft (concat "comint-" name "-hook"))))) (defun comint-exec (buffer name command startfile switches) @@ -1434,24 +1441,32 @@ If nil, Isearch operates on the whole comint buffer." (defun comint-history-isearch-backward () "Search for a string backward in input history using Isearch." (interactive) - (let ((comint-history-isearch t)) - (isearch-backward nil t))) + (setq comint-history-isearch t) + (isearch-backward nil t)) (defun comint-history-isearch-backward-regexp () "Search for a regular expression backward in input history using Isearch." (interactive) - (let ((comint-history-isearch t)) - (isearch-backward-regexp nil t))) + (setq comint-history-isearch t) + (isearch-backward-regexp nil t)) (defvar-local comint-history-isearch-message-overlay nil) (defun comint-history-isearch-setup () "Set up a comint for using Isearch to search the input history. Intended to be added to `isearch-mode-hook' in `comint-mode'." - (when (or (eq comint-history-isearch t) - (and (eq comint-history-isearch 'dwim) - ;; Point is at command line. - (comint-after-pmark-p))) + (when (and + ;; Prompt is not empty like in Async Shell Command buffers + ;; or in finished shell buffers + (not (eq (save-excursion + (goto-char (comint-line-beginning-position)) + (forward-line 0) + (point)) + (comint-line-beginning-position))) + (or (eq comint-history-isearch t) + (and (eq comint-history-isearch 'dwim) + ;; Point is at command line. + (comint-after-pmark-p)))) (setq isearch-message-prefix-add "history ") (setq-local isearch-search-fun-function #'comint-history-isearch-search) @@ -1472,7 +1487,9 @@ 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) - (remove-hook 'isearch-mode-end-hook 'comint-history-isearch-end t)) + (remove-hook 'isearch-mode-end-hook 'comint-history-isearch-end t) + (unless isearch-suspended + (custom-reevaluate-setting 'comint-history-isearch))) (defun comint-goto-input (pos) "Put input history item of the absolute history position POS." @@ -1610,8 +1627,8 @@ Go to the history element by the absolute history position HIST-POS." (defun comint-within-quotes (beg end) "Return t if the number of quotes between BEG and END is odd. Quotes are single and double." - (let ((countsq (comint-how-many-region "\\(^\\|[^\\\\]\\)'" beg end)) - (countdq (comint-how-many-region "\\(^\\|[^\\\\]\\)\"" beg end))) + (let ((countsq (comint-how-many-region "\\(^\\|[^\\]\\)'" beg end)) + (countdq (comint-how-many-region "\\(^\\|[^\\]\\)\"" beg end))) (or (= (mod countsq 2) 1) (= (mod countdq 2) 1)))) (defun comint-how-many-region (regexp beg end) @@ -1676,11 +1693,13 @@ characters), and are not considered to be delimiters." (defun comint-arguments (string nth mth) "Return from STRING the NTH to MTH arguments. NTH and/or MTH can be nil, which means the last argument. -Returned arguments are separated by single spaces. -We assume whitespace separates arguments, except within quotes -and except for a space or tab that immediately follows a backslash. -Also, a run of one or more of a single character -in `comint-delimiter-argument-list' is a separate argument. +NTH and MTH can be negative to count from the end; -1 means +the last argument. +Returned arguments are separated by single spaces. We assume +whitespace separates arguments, except within quotes and except +for a space or tab that immediately follows a backslash. Also, a +run of one or more of a single character in +`comint-delimiter-argument-list' is a separate argument. Argument 0 is the command name." ;; The first line handles ordinary characters and backslash-sequences ;; (except with w32 msdos-like shells, where backslashes are valid). @@ -1702,7 +1721,7 @@ Argument 0 is the command name." (count 0) beg str quotes) ;; Build a list of all the args until we have as many as we want. - (while (and (or (null mth) (<= count mth)) + (while (and (or (null mth) (< mth 0) (<= count mth)) (string-match argpart string pos)) ;; Apply the `literal' text property to backslash-escaped ;; characters, so that `comint-delim-arg' won't break them up. @@ -1729,8 +1748,14 @@ Argument 0 is the command name." args (if quotes (cons str args) (nconc (comint-delim-arg str) args)))) (setq count (length args)) - (let ((n (or nth (1- count))) - (m (if mth (1- (- count mth)) 0))) + (let ((n (cond + ((null nth) (1- count)) + ((>= nth 0) nth) + (t (+ count nth)))) + (m (cond + ((null mth) 0) + ((>= mth 0) (1- (- count mth))) + (t (1- (- mth)))))) (mapconcat (function (lambda (a) a)) (nthcdr n (nreverse (nthcdr m args))) " ")))) @@ -2056,20 +2081,6 @@ Make backspaces delete the previous character." (goto-char (process-mark process)) (set-marker comint-last-output-start (point)) - ;; Try to skip repeated prompts, which can occur as a result of - ;; commands sent without inserting them in the buffer. - (let ((bol (save-excursion (forward-line 0) (point)))) ;No fields. - (when (and (not (bolp)) - (looking-back comint-prompt-regexp bol)) - (let* ((prompt (buffer-substring bol (point))) - (prompt-re (concat "\\`" (regexp-quote prompt)))) - (while (string-match prompt-re string) - (setq string (substring string (match-end 0))))))) - (while (string-match (concat "\\(^" comint-prompt-regexp - "\\)\\1+") - string) - (setq string (replace-match "\\1" nil nil string))) - ;; insert-before-markers is a bad thing. XXX ;; Luckily we don't have to use it any more, we use ;; window-point-insertion-type instead. @@ -2232,7 +2243,7 @@ This function could be on `comint-output-filter-functions' or bound to a key." (error nil)) (while (re-search-forward "\r+$" pmark t) (replace-match "" t t))))) -(defalias 'shell-strip-ctrl-m 'comint-strip-ctrl-m) +(define-obsolete-function-alias 'shell-strip-ctrl-m #'comint-strip-ctrl-m "27.1") (defun comint-show-maximum-output () "Put the end of the buffer at the bottom of the window." @@ -2281,8 +2292,10 @@ If this takes us past the end of the current line, don't skip at all." (defun comint-after-pmark-p () "Return t if point is after the process output marker." - (let ((pmark (process-mark (get-buffer-process (current-buffer))))) - (<= (marker-position pmark) (point)))) + (let ((process (get-buffer-process (current-buffer)))) + (when process + (let ((pmark (process-mark process))) + (<= (marker-position pmark) (point)))))) (defun comint-simple-send (proc string) "Default function for sending to PROC input STRING. @@ -2340,9 +2353,9 @@ a buffer local variable." ;; These three functions are for entering text you don't want echoed or ;; saved -- typically passwords to ftp, telnet, or somesuch. -;; Just enter m-x send-invisible and type in your line. +;; Just enter m-x comint-send-invisible and type in your line. -(defun send-invisible (&optional prompt) +(defun comint-send-invisible (&optional prompt) "Read a string without echoing. Then send it to the process running in the current buffer. The string is sent using `comint-input-sender'. @@ -2365,18 +2378,24 @@ Security bug: your string can still be temporarily recovered with (message "Warning: text will be echoed"))) (error "Buffer %s has no process" (current-buffer))))) +(define-obsolete-function-alias 'send-invisible #'comint-send-invisible "27.1") + +(defvar comint--prompt-recursion-depth 0) + (defun comint-watch-for-password-prompt (string) "Prompt in the minibuffer for password and send without echoing. -This function uses `send-invisible' to read and send a password to the buffer's -process if STRING contains a password prompt defined by -`comint-password-prompt-regexp'. +Looks for a match to `comint-password-prompt-regexp' in order +to detect the need to (prompt and) send a password. This function could be in the list `comint-output-filter-functions'." (when (let ((case-fold-search t)) (string-match comint-password-prompt-regexp string)) (when (string-match "^[ \n\r\t\v\f\b\a]+" string) (setq string (replace-match "" t t string))) - (send-invisible 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))))) ;; Low-level process communication @@ -2517,13 +2536,16 @@ Useful if you accidentally suspend the top-level process." (defun comint-skip-input () "Skip all pending input, from last stuff output by interpreter to point. -This means mark it as if it had been sent as input, without sending it." +This means mark it as if it had been sent as input, without +sending it. The command keys used to trigger the command that +called this function are inserted into the buffer." (let ((comint-input-sender 'ignore) (comint-input-filter-functions nil)) (comint-send-input t t)) (end-of-line) (let ((pos (point)) - (marker (process-mark (get-buffer-process (current-buffer))))) + (marker (process-mark (get-buffer-process (current-buffer)))) + (inhibit-read-only t)) (insert " " (key-description (this-command-keys))) (if (= marker pos) (set-marker marker (point))))) @@ -2643,8 +2665,17 @@ text matching `comint-prompt-regexp'." (defvar-local comint-insert-previous-argument-last-start-pos nil) (defvar-local comint-insert-previous-argument-last-index nil) -;; Needs fixing: -;; make comint-arguments understand negative indices as bash does +(defcustom comint-insert-previous-argument-from-end nil + "If non-nil, `comint-insert-previous-argument' counts args from the end. +If this variable is nil, the default, `comint-insert-previous-argument' +counts the arguments from the beginning; if non-nil, it counts from +the end instead. This allows to emulate the behavior of `ESC-NUM ESC-.' +in both Bash and zsh: in Bash, `number' counts from the +beginning (variable is nil), while in zsh, it counts from the end." + :type 'boolean + :group 'comint + :version "27.1") + (defun comint-insert-previous-argument (index) "Insert the INDEXth argument from the previous Comint command-line at point. Spaces are added at beginning and/or end of the inserted string if @@ -2652,8 +2683,9 @@ necessary to ensure that it's separated from adjacent arguments. Interactively, if no prefix argument is given, the last argument is inserted. Repeated interactive invocations will cycle through the same argument from progressively earlier commands (using the value of INDEX specified -with the first command). -This command is like `M-.' in bash." +with the first command). Values of INDEX < 0 count from the end, so +INDEX = -1 is the last argument. This command is like `M-.' in +Bash and zsh." (interactive "P") (unless (null index) (setq index (prefix-numeric-value index))) @@ -2663,6 +2695,9 @@ This command is like `M-.' in bash." (setq index comint-insert-previous-argument-last-index)) (t ;; This is a non-repeat invocation, so initialize state. + (when (and index + comint-insert-previous-argument-from-end) + (setq index (- index))) (setq comint-input-ring-index nil) (setq comint-insert-previous-argument-last-index index) (when (null comint-insert-previous-argument-last-start-pos) @@ -2678,9 +2713,6 @@ This command is like `M-.' in bash." (set-marker comint-insert-previous-argument-last-start-pos (point)) ;; Insert the argument. (let ((input-string (comint-previous-input-string 0))) - (when (string-match "[ \t\n]*&" input-string) - ;; strip terminating '&' - (setq input-string (substring input-string 0 (match-beginning 0)))) (insert (comint-arguments input-string index index))) ;; Make next invocation return arg from previous input (setq comint-input-ring-index (1+ (or comint-input-ring-index 0))) @@ -3060,7 +3092,7 @@ interpreter (e.g., the percent notation of cmd.exe on Windows)." (let (env-var-name env-var-val) (save-match-data - (while (string-match "%\\([^\\\\/]*\\)%" name) + (while (string-match "%\\([^\\/]*\\)%" name) (setq env-var-name (match-string 1 name)) (setq env-var-val (or (getenv env-var-name) "")) (setq name (replace-match env-var-val t t name)))))) @@ -3452,7 +3484,7 @@ the process mark is at the beginning of the accumulated input." (message "Process mark set"))) -;; Author: Peter Breton <pbreton@cs.umb.edu> +;; Author: Peter Breton <pbreton@cs.umb.edu> ;; This little add-on for comint is intended to make it easy to get ;; output from currently active comint buffers into another buffer, diff --git a/lisp/completion.el b/lisp/completion.el index 7248d0d89fe..b9c3a21f5ea 100644 --- a/lisp/completion.el +++ b/lisp/completion.el @@ -409,10 +409,7 @@ Used to decide whether to save completions.") (defun cmpl-coerce-string-case (string case-type) (cond ((eq case-type :down) (downcase string)) ((eq case-type :up) (upcase string)) - ((eq case-type :capitalized) - (setq string (downcase string)) - (aset string 0 (logand ?\337 (aref string 0))) - string) + ((eq case-type :capitalized) (capitalize string)) (t string))) (defun cmpl-merge-string-cases (string-to-coerce given-string) @@ -435,7 +432,7 @@ Used to decide whether to save completions.") (defun cmpl-hours-since-origin () - (floor (float-time) 3600)) + (floor (encode-time nil 'integer) 3600)) ;;--------------------------------------------------------------------------- ;; "Symbol" parsing functions @@ -518,6 +515,9 @@ Used to decide whether to save completions.") (modify-syntax-entry char "w" table))) table)) +;; Old name, non-namespace-clean. +(defvaralias 'cmpl-syntax-table 'completion-syntax-table) + (defvar completion-syntax-table completion-standard-syntax-table "This variable holds the current completion syntax table.") (make-variable-buffer-local 'completion-syntax-table) @@ -1062,7 +1062,9 @@ and downcased. Sets up `cmpl-db-prefix-symbol'." (defvar inside-locate-completion-entry nil) ;; used to trap lossage in silent error correction -(defun locate-completion-entry (completion-entry prefix-entry) +(define-obsolete-function-alias 'locate-completion-entry + #'completion-locate-entry "27.1") +(defun completion-locate-entry (completion-entry prefix-entry) "Locate the completion entry. Returns a pointer to the element before the completion entry or nil if the completion entry is at the head. @@ -1085,14 +1087,16 @@ Must be called after `find-exact-completion'." cmpl--completion-string)) (inside-locate-completion-entry ;; recursive error: really scrod - (locate-completion-db-error)) + (completion-locate-db-error)) (t ;; Patch out (set cmpl-db-symbol nil) ;; Retry - (locate-completion-entry-retry completion-entry))))))) + (completion-locate-entry-retry completion-entry))))))) -(defun locate-completion-entry-retry (old-entry) +(define-obsolete-function-alias 'locate-completion-entry-retry + #'completion-locate-entry-retry "27.1") +(defun completion-locate-entry-retry (old-entry) (let ((inside-locate-completion-entry t)) (add-completion (completion-string old-entry) (completion-num-uses old-entry) @@ -1105,11 +1109,13 @@ Must be called after `find-exact-completion'." 0 completion-prefix-min-length))))) (if (and cmpl-entry pref-entry) ;; try again - (locate-completion-entry cmpl-entry pref-entry) + (completion-locate-entry cmpl-entry pref-entry) ;; still losing - (locate-completion-db-error))))) + (completion-locate-db-error))))) -(defun locate-completion-db-error () +(define-obsolete-function-alias 'locate-completion-db-error + #'completion-locate-db-error "27.1") +(defun completion-locate-db-error () ;; recursive error: really scrod (error "Completion database corrupted. Try M-x clear-all-completions. Send bug report")) @@ -1158,7 +1164,7 @@ Returns the completion entry." (let* ((prefix-entry (find-cmpl-prefix-entry (substring cmpl-db-downcase-string 0 completion-prefix-min-length))) - (splice-ptr (locate-completion-entry cmpl-db-entry prefix-entry)) + (splice-ptr (completion-locate-entry cmpl-db-entry prefix-entry)) (cmpl-ptr (cdr splice-ptr))) ;; update entry (set-completion-string cmpl-db-entry completion-string) @@ -1202,7 +1208,8 @@ String must be longer than `completion-prefix-min-length'." (let* ((prefix-entry (find-cmpl-prefix-entry (substring cmpl-db-downcase-string 0 completion-prefix-min-length))) - (splice-ptr (locate-completion-entry cmpl-db-entry prefix-entry))) + (splice-ptr (completion-locate-entry + cmpl-db-entry prefix-entry))) ;; delete symbol reference (set cmpl-db-symbol nil) ;; remove from prefix list @@ -2225,7 +2232,10 @@ TYPE is the type of the wrapper to be added. Can be :before or :under." (modify-syntax-entry char "_" table)) table)) +(declare-function cl-set-difference "cl-seq" (cl-list1 cl-list2 &rest cl-keys)) + (defun completion-lisp-mode-hook () + (require 'cl-lib) (setq completion-syntax-table completion-lisp-syntax-table) ;; Lisp Mode diffs (setq-local completion-separator-chars @@ -2269,10 +2279,7 @@ TYPE is the type of the wrapper to be added. Can be :before or :under." ;;;###autoload (define-minor-mode dynamic-completion-mode - "Toggle dynamic word-completion on or off. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "Toggle dynamic word-completion on or off." :global t :group 'completion ;; This is always good, not specific to dynamic-completion-mode. @@ -2357,8 +2364,7 @@ if ARG is omitted or nil." (completion-def-wrapper 'delete-backward-char :backward) (completion-def-wrapper 'delete-backward-char-untabify :backward) -;; Old names, non-namespace-clean. -(defvaralias 'cmpl-syntax-table 'completion-syntax-table) +;; Old name, non-namespace-clean. (defalias 'initialize-completions 'completion-initialize) (provide 'completion) diff --git a/lisp/composite.el b/lisp/composite.el index e50e5d381ec..e0d0721f16d 100644 --- a/lisp/composite.el +++ b/lisp/composite.el @@ -7,7 +7,7 @@ ;; National Institute of Advanced Industrial Science and Technology (AIST) ;; Registration Number H14PRO021 -;; Author: Kenichi HANDA <handa@etl.go.jp> +;; Author: Kenichi Handa <handa@gnu.org> ;; (according to ack.texi) ;; Keywords: mule, multilingual, character composition ;; Package: emacs @@ -119,7 +119,7 @@ RULE is a cons of global and new reference point symbols (setq nref (cdr (assq nref reference-point-alist)))) (or (and (>= gref 0) (< gref 12) (>= nref 0) (< nref 12)) (error "Invalid composition rule: %S" rule)) - (logior (lsh xoff 16) (lsh yoff 8) (+ (* gref 12) nref))) + (logior (ash xoff 16) (ash yoff 8) (+ (* gref 12) nref))) (error "Invalid composition rule: %S" rule)))) ;; Decode encoded composition rule RULE-CODE. The value is a cons of @@ -130,8 +130,8 @@ RULE is a cons of global and new reference point symbols (defun decode-composition-rule (rule-code) (or (and (natnump rule-code) (< rule-code #x1000000)) (error "Invalid encoded composition rule: %S" rule-code)) - (let ((xoff (lsh rule-code -16)) - (yoff (logand (lsh rule-code -8) #xFF)) + (let ((xoff (ash rule-code -16)) + (yoff (logand (ash rule-code -8) #xFF)) gref nref) (setq rule-code (logand rule-code #xFF) gref (car (rassq (/ rule-code 12) reference-point-alist)) @@ -382,8 +382,8 @@ This function is the default value of `compose-chars-after-function'." (looking-at pattern)) (<= (match-end 0) limit)) (setq result - (funcall func pos (match-end 0) font-obj object))) - (setq result (funcall func pos limit font-obj object))) + (funcall func pos (match-end 0) font-obj object nil))) + (setq result (funcall func pos limit font-obj object nil))) (if result (setq tail nil)))))) result)) @@ -524,8 +524,9 @@ after a sequence of character events." (setq from (1+ from))) gstring)) -(defun compose-gstring-for-graphic (gstring) - "Compose glyph-string GSTRING for graphic display. +(defun compose-gstring-for-graphic (gstring direction) + "Compose glyph-string GSTRING under bidi DIRECTION for graphic display. +DIRECTION is either L2R or R2L, or nil if unknown. Combining characters are composed with the preceding base character. If the preceding character is not a base character, each combining character is composed as a spacing character by @@ -559,7 +560,7 @@ All non-spacing characters have this function in ;; A base character and the following non-spacing characters. (t - (let ((gstr (font-shape-gstring gstring))) + (let ((gstr (font-shape-gstring gstring direction))) (if (and gstr (> (lglyph-to (lgstring-glyph gstr 0)) 0)) gstr @@ -686,12 +687,12 @@ All non-spacing characters have this function in (setq i (1+ i)))) gstring)))))) -(defun compose-gstring-for-dotted-circle (gstring) +(defun compose-gstring-for-dotted-circle (gstring direction) (let* ((dc (lgstring-glyph gstring 0)) ; glyph of dotted-circle (dc-id (lglyph-code dc)) (fc (lgstring-glyph gstring 1)) ; glyph of the following char (fc-id (lglyph-code fc)) - (gstr (and nil (font-shape-gstring gstring)))) + (gstr (and nil (font-shape-gstring gstring direction)))) (if (and gstr (or (= (lgstring-glyph-len gstr) 1) (and (= (lgstring-glyph-len gstr) 2) @@ -742,7 +743,7 @@ All non-spacing characters have this function in (aset composition-function-table #x25CC `([,(purecopy ".\\c^") 0 compose-gstring-for-dotted-circle]))) -(defun compose-gstring-for-terminal (gstring) +(defun compose-gstring-for-terminal (gstring _direction) "Compose glyph-string GSTRING for terminal display. Non-spacing characters are composed with the preceding base character. If the preceding character is not a base character, @@ -799,10 +800,11 @@ prepending a space before it." gstring)) -(defun auto-compose-chars (func from to font-object string) +(defun auto-compose-chars (func from to font-object string direction) "Compose the characters at FROM by FUNC. -FUNC is called with one argument GSTRING which is built for characters -in the region FROM (inclusive) and TO (exclusive). +FUNC is called with two arguments: GSTRING, which is built for +characters in the region FROM (inclusive) and TO (exclusive); +and DIRECTION, which is the bidi directionality of the characters. If the character are composed on a graphic display, FONT-OBJECT is a font to use. Otherwise, FONT-OBJECT is nil, and the function @@ -819,7 +821,7 @@ This function is the default value of `auto-composition-function' (which see)." gstring (or (fontp font-object 'font-object) (setq func 'compose-gstring-for-terminal)) - (funcall func gstring)))) + (funcall func gstring direction)))) (put 'auto-composition-mode 'permanent-local t) @@ -829,9 +831,6 @@ This function is the default value of `auto-composition-function' (which see)." ;;;###autoload (define-minor-mode auto-composition-mode "Toggle Auto Composition mode. -With a prefix argument ARG, enable Auto Composition mode if ARG -is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. When Auto Composition mode is enabled, text characters are automatically composed by functions registered in @@ -847,9 +846,6 @@ Auto Composition mode in all buffers (this is the default)." ;;;###autoload (define-minor-mode global-auto-composition-mode "Toggle Auto Composition mode in all buffers. -With a prefix argument ARG, enable it if ARG is positive, and -disable it otherwise. If called from Lisp, enable it if ARG is -omitted or nil. For more information on Auto Composition mode, see `auto-composition-mode' ." diff --git a/lisp/cus-dep.el b/lisp/cus-dep.el index e26837b1aac..05a01115957 100644 --- a/lisp/cus-dep.el +++ b/lisp/cus-dep.el @@ -27,6 +27,7 @@ (require 'widget) (require 'cus-face) +(require 'cl-lib) (defvar generated-custom-dependencies-file "cus-load.el" "Output file for `custom-make-dependencies'.") @@ -53,69 +54,81 @@ ldefs-boot\\|cus-load\\|finder-inf\\|esh-groups\\|subdirs\\)\\.el$\\)" (defun custom-make-dependencies () "Batch function to extract custom dependencies from .el files. Usage: emacs -batch -l ./cus-dep.el -f custom-make-dependencies DIRS" - (let ((enable-local-eval nil) - (enable-local-variables :safe) - subdir) + (let* ((enable-local-eval nil) + (enable-local-variables :safe) + (preloaded (concat "\\`\\(\\./+\\)?" + (regexp-opt preloaded-file-list t) + "\\.el\\'")) + (file-count 0) + (files + ;; Use up command-line-args-left else Emacs can try to open + ;; the args as directories after we are done. + (cl-loop for subdir = (pop command-line-args-left) + while subdir + append (mapcar (lambda (f) + (cons subdir f)) + (directory-files subdir nil + "\\`[^=.].*\\.el\\'")))) + (progress (make-progress-reporter + (byte-compile-info-string "Scanning files for custom") + 0 (length files) nil 10))) (with-temp-buffer - ;; Use up command-line-args-left else Emacs can try to open - ;; the args as directories after we are done. - (while (setq subdir (pop command-line-args-left)) - (message "Scanning %s for custom" subdir) - (let ((files (directory-files subdir nil "\\`[^=.].*\\.el\\'")) - (default-directory - (file-name-as-directory (expand-file-name subdir))) - (preloaded (concat "\\`\\(\\./+\\)?" - (regexp-opt preloaded-file-list t) - "\\.el\\'"))) - (dolist (file files) - (unless (or (string-match custom-dependencies-no-scan-regexp file) - (string-match preloaded (format "%s/%s" subdir file)) - (not (file-exists-p file))) - (erase-buffer) - (kill-all-local-variables) - (insert-file-contents file) - (hack-local-variables) - (goto-char (point-min)) - (string-match "\\`\\(.*\\)\\.el\\'" file) - (let ((name (or generated-autoload-load-name ; see bug#5277 - (file-name-nondirectory (match-string 1 file)))) - (load-file-name file)) - (if (save-excursion - (re-search-forward + (dolist (elem files) + (let* ((subdir (car elem)) + (file (cdr elem)) + (default-directory + (directory-file-name (expand-file-name subdir)))) + (progress-reporter-update progress (setq file-count (1+ file-count))) + (unless (or (string-match custom-dependencies-no-scan-regexp file) + (string-match preloaded (format "%s/%s" subdir file)) + (not (file-exists-p file))) + (erase-buffer) + (kill-all-local-variables) + (insert-file-contents file) + (hack-local-variables) + (goto-char (point-min)) + (string-match "\\`\\(.*\\)\\.el\\'" file) + (let ((name (or generated-autoload-load-name ; see bug#5277 + (file-name-nondirectory (match-string 1 file)))) + (load-file-name file)) + (if (save-excursion + (re-search-forward (concat "(\\(cc-\\)?provide[ \t\n]+\\('\\|(quote[ \t\n]\\)[ \t\n]*" (regexp-quote name) "[ \t\n)]") nil t)) - (setq name (intern name))) - (condition-case nil - (while (re-search-forward - "^(def\\(custom\\|face\\|group\\)" nil t) - (beginning-of-line) - (let ((type (match-string 1)) - (expr (read (current-buffer)))) - (condition-case nil - (let ((custom-dont-initialize t)) - ;; Eval to get the 'custom-group, -tag, - ;; -version, group-documentation etc properties. - (put (nth 1 expr) 'custom-where name) - (eval expr)) - ;; Eval failed for some reason. Eg maybe the - ;; defcustom uses something defined earlier - ;; in the file (we haven't loaded the file). - ;; In most cases, we can still get the :group. - (error - (ignore-errors - (let ((group (cadr (memq :group expr)))) - (and group - (eq (car group) 'quote) - (custom-add-to-group - (cadr group) - (nth 1 expr) - (intern (format "custom-%s" - (if (equal type "custom") - "variable" - type))))))))))) - (error nil))))))))) - (message "Generating %s..." generated-custom-dependencies-file) + (setq name (intern name))) + (condition-case nil + (while (re-search-forward + "^(def\\(custom\\|face\\|group\\)" nil t) + (beginning-of-line) + (let ((type (match-string 1)) + (expr (read (current-buffer)))) + (condition-case nil + (let ((custom-dont-initialize t)) + ;; Eval to get the 'custom-group, -tag, + ;; -version, group-documentation etc properties. + (put (nth 1 expr) 'custom-where name) + (eval expr)) + ;; Eval failed for some reason. Eg maybe the + ;; defcustom uses something defined earlier + ;; in the file (we haven't loaded the file). + ;; In most cases, we can still get the :group. + (error + (ignore-errors + (let ((group (cadr (memq :group expr)))) + (and group + (eq (car group) 'quote) + (custom-add-to-group + (cadr group) + (nth 1 expr) + (intern (format "custom-%s" + (if (equal type "custom") + "variable" + type))))))))))) + (error nil))))))) + (progress-reporter-done progress)) + (byte-compile-info-message "Generating %s..." + generated-custom-dependencies-file) (set-buffer (find-file-noselect generated-custom-dependencies-file)) (setq buffer-undo-list t) (erase-buffer) @@ -204,7 +217,8 @@ elements the files that have variables or faces that contain that version. These files should be loaded before showing the customization buffer that `customize-changed-options' generates.\")\n\n")) (save-buffer) - (message "Generating %s...done" generated-custom-dependencies-file)) + (byte-compile-info-message "Generating %s...done" + generated-custom-dependencies-file)) (provide 'cus-dep) diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 31c23a5c4b8..8a8bad91137 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -552,7 +552,11 @@ value unless you are sure you know what it does." (setq prefixes nil) (delete-region (point-min) (point))) (setq prefixes (cdr prefixes)))))) - (subst-char-in-region (point-min) (point-max) ?- ?\s t) + (goto-char (point-min)) + ;; Translate characters commonly used as delimiters between + ;; words in symbols into space; e.g. foo:bar-zot/thing. + (while (re-search-forward "[-:/]+" nil t) + (replace-match " ")) (capitalize-region (point-min) (point-max)) (unless no-suffix (goto-char (point-max)) @@ -986,7 +990,7 @@ If given a prefix (or a COMMENT argument), also prompt for a comment." current-prefix-arg)) (custom-load-symbol variable) (custom-push-theme 'theme-value variable 'user 'set (custom-quote value)) - (funcall (or (get variable 'custom-set) 'set-default) variable value) + (funcall (or (get variable 'custom-set) #'set-default) variable value) (put variable 'customized-value (list (custom-quote value))) (cond ((string= comment "") (put variable 'variable-comment nil) @@ -1722,10 +1726,8 @@ Operate on all settings in this buffer:\n")) (unless (eq (preceding-char) ?\n) (widget-insert "\n")) (message "Creating customization items ...done") - (message "Resetting customization items...") (unless (eq custom-buffer-style 'tree) (mapc 'custom-magic-reset custom-options)) - (message "Resetting customization items...done") (message "Creating customization setup...") (widget-setup) (buffer-enable-undo) @@ -1827,20 +1829,9 @@ item in another window.\n\n")) (" `-" "bottom"))) (defun custom-browse-insert-prefix (prefix) - "Insert PREFIX. On XEmacs convert it to line graphics." - ;; Fixme: do graphics. - (if nil ; (featurep 'xemacs) - (progn - (insert "*") - (while (not (string-equal prefix "")) - (let ((entry (substring prefix 0 3))) - (setq prefix (substring prefix 3)) - (let ((overlay (make-overlay (1- (point)) (point) nil t nil)) - (name (nth 1 (assoc entry custom-browse-alist)))) - (overlay-put overlay 'end-glyph (widget-glyph-find name entry)) - (overlay-put overlay 'start-open t) - (overlay-put overlay 'end-open t))))) - (insert prefix))) + "Insert PREFIX." + (declare (obsolete insert "27.1")) + (insert prefix)) ;;; Modification of Basic Widgets. ;; @@ -2431,8 +2422,20 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." ;;; The `custom-variable' Widget. +(defface custom-variable-obsolete + '((((class color) (background dark)) + :foreground "light blue") + (((min-colors 88) (class color) (background light)) + :foreground "blue1") + (((class color) (background light)) + :foreground "blue") + (t :slant italic)) + "Face used for obsolete variables." + :version "27.1" + :group 'custom-faces) + (defface custom-variable-tag - `((((class color) (background dark)) + '((((class color) (background dark)) :foreground "light blue" :weight bold) (((min-colors 88) (class color) (background light)) :foreground "blue1" :weight bold) @@ -2456,8 +2459,9 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." (defun custom-variable-documentation (variable) "Return documentation of VARIABLE for use in Custom buffer. Normally just return the docstring. But if VARIABLE automatically -becomes buffer local when set, append a message to that effect." - (format "%s%s" (documentation-property variable 'variable-documentation t) +becomes buffer local when set, append a message to that effect. +Also append any obsolescence information." + (format "%s%s%s" (documentation-property variable 'variable-documentation t) (if (and (local-variable-if-set-p variable) (or (not (local-variable-p variable)) (with-temp-buffer @@ -2465,7 +2469,21 @@ becomes buffer local when set, append a message to that effect." "\n This variable automatically becomes buffer-local when set outside Custom. However, setting it through Custom sets the default value." - ""))) + "") + ;; This duplicates some code from describe-variable. + ;; TODO extract to separate utility function? + (let* ((obsolete (get variable 'byte-obsolete-variable)) + (use (car obsolete))) + (if obsolete + (concat "\n +This variable is obsolete" + (if (nth 2 obsolete) + (format " since %s" (nth 2 obsolete))) + (cond ((stringp use) (concat ";\n" use)) + (use (format-message ";\nuse `%s' instead." + (car obsolete))) + (t "."))) + "")))) (define-widget 'custom-variable 'custom "A widget for displaying a Custom variable. @@ -2549,11 +2567,13 @@ try matching its doc string against `custom-guess-doc-alist'." (state (or (widget-get widget :custom-state) (if (memq (custom-variable-state symbol value) (widget-get widget :hidden-states)) - 'hidden)))) + 'hidden))) + (obsolete (get symbol 'byte-obsolete-variable))) ;; If we don't know the state, see if we need to edit it in lisp form. (unless state - (setq state (if (custom-show type value) 'unknown 'hidden))) + (with-suppressed-warnings ((obsolete custom-show)) + (setq state (if (custom-show type value) 'unknown 'hidden)))) (when (eq state 'unknown) (unless (widget-apply conv :match value) (setq form 'mismatch))) @@ -2581,7 +2601,9 @@ try matching its doc string against `custom-guess-doc-alist'." (push (widget-create-child-and-convert widget 'item :format "%{%t%} " - :sample-face 'custom-variable-tag + :sample-face (if obsolete + 'custom-variable-obsolete + 'custom-variable-tag) :tag tag :parent widget) buttons)) @@ -2639,7 +2661,9 @@ try matching its doc string against `custom-guess-doc-alist'." :help-echo "Change value of this option." :mouse-down-action 'custom-tag-mouse-down-action :button-face 'custom-variable-button - :sample-face 'custom-variable-tag + :sample-face (if obsolete + 'custom-variable-obsolete + 'custom-variable-tag) tag) buttons) (push (widget-create-child-and-convert @@ -3322,6 +3346,23 @@ Only match frames that support the specified face attributes.") :group 'custom-buffer :version "20.3") +(defun custom-face-documentation (face) + "Return documentation of FACE for use in Custom buffer." + (format "%s%s" (face-documentation face) + ;; This duplicates some code from describe-face. + ;; TODO extract to separate utility function? + ;; In practice this does not get used, because M-x customize-face + ;; follows aliases. + (let ((alias (get face 'face-alias)) + (obsolete (get face 'obsolete-face))) + (if (and alias obsolete) + (format "\nThis face is obsolete%s; use `%s' instead.\n" + (if (stringp obsolete) + (format " since %s" obsolete) + "") + alias) + "")))) + (define-widget 'custom-face 'custom "Widget for customizing a face. The following properties have special meanings for this widget: @@ -3345,7 +3386,7 @@ The following properties have special meanings for this widget: of the widget, instead of the current face spec." :sample-face 'custom-face-tag :help-echo "Set or reset this face." - :documentation-property #'face-doc-string + :documentation-property #'custom-face-documentation :value-create 'custom-face-value-create :action 'custom-face-action :custom-category 'face @@ -3741,10 +3782,6 @@ Optional EVENT is the location for the menu." (custom-save-all) (custom-face-state-set-and-redraw widget)) -;; For backward compatibility. -(define-obsolete-function-alias 'custom-face-save-command 'custom-face-save - "22.1") - (defun custom-face-reset-saved (widget) "Restore WIDGET to the face's default attributes. If there is a saved face, restore it; otherwise reset to the @@ -3875,7 +3912,7 @@ restoring it to the state of a face that has never been customized." (defun custom-hook-convert-widget (widget) ;; Handle `:options'. (let* ((options (widget-get widget :options)) - (other `(editable-list :inline t + (other '(editable-list :inline t :entry-format "%i %d%v" (function :format " %v"))) (args (if options @@ -3998,7 +4035,7 @@ If GROUPS-ONLY is non-nil, return only those members that are groups." (cond ((and (eq custom-buffer-style 'tree) (eq state 'hidden) (or members (custom-unloaded-widget-p widget))) - (custom-browse-insert-prefix prefix) + (insert prefix) (push (widget-create-child-and-convert widget 'custom-browse-visibility :tag "+") @@ -4011,19 +4048,17 @@ If GROUPS-ONLY is non-nil, return only those members that are groups." (widget-put widget :buttons buttons)) ((and (eq custom-buffer-style 'tree) (zerop (length members))) - (custom-browse-insert-prefix prefix) - (insert "[ ]-- ") + (insert prefix "[ ]-- ") (push (widget-create-child-and-convert widget 'custom-browse-group-tag) buttons) (insert " " tag "\n") (widget-put widget :buttons buttons)) ((eq custom-buffer-style 'tree) - (custom-browse-insert-prefix prefix) + (insert prefix) (if (zerop (length members)) (progn - (custom-browse-insert-prefix prefix) - (insert "[ ]-- ") + (insert prefix "[ ]-- ") ;; (widget-glyph-insert nil "[ ]" "empty") ;; (widget-glyph-insert nil "-- " "horizontal") (push (widget-create-child-and-convert @@ -4100,7 +4135,7 @@ If GROUPS-ONLY is non-nil, return only those members that are groups." ;; Update buttons. (widget-put widget :buttons buttons) ;; Insert documentation. - (if (and (eq custom-buffer-style 'links) (> level 1)) + (when (eq custom-buffer-style 'links) (widget-put widget :documentation-indent custom-group-doc-align-col)) (widget-add-documentation-string-button @@ -4176,19 +4211,14 @@ If GROUPS-ONLY is non-nil, return only those members that are groups." custom-buffer-order-groups)) (prefixes (widget-get widget :custom-prefixes)) (custom-prefix-list (custom-prefix-add symbol prefixes)) - (len (length members)) - (count 0) - (reporter (make-progress-reporter - "Creating group entries..." 0 len)) (have-subtitle (and (not (eq symbol 'emacs)) (eq custom-buffer-order-groups 'last))) prev-type children) - (dolist (entry members) + (dolist-with-progress-reporter (entry members) "Creating group entries..." (unless (eq prev-type 'custom-group) (widget-insert "\n")) - (progress-reporter-update reporter (setq count (1+ count))) (let ((sym (nth 0 entry)) (type (nth 1 entry))) (when (and have-subtitle (eq type 'custom-group)) @@ -4210,8 +4240,7 @@ If GROUPS-ONLY is non-nil, return only those members that are groups." (setq children (nreverse children)) (mapc 'custom-magic-reset children) (widget-put widget :children children) - (custom-group-state-update widget) - (progress-reporter-done reporter)) + (custom-group-state-update widget)) ;; End line (let ((p (1+ (point)))) (insert "\n\n") diff --git a/lisp/cus-face.el b/lisp/cus-face.el index 0662e9ca9fa..0ee6a8dcc8f 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -342,7 +342,7 @@ argument list." ;; is aliased to. (if (get face 'face-alias) (setq face (get face 'face-alias))) - (if custom--inhibit-theme-enable + (if (not (custom--should-apply-setting theme)) ;; Just update theme settings. (custom-push-theme 'theme-face face theme 'set spec) ;; Update theme settings and set the face spec. diff --git a/lisp/cus-start.el b/lisp/cus-start.el index 0fcfbed9fdb..e1d0bce2ad0 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -314,7 +314,13 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of (other :tag "hidden by keypress" 1)) "22.1") (make-pointer-invisible mouse boolean "23.2") - (menu-bar-mode frames boolean nil + (resize-mini-frames + frames (choice + (const :tag "Never" nil) + (const :tag "Fit frame to buffer" t) + (function :tag "User-defined function")) + "27.1") + (menu-bar-mode frames boolean nil ;; FIXME? ;; :initialize custom-initialize-default :set custom-set-minor-mode) @@ -345,6 +351,7 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of ;; keyboard.c (meta-prefix-char keyboard character) (auto-save-interval auto-save integer) + (auto-save-no-message auto-save boolean "27.1") (auto-save-timeout auto-save (choice (const :tag "off" nil) (integer :format "%v"))) (echo-keystrokes minibuffer number) @@ -414,6 +421,10 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of ;; msdos.c (dos-unsupported-char-glyph display integer) ;; nsterm.m + ;; + ;; FIXME: Why does ⌃ use nil instead of none? Also the + ;; description is confusing; setting it to nil disables ⌃ + ;; entirely. (ns-control-modifier ns (choice (const :tag "No modifier" nil) @@ -430,13 +441,13 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of (const super)) "24.1") (ns-command-modifier ns - (choice (const :tag "No modifier" nil) + (choice (const :tag "No modifier (work as layout switch)" none) (const control) (const meta) (const alt) (const hyper) (const super)) "23.1") (ns-right-command-modifier ns - (choice (const :tag "No modifier (work as command)" none) + (choice (const :tag "No modifier (work as layout switch)" none) (const :tag "Use the value of ns-command-modifier" left) (const control) (const meta) @@ -542,7 +553,12 @@ since it could result in memory overflow and make Emacs crash." (const :tag "Respect `truncate-lines'" nil) (other :tag "Truncate if not full-width" t)) "23.1") - (make-cursor-line-fully-visible windows boolean) + (make-cursor-line-fully-visible + windows + (choice + (const :tag "Make cursor always fully visible" t) + (const :tag "Allow cursor to be partially-visible" nil) + (function :tag "User-defined function"))) (mode-line-in-non-selected-windows mode-line boolean "22.1") (line-number-display-limit display (choice integer @@ -632,6 +648,20 @@ since it could result in memory overflow and make Emacs crash." (const :tag "Count lines from beginning of narrowed region" :value nil)) "26.1") + + (display-fill-column-indicator display-fill-column-indicator + boolean "27.1") + (display-fill-column-indicator-column display-fill-column-indicator + (choice + (const :tag "Use fill-column variable" + :value t) + (const :tag "Fixed column number" + :value 70 + :format "%v") + integer) + "27.1") + (display-fill-column-indicator-character display-fill-column-indicator + character "27.1") ;; xfaces.c (scalable-fonts-allowed display boolean "22.1") ;; xfns.c @@ -675,7 +705,7 @@ since it could result in memory overflow and make Emacs crash." ((string-match "selection" (symbol-name symbol)) (fboundp 'x-selection-exists-p)) ((string-match "fringe" (symbol-name symbol)) - (fboundp 'define-fringe-bitmap)) + (boundp 'fringe-bitmaps)) ((string-match "\\`imagemagick" (symbol-name symbol)) (fboundp 'imagemagick-types)) ((equal "font-use-system-font" (symbol-name symbol)) @@ -708,17 +738,19 @@ since it could result in memory overflow and make Emacs crash." (put symbol 'custom-set (cadr prop))) ;; This is used by describe-variable. (if version (put symbol 'custom-version version)) - ;; Note this is the _only_ initialize property we handle. - (if (eq (cadr (memq :initialize rest)) 'custom-initialize-delay) - ;; These vars are defined early and should hence be initialized - ;; early, even if this file happens to be loaded late. so add them - ;; to the end of custom-delayed-init-variables. Otherwise, - ;; auto-save-file-name-transforms will appear in M-x customize-rogue. - (add-to-list 'custom-delayed-init-variables symbol 'append)) + ;; Don't re-add to custom-delayed-init-variables post-startup. + (unless after-init-time + ;; Note this is the _only_ initialize property we handle. + (if (eq (cadr (memq :initialize rest)) 'custom-initialize-delay) + ;; These vars are defined early and should hence be initialized + ;; early, even if this file happens to be loaded late. so add them + ;; to the end of custom-delayed-init-variables. Otherwise, + ;; auto-save-file-name-transforms will appear in customize-rogue. + (add-to-list 'custom-delayed-init-variables symbol 'append))) ;; If this is NOT while dumping Emacs, set up the rest of the ;; customization info. This is the stuff that is not needed ;; until someone does M-x customize etc. - (unless purify-flag + (unless dump-mode ;; Add it to the right group(s). (if (listp group) (dolist (g group) @@ -740,7 +772,7 @@ since it could result in memory overflow and make Emacs crash." ;; Record cus-start as loaded if we have set up all the info that we can. ;; Don't record it as loaded if we have only set up the standard values ;; and safe/risky properties. -(unless purify-flag +(unless dump-mode (provide 'cus-start)) ;;; cus-start.el ends here diff --git a/lisp/cus-theme.el b/lisp/cus-theme.el index c195f4afe26..bc9d1d4f7d6 100644 --- a/lisp/cus-theme.el +++ b/lisp/cus-theme.el @@ -1,4 +1,4 @@ -;;; cus-theme.el -- custom theme creation user interface +;;; cus-theme.el -- custom theme creation user interface -*- lexical-binding: t -*- ;; ;; Copyright (C) 2001-2019 Free Software Foundation, Inc. ;; @@ -47,7 +47,7 @@ Do not call this mode function yourself. It is meant for internal use." (use-local-map custom-new-theme-mode-map) (custom--initialize-widget-variables) - (set (make-local-variable 'revert-buffer-function) 'custom-theme-revert)) + (setq-local revert-buffer-function #'custom-theme-revert)) (put 'custom-new-theme-mode 'mode-class 'special) (defvar custom-theme-name nil) @@ -93,15 +93,14 @@ named *Custom Theme*." (switch-to-buffer (get-buffer-create (or buffer "*Custom Theme*"))) (let ((inhibit-read-only t)) (erase-buffer) - (dolist (ov (overlays-in (point-min) (point-max))) - (delete-overlay ov))) + (delete-all-overlays)) (custom-new-theme-mode) (make-local-variable 'custom-theme-name) - (set (make-local-variable 'custom-theme--save-name) theme) - (set (make-local-variable 'custom-theme-faces) nil) - (set (make-local-variable 'custom-theme-variables) nil) - (set (make-local-variable 'custom-theme-description) "") - (set (make-local-variable 'custom-theme--migrate-settings) nil) + (setq-local custom-theme--save-name theme) + (setq-local custom-theme-faces nil) + (setq-local custom-theme-variables nil) + (setq-local custom-theme-description "") + (setq-local custom-theme--migrate-settings nil) (make-local-variable 'custom-theme-insert-face-marker) (make-local-variable 'custom-theme-insert-variable-marker) (make-local-variable 'custom-theme--listed-faces) @@ -118,13 +117,13 @@ remove them from your saved Custom file.\n\n")) :tag " Visit Theme " :help-echo "Insert the settings of a pre-defined theme." :action (lambda (_widget &optional _event) - (call-interactively 'custom-theme-visit-theme))) + (call-interactively #'custom-theme-visit-theme))) (widget-insert " ") (widget-create 'push-button :tag " Merge Theme " :help-echo "Merge in the settings of a pre-defined theme." :action (lambda (_widget &optional _event) - (call-interactively 'custom-theme-merge-theme))) + (call-interactively #'custom-theme-merge-theme))) (widget-insert " ") (widget-create 'push-button :tag " Revert " @@ -142,7 +141,7 @@ remove them from your saved Custom file.\n\n")) (widget-create 'text :value (format-time-string "Created %Y-%m-%d."))) (widget-create 'push-button - :notify (function custom-theme-write) + :notify #'custom-theme-write " Save Theme ") (when (eq theme 'user) (setq custom-theme--migrate-settings t) @@ -188,7 +187,7 @@ remove them from your saved Custom file.\n\n")) :mouse-face 'highlight :pressed-face 'highlight :action (lambda (_widget &optional _event) - (call-interactively 'custom-theme-add-face))) + (call-interactively #'custom-theme-add-face))) ;; If THEME is non-nil, insert all of that theme's variables. (widget-insert "\n\n Theme variables:\n ") @@ -207,7 +206,7 @@ remove them from your saved Custom file.\n\n")) :mouse-face 'highlight :pressed-face 'highlight :action (lambda (_widget &optional _event) - (call-interactively 'custom-theme-add-variable))) + (call-interactively #'custom-theme-add-variable))) (widget-insert ?\n) (widget-setup) (goto-char (point-min)) @@ -254,7 +253,7 @@ interactively, this defaults to the current value of VAR." :tag (custom-unlispify-tag-name symbol) :value symbol :shown-value (list val) - :notify 'ignore + :notify #'ignore :custom-level 0 :custom-state 'hidden :custom-style 'simple)) @@ -313,7 +312,7 @@ SPEC, if non-nil, should be a face spec to which to set the widget." (interactive (list (intern (completing-read "Find custom theme: " - (mapcar 'symbol-name + (mapcar #'symbol-name (custom-available-themes)))))) (unless (custom-theme-name-valid-p theme) (error "No valid theme named `%s'" theme)) @@ -328,7 +327,7 @@ SPEC, if non-nil, should be a face spec to which to set the widget." (interactive (list (intern (completing-read "Merge custom theme: " - (mapcar 'symbol-name + (mapcar #'symbol-name (custom-available-themes)))))) (unless (eq theme 'user) (unless (custom-theme-name-valid-p theme) @@ -343,8 +342,8 @@ SPEC, if non-nil, should be a face spec to which to set the widget." (memq name '(custom-enabled-themes custom-safe-themes))) (funcall (if option - 'custom-theme-add-variable - 'custom-theme-add-face) + #'custom-theme-add-variable + #'custom-theme-add-face) name value))))) theme) @@ -475,7 +474,7 @@ It includes all faces in list FACES." (interactive (list (intern (completing-read "Describe custom theme: " - (mapcar 'symbol-name + (mapcar #'symbol-name (custom-available-themes)))))) (unless (custom-theme-name-valid-p theme) (error "Invalid theme name `%s'" theme)) @@ -513,8 +512,7 @@ It includes all faces in list FACES." (condition-case nil (read (current-buffer)) (end-of-file nil))))) - (and sexp (listp sexp) - (eq (car sexp) 'deftheme) + (and (eq (car-safe sexp) 'deftheme) (setq doc (nth 2 sexp))))))) (princ "\n\nDocumentation:\n") (princ (if (stringp doc) @@ -552,10 +550,10 @@ It includes all faces in list FACES." Do not call this mode function yourself. It is meant for internal use." (use-local-map custom-theme-choose-mode-map) (custom--initialize-widget-variables) - (set (make-local-variable 'revert-buffer-function) - (lambda (_ignore-auto noconfirm) - (when (or noconfirm (y-or-n-p "Discard current choices? ")) - (customize-themes (current-buffer)))))) + (setq-local revert-buffer-function + (lambda (_ignore-auto noconfirm) + (when (or noconfirm (y-or-n-p "Discard current choices? ")) + (customize-themes (current-buffer)))))) (put 'custom-theme-choose-mode 'mode-class 'special) ;;;###autoload @@ -568,7 +566,7 @@ omitted, a buffer named *Custom Themes* is used." (let ((inhibit-read-only t)) (erase-buffer)) (custom-theme-choose-mode) - (set (make-local-variable 'custom--listed-themes) nil) + (setq-local custom--listed-themes nil) (make-local-variable 'custom-theme-allow-multiple-selections) (and (null custom-theme-allow-multiple-selections) (> (length custom-enabled-themes) 1) @@ -616,11 +614,11 @@ Theme files are named *-theme.el in `")) (widget-create 'push-button :tag " Save Theme Settings " :help-echo "Save the selected themes for future sessions." - :action 'custom-theme-save) + :action #'custom-theme-save) (widget-insert ?\n) (widget-create 'checkbox :value custom-theme-allow-multiple-selections - :action 'custom-theme-selections-toggle) + :action #'custom-theme-selections-toggle) (widget-insert (propertize " Select more than one theme at a time" 'face '(variable-pitch (:height 0.9)))) @@ -632,13 +630,13 @@ Theme files are named *-theme.el in `")) :value (custom-theme-enabled-p theme) :theme-name theme :help-echo help-echo - :action 'custom-theme-checkbox-toggle)) + :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 + :action #'widget-parent-action :help-echo help-echo) (widget-insert " -- " (propertize (custom-theme-summary theme) @@ -662,8 +660,7 @@ Theme files are named *-theme.el in `")) (condition-case nil (read (current-buffer)) (end-of-file nil))))) - (and sexp (listp sexp) - (eq (car sexp) 'deftheme) + (and (eq (car-safe sexp) 'deftheme) (setq doc (nth 2 sexp)))))))) (cond ((null doc) "(no documentation available)") diff --git a/lisp/custom.el b/lisp/custom.el index f0125742d1f..736460fec7b 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -1,4 +1,4 @@ -;;; custom.el --- tools for declaring and initializing options +;;; custom.el --- tools for declaring and initializing options -*- lexical-binding: t -*- ;; ;; Copyright (C) 1996-1997, 1999, 2001-2019 Free Software Foundation, ;; Inc. @@ -56,8 +56,14 @@ Otherwise, if symbol has a `saved-value' property, it will evaluate the car of that and use it as the default binding for symbol. Otherwise, EXP will be evaluated and used as the default binding for symbol." - (eval `(defvar ,symbol ,(let ((sv (get symbol 'saved-value))) - (if sv (car sv) exp))))) + (condition-case nil + (default-toplevel-value symbol) ;Test presence of default value. + (void-variable + ;; The var is not initialized yet. + (set-default-toplevel-value + symbol (eval (let ((sv (get symbol 'saved-value))) + (if sv (car sv) exp)) + t))))) (defun custom-initialize-set (symbol exp) "Initialize SYMBOL based on EXP. @@ -150,7 +156,7 @@ set to nil, as the value is no longer rogue." (put symbol 'force-value nil)) (if (keywordp doc) (error "Doc string is missing")) - (let ((initialize 'custom-initialize-reset) + (let ((initialize #'custom-initialize-reset) (requests nil)) (unless (memq :group args) (custom-add-to-group (custom-current-group) symbol 'custom-variable)) @@ -175,6 +181,11 @@ set to nil, as the value is no longer rogue." (put symbol 'risky-local-variable value)) ((eq keyword :safe) (put symbol 'safe-local-variable value)) + ((eq keyword :local) + (when (memq value '(t permanent)) + (make-variable-buffer-local symbol)) + (when (eq value 'permanent) + (put symbol 'permanent-local t))) ((eq keyword :type) (put symbol 'custom-type (purecopy value))) ((eq keyword :options) @@ -188,18 +199,13 @@ set to nil, as the value is no longer rogue." (t (custom-handle-keyword symbol keyword value 'custom-variable)))))) + ;; Set the docstring, record the var on load-history, as well + ;; as set the special-variable-p flag. + (internal--define-uninitialized-variable symbol doc) (put symbol 'custom-requests requests) ;; Do the actual initialization. (unless custom-dont-initialize (funcall initialize symbol default))) - ;; Use defvar to set the docstring as well as the special-variable-p flag. - ;; FIXME: We should reproduce more of `defvar's behavior, such as the warning - ;; when the var is currently let-bound. - (if (not (default-boundp symbol)) - ;; Don't use defvar to avoid setting a default-value when undesired. - (when doc (put symbol 'variable-documentation doc)) - (eval `(defvar ,symbol nil ,@(when doc (list doc))))) - (push symbol current-load-list) (run-hooks 'custom-define-hook) symbol) @@ -250,6 +256,9 @@ The following keywords are meaningful: :risky Set SYMBOL's `risky-local-variable' property to VALUE. :safe Set SYMBOL's `safe-local-variable' property to VALUE. See Info node `(elisp) File Local Variables'. +:local If VALUE is t, mark SYMBOL as automatically buffer-local. + If VALUE is `permanent', also set SYMBOL's `permanent-local' + property to t. The following common keywords are also meaningful. @@ -426,7 +435,7 @@ information." (defun custom-declare-group (symbol members doc &rest args) "Like `defgroup', but SYMBOL is evaluated as a normal argument." (while members - (apply 'custom-add-to-group symbol (car members)) + (apply #'custom-add-to-group symbol (car members)) (setq members (cdr members))) (when doc ;; This text doesn't get into DOC. @@ -618,11 +627,8 @@ VARIABLE is a symbol that names a user option. The result is that the change is treated as having been made through Custom." (put variable 'customized-value (list (custom-quote (eval variable))))) - -;;; Custom Themes - -;;; Loading files needed to customize a symbol. -;;; This is in custom.el because menu-bar.el needs it for toggle cmds. +;; Loading files needed to customize a symbol. +;; This is in custom.el because menu-bar.el needs it for toggle cmds. (defvar custom-load-recursion nil "Hack to avoid recursive dependencies.") @@ -633,14 +639,12 @@ The result is that the change is treated as having been made through Custom." (let ((custom-load-recursion t)) ;; Load these files if not already done, ;; to make sure we know all the dependencies of SYMBOL. - (condition-case nil - (require 'cus-load) - (error nil)) - (condition-case nil - (require 'cus-start) - (error nil)) + (ignore-errors + (require 'cus-load)) + (ignore-errors + (require 'cus-start)) (dolist (load (get symbol 'custom-loads)) - (cond ((symbolp load) (condition-case nil (require load) (error nil))) + (cond ((symbolp load) (ignore-errors (require load))) ;; This is subsumed by the test below, but it's much faster. ((assoc load load-history)) ;; This was just (assoc (locate-library load) load-history) @@ -658,7 +662,7 @@ The result is that the change is treated as having been made through Custom." ;; We are still loading it when we call this, ;; and it is not in load-history yet. ((equal load "cus-edit")) - (t (condition-case nil (load load) (error nil)))))))) + (t (ignore-errors (load load)))))))) (defvar custom-local-buffer nil "Non-nil, in a Customization buffer, means customize a specific buffer. @@ -691,16 +695,12 @@ this sets the local binding in that buffer instead." (defun custom-quote (sexp) "Quote SEXP if it is not self quoting." - (if (or (memq sexp '(t nil)) - (keywordp sexp) - (and (listp sexp) - (memq (car sexp) '(lambda))) - (stringp sexp) - (numberp sexp) - (vectorp sexp) -;;; (and (fboundp 'characterp) -;;; (characterp sexp)) - ) + ;; Can't use `macroexp-quote' because it is loaded after `custom.el' + ;; during bootstrap. See `loadup.el'. + (if (and (not (consp sexp)) + (or (keywordp sexp) + (not (symbolp sexp)) + (booleanp sexp))) sexp (list 'quote sexp))) @@ -715,18 +715,16 @@ To actually save the value, call `custom-save-all'. Return non-nil if the `saved-value' property actually changed." (custom-load-symbol symbol) - (let* ((get (or (get symbol 'custom-get) 'default-value)) + (let* ((get (or (get symbol 'custom-get) #'default-value)) (value (funcall get symbol)) (saved (get symbol 'saved-value)) (standard (get symbol 'standard-value)) (comment (get symbol 'customized-variable-comment))) ;; Save default value if different from standard value. - (if (or (null standard) - (not (equal value (condition-case nil - (eval (car standard)) - (error nil))))) - (put symbol 'saved-value (list (custom-quote value))) - (put symbol 'saved-value nil)) + (put symbol 'saved-value + (unless (and standard + (equal value (ignore-errors (eval (car standard))))) + (list (custom-quote value)))) ;; Clear customized information (set, but not saved). (put symbol 'customized-value nil) ;; Save any comment that might have been set. @@ -744,15 +742,14 @@ default value. Otherwise, set it to nil. Return non-nil if the `customized-value' property actually changed." (custom-load-symbol symbol) - (let* ((get (or (get symbol 'custom-get) 'default-value)) + (let* ((get (or (get symbol 'custom-get) #'default-value)) (value (funcall get symbol)) (customized (get symbol 'customized-value)) (old (or (get symbol 'saved-value) (get symbol 'standard-value)))) ;; Mark default value as set if different from old value. (if (not (and old - (equal value (condition-case nil - (eval (car old)) - (error nil))))) + (equal value (ignore-errors + (eval (car old)))))) (progn (put symbol 'customized-value (list (custom-quote value))) (custom-push-theme 'theme-value symbol 'user 'set (custom-quote value))) @@ -776,7 +773,7 @@ E.g. dumped variables whose default depends on run-time information." ;; always do the funcall step, even if symbol was not bound before. (or (default-boundp symbol) (eval `(defvar ,symbol nil))) ; reset below, so any value is fine - (funcall (or (get symbol 'custom-set) 'set-default) + (funcall (or (get symbol 'custom-set) #'set-default) symbol (eval (car (or (get symbol 'saved-value) (get symbol 'standard-value)))))) @@ -843,6 +840,11 @@ to the front of this list.") (unless (custom-theme-p theme) (error "Unknown theme `%s'" theme))) +(defun custom--should-apply-setting (theme) + (or (null custom--inhibit-theme-enable) + (and (eq custom--inhibit-theme-enable 'apply-only-user) + (eq theme 'user)))) + (defun custom-push-theme (prop symbol theme mode &optional value) "Record VALUE for face or variable SYMBOL in custom theme THEME. PROP is `theme-face' for a face, `theme-value' for a variable. @@ -882,7 +884,7 @@ See `custom-known-themes' for a list of known themes." (setcar (cdr setting) value))) ;; Add a new setting: (t - (unless custom--inhibit-theme-enable + (when (custom--should-apply-setting theme) (unless old ;; If the user changed a variable outside of Customize, save ;; the value to a fake theme, `changed'. If the theme is @@ -941,7 +943,7 @@ the default value for the SYMBOL to the value of EXP. REQUEST is a list of features we must require in order to handle SYMBOL properly. COMMENT is a comment string about SYMBOL." - (apply 'custom-theme-set-variables 'user args)) + (apply #'custom-theme-set-variables 'user args)) (defun custom-theme-set-variables (theme &rest args) "Initialize variables for theme THEME according to settings in ARGS. @@ -981,7 +983,7 @@ COMMENT is a comment string about SYMBOL." (let* ((symbol (indirect-variable (nth 0 entry))) (value (nth 1 entry))) (custom-push-theme 'theme-value symbol theme 'set value) - (unless custom--inhibit-theme-enable + (when (custom--should-apply-setting theme) ;; Now set the variable. (let* ((now (nth 2 entry)) (requests (nth 3 entry)) @@ -989,8 +991,8 @@ COMMENT is a comment string about SYMBOL." set) (when requests (put symbol 'custom-requests requests) - (mapc 'require requests)) - (setq set (or (get symbol 'custom-set) 'custom-set-default)) + (mapc #'require requests)) + (setq set (or (get symbol 'custom-set) #'custom-set-default)) (put symbol 'saved-value (list value)) (put symbol 'saved-variable-comment comment) ;; Allow for errors in the case where the setter has @@ -1086,26 +1088,29 @@ list, in which A occurs before B if B was defined with a ;; 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 &rest _ignored) "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)) + (declare (doc-string 2) + (advertised-calling-convention (theme &optional doc) "22.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 &rest _ignored) "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)) - (add-to-list 'custom-known-themes theme) + (unless (memq theme custom-known-themes) + (push theme custom-known-themes)) (put theme 'theme-feature feature) (when doc (put theme 'theme-documentation doc))) @@ -1149,11 +1154,13 @@ This variable is designed for use in lisp code (including external packages). For manual user customizations, use `custom-theme-directory' instead.") -(defvar custom--inhibit-theme-enable nil +(defvar custom--inhibit-theme-enable 'apply-only-user "Whether the custom-theme-set-* functions act immediately. If nil, `custom-theme-set-variables' and `custom-theme-set-faces' change the current values of the given variable or face. If -non-nil, they just make a record of the theme settings.") +t, they just make a record of the theme settings. If the +value is `apply-only-user', then apply setting to the +`user' theme immediately and defer other updates.") (defun provide-theme (theme) "Indicate that this file provides THEME. @@ -1184,7 +1191,7 @@ This variable cannot be set in a Custom theme." :version "24.1") (defun load-theme (theme &optional no-confirm no-enable) - "Load Custom theme named THEME from its file. + "Load Custom theme named THEME from its file and possibly enable it. The theme file is named THEME-theme.el, in one of the directories specified by `custom-theme-load-path'. @@ -1197,6 +1204,11 @@ Normally, this function also enables THEME. If optional arg NO-ENABLE is non-nil, load the theme but don't enable it, unless the theme was already enabled. +Note that enabling THEME does not disable any other +already-enabled themes. If THEME is enabled, it has the highest +precedence (after `user') among enabled themes. To disable other +themes, use `disable-theme'. + This function is normally called through Customize when setting `custom-enabled-themes'. If used directly in your init file, it should be called with a non-nil NO-CONFIRM argument, or after @@ -1206,7 +1218,7 @@ Return t if THEME was successfully loaded, nil otherwise." (interactive (list (intern (completing-read "Load custom theme: " - (mapcar 'symbol-name + (mapcar #'symbol-name (custom-available-themes)))) nil nil)) (unless (custom-theme-name-valid-p theme) @@ -1221,43 +1233,47 @@ Return t if THEME was successfully loaded, nil otherwise." (put theme 'theme-settings nil) (put theme 'theme-feature nil) (put theme 'theme-documentation nil)) - (let ((fn (locate-file (concat (symbol-name theme) "-theme.el") - (custom-theme--load-path) - '("" "c")))) - (unless fn - (error "Unable to find theme file for `%s'" theme)) - (with-temp-buffer - (insert-file-contents fn) - ;; Check file safety with `custom-safe-themes', prompting the - ;; user if necessary. - (when (or no-confirm - (eq custom-safe-themes t) - (and (memq 'default custom-safe-themes) - (equal (file-name-directory fn) - (expand-file-name "themes/" data-directory))) - (let ((hash (secure-hash 'sha256 (current-buffer)))) - (or (member hash custom-safe-themes) - (custom-theme-load-confirm hash)))) - (let ((custom--inhibit-theme-enable t) - (buffer-file-name fn)) ;For load-history. - (eval-buffer)) - ;; 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. - (let* ((settings (get theme 'theme-settings)) - (tail settings) - found) - (while (and tail (not found)) - (and (eq (nth 0 (car tail)) 'theme-face) - (eq (nth 1 (car tail)) 'default) - (setq found (car tail))) - (setq tail (cdr tail))) - (if found - (put theme 'theme-settings (cons found (delq found settings))))) - ;; Finally, enable the theme. - (unless no-enable - (enable-theme theme)) - t)))) + (let ((file (locate-file (concat (symbol-name theme) "-theme.el") + (custom-theme--load-path) + '("" "c"))) + (custom--inhibit-theme-enable t)) + ;; Check file safety with `custom-safe-themes', prompting the + ;; user if necessary. + (cond ((not file) + (error "Unable to find theme file for `%s'" theme)) + ((or no-confirm + (eq custom-safe-themes t) + (and (memq 'default custom-safe-themes) + (equal (file-name-directory file) + (expand-file-name "themes/" data-directory)))) + ;; Theme is safe; load byte-compiled version if available. + (load (file-name-sans-extension file) nil t nil t)) + ((with-temp-buffer + (insert-file-contents file) + (let ((hash (secure-hash 'sha256 (current-buffer)))) + (when (or (member hash custom-safe-themes) + (custom-theme-load-confirm hash)) + (eval-buffer nil nil file) + t)))) + (t + (error "Unable to load theme `%s'" theme)))) + ;; 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. + (let* ((settings (get theme 'theme-settings)) + (tail settings) + found) + (while (and tail (not found)) + (and (eq (nth 0 (car tail)) 'theme-face) + (eq (nth 1 (car tail)) 'default) + (setq found (car tail))) + (setq tail (cdr tail))) + (when found + (put theme 'theme-settings (cons found (delq found settings))))) + ;; Finally, enable the theme. + (unless no-enable + (enable-theme theme)) + t) (defun custom-theme-load-confirm (hash) "Query the user about loading a Custom theme that may not be safe. @@ -1280,11 +1296,9 @@ query also about adding HASH to `custom-safe-themes'." (defun custom-theme-name-valid-p (name) "Return t if NAME is a valid name for a Custom theme, nil otherwise. NAME should be a symbol." - (and (symbolp name) - name - (not (or (zerop (length (symbol-name name))) - (eq name 'user) - (eq name 'changed))))) + (and (not (memq name '(nil user changed))) + (symbolp name) + (not (string= "" (symbol-name name))))) (defun custom-available-themes () "Return a list of Custom themes available for loading. @@ -1295,19 +1309,25 @@ The returned symbols may not correspond to themes that have been loaded, and no effort is made to check that the files contain valid Custom themes. For a list of loaded themes, check the variable `custom-known-themes'." - (let (sym themes) + (let ((suffix "-theme\\.el\\'") + themes) (dolist (dir (custom-theme--load-path)) - (when (file-directory-p dir) - (dolist (file (file-expand-wildcards - (expand-file-name "*-theme.el" dir) t)) - (setq file (file-name-nondirectory file)) - (and (string-match "\\`\\(.+\\)-theme.el\\'" file) - (setq sym (intern (match-string 1 file))) - (custom-theme-name-valid-p sym) - (push sym themes))))) - (nreverse (delete-dups themes)))) + ;; `custom-theme--load-path' promises DIR exists and is a + ;; directory, but `custom.el' is loaded too early during + ;; bootstrap to use `cl-lib' macros, so guard with + ;; `file-directory-p' instead of calling `cl-assert'. + (dolist (file (and (file-directory-p dir) + (directory-files dir nil suffix))) + (let ((theme (intern (substring file 0 (string-match-p suffix file))))) + (and (custom-theme-name-valid-p theme) + (not (memq theme themes)) + (push theme themes))))) + (nreverse themes))) (defun custom-theme--load-path () + "Expand `custom-theme-load-path' into a list of directories. +Members of `custom-theme-load-path' that either don't exist or +are not directories are omitted from the expansion." (let (lpath) (dolist (f custom-theme-load-path) (cond ((eq f 'custom-theme-directory) @@ -1324,14 +1344,18 @@ variable `custom-known-themes'." (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'. + After this function completes, THEME will have the highest -precedence (after `user')." +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'." (interactive (list (intern (completing-read "Enable custom theme: " obarray (lambda (sym) (get sym 'theme-settings)) t)))) - (if (not (custom-theme-p theme)) - (error "Undefined Custom theme %s" theme)) + (unless (custom-theme-p theme) + (error "Undefined Custom theme %s" theme)) (let ((settings (get theme 'theme-settings))) ;; Loop through theme settings, recalculating vars/faces. (dolist (s settings) @@ -1371,23 +1395,23 @@ Setting this variable through Customize calls `enable-theme' or (let (failures) (setq themes (delq 'user (delete-dups themes))) ;; Disable all themes not in THEMES. - (if (boundp symbol) - (dolist (theme (symbol-value symbol)) - (if (not (memq theme themes)) - (disable-theme theme)))) + (dolist (theme (and (boundp symbol) + (symbol-value symbol))) + (unless (memq theme themes) + (disable-theme theme))) ;; Call `enable-theme' or `load-theme' on each of THEMES. (dolist (theme (reverse themes)) (condition-case nil (if (custom-theme-p theme) (enable-theme theme) (load-theme theme)) - (error (setq failures (cons theme failures) - themes (delq theme themes))))) + (error (push theme failures) + (setq themes (delq theme themes))))) (enable-theme 'user) (custom-set-default symbol themes) - (if failures - (message "Failed to enable theme: %s" - (mapconcat 'symbol-name failures ", ")))))) + (when failures + (message "Failed to enable theme(s): %s" + (mapconcat #'symbol-name failures ", ")))))) (defsubst custom-theme-enabled-p (theme) "Return non-nil if THEME is enabled." @@ -1399,7 +1423,7 @@ See `custom-enabled-themes' for a list of enabled themes." (interactive (list (intern (completing-read "Disable custom theme: " - (mapcar 'symbol-name custom-enabled-themes) + (mapcar #'symbol-name custom-enabled-themes) nil t)))) (when (custom-theme-enabled-p theme) (let ((settings (get theme 'theme-settings))) @@ -1415,23 +1439,23 @@ See `custom-enabled-themes' for a list of enabled themes." ;; If the face spec specified by this theme is in the ;; saved-face property, reset that property. (when (equal (nth 3 s) (get symbol 'saved-face)) - (put symbol 'saved-face (and val (cadr (car val))))))))) - ;; Recompute faces on all frames. - (dolist (frame (frame-list)) - ;; We must reset the fg and bg color frame parameters, or - ;; `face-set-after-frame-default' will use the existing - ;; parameters, which could be from the disabled theme. - (set-frame-parameter frame 'background-color - (custom--frame-color-default - frame :background "background" "Background" - "unspecified-bg" "white")) - (set-frame-parameter frame 'foreground-color - (custom--frame-color-default - frame :foreground "foreground" "Foreground" - "unspecified-fg" "black")) - (face-set-after-frame-default frame)) - (setq custom-enabled-themes - (delq theme custom-enabled-themes))))) + (put symbol 'saved-face (cadar val)))))))) + ;; Recompute faces on all frames. + (dolist (frame (frame-list)) + ;; We must reset the fg and bg color frame parameters, or + ;; `face-set-after-frame-default' will use the existing + ;; parameters, which could be from the disabled theme. + (set-frame-parameter frame 'background-color + (custom--frame-color-default + frame :background "background" "Background" + "unspecified-bg" "white")) + (set-frame-parameter frame 'foreground-color + (custom--frame-color-default + frame :foreground "foreground" "Foreground" + "unspecified-fg" "black")) + (face-set-after-frame-default frame)) + (setq custom-enabled-themes + (delq theme custom-enabled-themes)))) ;; Only used if window-system not null. (declare-function x-get-resource "frame.c" @@ -1465,7 +1489,7 @@ This function returns nil if no custom theme specifies a value for VARIABLE." (if (and valspec (or (get variable 'force-value) (default-boundp variable))) - (funcall (or (get variable 'custom-set) 'set-default) variable + (funcall (or (get variable 'custom-set) #'set-default) variable (eval (car valspec)))))) (defun custom-theme-recalc-face (face) @@ -1506,7 +1530,7 @@ Each of the arguments ARGS has this form: (VARIABLE IGNORED) This means reset VARIABLE. (The argument IGNORED is ignored)." - (apply 'custom-theme-reset-variables 'user args)) + (apply #'custom-theme-reset-variables 'user args)) ;;; The End. diff --git a/lisp/dabbrev.el b/lisp/dabbrev.el index 650ea84f088..23abe7ae165 100644 --- a/lisp/dabbrev.el +++ b/lisp/dabbrev.el @@ -82,7 +82,7 @@ ;; [hymie] Hyman Rosen <marks!hymie@jyacc.jyacc.com> ;; [burgett] Steve Burgett <burgett@bizet.eecs.berkeley.edu> ;; [jules] Julian Gosnell <jules@x.co.uk> -;; [kifer] Michael Kifer <kifer@sbcs.sunysb.edu> +;; [kifer] Michael Kifer <kifer@cs.stonybrook.edu> ;; [ake] Ake Stenhoff <extaksf@aom.ericsson.se> ;; [alon] Alon Albert <al%imercury@uunet.uu.net> ;; [tromey] Tom Tromey <tromey@busco.lanl.gov> @@ -219,7 +219,7 @@ designated by `dabbrev-select-buffers-function'. Then, if `dabbrev-check-all-buffers' is non-nil, dabbrev searches all the other buffers, except those named in `dabbrev-ignored-buffer-names', -or matched by `dabbrev-ignored-regexps'." +or matched by `dabbrev-ignored-buffer-regexps'." :type 'boolean :group 'dabbrev) @@ -238,8 +238,7 @@ See also `dabbrev-ignored-buffer-names'." :version "21.1") (defcustom dabbrev-check-other-buffers t - "Should \\[dabbrev-expand] look in other buffers?\ - + "Should \\[dabbrev-expand] look in other buffers? nil: Don't look in other buffers. t: Also look for expansions in the buffers pointed out by `dabbrev-select-buffers-function'. @@ -434,7 +433,7 @@ buffers accepted by the function pointed out by variable `dabbrev-friend-buffer-function', if `dabbrev-check-other-buffers' says so. Then, if `dabbrev-check-all-buffers' is non-nil, look in all the other buffers, subject to constraints specified -by `dabbrev-ignored-buffer-names' and `dabbrev-ignored-regexps'. +by `dabbrev-ignored-buffer-names' and `dabbrev-ignored-buffer-regexps'. A positive prefix argument, N, says to take the Nth backward *distinct* possibility. A negative argument says search forward. diff --git a/lisp/delim-col.el b/lisp/delim-col.el index d8116f3544b..2f3ee3647e8 100644 --- a/lisp/delim-col.el +++ b/lisp/delim-col.el @@ -1,12 +1,11 @@ -;;; delim-col.el --- prettify all columns in a region or rectangle +;;; delim-col.el --- prettify all columns in a region or rectangle -*- lexical-binding: t; -*- ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Version: 2.1 -;; Keywords: internal -;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre +;; Keywords: convenience text +;; X-URL: https://www.emacswiki.org/emacs/ViniciusJoseLatorre ;; This file is part of GNU Emacs. @@ -27,11 +26,6 @@ ;; delim-col helps to prettify columns in a text region or rectangle. ;; -;; To use it, make sure that this file is in load-path and insert in your -;; .emacs: -;; -;; (require 'delim-col) -;; ;; If you have, for example, the following columns: ;; ;; a b c d @@ -91,9 +85,9 @@ ;; aaa [ <bbb>, <cccc> ] dddd ;; aa [ <bb> , <ccccccc> ] ddd ;; -;; Note that `delimit-columns-region' operates over all text region -;; selected, extending the region start to the beginning of line and the -;; region end to the end of line. While `delimit-columns-rectangle' +;; Note that `delimit-columns-region' operates over the entire selected +;; text region, extending the region start to the beginning of line and +;; the region end to the end of line. While `delimit-columns-rectangle' ;; operates over the text rectangle selected which rectangle diagonal is ;; given by the region start and end. ;; @@ -117,6 +111,7 @@ ;;; Code: +(require 'rect) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; User Options: @@ -125,6 +120,7 @@ "Prettify columns." :link '(emacs-library-link :tag "Source Lisp File" "delim-col.el") :prefix "delimit-columns-" + :group 'convenience :group 'text) (defcustom delimit-columns-str-before "" @@ -213,10 +209,11 @@ See also `delimit-columns-end' for documentation. The following relation must hold: 0 <= delimit-columns-start <= delimit-columns-end -The column number start from 0 and it's relative to the beginning of selected -region. So if you selected a text region, the first column (column 0) is -located at beginning of line. If you selected a text rectangle, the first -column (column 0) is located at left corner." +The column number starts at 0 and is relative to the beginning of +the selected region. So if you select a text region, the first +column (column 0) is located at the beginning of line. If you +select a text rectangle, the first column (column 0) is located +at the left corner." :type '(integer :tag "Column Start") :group 'columns) @@ -228,10 +225,11 @@ See also `delimit-columns-start' for documentation. The following relation must hold: 0 <= delimit-columns-start <= delimit-columns-end -The column number start from 0 and it's relative to the beginning of selected -region. So if you selected a text region, the first column (column 0) is -located at beginning of line. If you selected a text rectangle, the first -column (column 0) is located at left corner." +The column number starts at 0 and is relative to the beginning of +the selected region. So if you select a text region, the first +column (column 0) is located at the beginning of line. If you +select a text rectangle, the first column (column 0) is located +at the left corner." :type '(integer :tag "Column End") :group 'columns) @@ -247,76 +245,96 @@ column (column 0) is located at left corner." ;;;###autoload (defun delimit-columns-customize () - "Customization of `columns' group." + "Customize the `columns' group." (interactive) (customize-group 'columns)) -(defmacro delimit-columns-str (str) - `(if (stringp ,str) ,str "")) +(defun delimit-columns-str (str) + (if (stringp str) str "")) ;;;###autoload (defun delimit-columns-region (start end) "Prettify all columns in a text region. -START and END delimits the text region." - (interactive "*r") - (let ((delimit-columns-str-before - (delimit-columns-str delimit-columns-str-before)) - (delimit-columns-str-separator - (delimit-columns-str delimit-columns-str-separator)) - (delimit-columns-str-after - (delimit-columns-str delimit-columns-str-after)) - (delimit-columns-before - (delimit-columns-str delimit-columns-before)) - (delimit-columns-after - (delimit-columns-str delimit-columns-after)) - (delimit-columns-start - (if (and (integerp delimit-columns-start) - (>= delimit-columns-start 0)) - delimit-columns-start - 0)) - (delimit-columns-end - (if (integerp delimit-columns-end) - delimit-columns-end - 1000000)) - (delimit-columns-limit (make-marker)) - (the-end (copy-marker end)) - delimit-columns-max) - (when (<= delimit-columns-start delimit-columns-end) - (save-excursion - (goto-char start) - (beginning-of-line) - ;; get maximum length for each column - (and delimit-columns-format - (save-excursion - (while (< (point) the-end) - (delimit-columns-rectangle-max - (prog1 - (point) - (end-of-line))) - (forward-char 1)))) - ;; prettify columns - (while (< (point) the-end) - (delimit-columns-rectangle-line - (prog1 - (point) - (end-of-line))) - (forward-char 1)) - ;; nullify markers - (set-marker delimit-columns-limit nil) - (set-marker the-end nil))))) +START and END delimit the text region. +If you have, for example, the following columns: -(require 'rect) + a b c d + aaaa bb ccc ddddd + +Depending on your settings (see below), you then obtain the +following result: + + [ a , b , c , d ] + [ aaaa, bb , ccc , ddddd ] + +See the `delimit-columns-str-before', +`delimit-columns-str-after', `delimit-columns-str-separator', +`delimit-columns-before', `delimit-columns-after', +`delimit-columns-separator', `delimit-columns-format' and +`delimit-columns-extra' variables for customization of the +look. " + (interactive "*r") + (if rectangle-mark-mode + ;; Delegate to delimit-columns-rectangle when called with a + ;; rectangular region. + (delimit-columns-rectangle start end) + (let ((delimit-columns-str-before + (delimit-columns-str delimit-columns-str-before)) + (delimit-columns-str-separator + (delimit-columns-str delimit-columns-str-separator)) + (delimit-columns-str-after + (delimit-columns-str delimit-columns-str-after)) + (delimit-columns-before + (delimit-columns-str delimit-columns-before)) + (delimit-columns-after + (delimit-columns-str delimit-columns-after)) + (delimit-columns-start + (if (natnump delimit-columns-start) + delimit-columns-start + 0)) + (delimit-columns-end + (if (integerp delimit-columns-end) + delimit-columns-end + 1000000)) + (delimit-columns-limit (make-marker)) + (the-end (copy-marker end)) + delimit-columns-max) + (when (<= delimit-columns-start delimit-columns-end) + (save-excursion + (goto-char start) + (beginning-of-line) + ;; get maximum length for each column + (and delimit-columns-format + (save-excursion + (while (< (point) the-end) + (delimit-columns-rectangle-max + (prog1 + (point) + (end-of-line))) + (forward-char 1)))) + ;; prettify columns + (while (< (point) the-end) + (delimit-columns-rectangle-line + (prog1 + (point) + (end-of-line))) + (forward-char 1)) + ;; nullify markers + (set-marker delimit-columns-limit nil) + (set-marker the-end nil)))))) ;;;###autoload (defun delimit-columns-rectangle (start end) "Prettify all columns in a text rectangle. -START and END delimits the corners of text rectangle." +See `delimit-columns-region' for what this entails. + +START and END delimit the corners of the text rectangle." (interactive "*r") (let ((delimit-columns-str-before (delimit-columns-str delimit-columns-str-before)) @@ -329,8 +347,7 @@ START and END delimits the corners of text rectangle." (delimit-columns-after (delimit-columns-str delimit-columns-after)) (delimit-columns-start - (if (and (integerp delimit-columns-start) - (>= delimit-columns-start 0)) + (if (natnump delimit-columns-start) delimit-columns-start 0)) (delimit-columns-end @@ -344,11 +361,11 @@ START and END delimits the corners of text rectangle." ;; get maximum length for each column (and delimit-columns-format (save-excursion - (operate-on-rectangle 'delimit-columns-rectangle-max + (operate-on-rectangle #'delimit-columns-rectangle-max start the-end nil))) ;; prettify columns (save-excursion - (operate-on-rectangle 'delimit-columns-rectangle-line + (operate-on-rectangle #'delimit-columns-rectangle-line start the-end nil)) ;; nullify markers (set-marker delimit-columns-limit nil) @@ -359,7 +376,7 @@ START and END delimits the corners of text rectangle." ;; Internal Variables and Functions: -(defun delimit-columns-rectangle-max (startpos &optional _ignore1 _ignore2) +(defun delimit-columns-rectangle-max (startpos &optional _begextra _endextra) (set-marker delimit-columns-limit (point)) (goto-char startpos) (let ((ncol 1) @@ -392,7 +409,7 @@ START and END delimits the corners of text rectangle." (setq values (cdr values))))) -(defun delimit-columns-rectangle-line (startpos &optional _ignore1 _ignore2) +(defun delimit-columns-rectangle-line (startpos &optional _begextra _endextra) (let ((len (length delimit-columns-max)) (ncol 0) origin) @@ -442,8 +459,7 @@ START and END delimits the corners of text rectangle." ((eq delimit-columns-format 'padding) (insert spaces delimit-columns-after delimit-columns-str-after)) (t - (insert delimit-columns-after spaces delimit-columns-str-after)) - )) + (insert delimit-columns-after spaces delimit-columns-str-after)))) (goto-char (max (point) delimit-columns-limit)))) @@ -466,8 +482,7 @@ START and END delimits the corners of text rectangle." (insert delimit-columns-after delimit-columns-str-separator spaces - delimit-columns-before)) - )) + delimit-columns-before)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/lisp/delsel.el b/lisp/delsel.el index 08c47ddca8d..8f71bc65191 100644 --- a/lisp/delsel.el +++ b/lisp/delsel.el @@ -70,12 +70,6 @@ Value must be the register (key) to use.") ;;;###autoload (define-minor-mode delete-selection-mode "Toggle Delete Selection mode. -Interactively, with a prefix argument, enable -Delete Selection mode if the prefix argument is positive, -and disable it otherwise. If called from Lisp, toggle -the mode if ARG is `toggle', disable the mode if ARG is -a non-positive integer, and enable the mode otherwise -\(including if ARG is omitted or nil or a positive integer). When Delete Selection mode is enabled, typed text replaces the selection if the selection is active. Otherwise, typed text is just inserted at @@ -300,18 +294,10 @@ then it takes a second \\[keyboard-quit] to abort the minibuffer." (abort-recursive-edit))) (define-key minibuffer-local-map "\C-g" 'minibuffer-keyboard-quit) -(define-key minibuffer-local-ns-map "\C-g" 'minibuffer-keyboard-quit) -(define-key minibuffer-local-completion-map "\C-g" 'minibuffer-keyboard-quit) -(define-key minibuffer-local-must-match-map "\C-g" 'minibuffer-keyboard-quit) -(define-key minibuffer-local-isearch-map "\C-g" 'minibuffer-keyboard-quit) (defun delsel-unload-function () "Unload the Delete Selection library." (define-key minibuffer-local-map "\C-g" 'abort-recursive-edit) - (define-key minibuffer-local-ns-map "\C-g" 'abort-recursive-edit) - (define-key minibuffer-local-completion-map "\C-g" 'abort-recursive-edit) - (define-key minibuffer-local-must-match-map "\C-g" 'abort-recursive-edit) - (define-key minibuffer-local-isearch-map "\C-g" 'abort-recursive-edit) (dolist (sym '(self-insert-command insert-char quoted-insert yank clipboard-yank insert-register newline-and-indent reindent-then-newline-and-indent newline open-line)) diff --git a/lisp/descr-text.el b/lisp/descr-text.el index c4959a81808..ba53aeb3855 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -88,8 +88,6 @@ into help buttons that call `describe-text-category' or (insert-text-button (format "%S" value) 'type 'help-face 'help-args (list value))) - ((widgetp value) - (describe-text-widget value)) (t (describe-text-sexp value)))) (insert "\n"))) @@ -413,12 +411,6 @@ The character information includes: (charset (if eight-bit-p 'eight-bit (or (get-text-property pos 'charset) (char-charset char)))) - ;; TIS620.2533 overlaps eight-bit-control, but we want to - ;; show eight-bit for raw bytes, not some obscure character - ;; set no one heard of. - (charset (if (eq charset 'tis620-2533) - 'eight-bit - charset)) (composition (find-composition pos nil nil t)) (component-chars nil) (display-table (or (window-display-table) @@ -850,8 +842,6 @@ The character information includes: (if text-props-desc (insert text-props-desc)) (setq buffer-read-only t)))))) -(define-obsolete-function-alias 'describe-char-after 'describe-char "22.1") - ;;; Describe-Char-ElDoc (defun describe-char-eldoc--truncate (name width) diff --git a/lisp/desktop.el b/lisp/desktop.el index a14abdd8fc1..59610a128a3 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -124,7 +124,7 @@ ;; avk@rtsg.mot.com (Andrew V. Klein) for a dired tip. ;; chris@tecc.co.uk (Chris Boucher) for a mark tip. ;; f89-kam@nada.kth.se (Klas Mellbourn) for a mh-e tip. -;; kifer@sbkifer.cs.sunysb.edu (M. Kifer) for a bug hunt. +;; kifer@cs.stonybrook.edu (M. Kifer) for a bug hunt. ;; treese@lcs.mit.edu (Win Treese) for ange-ftp tips. ;; pot@cnuce.cnr.it (Francesco Potortì) for misc. tips. ;; --------------------------------------------------------------------------- @@ -158,14 +158,9 @@ Used at desktop read to provide backward compatibility.") "Save status of Emacs when you exit." :group 'frames) -;; Maintained for backward compatibility -(define-obsolete-variable-alias 'desktop-enable 'desktop-save-mode "22.1") ;;;###autoload (define-minor-mode desktop-save-mode "Toggle desktop saving (Desktop Save mode). -With a prefix argument ARG, enable Desktop Save mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode if ARG -is omitted or nil. 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 @@ -248,9 +243,6 @@ the normal hook `desktop-not-loaded-hook' is run." :group 'desktop :version "22.2") -(define-obsolete-variable-alias 'desktop-basefilename - 'desktop-base-file-name "22.1") - (defcustom desktop-base-file-name (convert-standard-filename ".emacs.desktop") "Name of file for Emacs desktop, excluding the directory part." @@ -392,7 +384,7 @@ or `desktop-modes-not-to-save'." ;; Skip tramp and ange-ftp files (defcustom desktop-files-not-to-save - "\\(^/[^/:]*:\\|(ftp)$\\)" + "\\(\\`/[^/:]*:\\|(ftp)\\'\\)" "Regexp identifying files whose buffers are to be excluded from saving. The default value excludes buffers visiting remote files." :type '(choice (const :tag "None" nil) @@ -494,10 +486,6 @@ When file names are returned, they should be formatted using the call Later, when `desktop-read' evaluates the desktop file, auxiliary information is passed as the argument DESKTOP-BUFFER-MISC to functions in `desktop-buffer-mode-handlers'.") -(make-obsolete-variable 'desktop-buffer-modes-to-save - 'desktop-save-buffer "22.1") -(make-obsolete-variable 'desktop-buffer-misc-functions - 'desktop-save-buffer "22.1") ;;;###autoload (defvar desktop-buffer-mode-handlers nil @@ -541,12 +529,9 @@ can guess how to load the mode's definition.") ;;;###autoload (put 'desktop-buffer-mode-handlers 'risky-local-variable t) -(make-obsolete-variable 'desktop-buffer-handlers - 'desktop-buffer-mode-handlers "22.1") (defcustom desktop-minor-mode-table - '((auto-fill-function auto-fill-mode) - (defining-kbd-macro nil) + '((defining-kbd-macro nil) (isearch-mode nil) (vc-mode nil) (vc-dired-mode nil) @@ -631,7 +616,7 @@ DIRNAME omitted or nil means use `desktop-dirname'." ";; -------------------------------------------------------------------------- ;; Desktop File for Emacs ;; -------------------------------------------------------------------------- -" "*Header to place in Desktop file.") +" "Header to place in Desktop file.") (defvar desktop-delay-hook nil "Hooks run after all buffers are loaded; intended for internal use.") @@ -713,12 +698,12 @@ if different)." (if (symbolp var) (set-default var nil) (set-default var (eval (cdr var))))) - (let ((preserve-regexp (concat "^\\(" + (let ((preserve-regexp (concat "\\`\\(" (mapconcat (lambda (regexp) (concat "\\(" regexp "\\)")) desktop-clear-preserve-buffers "\\|") - "\\)$"))) + "\\)\\'"))) (dolist (buffer (buffer-list)) (let ((bufname (buffer-name buffer))) (unless (or (eq (aref bufname 0) ?\s) ;; Don't kill internal buffers @@ -746,7 +731,7 @@ if different)." ;; ---------------------------------------------------------------------------- (unless noninteractive - (add-hook 'kill-emacs-hook 'desktop-kill)) + (add-hook 'kill-emacs-hook #'desktop-kill)) (defun desktop-kill () "If `desktop-save-mode' is non-nil, do what `desktop-save' says to do. @@ -815,6 +800,7 @@ buffer, which is (in order): (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)))))) ;; point and mark, and read-only status @@ -852,10 +838,12 @@ QUOTE may be `may' (value may be quoted), ((or (numberp value) (null value) (eq t value) (keywordp value)) (cons 'may value)) ((stringp value) - (let ((copy (copy-sequence value))) - (set-text-properties 0 (length copy) nil copy) - ;; Get rid of text properties because we cannot read them. - (cons 'may copy))) + ;; Get rid of unreadable text properties. + (if (condition-case nil (read (format "%S" value)) (error nil)) + (cons 'may value) + (let ((copy (copy-sequence value))) + (set-text-properties 0 (length copy) nil copy) + (cons 'may copy)))) ((symbolp value) (cons 'must value)) ((vectorp value) @@ -868,6 +856,19 @@ QUOTE may be `may' (value may be quoted), `',(cdr el) (cdr el))) pass1))) (cons 'may `[,@(mapcar #'cdr pass1)])))) + ((and (recordp value) (symbolp (aref value 0))) + (let* ((pass1 (let ((res ())) + (dotimes (i (length value)) + (push (desktop--v2s (aref value i)) res)) + (nreverse res))) + (special (assq nil pass1))) + (if special + (cons nil `(record + ,@(mapcar (lambda (el) + (if (eq (car el) 'must) + `',(cdr el) (cdr el))) + pass1))) + (cons 'may (apply #'record (mapcar #'cdr pass1)))))) ((consp value) (let ((p value) newlist @@ -900,8 +901,8 @@ QUOTE may be `may' (value may be quoted), (cons nil `(let ((mk (make-marker))) (add-hook 'desktop-delay-hook - `(lambda () - (set-marker ,mk ,,pos (get-buffer ,,buf)))) + (lambda () + (set-marker mk ,pos (get-buffer ,buf)))) mk)))) (t ; Save as text. (cons 'may "Unprintable entity")))) @@ -1043,7 +1044,8 @@ without further confirmation." (setq desktop-dirname (file-name-as-directory (expand-file-name dirname))) (save-excursion (let ((eager desktop-restore-eager) - (new-modtime (nth 5 (file-attributes (desktop-full-file-name))))) + (new-modtime (file-attribute-modification-time + (file-attributes (desktop-full-file-name))))) (when (or (not new-modtime) ; nothing to overwrite (equal desktop-file-modtime new-modtime) @@ -1085,7 +1087,7 @@ without further confirmation." (with-temp-buffer (insert - ";; -*- mode: emacs-lisp; coding: emacs-mule; -*-\n" + ";; -*- mode: emacs-lisp; lexical-binding:t; coding: utf-8-emacs; -*-\n" desktop-header ";; Created " (current-time-string) "\n" ";; Desktop file format version " (format "%d" desktop-io-file-version) "\n" @@ -1098,7 +1100,7 @@ without further confirmation." (desktop-save-frameset) (unless (memq 'desktop-saved-frameset desktop-globals-to-save) (desktop-outvar 'desktop-saved-frameset)) - (mapc (function desktop-outvar) desktop-globals-to-save) + (mapc #'desktop-outvar desktop-globals-to-save) (setq desktop-saved-frameset nil) ; after saving desktop-globals-to-save (when (memq 'kill-ring desktop-globals-to-save) (insert @@ -1107,9 +1109,9 @@ without further confirmation." " kill-ring))\n")) (insert "\n;; Buffer section -- buffers listed in same order as in buffer list:\n") - (dolist (l (mapcar 'desktop-buffer-info (buffer-list))) + (dolist (l (mapcar #'desktop-buffer-info (buffer-list))) (let ((base (pop l))) - (when (apply 'desktop-save-buffer-p l) + (when (apply #'desktop-save-buffer-p l) (insert "(" (if (or (not (integerp eager)) (if (zerop eager) @@ -1140,13 +1142,15 @@ without further confirmation." ;; This is saved after the timestamp (search-forward (format "%S" desktop--app-id) nil t)) (point)))) - (checksum (and beg (md5 (current-buffer) beg (point-max) 'emacs-mule)))) + (checksum (and beg (md5 (current-buffer) beg (point-max) 'utf-8-emacs)))) (unless (and checksum (equal checksum desktop-file-checksum)) - (let ((coding-system-for-write 'emacs-mule)) + (let ((coding-system-for-write 'utf-8-emacs)) (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 (nth 5 (file-attributes (desktop-full-file-name))))))))))) + (setq desktop-file-modtime (file-attribute-modification-time + (file-attributes + (desktop-full-file-name))))))))))) ;; ---------------------------------------------------------------------------- ;;;###autoload @@ -1241,16 +1245,18 @@ Using it may cause conflicts. Use it anyway? " owner))))) ;; disabled when loading the desktop fails with errors, ;; thus not overwriting the desktop with broken contents. (setq desktop-autosave-was-enabled - (memq 'desktop-auto-save-set-timer - ;; Use the toplevel value of the hook, in case some + (memq #'desktop-auto-save-set-timer + ;; Use the global value of the hook, in case some ;; feature makes window-configuration-change-hook ;; buffer-local, and puts there stuff which ;; doesn't include our timer. - (default-toplevel-value + (default-value 'window-configuration-change-hook))) (desktop-auto-save-disable) ;; Evaluate desktop buffer and remember when it was modified. - (setq desktop-file-modtime (nth 5 (file-attributes (desktop-full-file-name)))) + (setq desktop-file-modtime (file-attribute-modification-time + (file-attributes + (desktop-full-file-name)))) (load (desktop-full-file-name) t t t) ;; If it wasn't already, mark it as in-use, to bother other ;; desktop instances. @@ -1265,7 +1271,7 @@ Using it may cause conflicts. Use it anyway? " owner))))) ;; We want buffers existing prior to evaluating the desktop (and ;; not reused) to be placed at the end of the buffer list, so we ;; move them here. - (mapc 'bury-buffer + (mapc #'bury-buffer (nreverse (cdr (memq desktop-first-buffer (nreverse (buffer-list)))))) (switch-to-buffer (car (buffer-list)))) (run-hooks 'desktop-delay-hook) @@ -1310,17 +1316,6 @@ Using it may cause conflicts. Use it anyway? " owner))))) nil))) ;; ---------------------------------------------------------------------------- -;; Maintained for backward compatibility -;;;###autoload -(defun desktop-load-default () - "Load the `default' start-up library manually. -Also inhibit further loading of it." - (declare (obsolete desktop-save-mode "22.1")) - (unless inhibit-default-init ; safety check - (load "default" t t) - (setq inhibit-default-init t))) - -;; ---------------------------------------------------------------------------- ;;;###autoload (defun desktop-change-dir (dirname) "Change to desktop saved in DIRNAME. @@ -1350,10 +1345,10 @@ directory DIRNAME." (defun desktop-auto-save-enable (&optional timeout) (when (and (integerp (or timeout desktop-auto-save-timeout)) (> (or timeout desktop-auto-save-timeout) 0)) - (add-hook 'window-configuration-change-hook 'desktop-auto-save-set-timer))) + (add-hook 'window-configuration-change-hook #'desktop-auto-save-set-timer))) (defun desktop-auto-save-disable () - (remove-hook 'window-configuration-change-hook 'desktop-auto-save-set-timer) + (remove-hook 'window-configuration-change-hook #'desktop-auto-save-set-timer) (desktop-auto-save-cancel-timer)) (defun desktop-auto-save () @@ -1562,11 +1557,10 @@ and try to load that." ;; for the sake of `clean-buffer-list': preserving the invariant ;; "how much time the user spent in Emacs without looking at this buffer". (setq buffer-display-time - (if buffer-display-time - (time-add buffer-display-time - (time-subtract (current-time) - desktop-file-modtime)) - (current-time))) + (time-since (if buffer-display-time + (time-subtract desktop-file-modtime + buffer-display-time) + 0))) (unless (< desktop-file-version 208) ; Don't misinterpret any old custom args (dolist (record compacted-vars) (let* @@ -1609,7 +1603,7 @@ ARGS must be an argument list for `desktop-create-buffer'." (let ((desktop-first-buffer nil) (desktop-buffer-ok-count 0) (desktop-buffer-fail-count 0)) - (apply 'desktop-create-buffer args) + (apply #'desktop-create-buffer args) (run-hooks 'desktop-delay-hook) (setq desktop-delay-hook nil) (bury-buffer (get-buffer buffer-name)) diff --git a/lisp/dframe.el b/lisp/dframe.el index eebc0bf7bdc..72deb0c45e4 100644 --- a/lisp/dframe.el +++ b/lisp/dframe.el @@ -135,9 +135,7 @@ This is nil for terminals, since updating a frame in a terminal is not useful to the user.") -(defcustom dframe-update-speed - (if (featurep 'xemacs) 2 ; 1 is too obtrusive in XEmacs - 1) +(defcustom dframe-update-speed 1 "Idle time in seconds needed before dframe will update itself. Updates occur to allow dframe to display directory information relevant to the buffer you are currently editing." @@ -204,40 +202,28 @@ Local to those buffers, as a function called that created it.") 'dframe-switch-buffer-attached-frame map global-map) - (if (featurep 'xemacs) - (progn - ;; mouse bindings so we can manipulate the items on each line - (define-key map 'button2 'dframe-click) - (define-key map '(shift button2) 'dframe-power-click) - ;; Info doc fix from Bob Weiner - (if (featurep 'infodoc) - nil - (define-key map 'button3 'dframe-popup-kludge)) - ) - - ;; mouse bindings so we can manipulate the items on each line - ;; (define-key map [down-mouse-1] 'dframe-double-click) - (define-key map [follow-link] 'mouse-face) - (define-key map [mouse-2] 'dframe-click) - ;; This is the power click for new frames, or refreshing a cache - (define-key map [S-mouse-2] 'dframe-power-click) - ;; This adds a small unnecessary visual effect - ;;(define-key map [down-mouse-2] 'dframe-quick-mouse) - - (define-key map [down-mouse-3] 'dframe-popup-kludge) - - ;; This lets the user scroll as if we had a scrollbar... well maybe not - (define-key map [mode-line mouse-2] 'dframe-mouse-hscroll) - ;; another handy place users might click to get our menu. - (define-key map [mode-line down-mouse-1] - 'dframe-popup-kludge) - - ;; We can't switch buffers with the buffer mouse menu. Lets hack it. - (define-key map [C-down-mouse-1] 'dframe-hack-buffer-menu) - - ;; Lastly, we want to track the mouse. Play here - (define-key map [mouse-movement] 'dframe-track-mouse) - )) + ;; mouse bindings so we can manipulate the items on each line + ;; (define-key map [down-mouse-1] 'dframe-double-click) + (define-key map [follow-link] 'mouse-face) + (define-key map [mouse-2] 'dframe-click) + ;; This is the power click for new frames, or refreshing a cache + (define-key map [S-mouse-2] 'dframe-power-click) + ;; This adds a small unnecessary visual effect + ;;(define-key map [down-mouse-2] 'dframe-quick-mouse) + + (define-key map [down-mouse-3] 'dframe-popup-kludge) + + ;; This lets the user scroll as if we had a scrollbar... well maybe not + (define-key map [mode-line mouse-2] 'dframe-mouse-hscroll) + ;; another handy place users might click to get our menu. + (define-key map [mode-line down-mouse-1] + 'dframe-popup-kludge) + + ;; We can't switch buffers with the buffer mouse menu. Lets hack it. + (define-key map [C-down-mouse-1] 'dframe-hack-buffer-menu) + + ;; Lastly, we want to track the mouse. Play here + (define-key map [mouse-movement] 'dframe-track-mouse)) (defun dframe-live-p (frame) "Return non-nil if FRAME is currently available." @@ -296,40 +282,10 @@ CREATE-HOOK is a hook to run after creating a frame." ;; Declare this buffer a dedicated frame (setq dframe-controlled local-mode-fn) - (if (featurep 'xemacs) - (progn - ;; Hack the XEmacs mouse-motion handler - (set (make-local-variable 'mouse-motion-handler) - 'dframe-track-mouse-xemacs) - ;; Hack the double click handler - (make-local-variable 'mouse-track-click-hook) - (add-hook 'mouse-track-click-hook - (lambda (event count) - (if (/= (event-button event) 1) - nil ; Do normal operations. - (cond ((eq count 1) - (dframe-quick-mouse event)) - ((or (eq count 2) - (eq count 3)) - (dframe-click event) - (dframe-quick-mouse event))) - ;; Don't do normal operations. - t)))) - ;; Enable mouse tracking in emacs - (if dframe-track-mouse-function - (set (make-local-variable 'track-mouse) t))) ;this could be messy. -;;;; DISABLED: This causes problems for users with multiple frames. -;;;; ;; Set this up special just for the passed in buffer -;;;; ;; Terminal minibuffer stuff does not require this. -;;;; (if (and (or (assoc 'minibuffer parameters) -;;;; ;; XEmacs plist is not an association list -;;;; (member 'minibuffer parameters)) -;;;; window-system (not (eq window-system 'pc)) -;;;; (null default-minibuffer-frame)) -;;;; (progn -;;;; (make-local-variable 'default-minibuffer-frame) -;;;; (setq default-minibuffer-frame dframe-attached-frame)) -;;;; ) + ;; Enable mouse tracking in emacs + (if dframe-track-mouse-function + (set (make-local-variable 'track-mouse) t)) ;this could be messy. + ;; Override `temp-buffer-show-hook' so that help and such ;; put their stuff into a frame other than our own. ;; Correct use of `temp-buffer-show-function': Bob Weiner @@ -350,8 +306,7 @@ CREATE-HOOK is a hook to run after creating a frame." (funcall dframe-controlled -1) (set buffer-var nil) ))))) - t t) - ) + t t)) ;; Get the frame to work in (if (frame-live-p (symbol-value cache-var)) (progn @@ -367,39 +322,32 @@ CREATE-HOOK is a hook to run after creating a frame." (if (frame-live-p (symbol-value frame-var)) (raise-frame (symbol-value frame-var)) (set frame-var - (if (featurep 'xemacs) - ;; Only guess height if it is not specified. - (if (member 'height parameters) - (make-frame parameters) - (make-frame (nconc (list 'height - (dframe-needed-height)) - parameters))) - (let* ((mh (dframe-frame-parameter dframe-attached-frame - 'menu-bar-lines)) - (paramsa - ;; Only add a guessed height if one is not specified - ;; in the input parameters. - (if (assoc 'height parameters) - parameters - (append - parameters - (list (cons 'height (+ (or mh 0) (frame-height))))))) - (params - ;; Only add a guessed width if one is not specified - ;; in the input parameters. - (if (assoc 'width parameters) - paramsa - (append - paramsa - (list (cons 'width (frame-width)))))) - (frame - (if (not (eq window-system 'x)) - (make-frame params) - (let ((x-pointer-shape x-pointer-top-left-arrow) - (x-sensitive-text-pointer-shape - x-pointer-hand2)) - (make-frame params))))) - frame))) + (let* ((mh (dframe-frame-parameter dframe-attached-frame + 'menu-bar-lines)) + (paramsa + ;; Only add a guessed height if one is not specified + ;; in the input parameters. + (if (assoc 'height parameters) + parameters + (append + parameters + (list (cons 'height (+ (or mh 0) (frame-height))))))) + (params + ;; Only add a guessed width if one is not specified + ;; in the input parameters. + (if (assoc 'width parameters) + paramsa + (append + paramsa + (list (cons 'width (frame-width)))))) + (frame + (if (not (eq window-system 'x)) + (make-frame params) + (let ((x-pointer-shape x-pointer-top-left-arrow) + (x-sensitive-text-pointer-shape + x-pointer-hand2)) + (make-frame params))))) + frame)) ;; Put the buffer into the frame (save-excursion (select-frame (symbol-value frame-var)) @@ -416,21 +364,13 @@ CREATE-HOOK is a hook to run after creating a frame." ;; On a terminal, raise the frame or the user will ;; be confused. (if (not window-system) - (select-frame (symbol-value frame-var))) - ))) ) - -(defun dframe-reposition-frame (new-frame parent-frame location) - "Move NEW-FRAME to be relative to PARENT-FRAME. -LOCATION can be one of `random', `left', `right', `left-right', or `top-bottom'." - (if (featurep 'xemacs) - (dframe-reposition-frame-xemacs new-frame parent-frame location) - (dframe-reposition-frame-emacs new-frame parent-frame location))) + (select-frame (symbol-value frame-var))))))) ;; Not defined in builds without X, but behind window-system test. (declare-function x-display-pixel-width "xfns.c" (&optional terminal)) (declare-function x-display-pixel-height "xfns.c" (&optional terminal)) -(defun dframe-reposition-frame-emacs (new-frame parent-frame location) +(defun dframe-reposition-frame (new-frame parent-frame location) "Move NEW-FRAME to be relative to PARENT-FRAME. LOCATION can be one of `random', `left-right', `top-bottom', or a cons cell indicating a position of the form (LEFT . TOP)." @@ -513,22 +453,6 @@ a cons cell indicating a position of the form (LEFT . TOP)." (list (cons 'left newleft) (cons 'top newtop)))))) -(defun dframe-reposition-frame-xemacs (_new-frame _parent-frame _location) - "Move NEW-FRAME to be relative to PARENT-FRAME. -LOCATION can be one of `random', `left-right', or `top-bottom'." - ;; Not yet implemented - ) - -;; XEmacs function only. -(defun dframe-needed-height (&optional frame) - "The needed height for the tool bar FRAME (in characters)." - (or frame (setq frame (selected-frame))) - ;; The 1 is the missing mode line or minibuffer - (+ 1 (/ (frame-pixel-height frame) - ;; This obscure code avoids a byte compiler warning in Emacs. - (let ((f 'face-height)) - (funcall f 'default frame))))) - (defun dframe-detach (frame-var cache-var buffer-var) "Detach the frame in symbol FRAME-VAR. CACHE-VAR and BUFFER-VAR are symbols as in `dframe-frame-mode'." @@ -540,8 +464,7 @@ CACHE-VAR and BUFFER-VAR are symbols as in `dframe-frame-mode'." (set cache-var nil) ;; FIXME: Looks very suspicious. Luckily this function is unused. (make-variable-buffer-local frame-var) - (set frame-var oldframe) - ))) + (set frame-var oldframe)))) ;;; Special frame event proxies (defvar dframe-setup-hook nil @@ -748,16 +671,10 @@ who requested the timer. NULL-ON-ERROR is ignored." (defun dframe-set-timer-internal (timeout &optional _null-on-error) "Apply a timer with TIMEOUT to call the dframe timer manager." (when dframe-timer - (if (featurep 'xemacs) - (delete-itimer dframe-timer) - (cancel-timer dframe-timer)) + (cancel-timer dframe-timer) (setq dframe-timer nil)) (when timeout - (setq dframe-timer - (if (featurep 'xemacs) - (start-itimer "dframe" 'dframe-timer-fn - timeout timeout t) - (run-with-idle-timer timeout t 'dframe-timer-fn))))) + (setq dframe-timer (run-with-idle-timer timeout t 'dframe-timer-fn)))) (defun dframe-timer-fn () "Called due to the dframe timer. @@ -768,90 +685,40 @@ Evaluates all cached timer functions in sequence." (funcall (car l))) (setq l (cdr l))))) -;;; Menu hacking for mouse-3 -;; -(defconst dframe-pass-event-to-popup-mode-menu - (let (max-args) - (and (fboundp 'popup-mode-menu) - (fboundp 'function-max-args) - (setq max-args (function-max-args 'popup-mode-menu)) - (not (zerop max-args)))) - "The EVENT arg to `popup-mode-menu' was introduced in XEmacs 21.4.0.") - -;; In XEmacs, we make popup menus work on the item over mouse (as -;; opposed to where the point happens to be.) We attain this by -;; temporarily moving the point to that place. -;; Hrvoje Niksic <hniksic@srce.hr> (defalias 'dframe-popup-kludge - (if (featurep 'xemacs) - (lambda (event) ; XEmacs. - "Pop up a menu related to the clicked on item. -Must be bound to EVENT." - (interactive "e") - (save-excursion - (if dframe-pass-event-to-popup-mode-menu - (popup-mode-menu event) - (goto-char (event-closest-point event)) - (beginning-of-line) - (forward-char (min 5 (- (line-end-position) - (line-beginning-position)))) - (popup-mode-menu)) - ;; Wait for menu to bail out. `popup-mode-menu' (and other popup - ;; menu functions) return immediately. - (let (new) - (while (not (misc-user-event-p (setq new (next-event)))) - (dispatch-event new)) - (dispatch-event new)))) - - (lambda (e) ; Emacs. - "Pop up a menu related to the clicked on item. + (lambda (e) + "Pop up a menu related to the clicked on item. Must be bound to event E." - (interactive "e") - (save-excursion - (mouse-set-point e) - ;; This gets the cursor where the user can see it. - (if (not (bolp)) (forward-char -1)) - (sit-for 0) - (if (fboundp 'mouse-menu-major-mode-map) - (popup-menu (mouse-menu-major-mode-map) e) - (with-no-warnings ; don't warn about obsolete fallback - (mouse-major-mode-menu e nil))))))) + (interactive "e") + (save-excursion + (mouse-set-point e) + ;; This gets the cursor where the user can see it. + (if (not (bolp)) (forward-char -1)) + (sit-for 0) + (popup-menu (mouse-menu-major-mode-map) e)))) ;;; Interactive user functions for the mouse ;; (defalias 'dframe-mouse-event-p - (if (featurep 'xemacs) - 'button-press-event-p - (lambda (event) - "Return t if the event is a mouse related event." - (if (and (listp event) - (member (event-basic-type event) - '(mouse-1 mouse-2 mouse-3))) - t - nil)))) + (lambda (event) + "Return t if the event is a mouse related event." + (if (and (listp event) + (member (event-basic-type event) + '(mouse-1 mouse-2 mouse-3))) + t + nil))) (defun dframe-track-mouse (event) "For motion EVENT, display info about the current line." (interactive "e") (when (and dframe-track-mouse-function - (or (featurep 'xemacs) ;; XEmacs always safe? - (windowp (posn-window (event-end event))) ; Sometimes + (windowp (posn-window (event-end event)))) ; Sometimes ; there is no window to jump into. - )) - (funcall dframe-track-mouse-function event))) -(defun dframe-track-mouse-xemacs (event) - "For motion EVENT, display info about the current line." - (if (functionp (default-value 'mouse-motion-handler)) - (funcall (default-value 'mouse-motion-handler) event)) - (if dframe-track-mouse-function - (funcall dframe-track-mouse-function event))) - (defun dframe-help-echo (_window &optional buffer position) "Display help based context. -The context is in WINDOW, viewing BUFFER, at POSITION. -BUFFER and POSITION are optional because XEmacs doesn't use them." +The context is in WINDOW, viewing BUFFER, at POSITION." (when (and (not dframe-track-mouse-function) (bufferp buffer) dframe-help-echo-function) @@ -862,22 +729,8 @@ BUFFER and POSITION are optional because XEmacs doesn't use them." (funcall dframe-help-echo-function)))))) (defun dframe-mouse-set-point (e) - "Set point based on event E. -Handles clicking on images in XEmacs." - (if (and (featurep 'xemacs) - (save-excursion - (save-window-excursion - (mouse-set-point e) - (event-over-glyph-p e)))) - ;; We are in XEmacs, and clicked on a picture - (let ((ext (event-glyph-extent e))) - ;; This position is back inside the extent where the - ;; junk we pushed into the property list lives. - (if (extent-end-position ext) - (goto-char (1- (extent-end-position ext))) - (mouse-set-point e))) - ;; We are not in XEmacs, OR we didn't click on a picture. - (mouse-set-point e))) + "Set point based on event E." + (mouse-set-point e)) (defun dframe-quick-mouse (e) "Since mouse events are strange, this will keep the mouse nicely positioned. @@ -912,7 +765,6 @@ E is the event causing the click." This must be bound to a mouse event. This should be bound to mouse event E." (interactive "e") - ;; Emacs only. XEmacs handles this via `mouse-track-click-hook'. (cond ((eq (car e) 'down-mouse-1) (dframe-mouse-set-point e)) ((eq (car e) 'mouse-1) @@ -933,15 +785,7 @@ redirected into a window on the attached frame." (if dframe-attached-frame (dframe-select-attached-frame)) (pop-to-buffer buffer nil) (other-window -1) - ;; Fix for using this hook on some platforms: Bob Weiner - (cond ((not (featurep 'xemacs)) - (run-hooks 'temp-buffer-show-hook)) - ((fboundp 'run-hook-with-args) - (run-hook-with-args 'temp-buffer-show-hook buffer)) - ((and (boundp 'temp-buffer-show-hook) - (listp temp-buffer-show-hook)) - (mapcar (function (lambda (hook) (funcall hook buffer))) - temp-buffer-show-hook)))) + (run-hooks 'temp-buffer-show-hook)) (defun dframe-hack-buffer-menu (_e) "Control mouse 1 is buffer menu. @@ -949,9 +793,7 @@ This hack overrides it so that the right thing happens in the main Emacs frame, not in the dedicated frame. Argument E is the event causing this activity." (interactive "e") - (let ((fn (lookup-key global-map (if (featurep 'xemacs) - '(control button1) - [C-down-mouse-1]))) + (let ((fn (lookup-key global-map [C-down-mouse-1])) (oldbuff (current-buffer)) (newbuff nil)) (unwind-protect @@ -977,19 +819,15 @@ broken because of the dedicated frame." (switch-to-buffer buffer) (call-interactively 'switch-to-buffer nil nil))) -;; XEmacs: this can be implemented using mode line keymaps, but there -;; is no use, as we have horizontal scrollbar (as the docstring -;; hints.) (defun dframe-mouse-hscroll (e) "Read a mouse event E from the mode line, and horizontally scroll. -If the mouse is being clicked on the far left, or far right of the -mode-line. This is only useful for non-XEmacs." +If the mouse is being clicked on the far left, or far right of +the mode-line." (interactive "e") (let* ((x-point (car (nth 2 (car (cdr e))))) (pixels-per-10-col (/ (* 10 (frame-pixel-width)) (frame-width))) - (click-col (1+ (/ (* 10 x-point) pixels-per-10-col))) - ) + (click-col (1+ (/ (* 10 x-point) pixels-per-10-col)))) (cond ((< click-col 3) (scroll-left 2)) ((> click-col (- (window-width) 5)) diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index a9443482d63..30a941c7bb6 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -148,7 +148,7 @@ the string of command switches used as the third argument of `diff'." (read-string "Options for diff: " (if (stringp diff-switches) diff-switches - (mapconcat 'identity diff-switches " "))))))) + (mapconcat #'identity diff-switches " "))))))) (let ((current (dired-get-filename t))) (when (or (equal (expand-file-name file) (expand-file-name current)) @@ -173,7 +173,7 @@ With prefix arg, prompt for argument SWITCHES which is options for `diff'." (list (read-string "Options for diff: " (if (stringp diff-switches) diff-switches - (mapconcat 'identity diff-switches " ")))) + (mapconcat #'identity diff-switches " ")))) nil)) (diff-backup (dired-get-filename) switches)) @@ -200,9 +200,12 @@ Examples of PREDICATE: (> mtime1 mtime2) - mark newer files (not (= size1 size2)) - mark files with different sizes - (not (string= (nth 8 fa1) (nth 8 fa2))) - mark files with different modes - (not (and (= (nth 2 fa1) (nth 2 fa2)) - mark files with different UID - (= (nth 3 fa1) (nth 3 fa2)))) and GID." + (not (string= (file-attribute-modes fa1) - mark files with different modes + (file-attribute-modes fa2))) + (not (and (= (file-attribute-user-id fa1) - mark files with different UID + (file-attribute-user-id fa2)) + (= (file-attribute-group-id fa1) - and GID. + (file-attribute-group-id fa2))))" (interactive (list (let* ((target-dir (dired-dwim-target-directory)) @@ -224,12 +227,12 @@ Examples of PREDICATE: (setq file-alist2 (delq (assoc "." file-alist2) file-alist2)) (setq file-alist2 (delq (assoc ".." file-alist2) file-alist2)) (setq file-list1 (mapcar - 'cadr + #'cadr (dired-file-set-difference file-alist1 file-alist2 predicate)) file-list2 (mapcar - 'cadr + #'cadr (dired-file-set-difference file-alist2 file-alist1 predicate))) @@ -243,9 +246,11 @@ Examples of PREDICATE: (lambda () (dired-mark-if (member (dired-get-filename nil t) file-list2) nil))) - (message "Marked in dir1: %s files, in dir2: %s files" - (length file-list1) - (length file-list2)))) + (message "Marked in dir1: %s, in dir2: %s" + (format-message (ngettext "%d file" "%d files" (length file-list1)) + (length file-list1)) + (format-message (ngettext "%d file" "%d files" (length file-list2)) + (length file-list2))))) (defun dired-file-set-difference (list1 list2 predicate) "Combine LIST1 and LIST2 using a set-difference operation. @@ -269,12 +274,12 @@ condition. Two file items are considered to match if they are equal (eval predicate `((fa1 . ,fa1) (fa2 . ,fa2) - (size1 . ,(nth 7 fa1)) - (size2 . ,(nth 7 fa2)) + (size1 . ,(file-attribute-size fa1)) + (size2 . ,(file-attribute-size fa2)) (mtime1 - . ,(float-time (nth 5 fa1))) + . ,(float-time (file-attribute-modification-time fa1))) (mtime2 - . ,(float-time (nth 5 fa2))) + . ,(float-time (file-attribute-modification-time fa2))) ))))) (setq list (cdr list))) list) @@ -301,18 +306,21 @@ List has a form of (file-name full-file-name (attribute-list))." ;; PROGRAM is the program used to change the attribute. ;; OP-SYMBOL is the type of operation (for use in `dired-mark-pop-up'). ;; ARG describes which files to use, as in `dired-get-marked-files'. - (let* ((files (dired-get-marked-files t arg)) + (let* ((files (dired-get-marked-files t arg nil nil t)) ;; The source of default file attributes is the file at point. (default-file (dired-get-filename t t)) (default (when default-file (cond ((eq op-symbol 'touch) (format-time-string "%Y%m%d%H%M.%S" - (nth 5 (file-attributes default-file)))) + (file-attribute-modification-time + (file-attributes default-file)))) ((eq op-symbol 'chown) - (nth 2 (file-attributes default-file 'string))) + (file-attribute-user-id + (file-attributes default-file 'string))) ((eq op-symbol 'chgrp) - (nth 3 (file-attributes default-file 'string)))))) + (file-attribute-group-id + (file-attributes default-file 'string)))))) (prompt (concat "Change " attribute-name " of %s to" (if (eq op-symbol 'touch) " (default now): " @@ -361,11 +369,11 @@ Symbolic modes like `g+w' are allowed. Type M-n to pull the file attributes of the file at point into the minibuffer." (interactive "P") - (let* ((files (dired-get-marked-files t arg)) + (let* ((files (dired-get-marked-files t arg nil nil t)) ;; The source of default file attributes is the file at point. (default-file (dired-get-filename t t)) (modestr (when default-file - (nth 8 (file-attributes default-file)))) + (file-attribute-modes (file-attributes default-file)))) (default (and (stringp modestr) (string-match "^.\\(...\\)\\(...\\)\\(...\\)$" modestr) @@ -402,7 +410,8 @@ into the minibuffer." Type M-n to pull the file attributes of the file at point into the minibuffer." (interactive "P") - (if (memq system-type '(ms-dos windows-nt)) + (if (and (memq system-type '(ms-dos windows-nt)) + (not (file-remote-p default-directory))) (error "chgrp not supported on this system")) (dired-do-chxxx "Group" "chgrp" 'chgrp arg)) @@ -412,7 +421,8 @@ into the minibuffer." Type M-n to pull the file attributes of the file at point into the minibuffer." (interactive "P") - (if (memq system-type '(ms-dos windows-nt)) + (if (and (memq system-type '(ms-dos windows-nt)) + (not (file-remote-p default-directory))) (error "chown not supported on this system")) (dired-do-chxxx "Owner" dired-chown-program 'chown arg)) @@ -476,7 +486,7 @@ Uses the shell command coming from variables `lpr-command' and `lpr-switches' as default." (interactive "P") (require 'lpr) - (let* ((file-list (dired-get-marked-files t arg)) + (let* ((file-list (dired-get-marked-files t arg nil nil t)) (lpr-switches (if (and (stringp printer-name) (string< "" printer-name)) @@ -485,7 +495,7 @@ Uses the shell command coming from variables `lpr-command' and lpr-switches)) (command (dired-mark-read-string "Print %s with: " - (mapconcat 'identity + (mapconcat #'identity (cons lpr-command (if (stringp lpr-switches) (list lpr-switches) @@ -591,7 +601,7 @@ with a prefix argument." (possibilities (file-name-all-completions base-versions (file-name-directory fn))) - (versions (mapcar 'backup-extract-version possibilities))) + (versions (mapcar #'backup-extract-version possibilities))) (if versions (setq dired-file-version-alist (cons (cons fn versions) @@ -668,7 +678,7 @@ In shell syntax this means separating the individual commands with `;'. The output appears in the buffer `*Async Shell Command*'." (interactive - (let ((files (dired-get-marked-files t current-prefix-arg))) + (let ((files (dired-get-marked-files t current-prefix-arg nil nil t))) (list ;; Want to give feedback whether this file or marked files are used: (dired-read-shell-command "& on %s: " current-prefix-arg files) @@ -729,7 +739,7 @@ can be produced by `dired-get-marked-files', for example." ;;Functions dired-run-shell-command and dired-shell-stuff-it do the ;;actual work and can be redefined for customization. (interactive - (let ((files (dired-get-marked-files t current-prefix-arg))) + (let ((files (dired-get-marked-files t current-prefix-arg nil nil t))) (list ;; Want to give feedback whether this file or marked files are used: (dired-read-shell-command "! on %s: " current-prefix-arg files) @@ -816,27 +826,28 @@ can be produced by `dired-get-marked-files', for example." retval)) (lambda (x) (concat cmd-prefix command dired-mark-separator x))))) (concat - (cond (on-each - (format "%s%s" - (mapconcat stuff-it (mapcar 'shell-quote-argument file-list) - cmd-sep) - ;; POSIX shells running a list of commands in the background - ;; (LIST = cmd_1 & [cmd_2 & ... cmd_i & ... cmd_N &]) - ;; return once cmd_N ends, i.e., the shell does not - ;; wait for cmd_i to finish before executing cmd_i+1. - ;; That means, running (shell-command LIST) may not show - ;; the output of all the commands (Bug#23206). - ;; Add 'wait' to force those POSIX shells to wait until - ;; all commands finish. - (or (and parallel-in-background (not w32-shell) - "&wait") - ""))) - (t - (let ((files (mapconcat 'shell-quote-argument - file-list dired-mark-separator))) - (when (cdr file-list) - (setq files (concat dired-mark-prefix files dired-mark-postfix))) - (funcall stuff-it files)))) + (cond + (on-each + (format "%s%s" + (mapconcat stuff-it (mapcar #'shell-quote-argument file-list) + cmd-sep) + ;; POSIX shells running a list of commands in the background + ;; (LIST = cmd_1 & [cmd_2 & ... cmd_i & ... cmd_N &]) + ;; return once cmd_N ends, i.e., the shell does not + ;; wait for cmd_i to finish before executing cmd_i+1. + ;; That means, running (shell-command LIST) may not show + ;; the output of all the commands (Bug#23206). + ;; Add 'wait' to force those POSIX shells to wait until + ;; all commands finish. + (or (and parallel-in-background (not w32-shell) + "&wait") + ""))) + (t + (let ((files (mapconcat #'shell-quote-argument + 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 "&") "")))) ;; This is an extra function so that it can be redefined by ange-ftp. @@ -866,7 +877,7 @@ Else returns nil for success." (set-buffer err-buffer) (erase-buffer) (setq default-directory dir ; caller's default-directory - err (not (eq 0 (apply 'process-file program nil t nil arguments)))) + err (not (eq 0 (apply #'process-file program nil t nil arguments)))) (if err (progn (dired-log (concat program " " (prin1-to-string arguments) "\n")) @@ -970,7 +981,7 @@ command with a prefix argument (the value does not matter)." (goto-char start) ;; Now replace the current line with an entry for NEW-FILE. (dired-update-file-line new-file) nil) - (dired-log (concat "Failed to compress" from-file)) + (dired-log (concat "Failed to (un)compress " from-file)) from-file))) (defvar dired-compress-file-suffixes @@ -990,6 +1001,9 @@ command with a prefix argument (the value does not matter)." ("\\.bz2\\'" "" "bunzip2") ("\\.xz\\'" "" "unxz") ("\\.zip\\'" "" "unzip -o -d %o %i") + ("\\.tar\\.zst\\'" "" "unzstd -c %i | tar -xf -") + ("\\.tzst\\'" "" "unzstd -c %i | tar -xf -") + ("\\.zst\\'" "" "unzstd --rm") ("\\.7z\\'" "" "7z x -aoa -o%o %i") ;; This item controls naming for compression. ("\\.tar\\'" ".tgz" nil) @@ -1014,6 +1028,7 @@ ARGS are command switches passed to PROGRAM.") '(("\\.tar\\.gz\\'" . "tar -cf - %i | gzip -c9 > %o") ("\\.tar\\.bz2\\'" . "tar -cf - %i | bzip2 -c9 > %o") ("\\.tar\\.xz\\'" . "tar -cf - %i | xz -c9 > %o") + ("\\.tar\\.zst\\'" . "tar -cf - %i | zstd -19 -o %o") ("\\.zip\\'" . "zip %o -r --filesync %i")) "Control the compression shell command for `dired-do-compress-to'. @@ -1033,7 +1048,7 @@ Prompt for the archive file name. Choose the archiving command based on the archive file-name extension and `dired-compress-files-alist'." (interactive) - (let* ((in-files (dired-get-marked-files)) + (let* ((in-files (dired-get-marked-files nil nil nil nil t)) (out-file (expand-file-name (read-file-name "Compress to: "))) (rule (cl-find-if (lambda (x) @@ -1058,7 +1073,9 @@ and `dired-compress-files-alist'." (shell-quote-argument (file-name-nondirectory file-desc))) in-files " ")))))) - (message "Compressed %d file(s) to %s" + (message (ngettext "Compressed %d file to %s" + "Compressed %d files to %s" + (length in-files)) (length in-files) (file-name-nondirectory out-file))))))) @@ -1097,12 +1114,17 @@ Return nil if no change in files." nil t) nil t))) ;; We found an uncompression rule. - (when (not - (dired-check-process - (concat "Uncompressing " file) - command - file)) - newname))) + (let ((match (string-match " " command)) + (msg (concat "Uncompressing " file))) + (unless (if match + (dired-check-process msg + (substring command 0 match) + (substring command (1+ match)) + file) + (dired-check-process msg + command + file)) + newname)))) (t ;; We don't recognize the file as compressed, so compress it. ;; Try gzip; if we don't have that, use compress. @@ -1156,7 +1178,7 @@ Return nil if no change in files." ;; Pass t for DISTINGUISH-ONE-MARKED so that a single file which ;; is marked pops up a window. That will help the user see ;; it isn't the current line file. - (let ((files (dired-get-marked-files t arg nil t)) + (let ((files (dired-get-marked-files t arg nil t t)) (string (if (eq op-symbol 'compress) "Compress or uncompress" (capitalize (symbol-name op-symbol))))) (dired-mark-pop-up nil op-symbol files #'y-or-n-p @@ -1186,12 +1208,14 @@ Return nil if no change in files." (string (if (eq op-symbol 'compress) "Compress or uncompress" (capitalize (symbol-name op-symbol))))) (if (not failures) - (message "%s: %d file%s." - string total (dired-plural-s total)) + (message (ngettext "%s: %d file." "%s: %d files." total) + string total) ;; end this bunch of errors: (dired-log-summary - (format "Failed to %s %d of %d file%s" - (downcase string) count total (dired-plural-s total)) + (format (ngettext "Failed to %s %d of %d file" + "Failed to %s %d of %d files" + total) + (downcase string) count total) failures))))) ;;;###autoload @@ -1343,7 +1367,7 @@ See Info node `(emacs)Subdir switches' for more details." ;; Replace space by old marker without moving point. ;; Faster than goto+insdel inside a save-excursion? (when char - (subst-char-in-region opoint (1+ opoint) ?\040 char))))) + (subst-char-in-region opoint (1+ opoint) ?\s char))))) (dired-move-to-filename)) ;;;###autoload @@ -1397,8 +1421,8 @@ files matching `dired-omit-regexp'." (catch 'not-found (if (string= directory cur-dir) (progn - (skip-chars-forward "^\r\n") - (if (eq (following-char) ?\r) + (end-of-line) + (if (dired--hidden-p) (dired-unhide-subdir)) ;; We are already where we should be, except when ;; point is before the subdir line or its total line. @@ -1408,7 +1432,7 @@ files matching `dired-omit-regexp'." ;; else try to find correct place to insert (if (dired-goto-subdir directory) (progn ;; unhide if necessary - (if (= (following-char) ?\r) + (if (dired--hidden-p) ;; Point is at end of subdir line. (dired-unhide-subdir)) ;; found - skip subdir and `total' line @@ -1517,7 +1541,7 @@ files matching `dired-omit-regexp'." (point)) (line-beginning-position 2))) (setq file (directory-file-name file)) - (dired-add-entry file (if (eq ?\040 marker) nil marker))))) + (dired-add-entry file (if (eq ?\s marker) nil marker))))) ;;; Copy, move/rename, making hard and symbolic links @@ -1557,22 +1581,41 @@ Special value `always' suppresses confirmation." (declare-function make-symbolic-link "fileio.c") +(defcustom dired-create-destination-dirs nil + "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." + :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") + +(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))) + (if (or (eq dired-create-destination-dirs 'always) + (yes-or-no-p (format "Create destination dir `%s'? " dir))) + (dired-create-directory dir)))) + (defun dired-copy-file-recursive (from to ok-flag &optional preserve-time top recursive) - (when (and (eq t (car (file-attributes from))) + (when (and (eq t (file-attribute-type (file-attributes from))) (file-in-directory-p to from)) (error "Cannot copy `%s' into its subdirectory `%s'" from to)) (let ((attrs (file-attributes from))) (if (and recursive - (eq t (car attrs)) + (eq t (file-attribute-type attrs)) (or (eq recursive 'always) (yes-or-no-p (format "Recursive copies of %s? " from)))) (copy-directory from to preserve-time) (or top (dired-handle-overwrite to)) (condition-case err - (if (stringp (car attrs)) + (if (stringp (file-attribute-type attrs)) ;; It is a symlink - (make-symbolic-link (car attrs) to ok-flag) + (make-symbolic-link (file-attribute-type attrs) to ok-flag) + (dired-maybe-create-dirs (file-name-directory to)) (copy-file from to ok-flag preserve-time)) (file-date-error (push (dired-make-relative from) @@ -1582,6 +1625,7 @@ Special value `always' suppresses confirmation." ;;;###autoload (defun dired-rename-file (file newname ok-if-already-exists) (dired-handle-overwrite newname) + (dired-maybe-create-dirs (file-name-directory newname)) (rename-file file newname ok-if-already-exists) ; error is caught in -create-files ;; Silently rename the visited file of any buffer visiting this file. (and (get-file-buffer file) @@ -1602,7 +1646,7 @@ Special value `always' suppresses confirmation." (while blist (with-current-buffer (car blist) (if (and buffer-file-name - (dired-in-this-tree buffer-file-name expanded-from-dir)) + (dired-in-this-tree-p buffer-file-name expanded-from-dir)) (let ((modflag (buffer-modified-p)) (to-file (dired-replace-in-string (concat "^" (regexp-quote from-dir)) @@ -1621,7 +1665,7 @@ Special value `always' suppresses confirmation." (while alist (setq elt (car alist) alist (cdr alist)) - (if (dired-in-this-tree (car elt) expanded-dir) + (if (dired-in-this-tree-p (car elt) expanded-dir) ;; ELT's subdir is affected by the rename (dired-rename-subdir-2 elt dir to))) (if (equal dir default-directory) @@ -1751,7 +1795,7 @@ ESC or `q' to not overwrite any of the remaining files, (setq to destname)) ;; If DESTNAME is a subdirectory of FROM, not a symlink, ;; and the method in use is copying, signal an error. - (and (eq t (car (file-attributes destname))) + (and (eq t (file-attribute-type (file-attributes destname))) (eq file-creator 'dired-copy-file) (file-in-directory-p destname from) (error "Cannot copy `%s' into its subdirectory `%s'" @@ -1771,32 +1815,36 @@ ESC or `q' to not overwrite any of the remaining files, (progn (push (dired-make-relative from) failures) - (dired-log "%s `%s' to `%s' failed:\n%s\n" + (dired-log "%s: `%s' to `%s' failed:\n%s\n" operation from to err)))))))) (cond (dired-create-files-failures (setq failures (nconc failures dired-create-files-failures)) (dired-log-summary - (format "%s failed for %d file%s in %d requests" - operation (length failures) - (dired-plural-s (length failures)) - total) + (format (ngettext "%s failed for %d file in %d requests" + "%s failed for %d files in %d requests" + (length failures)) + operation (length failures) total) failures)) (failures (dired-log-summary - (format "%s failed for %d of %d file%s" - operation (length failures) - total (dired-plural-s total)) + (format (ngettext "%s: %d of %d file failed" + "%s: %d of %d files failed" + total) + operation (length failures) total) failures)) (skipped (dired-log-summary - (format "%s: %d of %d file%s skipped" - operation (length skipped) total - (dired-plural-s total)) + (format (ngettext "%s: %d of %d file skipped" + "%s: %d of %d files skipped" + total) + operation (length skipped) total) skipped)) (t - (message "%s: %s file%s" - operation success-count (dired-plural-s success-count))))) + (message (ngettext "%s: %d file done" + "%s: %d files done" + success-count) + operation success-count)))) (dired-move-to-filename)) (defun dired-do-create-files (op-symbol file-creator operation arg @@ -1834,7 +1882,7 @@ Optional arg HOW-TO determines how to treat the target. arguments for the function that is the first element of the list. 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)) + (let* ((fn-list (dired-get-marked-files nil arg nil nil t)) (rfn-list (mapcar #'dired-make-relative fn-list)) (dired-one-file ; fluid variable inside dired-create-files (and (consp fn-list) (null (cdr fn-list)) (car fn-list))) @@ -1850,30 +1898,40 @@ Optional arg HOW-TO determines how to treat the target. (set (make-local-variable 'minibuffer-default-add-function) nil) (setq minibuffer-default defaults)) (dired-mark-read-file-name - (concat (if dired-one-file op1 operation) " %s to: ") + (format "%s %%s %s: " + (if dired-one-file op1 operation) + (if (memq op-symbol '(symlink hardlink)) + ;; Linking operations create links + ;; from the prompted file name; the + ;; other operations copy (etc) to the + ;; prompted file name. + "from" "to")) target-dir op-symbol arg rfn-list default)))) - (into-dir (cond ((null how-to) - ;; Allow users to change the letter case of - ;; a directory on a case-insensitive - ;; filesystem. If we don't test these - ;; conditions up front, file-directory-p - ;; below will return t on a case-insensitive - ;; filesystem, and Emacs will try to move - ;; foo -> foo/foo, which fails. - (if (and (file-name-case-insensitive-p (car fn-list)) - (eq op-symbol 'move) - dired-one-file - (string= (downcase - (expand-file-name (car fn-list))) - (downcase - (expand-file-name target))) - (not (string= - (file-name-nondirectory (car fn-list)) - (file-name-nondirectory target)))) - nil - (file-directory-p target))) - ((eq how-to t) nil) - (t (funcall how-to target))))) + (into-dir + (progn + (unless dired-one-file (dired-maybe-create-dirs target)) + (cond ((null how-to) + ;; Allow users to change the letter case of + ;; a directory on a case-insensitive + ;; filesystem. If we don't test these + ;; conditions up front, file-directory-p + ;; below will return t on a case-insensitive + ;; filesystem, and Emacs will try to move + ;; foo -> foo/foo, which fails. + (if (and (file-name-case-insensitive-p (car fn-list)) + (eq op-symbol 'move) + dired-one-file + (string= (downcase + (expand-file-name (car fn-list))) + (downcase + (expand-file-name target))) + (not (string= + (file-name-nondirectory (car fn-list)) + (file-name-nondirectory target)))) + nil + (file-directory-p target))) + ((eq how-to t) nil) + (t (funcall how-to target)))))) (if (and (consp into-dir) (functionp (car into-dir))) (apply (car into-dir) operation rfn-list fn-list target (cdr into-dir)) (if (not (or dired-one-file into-dir)) @@ -1972,6 +2030,19 @@ Optional arg HOW-TO determines how to treat the target. dired-dirs))) + +;; We use this function in `dired-create-directory' and +;; `dired-create-empty-file'; the return value is the new entry +;; in the updated Dired buffer. +(defun dired--find-topmost-parent-dir (filename) + "Return the topmost nonexistent parent dir of FILENAME. +FILENAME is a full file name." + (let ((try filename) new) + (while (and try (not (file-exists-p try)) (not (equal new try))) + (setq new try + try (directory-file-name (file-name-directory try)))) + new)) + ;;;###autoload (defun dired-create-directory (directory) "Create a directory called DIRECTORY. @@ -1980,18 +2051,32 @@ If DIRECTORY already exists, signal an error." (interactive (list (read-file-name "Create directory: " (dired-current-directory)))) (let* ((expanded (directory-file-name (expand-file-name directory))) - (try expanded) new) + new) (if (file-exists-p expanded) (error "Cannot create directory %s: file exists" expanded)) - ;; Find the topmost nonexistent parent dir (variable `new') - (while (and try (not (file-exists-p try)) (not (equal new try))) - (setq new try - try (directory-file-name (file-name-directory try)))) + (setq new (dired--find-topmost-parent-dir expanded)) (make-directory expanded t) (when new (dired-add-file new) (dired-move-to-filename)))) +;;;###autoload +(defun dired-create-empty-file (file) + "Create an empty file called FILE. + Add a new entry for the new file in the Dired buffer. + Parent directories of FILE are created as needed. + If FILE already exists, signal an error." + (interactive (list (read-file-name "Create empty file: "))) + (let* ((expanded (expand-file-name file)) + new) + (if (file-exists-p expanded) + (error "Cannot create file %s: file exists" expanded)) + (setq new (dired--find-topmost-parent-dir expanded)) + (make-empty-file file 'parents) + (when new + (dired-add-file new) + (dired-move-to-filename)))) + (defun dired-into-dir-with-symlinks (target) (and (file-directory-p target) (not (file-symlink-p target)))) @@ -2342,7 +2427,7 @@ This function takes some pains to conform to `ls -lR' output." (setq switches (dired-replace-in-string "R" "" switches)) (dolist (cur-ass dired-subdir-alist) (let ((cur-dir (car cur-ass))) - (and (dired-in-this-tree cur-dir dirname) + (and (dired-in-this-tree-p cur-dir dirname) (let ((cur-cons (assoc-string cur-dir dired-switches-alist))) (if cur-cons (setcdr cur-cons switches) @@ -2354,7 +2439,7 @@ This function takes some pains to conform to `ls -lR' output." (defun dired-insert-subdir-validate (dirname &optional switches) ;; Check that it is valid to insert DIRNAME with SWITCHES. ;; Signal an error if invalid (e.g. user typed `i' on `..'). - (or (dired-in-this-tree dirname (expand-file-name default-directory)) + (or (dired-in-this-tree-p dirname (expand-file-name default-directory)) (error "%s: not in this directory tree" dirname)) (let ((real-switches (or switches dired-subdir-switches))) (when real-switches @@ -2395,7 +2480,7 @@ of marked files. If KILL-ROOT is non-nil, kill DIRNAME as well." (setq dir (car (car s-alist)) s-alist (cdr s-alist)) (and (or kill-root (not (string-equal dir dirname))) - (dired-in-this-tree dir dirname) + (dired-in-this-tree-p dir dirname) (dired-goto-subdir dir) (setq m-alist (nconc (dired-kill-subdir remember-marks) m-alist)))) m-alist)) @@ -2506,7 +2591,7 @@ Optional third arg LIMIT (>= 1) is a limit to the length of the resulting list. Thus, if SEP is a regexp that only matches itself, - (mapconcat 'identity (dired-split SEP STRING) SEP) + (mapconcat #'identity (dired-split SEP STRING) SEP) is always equal to STRING." (let* ((start (string-match pat str)) @@ -2554,7 +2639,7 @@ When called interactively and not on a subdir line, go to this subdir's line." (defun dired-goto-subdir (dir) "Go to end of header line of DIR in this dired buffer. Return value of point on success, otherwise return nil. -The next char is either \\n, or \\r if DIR is hidden." +The next char is \\n." (interactive (prog1 ; let push-mark display its message (list (expand-file-name @@ -2569,8 +2654,8 @@ The next char is either \\n, or \\r if DIR is hidden." (and elt (goto-char (dired-get-subdir-min elt)) ;; dired-subdir-hidden-p and dired-add-entry depend on point being - ;; at either \r or \n after this function succeeds. - (progn (skip-chars-forward "^\r\n") + ;; at \n after this function succeeds. + (progn (end-of-line) (point))))) ;;;###autoload @@ -2633,7 +2718,7 @@ Lower levels are unaffected." (while rest (setq elt (car rest) rest (cdr rest)) - (if (dired-in-this-tree (directory-file-name (car elt)) dir) + (if (dired-in-this-tree-p (directory-file-name (car elt)) dir) (setq rest nil pos (dired-goto-subdir (car elt)))))) (if pos @@ -2643,18 +2728,13 @@ Lower levels are unaffected." ;;; hiding (defun dired-unhide-subdir () - (let (buffer-read-only) - (subst-char-in-region (dired-subdir-min) (dired-subdir-max) ?\r ?\n))) - -(defun dired-hide-check () - (or selective-display - (error "selective-display must be t for subdir hiding to work!"))) + (with-silent-modifications + (dired--unhide (dired-subdir-min) (dired-subdir-max)))) (defun dired-subdir-hidden-p (dir) - (and selective-display - (save-excursion - (dired-goto-subdir dir) - (= (following-char) ?\r)))) + (save-excursion + (dired-goto-subdir dir) + (dired--hidden-p))) ;;;###autoload (defun dired-hide-subdir (arg) @@ -2662,8 +2742,7 @@ Lower levels are unaffected." Optional prefix arg is a repeat factor. Use \\[dired-hide-all] to (un)hide all directories." (interactive "p") - (dired-hide-check) - (let ((modflag (buffer-modified-p))) + (with-silent-modifications (while (>= (setq arg (1- arg)) 0) (let* ((cur-dir (dired-current-directory)) (hidden-p (dired-subdir-hidden-p cur-dir)) @@ -2672,12 +2751,11 @@ Use \\[dired-hide-all] to (un)hide all directories." buffer-read-only) ;; keep header line visible, hide rest (goto-char (dired-get-subdir-min elt)) - (skip-chars-forward "^\n\r") + (end-of-line) (if hidden-p - (subst-char-in-region (point) end-pos ?\r ?\n) - (subst-char-in-region (point) end-pos ?\n ?\r))) - (dired-next-subdir 1 t)) - (restore-buffer-modified-p modflag))) + (dired--unhide (point) end-pos) + (dired--hide (point) end-pos))) + (dired-next-subdir 1 t)))) ;;;###autoload (defun dired-hide-all (&optional ignored) @@ -2685,28 +2763,20 @@ Use \\[dired-hide-all] to (un)hide all directories." If there is already something hidden, make everything visible again. Use \\[dired-hide-subdir] to (un)hide a particular subdirectory." (interactive "P") - (dired-hide-check) - (let ((modflag (buffer-modified-p)) - buffer-read-only) - (if (save-excursion - (goto-char (point-min)) - (search-forward "\r" nil t)) - ;; unhide - bombs on \r in filenames - (subst-char-in-region (point-min) (point-max) ?\r ?\n) + (with-silent-modifications + (if (text-property-any (point-min) (point-max) 'invisible 'dired) + (dired--unhide (point-min) (point-max)) ;; hide - (let ((pos (point-max)) ; pos of end of last directory - (alist dired-subdir-alist)) - (while alist ; while there are dirs before pos - (subst-char-in-region (dired-get-subdir-min (car alist)) ; pos of prev dir - (save-excursion - (goto-char pos) ; current dir - ;; we're somewhere on current dir's line - (forward-line -1) - (point)) - ?\n ?\r) - (setq pos (dired-get-subdir-min (car alist))) ; prev dir gets current dir - (setq alist (cdr alist))))) - (restore-buffer-modified-p modflag))) + (let ((pos (point-max))) ; pos of end of last directory + (dolist (subdir dired-subdir-alist) + (let ((start (dired-get-subdir-min subdir)) ; pos of prev dir + (end (save-excursion + (goto-char pos) ; current dir + ;; we're somewhere on current dir's line + (forward-line -1) + (point)))) + (dired--hide start end)) + (setq pos (dired-get-subdir-min subdir))))))) ; prev dir gets current dir ;;;###end dired-ins.el @@ -2732,8 +2802,8 @@ When off, it uses the original predicate." nil nil nil (if dired-isearch-filenames-mode (add-function :before-while (local 'isearch-filter-predicate) - #'dired-isearch-filter-filenames - '((isearch-message-prefix . "filename "))) + #'dired-isearch-filter-filenames + '((isearch-message-prefix . "filename "))) (remove-function (local 'isearch-filter-predicate) #'dired-isearch-filter-filenames)) (when isearch-mode @@ -2749,13 +2819,15 @@ Intended to be added to `isearch-mode-hook'." (get-text-property (point) 'dired-filename))) (define-key isearch-mode-map "\M-sff" 'dired-isearch-filenames-mode) (dired-isearch-filenames-mode 1) - (add-hook 'isearch-mode-end-hook 'dired-isearch-filenames-end nil t))) + (add-hook 'isearch-mode-end-hook #'dired-isearch-filenames-end nil t))) (defun dired-isearch-filenames-end () "Clean up the Dired file name search after terminating isearch." (define-key isearch-mode-map "\M-sff" nil) (dired-isearch-filenames-mode -1) - (remove-hook 'isearch-mode-end-hook 'dired-isearch-filenames-end t)) + (remove-hook 'isearch-mode-end-hook #'dired-isearch-filenames-end t) + (unless isearch-suspended + (custom-reevaluate-setting 'dired-isearch-filenames))) (defun dired-isearch-filter-filenames (beg end) "Test whether some part of the current search match is inside a file name. @@ -2768,15 +2840,15 @@ is part of a file name (i.e., has the text property `dired-filename')." (defun dired-isearch-filenames () "Search for a string using Isearch only in file names in the Dired buffer." (interactive) - (let ((dired-isearch-filenames t)) - (isearch-forward nil t))) + (setq dired-isearch-filenames t) + (isearch-forward nil t)) ;;;###autoload (defun dired-isearch-filenames-regexp () "Search for a regexp using Isearch only in file names in the Dired buffer." (interactive) - (let ((dired-isearch-filenames t)) - (isearch-forward-regexp nil t))) + (setq dired-isearch-filenames t) + (isearch-forward-regexp nil t)) ;; Functions for searching in tags style among marked files. @@ -2786,14 +2858,16 @@ is part of a file name (i.e., has the text property `dired-filename')." "Search for a string through all marked files using Isearch." (interactive) (multi-isearch-files - (dired-get-marked-files nil nil 'dired-nondirectory-p))) + (dired-get-marked-files nil nil #'dired-nondirectory-p nil t))) ;;;###autoload (defun dired-do-isearch-regexp () "Search for a regexp through all marked files using Isearch." (interactive) (multi-isearch-files-regexp - (dired-get-marked-files nil nil 'dired-nondirectory-p))) + (dired-get-marked-files nil nil 'dired-nondirectory-p nil t))) + +(declare-function fileloop-continue "fileloop" ()) ;;;###autoload (defun dired-do-search (regexp) @@ -2801,7 +2875,11 @@ is part of a file name (i.e., has the text property `dired-filename')." Stops when a match is found. To continue searching for next match, use command \\[tags-loop-continue]." (interactive "sSearch marked files (regexp): ") - (tags-search regexp '(dired-get-marked-files nil nil 'dired-nondirectory-p))) + (fileloop-initialize-search + regexp + (dired-get-marked-files nil nil #'dired-nondirectory-p) + 'default) + (fileloop-continue)) ;;;###autoload (defun dired-do-query-replace-regexp (from to &optional delimited) @@ -2814,13 +2892,16 @@ with the command \\[tags-loop-continue]." (query-replace-read-args "Query replace regexp in marked files" t t))) (list (nth 0 common) (nth 1 common) (nth 2 common)))) - (dolist (file (dired-get-marked-files nil nil 'dired-nondirectory-p)) + (dolist (file (dired-get-marked-files nil nil #'dired-nondirectory-p nil t)) (let ((buffer (get-file-buffer file))) (if (and buffer (with-current-buffer buffer buffer-read-only)) (error "File `%s' is visited read-only" file)))) - (tags-query-replace from to delimited - '(dired-get-marked-files nil nil 'dired-nondirectory-p))) + (fileloop-initialize-replace + from to (dired-get-marked-files nil nil #'dired-nondirectory-p) + (if (equal from (downcase from)) nil 'default) + delimited) + (fileloop-continue)) (declare-function xref--show-xrefs "xref") (declare-function xref-query-replace-in-results "xref") @@ -2836,22 +2917,26 @@ directories. REGEXP should use constructs supported by your local `grep' command." (interactive "sSearch marked files (regexp): ") (require 'grep) + (require 'xref) (defvar grep-find-ignored-files) - (defvar grep-find-ignored-directories) - (let* ((files (dired-get-marked-files)) + (declare-function rgrep-find-ignored-directories "grep" (dir)) + (let* ((files (dired-get-marked-files nil nil nil nil t)) (ignores (nconc (mapcar - (lambda (s) (concat s "/")) - grep-find-ignored-directories) + #'file-name-as-directory + (rgrep-find-ignored-directories default-directory)) grep-find-ignored-files)) - (xrefs (mapcan - (lambda (file) - (xref-collect-matches regexp "*" file - (and (file-directory-p file) - ignores))) - files))) - (unless xrefs - (user-error "No matches for: %s" regexp)) - (xref--show-xrefs xrefs nil t))) + (fetcher + (lambda () + (let ((xrefs (mapcan + (lambda (file) + (xref-collect-matches regexp "*" file + (and (file-directory-p file) + ignores))) + files))) + (unless xrefs + (user-error "No matches for: %s" regexp)) + xrefs)))) + (xref--show-xrefs fetcher nil))) ;;;###autoload (defun dired-do-find-regexp-and-replace (from to) @@ -2892,7 +2977,6 @@ instead." (provide 'dired-aux) ;; Local Variables: -;; byte-compile-dynamic: t ;; generated-autoload-file: "dired-loaddefs.el" ;; End: diff --git a/lisp/dired-x.el b/lisp/dired-x.el index 2f2a32e0a6b..462fa4ee152 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -137,13 +137,8 @@ folding to be used on case-insensitive filesystems only." (file-name-case-insensitive-p dir) dired-omit-case-fold)) -;; For backward compatibility -(define-obsolete-variable-alias 'dired-omit-files-p 'dired-omit-mode "22.1") (define-minor-mode dired-omit-mode "Toggle omission of uninteresting files in Dired (Dired-Omit mode). -With a prefix argument ARG, enable Dired-Omit mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Dired-Omit mode is a buffer-local minor mode. When enabled in a Dired buffer, Dired does not list files whose filenames match @@ -164,7 +159,7 @@ See Info node `(dired-x) Omitting Variables' for more information." (put 'dired-omit-mode 'safe-local-variable 'booleanp) -(defcustom dired-omit-files "^\\.?#\\|^\\.$\\|^\\.\\.$" +(defcustom dired-omit-files "\\`[.]?#\\|\\`[.][.]?\\'" "Filenames matching this regexp will not be displayed. This only has effect when `dired-omit-mode' is t. See interactive function `dired-omit-mode' (\\[dired-omit-mode]) and variable @@ -194,21 +189,6 @@ toggle between those two." :type 'boolean :group 'dired-x) -(defcustom dired-enable-local-variables t - "Control use of local-variables lists in Dired. -This temporarily overrides the value of `enable-local-variables' when -listing a directory. See also `dired-local-variables-file'." - :risky t - :type '(choice (const :tag "Query Unsafe" t) - (const :tag "Safe Only" :safe) - (const :tag "Do all" :all) - (const :tag "Ignore" nil) - (other :tag "Query" other)) - :group 'dired-x) - -(make-obsolete-variable 'dired-enable-local-variables - "use a standard `dir-locals-file' instead." "24.1") - (defcustom dired-guess-shell-gnutar (catch 'found (dolist (exe '("tar" "gtar")) @@ -332,7 +312,6 @@ See also the functions: `dired-do-find-marked-files'" (interactive) ;; These must be done in each new dired buffer. - (dired-hack-local-variables) (dired-omit-startup)) @@ -466,6 +445,7 @@ See variables `dired-texinfo-unclean-extensions', dired-tex-unclean-extensions (list ".dvi")))) +(defvar archive-superior-buffer) (defvar tar-superior-buffer) ;;; JUMP. @@ -482,8 +462,14 @@ Interactively with prefix argument, read FILE-NAME." (interactive (list nil (and current-prefix-arg (read-file-name "Jump to Dired file: ")))) - (if (bound-and-true-p tar-subfile-mode) - (switch-to-buffer tar-superior-buffer) + (cond + ((and (bound-and-true-p archive-subfile-mode) + (buffer-live-p archive-superior-buffer)) + (switch-to-buffer archive-superior-buffer)) + ((and (bound-and-true-p tar-subfile-mode) + (buffer-live-p tar-superior-buffer)) + (switch-to-buffer tar-superior-buffer)) + (t ;; Expand file-name before `dired-goto-file' call: ;; `dired-goto-file' requires its argument to be an absolute ;; file name; the result of `read-file-name' could be @@ -511,7 +497,7 @@ Interactively with prefix argument, read FILE-NAME." ;; Toggle omitting, if it is on, and try again. (when dired-omit-mode (dired-omit-mode) - (dired-goto-file file)))))))) + (dired-goto-file file))))))))) ;;;###autoload (defun dired-jump-other-window (&optional file-name) @@ -643,9 +629,12 @@ Optional fifth argument CASE-FOLD-P specifies the value of (let ((dired-marker-char (if unflag-p ?\s dired-marker-char))) (dired-mark-if (and - ;; not already marked - (= (following-char) ?\s) - ;; uninteresting + (if unflag-p + ;; Already marked. + (not (= (following-char) ?\s)) + ;; Not already marked. + (= (following-char) ?\s)) + ;; Interesting. (let ((fn (dired-get-filename localp t)) ;; Match patterns case-insensitively on case-insensitive ;; systems @@ -787,34 +776,6 @@ Also useful for `auto-mode-alist' like this: ;; mechanism is provided for special handling of the working directory in ;; special major modes. -(define-obsolete-variable-alias 'default-directory-alist - 'dired-default-directory-alist "24.1") - -;; It's easier to add to this alist than redefine function -;; default-directory while keeping the old information. -(defconst dired-default-directory-alist - '((dired-mode . (if (fboundp 'dired-current-directory) - (dired-current-directory) - default-directory))) - "Alist of major modes and their opinion on `default-directory'. -Each element has the form (MAJOR . EXPRESSION). -The function `dired-default-directory' evaluates EXPRESSION to -determine a default directory.") - -(put 'dired-default-directory-alist 'risky-local-variable t) ; gets eval'd -(make-obsolete-variable 'dired-default-directory-alist - "this feature is due to be removed." "24.1") - -(defun dired-default-directory () - "Return the `dired-default-directory-alist' entry for the current major-mode. -If none, return `default-directory'." - ;; It looks like this was intended to be something of a "general" - ;; feature, but it only ever seems to have been used in - ;; dired-smart-shell-command, and doesn't seem worth keeping around. - (declare (obsolete nil "24.1")) - (or (eval (cdr (assq major-mode dired-default-directory-alist))) - default-directory)) - (defun dired-smart-shell-command (command &optional output-buffer error-buffer) "Like function `shell-command', but in the current Virtual Dired directory." (interactive @@ -831,85 +792,6 @@ If none, return `default-directory'." (shell-command command output-buffer error-buffer))) -;;; LOCAL VARIABLES FOR DIRED BUFFERS. - -;; Brief Description (This feature is obsolete as of Emacs 24.1) -;; -;; * `dired-extra-startup' is part of the `dired-mode-hook'. -;; -;; * `dired-extra-startup' calls `dired-hack-local-variables' -;; -;; * `dired-hack-local-variables' checks the value of -;; `dired-local-variables-file' -;; -;; * Check if `dired-local-variables-file' is a non-nil string and is a -;; filename found in the directory of the Dired Buffer being created. -;; -;; * If `dired-local-variables-file' satisfies the above, then temporarily -;; include it in the Dired Buffer at the bottom. -;; -;; * Set `enable-local-variables' temporarily to the user variable -;; `dired-enable-local-variables' and run `hack-local-variables' on the -;; Dired Buffer. - -(defcustom dired-local-variables-file (convert-standard-filename ".dired") - "Filename, as string, containing local Dired buffer variables to be hacked. -If this file found in current directory, then it will be inserted into dired -buffer and `hack-local-variables' will be run. See Info node -`(emacs)File Variables' for more information on local variables. -See also `dired-enable-local-variables'." - :type 'file - :group 'dired) - -(make-obsolete-variable 'dired-local-variables-file 'dir-locals-file "24.1") - -(defun dired-hack-local-variables () - "Evaluate local variables in `dired-local-variables-file' for Dired buffer." - (declare (obsolete hack-dir-local-variables-non-file-buffer "24.1")) - (and (stringp dired-local-variables-file) - (file-exists-p dired-local-variables-file) - (let ((opoint (point-max)) - (inhibit-read-only t) - ;; In case user has `enable-local-variables' set to nil we - ;; override it locally with dired's variable. - (enable-local-variables dired-enable-local-variables)) - ;; Insert 'em. - (save-excursion - (goto-char opoint) - (insert "\^L\n") - (insert-file-contents dired-local-variables-file)) - ;; Hack 'em. - (unwind-protect - (let ((buffer-file-name dired-local-variables-file)) - (hack-local-variables)) - ;; Delete this stuff: `eobp' is used to find last subdir by dired.el. - (delete-region opoint (point-max))) - ;; Make sure that the mode line shows the proper information. - (dired-sort-set-mode-line)))) - -;; Does not seem worth a dedicated command. -;; See the more general features in files-x.el. -(defun dired-omit-here-always () - "Create `dir-locals-file' setting `dired-omit-mode' to t in `dired-mode'. -If in a Dired buffer, reverts it." - (declare (obsolete add-dir-local-variable "24.1")) - (interactive) - (if (file-exists-p dired-local-variables-file) - (error "Old-style dired-local-variables-file `./%s' found; -replace it with a dir-locals-file `./%s'" - dired-local-variables-file - dir-locals-file)) - (if (file-exists-p dir-locals-file) - (message "File `./%s' already exists." dir-locals-file) - (add-dir-local-variable 'dired-mode 'subdirs nil) - (add-dir-local-variable 'dired-mode 'dired-omit-mode t) - ;; Run extra-hooks and revert directory. - (when (derived-mode-p 'dired-mode) - (hack-dir-local-variables-non-file-buffer) - (dired-extra-startup) - (dired-revert)))) - - ;;; GUESS SHELL COMMAND. ;; Brief Description: @@ -1335,7 +1217,8 @@ displayed this way is restricted by the height of the current window and To keep Dired buffer displayed, type \\[split-window-below] first. To display just marked files, type \\[delete-other-windows] first." (interactive "P") - (dired-simultaneous-find-file (dired-get-marked-files) noselect)) + (dired-simultaneous-find-file (dired-get-marked-files nil nil nil nil t) + noselect)) (defun dired-simultaneous-find-file (file-list noselect) "Visit all files in FILE-LIST and display them simultaneously. @@ -1718,7 +1601,6 @@ If `current-prefix-arg' is non-nil, uses name at point as guess." (provide 'dired-x) ;; Local Variables: -;; byte-compile-dynamic: t ;; generated-autoload-file: "dired-loaddefs.el" ;; End: diff --git a/lisp/dired.el b/lisp/dired.el index c831c5e93da..d47393b1349 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -201,8 +201,10 @@ The target is used in the prompt for file copy, rename etc." ; These variables were deleted and the replacements are on files.el. ; We leave aliases behind for back-compatibility. -(defvaralias 'dired-free-space-program 'directory-free-space-program) -(defvaralias 'dired-free-space-args 'directory-free-space-args) +(define-obsolete-variable-alias 'dired-free-space-program + 'directory-free-space-program "27.1") +(define-obsolete-variable-alias 'dired-free-space-args + 'directory-free-space-args "27.1") ;;; Hook variables @@ -323,7 +325,7 @@ The directory name must be absolute, but need not be fully expanded.") (put 'dired-actual-switches 'safe-local-variable 'dired-safe-switches-p) -(defvar dired-re-inode-size "[0-9 \t]*[.,0-9]*[BkKMGTPEZY]?[ \t]*" +(defvar dired-re-inode-size "[0-9 \t]*[.,0-9]*[BkKMGTPEZY]?[ \t]*" "Regexp for optional initial inode and file size as made by `ls -i -s'.") ;; These regexps must be tested at beginning-of-line, but are also @@ -338,6 +340,8 @@ The directory name must be absolute, but need not be fully expanded.") ;; DOS/Windows-style drive letters in directory names, like in "d:/foo". (defvar dired-re-dir (concat dired-re-maybe-mark dired-re-inode-size "d[^:]")) (defvar dired-re-sym (concat dired-re-maybe-mark dired-re-inode-size "l[^:]")) +(defvar dired-re-socket (concat dired-re-maybe-mark dired-re-inode-size + "[bcsp][^:]")) (defvar dired-re-exe;; match ls permission string of an executable file (mapconcat (lambda (x) (concat dired-re-maybe-mark dired-re-inode-size x)) @@ -362,12 +366,12 @@ This is an alist of the form (SUBDIR . SWITCHES).") (defvaralias 'dired-move-to-filename-regexp 'directory-listing-before-filename-regexp) -(defvar dired-subdir-regexp "^. \\([^\n\r]+\\)\\(:\\)[\n\r]" +(defvar dired-subdir-regexp "^. \\(.+\\)\\(:\\)\n" "Regexp matching a maybe hidden subdirectory line in `ls -lR' output. Subexpression 1 is the subdirectory proper, no trailing colon. The match starts at the beginning of the line and ends after the end -of the line (\\n or \\r). -Subexpression 2 must end right before the \\n or \\r.") +of the line. +Subexpression 2 must end right before the \\n.") (defgroup dired-faces nil "Faces used by Dired." @@ -443,6 +447,12 @@ Subexpression 2 must end right before the \\n or \\r.") (defvar dired-symlink-face 'dired-symlink "Face name used for symbolic links.") +(defface dired-socket + '((t (:inherit font-lock-variable-name-face))) + "Face used for sockets, pipes, block devices and char devices." + :group 'dired-faces + :version "27.1") + (defface dired-ignored '((t (:inherit shadow))) "Face used for files suffixed with `completion-ignored-extensions'." @@ -498,6 +508,10 @@ Subexpression 2 must end right before the \\n or \\r.") (list dired-re-sym '(".+" (dired-move-to-filename) nil (0 dired-symlink-face))) ;; + ;; Sockets, pipes, block devices, char devices. + (list dired-re-socket + '(".+" (dired-move-to-filename) nil (0 'dired-socket))) + ;; ;; Files suffixed with `completion-ignored-extensions'. '(eval . ;; It is quicker to first find just an extension, then go back to the @@ -536,7 +550,7 @@ Subexpression 2 must end right before the \\n or \\r.") ;;; Macros must be defined before they are used, for the byte compiler. (defmacro dired-mark-if (predicate msg) - "Mark all files for which PREDICATE evals to non-nil. + "Mark files for PREDICATE, according to `dired-marker-char'. PREDICATE is evaluated on each line, with point at beginning of line. MSG is a noun phrase for the type of files being marked. It should end with a noun that can be pluralized by adding `s'. @@ -546,7 +560,7 @@ Return value is the number of files marked, or nil if none were marked." (setq count 0) (when ,msg (message "%s %ss%s..." - (cond ((eq dired-marker-char ?\040) "Unmarking") + (cond ((eq dired-marker-char ?\s) "Unmarking") ((eq dired-del-marker dired-marker-char) "Flagging") (t "Marking")) @@ -556,17 +570,17 @@ Return value is the number of files marked, or nil if none were marked." ""))) (goto-char (point-min)) (while (not (eobp)) - (if ,predicate - (progn - (delete-char 1) - (insert dired-marker-char) - (setq count (1+ count)))) + (when ,predicate + (unless (= (following-char) dired-marker-char) + (delete-char 1) + (insert dired-marker-char) + (setq count (1+ count)))) (forward-line 1)) - (if ,msg (message "%s %s%s %s%s." + (when ,msg (message "%s %s%s %s%s" count ,msg (dired-plural-s count) - (if (eq dired-marker-char ?\040) "un" "") + (if (eq dired-marker-char ?\s) "un" "") (if (eq dired-marker-char dired-del-marker) "flagged" "marked")))) (and (> count 0) count))) @@ -646,7 +660,7 @@ marked file, return (t FILENAME) instead of (FILENAME)." ;; save-excursion loses, again (dired-move-to-filename))) -(defun dired-get-marked-files (&optional localp arg filter distinguish-one-marked) +(defun dired-get-marked-files (&optional localp arg filter distinguish-one-marked error) "Return the marked files' names as list of strings. The list is in the same order as the buffer, that is, the car is the first marked file. @@ -663,7 +677,10 @@ Optional third argument FILTER, if non-nil, is a function to select If DISTINGUISH-ONE-MARKED is non-nil, then if we find just one marked file, return (t FILENAME) instead of (FILENAME). -Don't use that together with FILTER." +Don't use that together with FILTER. + +If ERROR is non-nil, signal an error when the list of found files is empty. +ERROR can be a string with the error message." (let ((all-of-them (save-excursion (delq nil (dired-map-over-marks @@ -673,13 +690,17 @@ Don't use that together with FILTER." (when (equal all-of-them '(t)) (setq all-of-them nil)) (if (not filter) - (if (and distinguish-one-marked (eq (car all-of-them) t)) - all-of-them - (nreverse all-of-them)) + (setq result + (if (and distinguish-one-marked (eq (car all-of-them) t)) + all-of-them + (nreverse all-of-them))) (dolist (file all-of-them) (if (funcall filter file) - (push file result))) - result))) + (push file result)))) + (when (and (null result) error) + (user-error (if (stringp error) error "No files specified"))) + result)) + ;; The dired command @@ -765,6 +786,15 @@ as an argument to `dired-goto-file'." (file-name-as-directory (abbreviate-file-name filename)) (abbreviate-file-name filename))))) +(defun dired-grep-read-files () + "Use file at point as the file for grep's default file-name pattern suggestion. +If a directory or nothing is found at point, return nil." + (let ((file-name (dired-file-name-at-point))) + (if (and file-name + (not (file-directory-p file-name))) + file-name))) +(put 'dired-mode 'grep-read-files 'dired-grep-read-files) + ;;;###autoload (define-key ctl-x-map "d" 'dired) ;;;###autoload (defun dired (dirname &optional switches) @@ -841,17 +871,21 @@ If DIRNAME is already in a Dired buffer, that buffer is used without refresh." (not (let ((attributes (file-attributes dirname)) (modtime (visited-file-modtime))) (or (eq modtime 0) - (not (eq (car attributes) t)) - (equal (nth 5 attributes) modtime))))) + (not (eq (file-attribute-type attributes) t)) + (equal (file-attribute-modification-time attributes) modtime))))) + +(defvar auto-revert-remote-files) (defun dired-buffer-stale-p (&optional noconfirm) "Return non-nil if current Dired buffer needs updating. -If NOCONFIRM is non-nil, then this function always returns nil -for a remote directory. This feature is used by Auto Revert mode." +If NOCONFIRM is non-nil, then this function returns nil for a +remote directory, unless `auto-revert-remote-files' is non-nil. +This feature is used by Auto Revert mode." (let ((dirname (if (consp dired-directory) (car dired-directory) dired-directory))) (and (stringp dirname) - (not (when noconfirm (file-remote-p dirname))) + (not (when noconfirm (and (not auto-revert-remote-files) + (file-remote-p dirname)))) (file-readable-p dirname) ;; Do not auto-revert when the dired buffer can be currently ;; written by the user as in `wdired-mode'. @@ -1079,7 +1113,8 @@ wildcards, erases the buffer, and builds the subdir-alist anew (dired-build-subdir-alist) (let ((attributes (file-attributes dirname))) (if (eq (car attributes) t) - (set-visited-file-modtime (nth 5 attributes)))) + (set-visited-file-modtime (file-attribute-modification-time + attributes)))) (set-buffer-modified-p nil) ;; No need to narrow since the whole buffer contains just ;; dired-readin's output, nothing else. The hook can @@ -1255,8 +1290,8 @@ If HDR is non-nil, insert a header line with the directory name." ;; as indicated by `ls-lisp-use-insert-directory-program'. (not (and (featurep 'ls-lisp) (null ls-lisp-use-insert-directory-program))) - (not (and (featurep 'eshell) - (bound-and-true-p eshell-ls-use-in-dired))) + ;; FIXME: Big ugly hack for Eshell's eshell-ls-use-in-dired. + (not (bound-and-true-p eshell-ls-use-in-dired)) (or (file-remote-p dir) (if (eq dired-use-ls-dired 'unspecified) ;; Check whether "ls --dired" gives exit code 0, and @@ -1433,7 +1468,8 @@ ARG and NOCONFIRM, passed from `revert-buffer', are ignored." (dolist (dir hidden-subdirs) (if (dired-goto-subdir dir) (dired-hide-subdir 1)))) - (unless modflag (restore-buffer-modified-p nil))) + (unless modflag (restore-buffer-modified-p nil)) + (hack-dir-local-variables-non-file-buffer)) ;; outside of the let scope ;;; Might as well not override the user if the user changed this. ;;; (setq buffer-read-only t) @@ -1463,12 +1499,36 @@ change; the point does." (list w (dired-get-filename nil t) (line-number-at-pos (window-point w))))) - (get-buffer-window-list nil 0 t)))) + (get-buffer-window-list nil 0 t)) + ;; For each window that showed the current buffer before, scan its + ;; list of previous buffers. For each association thus found save + ;; a triple <point, name, line> where 'point' is that window's + ;; window-point marker stored in the window's list of previous + ;; buffers, 'name' is the filename at the position of 'point' and + ;; 'line' is the line number at the position of 'point'. + (let ((buffer (current-buffer)) + prevs) + (walk-windows + (lambda (window) + (let ((prev (assq buffer (window-prev-buffers window)))) + (when prev + (with-current-buffer buffer + (save-excursion + (goto-char (nth 2 prev)) + (setq prevs + (cons + (list (nth 2 prev) + (dired-get-filename nil t) + (line-number-at-pos (point))) + prevs))))))) + 'nomini t) + prevs))) (defun dired-restore-positions (positions) "Restore POSITIONS saved with `dired-save-positions'." (let* ((buf-file-pos (nth 0 positions)) - (buffer (nth 0 buf-file-pos))) + (buffer (nth 0 buf-file-pos)) + (prevs (nth 2 positions))) (unless (and (nth 1 buf-file-pos) (dired-goto-file (nth 1 buf-file-pos))) (goto-char (point-min)) @@ -1482,13 +1542,26 @@ change; the point does." (dired-goto-file (nth 1 win-file-pos))) (goto-char (point-min)) (forward-line (1- (nth 2 win-file-pos))) - (dired-move-to-filename))))))) + (dired-move-to-filename))))) + (when prevs + (with-current-buffer buffer + (save-excursion + (dolist (prev prevs) + (let ((point (nth 0 prev))) + ;; Sanity check of the point marker. + (when (and (markerp point) + (eq (marker-buffer point) buffer)) + (unless (and (nth 1 prev) + (dired-goto-file (nth 1 prev))) + (goto-char (point-min)) + (forward-line (1- (nth 2 prev)))) + (dired-move-to-filename) + (move-marker point (point) buffer))))))))) (defun dired-remember-marks (beg end) "Return alist of files and their marks, from BEG to END." - (if selective-display ; must unhide to make this work. - (let ((inhibit-read-only t)) - (subst-char-in-region beg end ?\r ?\n))) + (if (dired--find-hidden-pos (point-min) (point-max)) + (dired--unhide (point-min) (point-max))) ;Must unhide to make this work. (let (fil chr alist) (save-excursion (goto-char beg) @@ -1515,15 +1588,12 @@ Each element of ALIST looks like (FILE . MARKERCHAR)." (defun dired-remember-hidden () "Return a list of names of subdirs currently hidden." - (let ((l dired-subdir-alist) dir pos result) - (while l - (setq dir (car (car l)) - pos (cdr (car l)) - l (cdr l)) + (let (result) + (pcase-dolist (`(,dir . ,pos) dired-subdir-alist) (goto-char pos) - (skip-chars-forward "^\r\n") - (if (eq (following-char) ?\r) - (setq result (cons dir result)))) + (end-of-line) + (if (dired--hidden-p) + (push dir result))) result)) (defun dired-insert-old-subdirs (old-subdir-alist) @@ -1611,6 +1681,7 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST." (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) @@ -1757,6 +1828,9 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST." (define-key map [menu-bar immediate revert-buffer] '(menu-item "Refresh" revert-buffer :help "Update contents of shown directories")) + (define-key map [menu-bar immediate dired-number-of-marked-files] + '(menu-item "#Marked Files" dired-number-of-marked-files + :help "Display the number and size of the marked files")) (define-key map [menu-bar immediate dashes] '("--")) @@ -1791,6 +1865,9 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST." (define-key map [menu-bar immediate create-directory] '(menu-item "Create Directory..." dired-create-directory :help "Create a directory")) + (define-key map [menu-bar immediate create-empty-file] + '(menu-item "Create Empty file..." dired-create-empty-file + :help "Create an empty file")) (define-key map [menu-bar immediate wdired-mode] '(menu-item "Edit File Names" wdired-change-to-wdired-mode :help "Put a Dired buffer in a mode in which filenames are editable" @@ -2079,14 +2156,15 @@ Keybindings: mode-name "Dired" ;; case-fold-search nil buffer-read-only t - selective-display t ; for subdirectory hiding mode-line-buffer-identification (propertized-buffer-identification "%17b")) + (add-to-invisibility-spec '(dired . t)) ;; Ignore dired-hide-details-* value of invisible text property by default. (when (eq buffer-invisibility-spec t) (setq buffer-invisibility-spec (list t))) (setq-local revert-buffer-function #'dired-revert) (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)) ;; list-buffers uses this to display the dir being edited in this buffer. @@ -2104,8 +2182,8 @@ Keybindings: (when (featurep 'dnd) (setq-local dnd-protocol-alist (append dired-dnd-protocol-alist dnd-protocol-alist))) - (add-hook 'file-name-at-point-functions 'dired-file-name-at-point nil t) - (add-hook 'isearch-mode-hook 'dired-isearch-filenames-setup nil t) + (add-hook 'file-name-at-point-functions #'dired-file-name-at-point nil t) + (add-hook 'isearch-mode-hook #'dired-isearch-filenames-setup nil t) (run-mode-hooks 'dired-mode-hook)) ;; Idiosyncratic dired commands that don't deal with marks. @@ -2201,7 +2279,7 @@ directory in another window." (let ((raw (dired-get-filename nil t)) file-name) (if (null raw) - (error "No file on this line")) + (user-error "No file on this line")) (setq file-name (file-name-sans-versions raw t)) (if (file-exists-p file-name) file-name @@ -2210,7 +2288,8 @@ directory in another window." (error "File no longer exists; type `g' 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 'dired-find-file "23.2") +(define-obsolete-function-alias 'dired-advertised-find-file + #'dired-find-file "23.2") (defun dired-find-file () "In Dired, visit the file or directory named on this line." (interactive) @@ -2346,12 +2425,7 @@ Otherwise, an error occurs in these cases." (setq start (match-end 0)))))) ;; Hence we don't need to worry about converting `\\' back to `\'. - (setq file (read (concat "\"" file "\""))) - ;; The above `read' will return a unibyte string if FILE - ;; contains eight-bit-control/graphic characters. - (if (and enable-multibyte-characters - (not (multibyte-string-p file))) - (setq file (string-to-multibyte file))))) + (setq file (read (concat "\"" file "\""))))) (and file (files--name-absolute-system-p file) (setq already-absolute t)) (cond @@ -2463,6 +2537,34 @@ See options: `dired-hide-details-hide-symlink-targets' and 'remove-from-invisibility-spec) 'dired-hide-details-link)) +;;; Functions to hide/unhide text + +(defun dired--find-hidden-pos (start end) + (text-property-any start end 'invisible 'dired)) + +(defun dired--hidden-p (&optional pos) + (eq (get-char-property (or pos (point)) 'invisible) 'dired)) + +(defun dired--hide (start end) + ;; The old code used selective-display which only works at + ;; a line-granularity, so it used start and end positions that where + ;; approximate ("anywhere on the line is fine"). + (save-excursion + (put-text-property (progn (goto-char start) (line-end-position)) + (progn (goto-char end) (line-end-position)) + 'invisible 'dired))) + +(defun dired--unhide (start end) + ;; The old code used selective-display which only works at + ;; a line-granularity, so it used start and end positions that where + ;; approximate ("anywhere on the line is fine"). + ;; FIXME: This also removes other invisible properties! + (save-excursion + (remove-text-properties + (progn (goto-char start) (line-end-position)) + (progn (goto-char end) (line-end-position)) + '(invisible)))) + ;;; Functions for finding the file name in a dired buffer line. (defvar dired-permission-flags-regexp @@ -2502,12 +2604,11 @@ Return the position of the beginning of the filename, or nil if none found." ;; This is the UNIX version. (if (get-text-property (point) 'dired-filename) (goto-char (next-single-property-change (point) 'dired-filename)) - (let (opoint file-type executable symlink hidden used-F eol) - (setq used-F (dired-check-switches dired-actual-switches "F" "classify") - opoint (point) - eol (line-end-position) - hidden (and selective-display - (save-excursion (search-forward "\r" eol t)))) + (let ((opoint (point)) + (used-F (dired-check-switches dired-actual-switches "F" "classify")) + (eol (line-end-position)) + (hidden (dired--hidden-p)) + file-type executable symlink) (if hidden nil (save-excursion ;; Find out what kind of file this is: @@ -2608,7 +2709,7 @@ You can then feed the file name(s) to other commands with \\[yank]." ((null (buffer-name buf)) ;; Buffer is killed - clean up: (setq dired-buffers (delq elt dired-buffers))) - ((dired-in-this-tree dir (car elt)) + ((dired-in-this-tree-p dir (car elt)) (with-current-buffer buf (and (assoc dir dired-subdir-alist) (or (null file) @@ -2681,10 +2782,12 @@ You can then feed the file name(s) to other commands with \\[yank]." ;;; utility functions -(defun dired-in-this-tree (file dir) +(defun dired-in-this-tree-p (file dir) ;;"Is FILE part of the directory tree starting at DIR?" (let (case-fold-search) (string-match-p (concat "^" (regexp-quote dir)) file))) +(define-obsolete-function-alias 'dired-in-this-tree + 'dired-in-this-tree-p "27.1") (defun dired-normalize-subdir (dir) ;; Prepend default-directory to DIR if relative file name. @@ -2744,7 +2847,7 @@ You can then feed the file name(s) to other commands with \\[yank]." (if pos (progn (goto-char pos) - (or no-skip (skip-chars-forward "^\n\r")) + (or no-skip (end-of-line)) (point)) (if no-error-if-not-found nil ; return nil if not found @@ -3033,10 +3136,10 @@ TRASH non-nil means to trash the file instead of deleting, provided ("no" ?n "skip to next") ("all" ?! "delete all remaining directories with no more questions") ("quit" ?q "exit"))) - ('"all" (setq recursive 'always dired-recursive-deletes recursive)) - ('"yes" (if (eq recursive 'top) (setq recursive 'always))) - ('"no" (setq recursive nil)) - ('"quit" (keyboard-quit)) + ("all" (setq recursive 'always dired-recursive-deletes recursive)) + ("yes" (if (eq recursive 'top) (setq recursive 'always))) + ("no" (setq recursive nil)) + ("quit" (keyboard-quit)) (_ (keyboard-quit))))) ; catch all unknown answers (setq recursive nil)) ; Empty dir or recursive is nil. (delete-directory file recursive trash)))) @@ -3095,7 +3198,7 @@ non-empty directories is allowed." (dired-recursive-deletes dired-recursive-deletes) (trashing (and trash delete-by-moving-to-trash))) ;; canonicalize file list for pop up - (setq files (nreverse (mapcar #'dired-make-relative files))) + (setq files (mapcar #'dired-make-relative files)) (if (dired-mark-pop-up " *Deletions*" 'delete files dired-deletion-confirmer (format "%s %s " @@ -3128,25 +3231,26 @@ non-empty directories is allowed." (if (not failures) (progress-reporter-done progress-reporter) (dired-log-summary - (format "%d of %d deletion%s failed" - (length failures) count - (dired-plural-s count)) + (format (ngettext "%d of %d deletion failed" + "%d of %d deletions failed" + count) + (length failures) count) failures))))) (message "(No deletions performed)"))) (dired-move-to-filename)) (defun dired-fun-in-all-buffers (directory file fun &rest args) - ;; In all buffers dired'ing DIRECTORY, run FUN with ARGS. - ;; If the buffer has a wildcard pattern, check that it matches FILE. - ;; (FILE does not include a directory component.) - ;; FILE may be nil, in which case ignore it. - ;; Return list of buffers where FUN succeeded (i.e., returned non-nil). + "In all buffers dired'ing DIRECTORY, run FUN with ARGS. +If the buffer has a wildcard pattern, check that it matches FILE. +(FILE does not include a directory component.) +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 (expand-file-name directory) file)) (with-current-buffer buf (if (apply fun args) - (setq success-list (cons (buffer-name buf) success-list))))) + (push buf success-list)))) + ;; FIXME: AFAICT, this return value is not used by any of the callers! success-list)) ;; Delete the entry for FILE from @@ -3183,8 +3287,9 @@ confirmation. To disable the confirmation, see (let ((buf-list (dired-buffers-for-dir (expand-file-name fn)))) (and buf-list (and dired-clean-confirm-killing-deleted-buffers - (y-or-n-p (format "Kill Dired buffer%s of %s, too? " - (dired-plural-s (length buf-list)) + (y-or-n-p (format (ngettext "Kill Dired buffer of %s, too? " + "Kill Dired buffers of %s, too? " + (length buf-list)) (file-name-nondirectory fn)))) (dolist (buf buf-list) (kill-buffer buf)))))) @@ -3221,7 +3326,7 @@ or \"* [3 files]\"." (defun dired-pop-to-buffer (buf) "Pop up buffer BUF in a way suitable for Dired." - (declare (obsolete dired-mark-pop-up "24.3")) + (declare (obsolete pop-to-buffer "24.3")) (let ((split-window-preferred-function (lambda (window) (or (and (let ((split-height-threshold 0)) @@ -3379,7 +3484,7 @@ no ARGth marked file is found before this line." (and (dired-goto-file file) (progn (beginning-of-line) - (if (not (equal ?\040 (following-char))) + (if (not (equal ?\s (following-char))) (following-char)))))) (defun dired-mark-files-in-region (start end) @@ -3437,7 +3542,7 @@ If looking at a subdir, unmark all its files except `.' and `..'. If the region is active in Transient Mark mode, unmark all files in the active region." (interactive (list current-prefix-arg t)) - (let ((dired-marker-char ?\040)) + (let ((dired-marker-char ?\s)) (dired-mark arg interactive))) (defun dired-flag-file-deletion (arg &optional interactive) @@ -3476,11 +3581,11 @@ As always, hidden subdirs are not affected." ;; use subst instead of insdel because it does not move ;; the gap and thus should be faster and because ;; other characters are left alone automatically - (apply 'subst-char-in-region + (apply #'subst-char-in-region (point) (1+ (point)) - (if (eq ?\040 (following-char)) ; SPC - (list ?\040 dired-marker-char) - (list dired-marker-char ?\040)))) + (if (eq ?\s (following-char)) + (list ?\s dired-marker-char) + (list dired-marker-char ?\s)))) (forward-line 1))))) ;;; Commands to mark or flag files based on their characteristics or names. @@ -3511,7 +3616,7 @@ object files--just `.o' will mark more than you might think." (dired-get-filename nil t) t)) "\\'")))) 'dired-regexp-history) - (if current-prefix-arg ?\040))) + (if current-prefix-arg ?\s))) (let ((dired-marker-char (or marker-char dired-marker-char))) (dired-mark-if (and (not (looking-at-p dired-re-dot)) @@ -3520,6 +3625,30 @@ object files--just `.o' will mark more than you might think." (and fn (string-match-p regexp fn)))) "matching file"))) +(defun dired-number-of-marked-files () + "Display the number and total size of the marked files." + (interactive) + (let* ((files (dired-get-marked-files nil nil nil t)) + (nmarked + (cond ((null (cdr files)) + 0) + ((and (= (length files) 2) + (eq (car files) t)) + 1) + (t + (length files)))) + (size (cl-loop for file in files + when (stringp file) + sum (file-attribute-size (file-attributes file))))) + (if (zerop nmarked) + (message "No marked files")) + (message "%d marked file%s (%sB total size)" + nmarked + (if (= nmarked 1) + "" + "s") + (file-size-human-readable size)))) + (defun dired-mark-files-containing-regexp (regexp &optional marker-char) "Mark all files with contents containing REGEXP for use in later commands. A prefix argument means to unmark them instead. @@ -3534,7 +3663,7 @@ since it was last visited." (list (read-regexp (concat (if current-prefix-arg "Unmark" "Mark") " files containing (regexp): ") nil 'dired-regexp-history) - (if current-prefix-arg ?\040))) + (if current-prefix-arg ?\s))) (let ((dired-marker-char (or marker-char dired-marker-char))) (dired-mark-if (and (not (looking-at-p dired-re-dot)) @@ -3571,14 +3700,14 @@ The match is against the non-directory part of the filename. Use `^' "Mark all symbolic links. With prefix argument, unmark or unflag all those files." (interactive "P") - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) + (let ((dired-marker-char (if unflag-p ?\s dired-marker-char))) (dired-mark-if (looking-at-p dired-re-sym) "symbolic link"))) (defun dired-mark-directories (unflag-p) "Mark all directory file lines except `.' and `..'. With prefix argument, unmark or unflag all those files." (interactive "P") - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) + (let ((dired-marker-char (if unflag-p ?\s dired-marker-char))) (dired-mark-if (and (looking-at-p dired-re-dir) (not (looking-at-p dired-re-dot))) "directory file"))) @@ -3587,7 +3716,7 @@ With prefix argument, unmark or unflag all those files." "Mark all executable files. With prefix argument, unmark or unflag all those files." (interactive "P") - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) + (let ((dired-marker-char (if unflag-p ?\s dired-marker-char))) (dired-mark-if (looking-at-p dired-re-exe) "executable file"))) ;; dired-x.el has a dired-mark-sexp interactive command: mark @@ -3597,7 +3726,7 @@ With prefix argument, unmark or unflag all those files." "Flag for deletion files whose names suggest they are auto save files. A prefix argument says to unmark or unflag those files instead." (interactive "P") - (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker))) + (let ((dired-marker-char (if unflag-p ?\s dired-del-marker))) (dired-mark-if ;; It is less than general to check for # here, ;; but it's the only way this runs fast enough. @@ -3836,7 +3965,7 @@ The idea is to set this buffer-locally in special Dired buffers.") (force-mode-line-update))) (define-obsolete-function-alias 'dired-sort-set-modeline - 'dired-sort-set-mode-line "24.3") + #'dired-sort-set-mode-line "24.3") (defun dired-sort-toggle-or-edit (&optional arg) "Toggle sorting by date, and refresh the Dired buffer. @@ -4078,7 +4207,7 @@ Ask means pop up a menu for the user to select one of copy, move or link." (dired dired-dir) ;; The following elements of `misc-data' are the keys ;; from `dired-subdir-alist'. - (mapc 'dired-maybe-insert-subdir (cdr misc-data)) + (mapc #'dired-maybe-insert-subdir (cdr misc-data)) (current-buffer)) (message "Desktop: Directory %s no longer exists." dir) (when desktop-missing-file-warning (sit-for 1)) diff --git a/lisp/dirtrack.el b/lisp/dirtrack.el index e811ccfa846..259d3fdf2e2 100644 --- a/lisp/dirtrack.el +++ b/lisp/dirtrack.el @@ -179,14 +179,9 @@ and ends with a forward slash." dir)) -(define-obsolete-function-alias 'dirtrack-toggle 'dirtrack-mode "23.1") -(define-obsolete-variable-alias 'dirtrackp 'dirtrack-mode "23.1") ;;;###autoload (define-minor-mode dirtrack-mode "Toggle directory tracking in shell buffers (Dirtrack mode). -With a prefix argument ARG, enable Dirtrack mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. This method requires that your shell prompt contain the current working directory at all times, and that you set the variable @@ -205,10 +200,7 @@ directory." "23.1") (define-obsolete-variable-alias 'dirtrack-debug 'dirtrack-debug-mode "23.1") (define-minor-mode dirtrack-debug-mode - "Toggle Dirtrack debugging. -With a prefix argument ARG, enable Dirtrack debugging if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil." + "Toggle Dirtrack debugging." nil nil nil (if dirtrack-debug-mode (display-buffer (get-buffer-create dirtrack-debug-buffer)))) diff --git a/lisp/disp-table.el b/lisp/disp-table.el index f10fc0ebdc7..4a597506774 100644 --- a/lisp/disp-table.el +++ b/lisp/disp-table.el @@ -175,8 +175,8 @@ in the default way after this call." (defun standard-display-g1 (c sc) "Display character C as character SC in the g1 character set. This function assumes that your terminal uses the SO/SI characters; -it is meaningless for an X frame." - (if (memq window-system '(x w32 ns)) +it is meaningless for a graphical frame." + (if (display-graphic-p) (error "Cannot use string glyphs in a windowing system")) (or standard-display-table (setq standard-display-table (make-display-table))) @@ -186,9 +186,9 @@ it is meaningless for an X frame." ;;;###autoload (defun standard-display-graphic (c gc) "Display character C as character GC in graphics character set. -This function assumes VT100-compatible escapes; it is meaningless for an -X frame." - (if (memq window-system '(x w32 ns)) +This function assumes VT100-compatible escapes; it is meaningless +for a graphical frame." + (if (display-graphic-p) (error "Cannot use string glyphs in a windowing system")) (or standard-display-table (setq standard-display-table (make-display-table))) @@ -226,7 +226,7 @@ X frame." char (let ((fid (face-id face))) (if (< fid 64) ; we have 32 - 3(LSB) - 1(SIGN) - 22(CHAR) = 6 bits for face id - (logior char (lsh fid 22)) + (logior char (ash fid 22)) (cons char fid))))) ;;;###autoload @@ -239,7 +239,7 @@ X frame." ;;;###autoload (defun glyph-face (glyph) "Return the face of glyph code GLYPH, or nil if glyph has default face." - (let ((face-id (if (consp glyph) (cdr glyph) (lsh glyph -22)))) + (let ((face-id (if (consp glyph) (cdr glyph) (ash glyph -22)))) (and (> face-id 0) (catch 'face (dolist (face (face-list)) @@ -276,7 +276,7 @@ in `.emacs'." (progn (standard-display-default (unibyte-char-to-multibyte 160) (unibyte-char-to-multibyte 255)) - (unless (or (memq window-system '(x w32 ns))) + (unless (display-graphic-p) (and (terminal-coding-system) (set-terminal-coding-system nil)))) @@ -289,7 +289,7 @@ in `.emacs'." ;; unless some other has been specified. (if (equal current-language-environment "English") (set-language-environment "latin-1")) - (unless (or noninteractive (memq window-system '(x w32 ns))) + (unless (or noninteractive (display-graphic-p)) ;; Send those codes literally to a character-based terminal. ;; If we are using single-byte characters, ;; it doesn't matter which coding system we use. diff --git a/lisp/display-fill-column-indicator.el b/lisp/display-fill-column-indicator.el new file mode 100644 index 00000000000..6d5f5a9f894 --- /dev/null +++ b/lisp/display-fill-column-indicator.el @@ -0,0 +1,78 @@ +;;; display-fill-column-indicator.el --- interface for display-fill-column-indicator -*- lexical-binding: t -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; Maintainer: emacs-devel@gnu.org +;; Keywords: convenience + +;; 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: + +;; Provides a minor mode interface for `display-fill-column-indicator'. +;; +;; Toggle display of the column indicator with M-x +;; display-fill-column-indicator-mode. To enable the indicator in +;; all buffers, use M-x global-display-fill-column-indicator-mode. + + +;; NOTE: Customization variables for +;; `display-fill-column-indicator-column' and +;; `display-fill-column-indicator-char' itself are defined in +;; cus-start.el. + +;;; Code: + +(defgroup display-fill-column-indicator nil + "Display a fill column indicator in the buffer." + :group 'convenience + :group 'display) + + +;;;###autoload +(define-minor-mode display-fill-column-indicator-mode + "Toggle display of fill-column indicator. +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 +character for the indicator setting `display-fill-column-indicator-character'." + :lighter nil + (if display-fill-column-indicator-mode + (progn + (setq display-fill-column-indicator t) + (unless display-fill-column-indicator-character + (if (and (char-displayable-p ?\u2502) + (or (not (display-graphic-p)) + (eq (aref (query-font (car (internal-char-font nil ?\u2502))) 0) + (face-font 'default)))) + (setq display-fill-column-indicator-character ?\u2502) + (setq display-fill-column-indicator-character ?|)))) + (setq display-fill-column-indicator nil))) + +(defun display-fill-column-indicator--turn-on () + "Turn on `display-fill-column-indicator-mode'." + (unless (or (minibufferp) + (and (daemonp) (null (frame-parameter nil 'client)))) + (display-fill-column-indicator-mode))) + +;;;###autoload +(define-globalized-minor-mode global-display-fill-column-indicator-mode + display-fill-column-indicator-mode display-fill-column-indicator--turn-on) + +(provide 'display-fill-column-indicator) + +;;; display-fill-column-indicator.el ends here diff --git a/lisp/dnd.el b/lisp/dnd.el index 73703863e6b..973af7e518b 100644 --- a/lisp/dnd.el +++ b/lisp/dnd.el @@ -130,6 +130,7 @@ Return nil if URI is not a local file." (match-string 0 sysname) sysname)))) (when (and hostname + (not (eq system-type 'windows-nt)) (or (string-equal "localhost" hostname) (string-equal (downcase sysname) hostname) (string-equal sysname-no-dot hostname))) @@ -137,7 +138,7 @@ Return nil if URI is not a local file." (defsubst dnd-unescape-uri (uri) (replace-regexp-in-string - "%[A-Fa-f0-9][A-Fa-f0-9]" + "%[[:xdigit:]][[:xdigit:]]" (lambda (arg) (let ((str (make-string 1 0))) (aset str 0 (string-to-number (substring arg 1) 16)) diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 4b21401e94c..78895ebd7a6 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. ;; ;; Author: Tassilo Horn <tsdh@gnu.org> -;; Maintainer: Tassilo Horn <tsdh@gnu.org> ;; Keywords: files, pdf, ps, dvi ;; This file is part of GNU Emacs. @@ -153,14 +152,21 @@ :group 'multimedia :prefix "doc-view-") -(defcustom doc-view-ghostscript-program "gs" +(defcustom doc-view-ghostscript-program + (cond + ((memq system-type '(windows-nt ms-dos)) + "gswin32c") + (t + "gs")) "Program to convert PS and PDF files to PNG." :type 'file - :group 'doc-view) + :version "27.1") (defcustom doc-view-pdfdraw-program (cond ((executable-find "pdfdraw") "pdfdraw") + ((executable-find "mudraw") "mudraw") + ((executable-find "mutool") "mutool") (t "mudraw")) "Name of MuPDF's program to convert PDF files to PNG." :type 'file @@ -182,17 +188,20 @@ (defcustom doc-view-ghostscript-options '("-dSAFER" ;; Avoid security problems when rendering files from untrusted ;; sources. - "-dNOPAUSE" "-sDEVICE=png16m" "-dTextAlphaBits=4" + "-dNOPAUSE" "-dTextAlphaBits=4" "-dBATCH" "-dGraphicsAlphaBits=4" "-dQUIET") "A list of options to give to ghostscript." - :type '(repeat string) - :group 'doc-view) + :type '(repeat string)) + +(defcustom doc-view-ghostscript-device "png16m" + "Output device to give to ghostscript." + :type 'string + :version "27.1") (defcustom doc-view-resolution 100 "Dots per inch resolution used to render the documents. Higher values result in larger images." - :type 'number - :group 'doc-view) + :type 'number) (defcustom doc-view-scale-internally t "Whether we should try to rescale images ourselves. @@ -207,8 +216,7 @@ scaling." Has only an effect if `doc-view-scale-internally' is non-nil and support for scaling is compiled into emacs." :version "24.1" - :type 'number - :group 'doc-view) + :type 'number) (defcustom doc-view-dvipdfm-program "dvipdfm" "Program to convert DVI files to PDF. @@ -218,8 +226,7 @@ converted to PNG. If this and `doc-view-dvipdf-program' are set, `doc-view-dvipdf-program' will be preferred." - :type 'file - :group 'doc-view) + :type 'file) (defcustom doc-view-dvipdf-program "dvipdf" "Program to convert DVI files to PDF. @@ -229,8 +236,7 @@ converted to PNG. If this and `doc-view-dvipdfm-program' are set, `doc-view-dvipdf-program' will be preferred." - :type 'file - :group 'doc-view) + :type 'file) (define-obsolete-variable-alias 'doc-view-unoconv-program 'doc-view-odf->pdf-converter-program @@ -245,8 +251,7 @@ If this and `doc-view-dvipdfm-program' are set, Needed for viewing OpenOffice.org (and MS Office) files." :version "24.4" - :type 'file - :group 'doc-view) + :type 'file) (defcustom doc-view-odf->pdf-converter-function (cond @@ -267,22 +272,19 @@ Needed for viewing OpenOffice.org (and MS Office) files." "Program to convert PS files to PDF. PS files will be converted to PDF before searching is possible." - :type 'file - :group 'doc-view) + :type 'file) (defcustom doc-view-pdftotext-program "pdftotext" "Program to convert PDF files to plain text. Needed for searching." - :type 'file - :group 'doc-view) + :type 'file) (defcustom doc-view-cache-directory (expand-file-name (format "docview%d" (user-uid)) temporary-file-directory) "The base directory, where the PNG images will be saved." - :type 'directory - :group 'doc-view) + :type 'directory) (defvar doc-view-conversion-buffer " *doc-view conversion output*" "The buffer where messages from the converter programs go to.") @@ -293,8 +295,7 @@ After such a refresh newly converted pages will be available for viewing. If set to nil there won't be any refreshes and the pages won't be displayed before conversion of the whole document has finished." - :type 'integer - :group 'doc-view) + :type 'integer) (defcustom doc-view-continuous nil "In Continuous mode reaching the page edge advances to next/previous page. @@ -302,7 +303,6 @@ When non-nil, scrolling a line upward at the bottom edge of the page moves to the next page, and scrolling a line downward at the top edge of the page moves to the previous page." :type 'boolean - :group 'doc-view :version "23.2") ;;;; Internal Variables @@ -354,9 +354,6 @@ of the page moves to the previous page." (defvar doc-view--pending-cache-flush nil "Only used internally.") -(defvar doc-view--previous-major-mode nil - "Only used internally.") - (defvar doc-view--buffer-file-name nil "Only used internally. The file name used for conversion. Normally it's the same as @@ -415,6 +412,7 @@ Typically \"page-%s.png\".") (define-key map "W" 'doc-view-fit-width-to-window) (define-key map "H" 'doc-view-fit-height-to-window) (define-key map "P" 'doc-view-fit-page-to-window) + (define-key map "F" 'doc-view-fit-window-to-page) ;F = frame ;; Killing the buffer (and the process) (define-key map (kbd "K") 'doc-view-kill-proc) ;; Slicing the image @@ -432,22 +430,20 @@ Typically \"page-%s.png\".") (define-key map (kbd "C-c C-c") 'doc-view-toggle-display) ;; Open a new buffer with doc's text contents (define-key map (kbd "C-c C-t") 'doc-view-open-text) - ;; Reconvert the current document. Don't just use revert-buffer - ;; because that resets the scale factor, the page number, ... - (define-key map (kbd "g") 'doc-view-revert-buffer) - (define-key map (kbd "r") 'doc-view-revert-buffer) + (define-key map (kbd "r") 'revert-buffer) map) "Keymap used by `doc-view-mode' when displaying a doc as a set of images.") -(defun doc-view-revert-buffer (&optional ignore-auto noconfirm) - "Like `revert-buffer', but preserves the buffer's current modes." - (interactive (list (not current-prefix-arg))) +(define-obsolete-function-alias 'doc-view-revert-buffer #'revert-buffer "27.1") +(defvar revert-buffer-preserve-modes) +(defun doc-view--revert-buffer (orig-fun &rest args) + "Preserve the buffer's current mode and check PDF sanity." (if (< undo-outer-limit (* 2 (buffer-size))) ;; 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-function) - (revert-buffer ignore-auto noconfirm 'preserve-modes)))) + (let ((revert-buffer-preserve-modes t)) + (apply orig-fun args)))) (if (and (eq 'pdf doc-view-doc-type) (executable-find "pdfinfo")) ;; We don't want to revert if the PDF file is corrupted which @@ -455,7 +451,7 @@ Typically \"page-%s.png\".") ;; file. (TODO: We'd like to have something like that also ;; for other types, at least PS, but I don't know a good way ;; to test if a PS file is complete.) - (if (= 0 (call-process (executable-find "pdfinfo") nil nil nil + (if (= 0 (call-process "pdfinfo" nil nil nil doc-view--buffer-file-name)) (revert) (when (called-interactively-p 'interactive) @@ -495,12 +491,14 @@ Typically \"page-%s.png\".") ;;;; Navigation Commands +;; 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)) +(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)) (defun doc-view-last-page-number () (length doc-view--current-files)) @@ -686,7 +684,7 @@ at the top edge of the page moves to the previous page." (file-error (error (format "Unable to use temporary directory %s: %s" - dir (mapconcat 'identity (cdr error) " ")))))))) + dir (mapconcat #'identity (cdr error) " ")))))))) (defun doc-view--current-cache-dir () "Return the directory where the png files of the current doc should be saved. @@ -875,6 +873,38 @@ min {(window-width / image-width), (window-height / image-height)} times." (setf (doc-view-current-slice) new-slice) (doc-view-goto-page (doc-view-current-page)))))) +(defun doc-view-fit-window-to-page () + "Resize selected window so it just fits the current page. +Resize the containing frame if needed." + (interactive) + (let* ((slice (doc-view-current-slice)) + (img-width (if slice (nth 2 slice) + (car (image-display-size + (image-get-display-property) t)))) + (img-height (if slice (nth 3 slice) + (cdr (image-display-size + (image-get-display-property) t)))) + (win-width (- (nth 2 (window-inside-pixel-edges)) + (nth 0 (window-inside-pixel-edges)))) + (win-height (- (nth 3 (window-inside-pixel-edges)) + (nth 1 (window-inside-pixel-edges)))) + (width-diff (- img-width win-width)) + (height-diff (- img-height win-height)) + (new-frame-params + (append + (if (= (window-width) (frame-width)) + `((width . (text-pixels + . ,(+ (frame-text-width) width-diff)))) + (enlarge-window (/ width-diff (frame-char-width)) 'horiz) + nil) + (if (= (window-height) (frame-height)) + `((height . (text-pixels + . ,(+ (frame-text-height) height-diff)))) + (enlarge-window (/ height-diff (frame-char-height)) nil) + nil)))) + (when new-frame-params + (modify-frame-parameters (selected-frame) new-frame-params)))) + (defun doc-view-reconvert-doc () "Reconvert the current document. Should be invoked when the cached images aren't up-to-date." @@ -909,7 +939,7 @@ Should be invoked when the cached images aren't up-to-date." (let* ((default-directory (or (unhandled-file-name-directory default-directory) (expand-file-name "~/"))) - (proc (apply 'start-process name doc-view-conversion-buffer + (proc (apply #'start-process name doc-view-conversion-buffer program args))) (push proc doc-view--current-converter-processes) (setq mode-line-process (list (format ":%s" proc))) @@ -930,16 +960,31 @@ Should be invoked when the cached images aren't up-to-date." (list "-o" pdf dvi) callback))) +(defun doc-view-pdf-password-protected-ghostscript-p (pdf) + "Return non-nil if a PDF file is password-protected. +The test is performed using `doc-view-ghostscript-program'." + (with-temp-buffer + (apply #'call-process doc-view-ghostscript-program nil (current-buffer) + nil `(,@doc-view-ghostscript-options + "-sNODISPLAY" + ,pdf)) + (goto-char (point-min)) + (search-forward "This file requires a password for access." nil t))) + (defun doc-view-pdf->png-converter-ghostscript (pdf png page callback) - (doc-view-start-process - "pdf/ps->png" doc-view-ghostscript-program - `(,@doc-view-ghostscript-options - ,(format "-r%d" (round doc-view-resolution)) - ,@(if page `(,(format "-dFirstPage=%d" page))) - ,@(if page `(,(format "-dLastPage=%d" page))) - ,(concat "-sOutputFile=" png) - ,pdf) - callback)) + (let ((pdf-passwd (if (doc-view-pdf-password-protected-ghostscript-p pdf) + (read-passwd "Enter password for PDF file: ")))) + (doc-view-start-process + "pdf/ps->png" doc-view-ghostscript-program + `(,@doc-view-ghostscript-options + ,(concat "-sDEVICE=" doc-view-ghostscript-device) + ,(format "-r%d" (round doc-view-resolution)) + ,@(if page `(,(format "-dFirstPage=%d" page))) + ,@(if page `(,(format "-dLastPage=%d" page))) + ,@(if pdf-passwd `(,(format "-sPDFPassword=%s" pdf-passwd))) + ,(concat "-sOutputFile=" png) + ,pdf) + callback))) (defalias 'doc-view-ps->png-converter-ghostscript 'doc-view-pdf->png-converter-ghostscript) @@ -960,14 +1005,36 @@ If PAGE is nil, convert the whole document." ,tiff) callback)) +(defun doc-view-pdfdraw-program-subcommand () + "Return the mutool subcommand replacing mudraw. +Recent MuPDF distributions replaced 'mudraw' with 'mutool draw'." + (when (string-match "mutool[^/\\]*$" doc-view-pdfdraw-program) + '("draw"))) + +(defun doc-view-pdf-password-protected-pdfdraw-p (pdf) + "Return non-nil if a PDF file is password-protected. +The test is performed using `doc-view-pdfdraw-program'." + (with-temp-buffer + (apply #'call-process doc-view-pdfdraw-program nil (current-buffer) nil + `(,@(doc-view-pdfdraw-program-subcommand) + ,(concat "-o" null-device) + ;; In case PDF isn't password-protected, "draw" only one page. + ,pdf "1")) + (goto-char (point-min)) + (search-forward "error: cannot authenticate password" nil t))) + (defun doc-view-pdf->png-converter-mupdf (pdf png page callback) - (doc-view-start-process - "pdf->png" doc-view-pdfdraw-program - `(,(concat "-o" png) - ,(format "-r%d" (round doc-view-resolution)) - ,pdf - ,@(if page `(,(format "%d" page)))) - callback)) + (let ((pdf-passwd (if (doc-view-pdf-password-protected-pdfdraw-p pdf) + (read-passwd "Enter password for PDF file: ")))) + (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)) + ,pdf + ,@(if page `(,(format "%d" page)))) + callback))) (defun doc-view-odf->pdf-converter-unoconv (odf callback) "Convert ODF to PDF asynchronously and call CALLBACK when finished. @@ -1007,8 +1074,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) - (`djvu #'doc-view-djvu->tiff-converter-ddjvu) + ('pdf doc-view-pdf->png-converter-function) + ('djvu #'doc-view-djvu->tiff-converter-ddjvu) (_ #'doc-view-ps->png-converter-ghostscript)) pdf-ps png nil (let ((resolution doc-view-resolution)) @@ -1077,20 +1144,20 @@ Start by converting PAGES, and then the rest." "Convert the current document to text and call CALLBACK when done." (make-directory (doc-view--current-cache-dir) t) (pcase doc-view-doc-type - (`pdf + ('pdf ;; Doc is a PDF, so convert it to TXT (doc-view-pdf->txt doc-view--buffer-file-name txt callback)) - (`ps + ('ps ;; Doc is a PS, so convert it to PDF (which will be converted to ;; TXT thereafter). (let ((pdf (doc-view-current-cache-doc-pdf))) (doc-view-ps->pdf doc-view--buffer-file-name pdf (lambda () (doc-view-pdf->txt pdf txt callback))))) - (`dvi + ('dvi ;; Doc is a DVI. This means that a doc.pdf already exists in its ;; cache subdirectory. (doc-view-pdf->txt (doc-view-current-cache-doc-pdf) txt callback)) - (`odf + ('odf ;; Doc is some ODF (or MS Office) doc. This means that a doc.pdf ;; already exists in its cache subdirectory. (doc-view-pdf->txt (doc-view-current-cache-doc-pdf) txt callback)) @@ -1131,13 +1198,13 @@ Those files are saved in the directory given by the function (doc-view--current-cache-dir)))) (make-directory (doc-view--current-cache-dir) t) (pcase doc-view-doc-type - (`dvi + ('dvi ;; DVI files have to be converted to PDF before Ghostscript can process ;; it. (let ((pdf (doc-view-current-cache-doc-pdf))) (doc-view-dvi->pdf doc-view--buffer-file-name pdf (lambda () (doc-view-pdf/ps->png pdf png-file))))) - (`odf + ('odf ;; ODF files have to be converted to PDF before Ghostscript can ;; process it. (let ((pdf (doc-view-current-cache-doc-pdf)) @@ -1150,11 +1217,11 @@ Those files are saved in the directory given by the function ;; file name. It's named like the input file with the ;; extension replaced by pdf. (funcall doc-view-odf->pdf-converter-function doc-view--buffer-file-name - (lambda () - ;; Rename to doc.pdf - (rename-file opdf pdf) - (doc-view-pdf/ps->png pdf png-file))))) - ((or `pdf `djvu) + (lambda () + ;; Rename to doc.pdf + (rename-file opdf pdf) + (doc-view-pdf/ps->png pdf png-file))))) + ((or 'pdf 'djvu) (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))) @@ -1220,7 +1287,8 @@ dragging it to its bottom-right corner. See also (save-match-data (when (string-match (concat "%%BoundingBox: " "\\([[:digit:]]+\\) \\([[:digit:]]+\\) " - "\\([[:digit:]]+\\) \\([[:digit:]]+\\)") o) + "\\([[:digit:]]+\\) \\([[:digit:]]+\\)") + o) (mapcar #'string-to-number (list (match-string 1 o) (match-string 2 o) @@ -1304,10 +1372,10 @@ ARGS is a list of image descriptors." (let* ((image (if (and file (file-readable-p file)) (if (not (and doc-view-scale-internally (fboundp 'imagemagick-types))) - (apply 'create-image file doc-view--image-type nil args) + (apply #'create-image file doc-view--image-type nil args) (unless (member :width args) (setq args `(,@args :width ,doc-view-image-width))) - (apply 'create-image file 'imagemagick nil args)))) + (apply #'create-image file 'imagemagick nil args)))) (slice (doc-view-current-slice)) (img-width (and image (car (image-size image)))) (displayed-img-width (if (and image slice) @@ -1413,6 +1481,14 @@ For now these keys are useful: (interactive) (tooltip-show (doc-view-current-info))) +;; We define an own major mode for DocView's text display so that we +;; can easily distinguish when we want to toggle back because +;; text-mode is a likely candidate for a default major-mode +;; (bug#34451). +(define-derived-mode doc-view--text-view-mode text-mode "DV/Text" + "View mode used in DocView's text buffers." + (view-mode)) + (defun doc-view-open-text () "Display the current doc's contents as text." (interactive) @@ -1424,15 +1500,22 @@ For now these keys are useful: (buffer-undo-list t) (dv-bfn doc-view--buffer-file-name)) (erase-buffer) + ;; FIXME: Replacing the buffer's PDF content with its txt rendering + ;; is pretty risky. We should probably use *another* + ;; buffer instead, so there's much less risk of + ;; overwriting the PDF file with some text rendering. (set-buffer-multibyte t) (insert-file-contents txt) - (text-mode) + (doc-view--text-view-mode) (setq-local doc-view--buffer-file-name dv-bfn) (set-buffer-modified-p nil) (doc-view-minor-mode) (add-hook 'write-file-functions (lambda () - (when (eq major-mode 'text-mode) + ;; FIXME: If the user changes major mode and then + ;; saves the buffer, the PDF file will be clobbered + ;; with its txt rendering! + (when (eq major-mode 'doc-view--text-view-mode) (error "Cannot save text contents of document %s" buffer-file-name))) nil t)) @@ -1456,7 +1539,7 @@ For now these keys are useful: ;; normal mode. (doc-view-fallback-mode) (doc-view-minor-mode 1)) - ((eq major-mode 'text-mode) + ((eq major-mode 'doc-view--text-view-mode) (let ((buffer-undo-list t)) ;; We're currently viewing the document's text contents, so switch ;; back to . @@ -1698,7 +1781,7 @@ If BACKWARD is non-nil, jump to the previous match." "Find the right single-page converter for the current document type" (pcase-let ((`(,conv-function ,type ,extension) (pcase doc-view-doc-type - (`djvu (list #'doc-view-djvu->tiff-converter-ddjvu 'tiff "tif")) + ('djvu (list #'doc-view-djvu->tiff-converter-ddjvu 'tiff "tif")) (_ (list doc-view-pdf->png-converter-function 'png "png"))))) (setq-local doc-view-single-page-converter-function conv-function) (setq-local doc-view--image-type type) @@ -1728,7 +1811,7 @@ If BACKWARD is non-nil, jump to the previous match." ;; window-parameters in the window-state(s) and then restoring this ;; window-state should call us back (to interpret/use those parameters). (doc-view-goto-page page) - (when slice (apply 'doc-view-set-slice slice)) + (when slice (apply #'doc-view-set-slice slice)) (current-buffer)))) (add-to-list 'desktop-buffer-mode-handlers @@ -1752,12 +1835,7 @@ toggle between displaying the document or editing it as text. ;; returns nil for tar members. (doc-view-fallback-mode) - (let* ((prev-major-mode (if (derived-mode-p 'doc-view-mode) - doc-view--previous-major-mode - (unless (eq major-mode 'fundamental-mode) - major-mode)))) - (kill-all-local-variables) - (setq-local doc-view--previous-major-mode prev-major-mode)) + (major-mode-suspend) (dolist (var doc-view-saved-settings) (set (make-local-variable (car var)) (cdr var))) @@ -1797,22 +1875,22 @@ toggle between displaying the document or editing it as text. (when (not (string= doc-view--buffer-file-name buffer-file-name)) (write-region nil nil doc-view--buffer-file-name)) - (setq-local revert-buffer-function #'doc-view-revert-buffer) + (add-function :around (local 'revert-buffer-function) #'doc-view--revert-buffer) (add-hook 'change-major-mode-hook (lambda () (doc-view-kill-proc) (remove-overlays (point-min) (point-max) 'doc-view t)) nil t) - (add-hook 'clone-indirect-buffer-hook 'doc-view-clone-buffer-hook nil t) - (add-hook 'kill-buffer-hook 'doc-view-kill-proc nil t) - (setq-local desktop-save-buffer 'doc-view-desktop-save-buffer) + (add-hook 'clone-indirect-buffer-hook #'doc-view-clone-buffer-hook nil t) + (add-hook 'kill-buffer-hook #'doc-view-kill-proc nil t) + (setq-local desktop-save-buffer #'doc-view-desktop-save-buffer) (remove-overlays (point-min) (point-max) 'doc-view t) ;Just in case. ;; Keep track of display info ([vh]scroll, page number, overlay, ;; ...) for each window in which this document is shown. (add-hook 'image-mode-new-window-functions - 'doc-view-new-window-function nil t) + #'doc-view-new-window-function nil t) (image-mode-setup-winprops) (setq-local mode-line-position @@ -1828,7 +1906,7 @@ toggle between displaying the document or editing it as text. #'doc-view-scroll-down-or-previous-page)) (setq-local cursor-type nil) (use-local-map doc-view-mode-map) - (add-hook 'after-revert-hook 'doc-view-reconvert-doc nil t) + (add-hook 'after-revert-hook #'doc-view-reconvert-doc nil t) (setq-local bookmark-make-record-function #'doc-view-bookmark-make-record) (setq mode-name "DocView" @@ -1849,14 +1927,7 @@ toggle between displaying the document or editing it as text. '(doc-view-resolution image-mode-winprops-alist))))) (remove-overlays (point-min) (point-max) 'doc-view t) - (if doc-view--previous-major-mode - (funcall doc-view--previous-major-mode) - (let ((auto-mode-alist - (rassq-delete-all - 'doc-view-mode-maybe - (rassq-delete-all 'doc-view-mode - (copy-alist auto-mode-alist))))) - (normal-mode))) + (major-mode-restore '(doc-view-mode-maybe doc-view-mode)) (when vars (setq-local doc-view-saved-settings vars)))) @@ -1875,13 +1946,9 @@ to the next best mode." ;;;###autoload (define-minor-mode doc-view-minor-mode "Toggle displaying buffer via Doc View (Doc View minor mode). -With a prefix argument ARG, enable Doc View minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. See the command `doc-view-mode' for more information on this mode." - nil " DocView" doc-view-minor-mode-map - :group 'doc-view + :lighter " DocView" (when doc-view-minor-mode (add-hook 'change-major-mode-hook (lambda () (doc-view-minor-mode -1)) nil t) (message @@ -1899,6 +1966,84 @@ See the command `doc-view-mode' for more information on this mode." (interactive) (dired doc-view-cache-directory)) +;;;; Presentation mode + +(defvar doc-view-presentation-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\e" 'doc-view-presentation-exit) + (define-key map "q" 'doc-view-presentation-exit) + ;; (define-key map "C" 'doc-view-convert-all-pages) + map)) + +(defvar-local doc-view-presentation--src-data nil) + +(defun doc-view-presentation-exit () + "Leave Doc-View's presentation mode." + (interactive) + (doc-view-presentation-mode -1)) + +(define-minor-mode doc-view-presentation-mode + "Minor mode used while in presentation mode." + :init-value nil :keymap doc-view-presentation-mode-map + (if doc-view-presentation-mode + (progn + (set (make-local-variable 'mode-line-format) nil) + (doc-view-fit-page-to-window) + ;; (doc-view-convert-all-pages) + ) + (kill-local-variable 'mode-line-format) + (let ((pn (doc-view-current-page)) + (win (selected-window))) + (doc-view-presentation--propagate-pn doc-view-presentation--src-data pn) + (setq doc-view-presentation--src-data nil) + (with-selected-window win + (if (and (one-window-p) (window-dedicated-p)) + (delete-frame)))))) + +(defun doc-view-presentation--propagate-pn (src-data pn) + (when src-data + (let ((win (car src-data))) + (when (and (window-live-p win) + (eq (current-buffer) (window-buffer win))) + (select-window win)) + (when (eq (doc-view-current-page) (cdr src-data)) + (doc-view-goto-page pn))))) + +(defun doc-view-presentation () + "Put Doc-View in presentation mode." + (interactive) + (let* ((src-data (cons (selected-window) (doc-view-current-page))) + (mal (display-monitor-attributes-list)) + (monitor-top 0) + (monitor-left 0) + (monitor-height (display-pixel-height)) + (monitor-width (display-pixel-width))) + (dolist (attrs mal) + (when (memq (selected-frame) (alist-get 'frames attrs)) + (let ((geom (alist-get 'geometry attrs))) + (when geom + (setq monitor-top (nth 0 geom)) + (setq monitor-left (nth 1 geom)) + (setq monitor-width (nth 2 geom)) + (setq monitor-height (nth 3 geom)))))) + (let ((frame (make-frame + `((minibuffer . nil) + (fullscreen . fullboth) + (height . ,(ceiling monitor-height (frame-char-height))) + ;; Don't use `ceiling' here since doc-view will center the + ;; image instead. + (width . ,(ceiling monitor-width (frame-char-width))) + (name . "Doc-View-Presentation") + (top . ,monitor-top) (left . ,monitor-left) (user-position . t) + (vertical-scroll-bars . nil) + (left-fringe . 0) (right-fringe . 0) + (menu-bar-lines . 0) + (tool-bar-lines . 0))))) + (select-window (frame-root-window frame)) + (setq doc-view-presentation--src-data src-data) + (set-window-dedicated-p (selected-window) t) + (doc-view-presentation-mode 1)))) + ;;;; Bookmark integration diff --git a/lisp/dom.el b/lisp/dom.el index eb4603a7f2f..d8c44339985 100644 --- a/lisp/dom.el +++ b/lisp/dom.el @@ -78,15 +78,19 @@ A typical attribute is `href'." (defun dom-texts (node &optional separator) "Return all textual data under NODE concatenated with SEPARATOR in-between." - (mapconcat - 'identity - (mapcar - (lambda (elem) - (if (stringp elem) - elem - (dom-texts elem separator))) - (dom-children node)) - (or separator " "))) + (if (eq (dom-tag node) 'script) + "" + (mapconcat + (lambda (elem) + (cond + ((stringp elem) + elem) + ((eq (dom-tag elem) 'script) + "") + (t + (dom-texts elem separator)))) + (dom-children node) + (or separator " ")))) (defun dom-child-by-tag (dom tag) "Return the first child of DOM that is of type TAG." diff --git a/lisp/dos-fns.el b/lisp/dos-fns.el index 7031dfdda6d..c575dd413fc 100644 --- a/lisp/dos-fns.el +++ b/lisp/dos-fns.el @@ -212,9 +212,7 @@ returned unaltered." ;; Override settings chosen at startup. (defun dos-set-default-process-coding-system () (setq default-process-coding-system - (if (default-value 'enable-multibyte-characters) - '(undecided-dos . undecided-dos) - '(raw-text-dos . raw-text-dos)))) + '(undecided-dos . undecided-dos))) (add-hook 'before-init-hook 'dos-set-default-process-coding-system) @@ -271,7 +269,7 @@ returned unaltered." (car where) (if (zerop (cdr where)) (logior (logand tem 65280) value) - (logior (logand tem 255) (lsh value 8)))))) + (logior (logand tem 255) (ash value 8)))))) ((numberp where) (aset regs where (logand value 65535)))))) regs) diff --git a/lisp/dos-w32.el b/lisp/dos-w32.el index b84d85bab15..0c04b8fa7f2 100644 --- a/lisp/dos-w32.el +++ b/lisp/dos-w32.el @@ -342,7 +342,7 @@ filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"." w32-direct-print-region-use-command-dot-com ;; file-attributes fails on LPT ports on Windows 9x but ;; not on NT, so handle both cases for safety. - (eq (or (nth 7 (file-attributes printer)) 0) 0)) + (eq (or (file-attribute-size (file-attributes printer)) 0) 0)) (write-region start end tempfile nil 0) (let ((w32-quote-process-args nil)) (call-process "command.com" nil errbuf nil "/c" diff --git a/lisp/double.el b/lisp/double.el index 54b4b51b4b6..a5e7dcdc4a8 100644 --- a/lisp/double.el +++ b/lisp/double.el @@ -150,9 +150,6 @@ but not `C-u X' or `ESC X' since the X is not the prefix key." ;;;###autoload (define-minor-mode double-mode "Toggle special insertion on double keypresses (Double mode). -With a prefix argument ARG, enable Double mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. When Double mode is enabled, some keys will insert different strings when pressed twice. See `double-map' for details." diff --git a/lisp/ecomplete.el b/lisp/ecomplete.el index c54c110867b..d9f34ef0c00 100644 --- a/lisp/ecomplete.el +++ b/lisp/ecomplete.el @@ -1,4 +1,4 @@ -;;; ecomplete.el --- electric completion of addresses and the like +;;; ecomplete.el --- electric completion of addresses and the like -*- lexical-binding:t -*- ;; Copyright (C) 2006-2019 Free Software Foundation, Inc. @@ -53,22 +53,32 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup ecomplete nil "Electric completion of email addresses and the like." :group 'mail) -(defcustom ecomplete-database-file "~/.ecompleterc" +(defcustom ecomplete-database-file + (locate-user-emacs-file "ecompleterc" "~/.ecompleterc") "The name of the file to store the ecomplete data." - :group 'ecomplete :type 'file) (defcustom ecomplete-database-file-coding-system 'iso-2022-7bit "Coding system used for writing the ecomplete database file." - :type '(symbol :tag "Coding system") - :group 'ecomplete) + :type '(symbol :tag "Coding system")) + +(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 +the times the completion has been used, the second is the +timestamp of the most recent usage, and the third item is the +string that was matched." + :type '(radio (function-item :tag "Sort by usage and newness" ecomplete-decay) + (function-item :tag "Sort by times used" ecomplete-usage) + (function-item :tag "Sort by newness" ecomplete-newness) + (function :tag "Other"))) ;;; Internal variables. @@ -86,7 +96,7 @@ (defun ecomplete-add-item (type key text) "Add item TEXT of TYPE to the database, using KEY as the identifier." (let ((elems (assq type ecomplete-database)) - (now (string-to-number (format-time-string "%s"))) + (now (encode-time nil 'integer)) entry) (unless elems (push (setq elems (list type)) ecomplete-database)) @@ -103,13 +113,13 @@ (with-temp-buffer (let ((coding-system-for-write ecomplete-database-file-coding-system)) (insert "(") - (loop for (type . elems) in ecomplete-database - do - (insert (format "(%s\n" type)) - (dolist (entry elems) - (prin1 entry (current-buffer)) - (insert "\n")) - (insert ")\n")) + (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)))) @@ -119,11 +129,10 @@ (match (regexp-quote match)) (candidates (sort - (loop for (key count time text) in elems - when (string-match match text) - collect (list count time text)) - (lambda (l1 l2) - (> (car l1) (car l2)))))) + (cl-loop for (_key count time text) in elems + when (string-match match text) + collect (list count time text)) + ecomplete-sort-predicate))) (when (> (length candidates) 10) (setcdr (nthcdr 10 candidates) nil)) (unless (zerop (length candidates)) @@ -156,22 +165,22 @@ matches." nil) (setq highlight (ecomplete-highlight-match-line matches line)) (let ((local-map (make-sparse-keymap)) + (prev-func (lambda () (setq line (max (1- line) 0)))) + (next-func (lambda () (setq line (min (1+ line) max-lines)))) selected) (define-key local-map (kbd "RET") (lambda () (setq selected (nth line (split-string matches "\n"))))) - (define-key local-map (kbd "M-n") - (lambda () (setq line (min (1+ line) max-lines)))) - (define-key local-map (kbd "M-p") - (lambda () (setq line (max (1- line) 0)))) + (define-key local-map (kbd "M-n") next-func) + (define-key local-map (kbd "<down>") next-func) + (define-key local-map (kbd "M-p") prev-func) + (define-key local-map (kbd "<up>") prev-func) (let ((overriding-local-map local-map)) (while (and (null selected) (setq command (read-key-sequence highlight)) (lookup-key local-map command)) (apply (key-binding command) nil) (setq highlight (ecomplete-highlight-match-line matches line)))) - (if selected - (message selected) - (message "Abort")) + (message (or selected "Abort")) selected))))) (defun ecomplete-highlight-match-line (matches line) @@ -189,6 +198,46 @@ matches." (forward-char 1))) (buffer-string))) +(defun ecomplete-usage (l1 l2) + (> (car l1) (car l2))) + +(defun ecomplete-newness (l1 l2) + (> (cadr l1) (cadr l2))) + +(defun ecomplete-decay (l1 l2) + (> (ecomplete-decay-1 l1) (ecomplete-decay-1 l2))) + +(defun ecomplete-decay-1 (elem) + ;; We subtract 5% from the item for each week it hasn't been used. + (/ (car elem) + (expt 1.05 (/ (float-time (time-since (cadr elem))) + (* 7 24 60 60))))) + +;; `ecomplete-get-matches' uses substring matching, so also use the `substring' +;; style by default. +(add-to-list 'completion-category-defaults + '(ecomplete (styles basic substring))) + +(defun ecomplete-completion-table (type) + "Return a completion-table suitable for TYPE." + (lambda (string pred action) + (pcase action + (`(boundaries . ,_) nil) + ('metadata `(metadata (category . ecomplete) + (display-sort-function . ,#'identity) + (cycle-sort-function . ,#'identity))) + (_ + (let* ((elems (cdr (assq type ecomplete-database))) + (candidates + (mapcar (lambda (x) (nth 2 x)) + (sort + (cl-loop for x in elems + when (string-prefix-p string (nth 3 x) + completion-ignore-case) + collect (cdr x)) + ecomplete-sort-predicate)))) + (complete-with-action action candidates string pred)))))) + (provide 'ecomplete) ;;; ecomplete.el ends here diff --git a/lisp/edmacro.el b/lisp/edmacro.el index a5b5276a1e1..da3e782bd97 100644 --- a/lisp/edmacro.el +++ b/lisp/edmacro.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1993-1994, 2001-2019 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> -;; Maintainer: Dave Gillespie <daveg@synaptics.com> ;; Version: 2.01 ;; Keywords: abbrev @@ -547,7 +546,7 @@ doubt, use whitespace." ?\M-\^@ ?\s-\^@ ?\S-\^@) when (/= (logand ch bit) 0) concat (format "%c-" pf)) - (let ((ch2 (logand ch (1- (lsh 1 18))))) + (let ((ch2 (logand ch (1- (ash 1 18))))) (cond ((<= ch2 32) (pcase ch2 (0 "NUL") (9 "TAB") (10 "LFD") @@ -623,12 +622,16 @@ This function assumes that the events can be stored in a string." (push (vector 'menu-bar (car ev)) result)) ;; It would be nice to do pop-up menus, too, but not enough ;; info is recorded in macros to make this possible. - (noerror - ;; Just ignore mouse events. + ((or (mouse-event-p ev) (mouse-movement-p ev) + (memq (event-basic-type ev) + (list mouse-wheel-down-event mouse-wheel-up-event + mouse-wheel-right-event + mouse-wheel-left-event))) nil) + (noerror nil) (t - (error "Macros with mouse clicks are not %s" - "supported by this command")))) + (error "`edmacro-fix-menu-commands': Unsupported event: %S" + ev)))) ;; Reverse them again and make them back into a vector. (vconcat (nreverse result))) macro)) diff --git a/lisp/ehelp.el b/lisp/ehelp.el index 2a24c9857c2..ec6e7afeb14 100644 --- a/lisp/ehelp.el +++ b/lisp/ehelp.el @@ -355,7 +355,10 @@ will select it.)" (defun electric-help-execute-extended (_prefixarg) (interactive "p") (setq electric-help-form-to-execute - (lambda () (execute-extended-command nil))) + (lambda () + (with-suppressed-warnings ((interactive-only + execute-extended-command)) + (execute-extended-command nil)))) (electric-help-retain)) ;; This is to be buond to C-x in ehelp mode. Retains ehelp buffer and then diff --git a/lisp/elec-pair.el b/lisp/elec-pair.el index b8a243b38a9..5fb9d751e25 100644 --- a/lisp/elec-pair.el +++ b/lisp/elec-pair.el @@ -155,6 +155,13 @@ return value is considered instead." (const :tag "Newline" ?\n)) (list character))) +(defvar-local electric-pair-skip-whitespace-function + #'electric-pair--skip-whitespace + "Function to use to skip whitespace forward. +Before attempting a skip, if `electric-pair-skip-whitespace' is +non-nil, this function is called. It move point to a new buffer +position, presumably skipping only whitespace in between.") + (defun electric-pair--skip-whitespace () "Skip whitespace forward, not crossing comment or string boundaries." (let ((saved (point)) @@ -220,7 +227,14 @@ inside a comment or string." (defun electric-pair--insert (char) (let ((last-command-event char) (blink-matching-paren nil) - (electric-pair-mode nil)) + (electric-pair-mode nil) + ;; When adding the "closer" delimiter, a job his function is + ;; frequently used for, we don't want to munch any extra + ;; newlines above us. That would be the default behaviour of + ;; `electric-layout-mode', which potentially kicked in before + ;; us to add these newlines, and is probably about to kick in + ;; again after we add the closer. + (electric-layout-allow-duplicate-newlines t)) (self-insert-command 1))) (cl-defmacro electric-pair--with-uncached-syntax ((table &optional start) &rest body) @@ -232,7 +246,7 @@ functions when `parse-sexp-lookup-properties' is non-nil. The cache is flushed from position START, defaulting to point." (declare (debug ((form &optional form) body)) (indent 1)) (let ((start-var (make-symbol "start"))) - `(let ((syntax-propertize-function nil) + `(let ((syntax-propertize-function #'ignore) (,start-var ,(or start '(point)))) (unwind-protect (with-syntax-table ,table @@ -398,6 +412,15 @@ strings." (let ((ppss (electric-pair--syntax-ppss (point) '(comment)))) (memq (nth 3 ppss) (list t char)))) +(defmacro electric-pair--save-literal-point-excursion (&rest body) + ;; FIXME: need this instead of `save-excursion' when functions in + ;; BODY, such as `electric-pair-inhibit-if-helps-balance' and + ;; `electric-pair-skip-if-helps-balance' modify and restore the + ;; buffer in a way that modifies the marker used by save-excursion. + (let ((point (make-symbol "point"))) + `(let ((,point (point))) + (unwind-protect (progn ,@body) (goto-char ,point))))) + (defun electric-pair-inhibit-if-helps-balance (char) "Return non-nil if auto-pairing of CHAR would hurt parentheses' balance. @@ -406,24 +429,28 @@ some list calculations, finally restoring the situation as if nothing happened." (pcase (electric-pair-syntax-info char) (`(,syntax ,pair ,_ ,s-or-c) - (unwind-protect - (progn - (delete-char -1) - (cond ((eq ?\( syntax) - (let* ((pair-data - (electric-pair--balance-info 1 s-or-c)) - (outermost (cdr pair-data))) - (cond ((car outermost) - nil) - (t - (eq (cdr outermost) pair))))) - ((eq syntax ?\") - (electric-pair--unbalanced-strings-p char)))) - (insert-char char))))) + (catch 'done + ;; FIXME: modify+undo is *very* tricky business. We used to + ;; use `delete-char' followed by `insert', but this changed the + ;; position some markers. The real fix would be to compute the + ;; result without having to modify the buffer at all. + (atomic-change-group + (delete-char -1) + (throw + 'done + (cond ((eq ?\( syntax) + (let* ((pair-data + (electric-pair--balance-info 1 s-or-c)) + (outermost (cdr pair-data))) + (cond ((car outermost) + nil) + (t + (eq (cdr outermost) pair))))) + ((eq syntax ?\") + (electric-pair--unbalanced-strings-p char))))))))) (defun electric-pair-skip-if-helps-balance (char) "Return non-nil if skipping CHAR would benefit parentheses' balance. - Works by first removing the character from the buffer, then doing some list calculations, finally restoring the situation as if nothing happened." @@ -445,7 +472,7 @@ happened." (not (eq (cdr outermost) pair))))))) ((eq syntax ?\") (electric-pair--inside-string-p char)))) - (insert-char char))))) + (insert char))))) (defun electric-pair-default-skip-self (char) (if electric-pair-preserve-balance @@ -491,7 +518,9 @@ happened." ((and (memq syntax '(?\) ?\" ?\$)) (and (or unconditional (if (functionp electric-pair-skip-self) - (funcall electric-pair-skip-self last-command-event) + (electric-pair--save-literal-point-excursion + (goto-char pos) + (funcall electric-pair-skip-self last-command-event)) electric-pair-skip-self)) (save-excursion (when (and (not (and unconditional @@ -501,7 +530,7 @@ happened." (functionp electric-pair-skip-whitespace)) (funcall electric-pair-skip-whitespace) electric-pair-skip-whitespace))) - (electric-pair--skip-whitespace)) + (funcall electric-pair-skip-whitespace-function)) (eq (char-after) last-command-event)))) ;; This is too late: rather than insert&delete we'd want to only ;; skip (or insert in overwrite mode). The difference is in what @@ -509,17 +538,19 @@ happened." ;; be visible to other post-self-insert-hook. We'll just have to ;; live with it for now. (when skip-whitespace-info - (electric-pair--skip-whitespace)) + (funcall electric-pair-skip-whitespace-function)) (delete-region (1- pos) (if (eq skip-whitespace-info 'chomp) (point) pos)) (forward-char)) ;; Insert matching pair. - ((and (memq syntax `(?\( ?\" ?\$)) + ((and (memq syntax '(?\( ?\" ?\$)) (not overwrite-mode) (or unconditional - (not (funcall electric-pair-inhibit-predicate - last-command-event)))) + (not (electric-pair--save-literal-point-excursion + (goto-char pos) + (funcall electric-pair-inhibit-predicate + last-command-event))))) (save-excursion (electric-pair--insert pair))))) (_ (when (and (if (functionp electric-pair-open-newline-between-pairs) @@ -533,8 +564,6 @@ happened." (matching-paren (char-after)))) (save-excursion (newline 1 t))))))) -(put 'electric-pair-post-self-insert-function 'priority 20) - (defun electric-pair-will-use-region () (and (use-region-p) (memq (car (electric-pair-syntax-info last-command-event)) @@ -574,9 +603,6 @@ ARG and KILLP are passed directly to ;;;###autoload (define-minor-mode electric-pair-mode "Toggle automatic parens pairing (Electric Pair mode). -With a prefix argument ARG, enable Electric Pair mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Electric Pair mode is a global minor mode. When enabled, typing an open parenthesis automatically inserts the corresponding @@ -589,8 +615,14 @@ To toggle the mode in a single buffer, use `electric-pair-local-mode'." (if electric-pair-mode (progn (add-hook 'post-self-insert-hook - #'electric-pair-post-self-insert-function) - (electric--sort-post-self-insertion-hook) + #'electric-pair-post-self-insert-function + ;; Prioritize this to kick in after + ;; `electric-layout-post-self-insert-function': that + ;; considerably simplifies interoperation when + ;; `electric-pair-mode', `electric-layout-mode' and + ;; `electric-indent-mode' are used together. + ;; Use `vc-region-history' on these lines for more info. + 50) (add-hook 'self-insert-uses-region-functions #'electric-pair-will-use-region)) (remove-hook 'post-self-insert-hook diff --git a/lisp/electric.el b/lisp/electric.el index a30090d1d8e..a14deb71afb 100644 --- a/lisp/electric.el +++ b/lisp/electric.el @@ -190,17 +190,6 @@ Returns nil when we can't find this char." (eq (char-before) last-command-event))))) pos))) -(defun electric--sort-post-self-insertion-hook () - "Ensure order of electric functions in `post-self-insertion-hook'. - -Hooks in this variable interact in non-trivial ways, so a -relative order must be maintained within it." - (setq-default post-self-insert-hook - (sort (default-value 'post-self-insert-hook) - #'(lambda (fn1 fn2) - (< (or (get fn1 'priority) 0) - (or (get fn2 'priority) 0)))))) - ;;; Electric indentation. ;; Autoloading variables is generally undesirable, but major modes @@ -260,34 +249,45 @@ or comment." (or (memq act '(nil no-indent)) ;; In a string or comment. (unless (eq act 'do-indent) (nth 8 (syntax-ppss)))))))) - ;; For newline, we want to reindent both lines and basically behave like - ;; reindent-then-newline-and-indent (whose code we hence copied). - (let ((at-newline (<= pos (line-beginning-position)))) - (when at-newline - (let ((before (copy-marker (1- pos) t))) - (save-excursion - (unless (or (memq indent-line-function - electric-indent-functions-without-reindent) - electric-indent-inhibit) - ;; Don't reindent the previous line if the indentation function - ;; is not a real one. - (goto-char before) - (indent-according-to-mode)) - ;; We are at EOL before the call to indent-according-to-mode, and - ;; after it we usually are as well, but not always. We tried to - ;; address it with `save-excursion' but that uses a normal marker - ;; whereas we need `move after insertion', so we do the - ;; save/restore by hand. - (goto-char before) - (when (eolp) - ;; Remove the trailing whitespace after indentation because - ;; indentation may (re)introduce the whitespace. - (delete-horizontal-space t))))) - (unless (and electric-indent-inhibit - (not at-newline)) - (indent-according-to-mode)))))) - -(put 'electric-indent-post-self-insert-function 'priority 60) + ;; If we error during indent, silently give up since this is an + ;; automatic action that the user didn't explicitly request. + ;; But we don't want to suppress errors from elsewhere in *this* + ;; function, hence the `condition-case' and `throw' (Bug#18764). + (catch 'indent-error + ;; For newline, we want to reindent both lines and basically + ;; behave like reindent-then-newline-and-indent (whose code we + ;; hence copied). + (let ((at-newline (<= pos (line-beginning-position)))) + (when at-newline + (let ((before (copy-marker (1- pos) t))) + (save-excursion + (unless + (or (memq indent-line-function + electric-indent-functions-without-reindent) + electric-indent-inhibit) + ;; Don't reindent the previous line if the + ;; indentation function is not a real one. + (goto-char before) + (condition-case-unless-debug () + (indent-according-to-mode) + (error (throw 'indent-error nil)))) + (unless (eq electric-indent-inhibit 'electric-layout-mode) + ;; Unless we're operating under + ;; `electric-layout-mode' (Bug#35254), the goal here + ;; will be to remove the trailing whitespace after + ;; reindentation of the previous line because that + ;; may have (re)introduced it. + (goto-char before) + ;; We were at EOL in marker `before' before the call + ;; to `indent-according-to-mode' but after we may + ;; not be (Bug#15767). + (when (and (eolp)) + (delete-horizontal-space t)))))) + (unless (and electric-indent-inhibit + (not at-newline)) + (condition-case-unless-debug () + (indent-according-to-mode) + (error (throw 'indent-error nil))))))))) (defun electric-indent-just-newline (arg) "Insert just a newline, without any auto-indentation." @@ -314,9 +314,6 @@ column specified by the function `current-left-margin'." ;;;###autoload (define-minor-mode electric-indent-mode "Toggle on-the-fly reindentation (Electric Indent mode). -With a prefix argument ARG, enable Electric Indent mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. When enabled, this reindents whenever the hook `electric-indent-functions' returns non-nil, or if you insert a character from `electric-indent-chars'. @@ -334,8 +331,8 @@ use `electric-indent-local-mode'." (remove-hook 'post-self-insert-hook #'electric-indent-post-self-insert-function)) (add-hook 'post-self-insert-hook - #'electric-indent-post-self-insert-function) - (electric--sort-post-self-insertion-hook))) + #'electric-indent-post-self-insert-function + 60))) ;;;###autoload (define-minor-mode electric-indent-local-mode @@ -355,64 +352,143 @@ use `electric-indent-local-mode'." (defvar electric-layout-rules nil "List of rules saying where to automatically insert newlines. -Each rule has the form (CHAR . WHERE) where CHAR is the char that -was just inserted and WHERE specifies where to insert newlines -and can be: nil, `before', `after', `around', `after-stay', or a -function of no arguments that returns one of those symbols. +Each rule has the form (CHAR . WHERE), the rule matching if the +character just inserted was CHAR. WHERE specifies where to +insert newlines, and can be: + +* one of the symbols `before', `after', `around', `after-stay', + or nil. + +* a list of the preceding symbols, processed in order of + appearance to insert multiple newlines; + +* a function of no arguments that returns one of the previous + values. -The symbols specify where in relation to CHAR the newline -character(s) should be inserted. `after-stay' means insert a -newline after CHAR but stay in the same place.") +Each symbol specifies where, in relation to the position POS of +the character inserted, the newline character(s) should be +inserted. `after-stay' means insert a newline after POS but stay +in the same place. + +Instead of the (CHAR . WHERE) form, a rule can also be just a +function of a single argument, the character just inserted. It +is called at that position, and should return a value compatible with +WHERE if the rule matches, or nil if it doesn't match. + +If multiple rules match, only first one is executed.") + +;; TODO: Make this a defcustom? +(defvar electric-layout-allow-duplicate-newlines nil + "If non-nil, allow duplication of `before' newlines.") (defun electric-layout-post-self-insert-function () - (let* ((rule (cdr (assq last-command-event electric-layout-rules))) - pos) + (when electric-layout-mode + (electric-layout-post-self-insert-function-1))) + +;; for edebug's sake, a separate function +(defun electric-layout-post-self-insert-function-1 () + (let* ((pos (electric--after-char-pos)) + probe + (rules electric-layout-rules) + (rule + (catch 'done + (when pos + (while (setq probe (pop rules)) + (cond ((and (consp probe) + (eq (car probe) last-command-event)) + (throw 'done (cdr probe))) + ((functionp probe) + (let ((res + (save-excursion + (goto-char pos) + (funcall probe last-command-event)))) + (when res (throw 'done res)))))))))) (when (and rule - (setq pos (electric--after-char-pos)) ;; Not in a string or comment. (not (nth 8 (save-excursion (syntax-ppss pos))))) - (let ((end (point-marker)) - (sym (if (functionp rule) (funcall rule) rule))) - (set-marker-insertion-type end (not (eq sym 'after-stay))) - (goto-char pos) - (pcase sym - ;; FIXME: we used `newline' down here which called - ;; self-insert-command and ran post-self-insert-hook recursively. - ;; It happened to make electric-indent-mode work automatically with - ;; electric-layout-mode (at the cost of re-indenting lines - ;; multiple times), but I'm not sure it's what we want. - ;; - ;; FIXME: check eolp before inserting \n? - (`before (goto-char (1- pos)) (skip-chars-backward " \t") - (unless (bolp) (insert "\n"))) - (`after (insert "\n")) - (`after-stay (save-excursion - (let ((electric-layout-rules nil)) - (newline 1 t)))) - (`around (save-excursion - (goto-char (1- pos)) (skip-chars-backward " \t") - (unless (bolp) (insert "\n"))) - (insert "\n"))) ; FIXME: check eolp before inserting \n? - (goto-char end))))) - -(put 'electric-layout-post-self-insert-function 'priority 40) + (goto-char pos) + (when (functionp rule) (setq rule (funcall rule))) + (dolist (sym (if (symbolp rule) (list rule) rule)) + (let* ((nl-after + (lambda () + ;; FIXME: we use `newline', which calls + ;; `self-insert-command' and ran + ;; `post-self-insert-hook' recursively. It happened + ;; to make `electric-indent-mode' work automatically + ;; with `electric-layout-mode' (at the cost of + ;; re-indenting lines multiple times), but I'm not + ;; sure it's what we want. + ;; + ;; JT@19/02/22: Indeed in the case of `before' + ;; newlines, re-indentation is prevented. + ;; + ;; FIXME: when `newline'ing, we exceptionally + ;; prevent a specific behaviour of + ;; `eletric-pair-mode', that of opening an extra + ;; newline between newly inserted matching paris. + ;; In theory that behaviour should be provided by + ;; `electric-layout-mode' instead, which should be + ;; possible given the current API. + ;; + ;; FIXME: check eolp before inserting \n? + (let ((electric-layout-mode nil) + (electric-pair-open-newline-between-pairs nil)) + (newline 1 t)))) + (nl-before + (lambda () + (save-excursion + (goto-char (1- pos)) + ;; Normally, we don't duplicate newlines, but when + ;; we're being called for i.e. a closer brace for + ;; `electric-pair-mode' generally make sense. So + ;; consult `electric-layout-allow-duplicate-newlines' + (unless (and (not electric-layout-allow-duplicate-newlines) + (progn (skip-chars-backward " \t") + (bolp))) + ;; FIXME: JT@19/03/22: Make sure the `before' + ;; newline being inserted here does not trigger + ;; reindentation. It doesn't seem to be our job + ;; to do so and it break with `cc-mode's + ;; indentation function. Later on we can add a + ;; before-and-maybe-indent, or if the user + ;; really wants to reindent, then + ;; `last-command-event' should be in + ;; `electric-indent-chars'. + (let ((electric-indent-inhibit 'electric-layout-mode)) + (funcall nl-after))))))) + (pcase sym + ('before (funcall nl-before)) + ('after (funcall nl-after)) + ('after-stay (save-excursion (funcall nl-after))) + ('around (funcall nl-before) (funcall nl-after)))))))) ;;;###autoload (define-minor-mode electric-layout-mode "Automatically insert newlines around some chars. -With a prefix argument ARG, enable Electric Layout mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + The variable `electric-layout-rules' says when and how to insert newlines." :global t :group 'electricity (cond (electric-layout-mode (add-hook 'post-self-insert-hook - #'electric-layout-post-self-insert-function) - (electric--sort-post-self-insertion-hook)) + #'electric-layout-post-self-insert-function + 40)) (t (remove-hook 'post-self-insert-hook #'electric-layout-post-self-insert-function)))) +;;;###autoload +(define-minor-mode electric-layout-local-mode + "Toggle `electric-layout-mode' only in this buffer." + :variable (buffer-local-value 'electric-layout-mode (current-buffer)) + (cond + ((eq electric-layout-mode (default-value 'electric-layout-mode)) + (kill-local-variable 'electric-layout-mode)) + ((not (default-value 'electric-layout-mode)) + ;; Locally enabled, but globally disabled. + (electric-layout-mode 1) ; Setup the hooks. + (setq-default electric-layout-mode nil) ; But keep it globally disabled. + ))) + ;;; Electric quoting. (defcustom electric-quote-comment t @@ -451,6 +527,14 @@ whitespace, opening parenthesis, or quote and leaves \\=` alone." :version "26.1" :type 'boolean :safe #'booleanp :group 'electricity) +(defcustom electric-quote-replace-double nil + "Non-nil means to replace \" with an electric double quote. +Emacs replaces \" with an opening double quote after a line +break, whitespace, opening parenthesis, or quote, and with a +closing double quote otherwise." + :version "26.1" + :type 'boolean :safe #'booleanp :group 'electricity) + (defvar electric-quote-inhibit-functions () "List of functions that should inhibit electric quoting. When the variable `electric-quote-mode' is non-nil, Emacs will @@ -461,13 +545,17 @@ substitution is inhibited. The functions are called after the after the inserted character. The functions in this hook should not move point or change the current buffer.") +(defvar electric-pair-text-pairs) + (defun electric-quote-post-self-insert-function () "Function that `electric-quote-mode' adds to `post-self-insert-hook'. This requotes when a quoting key is typed." (when (and electric-quote-mode (or (eq last-command-event ?\') (and (not electric-quote-context-sensitive) - (eq last-command-event ?\`))) + (eq last-command-event ?\`)) + (and electric-quote-replace-double + (eq last-command-event ?\"))) (not (run-hook-with-args-until-success 'electric-quote-inhibit-functions)) (if (derived-mode-p 'text-mode) @@ -488,9 +576,12 @@ This requotes when a quoting key is typed." (save-excursion (let ((backtick ?\`)) (if (or (eq last-command-event ?\`) - (and electric-quote-context-sensitive + (and (or electric-quote-context-sensitive + (and electric-quote-replace-double + (eq last-command-event ?\"))) (save-excursion (backward-char) + (skip-syntax-backward "\\") (or (bobp) (bolp) (memq (char-before) (list q< q<<)) (memq (char-syntax (char-before)) @@ -506,22 +597,23 @@ This requotes when a quoting key is typed." (setq last-command-event q<<)) ((search-backward (string backtick) (1- (point)) t) (replace-match (string q<)) - (setq last-command-event q<))) + (setq last-command-event q<)) + ((search-backward "\"" (1- (point)) t) + (replace-match (string q<<)) + (setq last-command-event q<<))) (cond ((search-backward (string q> ?') (- (point) 2) t) (replace-match (string q>>)) (setq last-command-event q>>)) ((search-backward "'" (1- (point)) t) (replace-match (string q>)) - (setq last-command-event q>)))))))))) - -(put 'electric-quote-post-self-insert-function 'priority 10) + (setq last-command-event q>)) + ((search-backward "\"" (1- (point)) t) + (replace-match (string q>>)) + (setq last-command-event q>>)))))))))) ;;;###autoload (define-minor-mode electric-quote-mode "Toggle on-the-fly requoting (Electric Quote mode). -With a prefix argument ARG, enable Electric Quote mode if -ARG is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. When enabled, as you type this replaces \\=` with ‘, \\=' with ’, \\=`\\=` with “, and \\='\\=' with ”. This occurs only in comments, strings, @@ -545,8 +637,8 @@ use `electric-quote-local-mode'." (remove-hook 'post-self-insert-hook #'electric-quote-post-self-insert-function)) (add-hook 'post-self-insert-hook - #'electric-quote-post-self-insert-function) - (electric--sort-post-self-insertion-hook))) + #'electric-quote-post-self-insert-function + 10))) ;;;###autoload (define-minor-mode electric-quote-local-mode diff --git a/lisp/elide-head.el b/lisp/elide-head.el index 82d08190a63..c1678c003db 100644 --- a/lisp/elide-head.el +++ b/lisp/elide-head.el @@ -52,7 +52,7 @@ (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 <http://www\\.gnu\\.org/licenses/>\\)\\.") +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 diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 3ab7e1fe988..2034f33d0e6 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1514,7 +1514,7 @@ ;; `ad-return-value' in a piece of after advice. For example: ;; ;; (defmacro foom (x) -;; (` (list (, x)))) +;; `(list ,x)) ;; foom ;; ;; (foom '(a)) @@ -1547,8 +1547,8 @@ ;; (defadvice foom (after fg-print-x act) ;; "Print the value of X." ;; (setq ad-return-value -;; (` (progn (print (, x)) -;; (, ad-return-value))))) +;; `(progn (print ,x) +;; ,ad-return-value))) ;; foom ;; ;; (macroexpand '(foom '(a))) @@ -1575,7 +1575,6 @@ ;; ============================== (require 'macroexp) -;; At run-time also, since ad-do-advised-functions returns code that uses it. (eval-when-compile (require 'cl-lib)) ;; @@ Variable definitions: @@ -1662,18 +1661,14 @@ generates a copy of TREE." ;; (this list is maintained as a completion table): (defvar ad-advised-functions nil) -(defmacro ad-pushnew-advised-function (function) +(defun ad-pushnew-advised-function (function) "Add FUNCTION to `ad-advised-functions' unless its already there." - `(if (not (assoc (symbol-name ,function) ad-advised-functions)) - (setq ad-advised-functions - (cons (list (symbol-name ,function)) - ad-advised-functions)))) + (add-to-list 'ad-advised-functions (symbol-name function))) -(defmacro ad-pop-advised-function (function) +(defun ad-pop-advised-function (function) "Remove FUNCTION from `ad-advised-functions'." - `(setq ad-advised-functions - (delq (assoc (symbol-name ,function) ad-advised-functions) - ad-advised-functions))) + (setq ad-advised-functions + (delete (symbol-name function) ad-advised-functions))) (defmacro ad-do-advised-functions (varform &rest body) "`dolist'-style iterator that maps over advised functions. @@ -1683,14 +1678,14 @@ On each iteration VAR will be bound to the name of an advised function \(a symbol)." (declare (indent 1)) `(dolist (,(car varform) ad-advised-functions) - (setq ,(car varform) (intern (car ,(car varform)))) + (setq ,(car varform) (intern ,(car varform))) ,@body)) -(defun ad-get-advice-info (function) +(defsubst ad-get-advice-info (function) (get function 'ad-advice-info)) -(defmacro ad-get-advice-info-macro (function) - `(get ,function 'ad-advice-info)) +(define-obsolete-function-alias 'ad-get-advice-info-macro + #'ad-get-advice-info "27.1") (defsubst ad-set-advice-info (function advice-info) (cond @@ -1702,13 +1697,12 @@ On each iteration VAR will be bound to the name of an advised function #'ad--defalias-fset))) (put function 'ad-advice-info advice-info)) -(defmacro ad-copy-advice-info (function) - `(copy-tree (get ,function 'ad-advice-info))) +(defsubst ad-copy-advice-info (function) + (copy-tree (get function 'ad-advice-info))) -(defmacro ad-is-advised (function) +(defalias 'ad-is-advised #'ad-get-advice-info "Return non-nil if FUNCTION has any advice info associated with it. -This does not mean that the advice is also active." - `(ad-get-advice-info-macro ,function)) +This does not mean that the advice is also active.") (defun ad-initialize-advice-info (function) "Initialize the advice info for FUNCTION. @@ -1716,19 +1710,19 @@ Assumes that FUNCTION has not yet been advised." (ad-pushnew-advised-function function) (ad-set-advice-info function (list (cons 'active nil)))) -(defmacro ad-get-advice-info-field (function field) +(defsubst ad-get-advice-info-field (function field) "Retrieve the value of the advice info FIELD of FUNCTION." - `(cdr (assq ,field (ad-get-advice-info-macro ,function)))) + (cdr (assq field (ad-get-advice-info function)))) (defun ad-set-advice-info-field (function field value) "Destructively modify VALUE of the advice info FIELD of FUNCTION." - (and (ad-is-advised function) - (cond ((assq field (ad-get-advice-info-macro function)) - ;; A field with that name is already present: - (rplacd (assq field (ad-get-advice-info-macro function)) value)) - (t;; otherwise, create a new field with that name: - (nconc (ad-get-advice-info-macro function) - (list (cons field value))))))) + (let ((info (ad-get-advice-info function))) + (and info + (cond ((assq field info) + ;; A field with that name is already present: + (rplacd (assq field info) value)) + (t;; otherwise, create a new field with that name: + (nconc info (list (cons field value)))))))) ;; Don't make this a macro so we can use it as a predicate: (defun ad-is-active (function) @@ -1849,7 +1843,7 @@ function at point for which PREDICATE returns non-nil)." (require 'help) (function-called-at-point)))) (and function - (assoc (symbol-name function) ad-advised-functions) + (member (symbol-name function) ad-advised-functions) (or (null predicate) (funcall predicate function)) function)) @@ -1939,9 +1933,9 @@ be used to prompt for the function." ;; @@ Finding, enabling, adding and removing pieces of advice: ;; =========================================================== -(defmacro ad-find-advice (function class name) +(defsubst ad-find-advice (function class name) "Find the first advice of FUNCTION in CLASS with NAME." - `(assq ,name (ad-get-advice-info-field ,function ,class))) + (assq name (ad-get-advice-info-field function class))) (defun ad-advice-position (function class name) "Return position of first advice of FUNCTION in CLASS with NAME." @@ -2109,34 +2103,33 @@ the cache-id will clear the cache." ;; @@ Accessing and manipulating function definitions: ;; =================================================== -(defmacro ad-macrofy (definition) +(defsubst ad-macrofy (definition) "Take a lambda function DEFINITION and make a macro out of it." - `(cons 'macro ,definition)) + (cons 'macro definition)) -(defmacro ad-lambdafy (definition) - "Take a macro function DEFINITION and make a lambda out of it." - `(cdr ,definition)) +(defalias 'ad-lambdafy #'cdr + "Take a macro function DEFINITION and make a lambda out of it.") -(defmacro ad-lambda-p (definition) +(defsubst ad-lambda-p (definition) ;;"non-nil if DEFINITION is a lambda expression." - `(eq (car-safe ,definition) 'lambda)) + (eq (car-safe definition) 'lambda)) ;; see ad-make-advice for the format of advice definitions: -(defmacro ad-advice-p (definition) +(defsubst ad-advice-p (definition) ;;"non-nil if DEFINITION is a piece of advice." - `(eq (car-safe ,definition) 'advice)) + (eq (car-safe definition) 'advice)) -(defmacro ad-compiled-p (definition) +(defsubst ad-compiled-p (definition) "Return non-nil if DEFINITION is a compiled byte-code object." - `(or (byte-code-function-p ,definition) - (and (macrop ,definition) - (byte-code-function-p (ad-lambdafy ,definition))))) + (or (byte-code-function-p definition) + (and (macrop definition) + (byte-code-function-p (ad-lambdafy definition))))) -(defmacro ad-compiled-code (compiled-definition) +(defsubst ad-compiled-code (compiled-definition) "Return the byte-code object of a COMPILED-DEFINITION." - `(if (macrop ,compiled-definition) - (ad-lambdafy ,compiled-definition) - ,compiled-definition)) + (if (macrop compiled-definition) + (ad-lambdafy compiled-definition) + compiled-definition)) (defun ad-lambda-expression (definition) "Return the lambda expression of a function/macro/advice DEFINITION." @@ -2697,15 +2690,15 @@ should be modified. The assembled function will be returned." ;; the added efficiency. The validation itself is also pretty cheap, certainly ;; a lot cheaper than reconstructing an advised definition. -(defmacro ad-get-cache-definition (function) - `(car (ad-get-advice-info-field ,function 'cache))) +(defsubst ad-get-cache-definition (function) + (car (ad-get-advice-info-field function 'cache))) -(defmacro ad-get-cache-id (function) - `(cdr (ad-get-advice-info-field ,function 'cache))) +(defsubst ad-get-cache-id (function) + (cdr (ad-get-advice-info-field function 'cache))) -(defmacro ad-set-cache (function definition id) - `(ad-set-advice-info-field - ,function 'cache (cons ,definition ,id))) +(defsubst ad-set-cache (function definition id) + (ad-set-advice-info-field + function 'cache (cons definition id))) (defun ad-clear-cache (function) "Clears a previously cached advised definition of FUNCTION. @@ -2813,7 +2806,7 @@ advised definition from scratch." ;; advised definition will be generated. (defun ad-preactivate-advice (function advice class position) - "Preactivate FUNCTION and returns the constructed cache." + "Preactivate FUNCTION and return the constructed cache." (let* ((advicefunname (ad-get-advice-info-field function 'advicefunname)) (old-advice (symbol-function advicefunname)) (old-advice-info (ad-copy-advice-info function)) @@ -3098,9 +3091,8 @@ deactivation, which might run hooks and get into other trouble." ;; Completion alist of valid `defadvice' flags -(defvar ad-defadvice-flags - '(("protect") ("disable") ("activate") - ("compile") ("preactivate"))) +(defconst ad-defadvice-flags + '("protect" "disable" "activate" "compile" "preactivate")) ;;;###autoload (defmacro defadvice (function args &rest body) @@ -3180,7 +3172,7 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) (let ((completion (try-completion (symbol-name flag) ad-defadvice-flags))) (cond ((eq completion t) flag) - ((assoc completion ad-defadvice-flags) + ((member completion ad-defadvice-flags) (intern completion)) (t (error "defadvice: Invalid or ambiguous flag: %s" flag)))))) @@ -3221,7 +3213,7 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) For any members of FUNCTIONS that are not currently advised the rebinding will be a noop. Any modifications done to the definitions of FUNCTIONS will be undone on exit of this macro." - (declare (indent 1)) + (declare (indent 1) (obsolete nil "27.1")) (let* ((index -1) ;; Make let-variables to store current definitions: (current-bindings diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 2268d427c35..541b22e3eea 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -146,7 +146,7 @@ expression, in which case we want to handle forms differently." t)))) ;; 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))) + (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))) @@ -182,13 +182,13 @@ expression, in which case we want to handle forms differently." (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) + ((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) + ('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)) @@ -324,6 +324,7 @@ put the output in." (setcdr p nil) (princ "\n(" outbuf) (let ((print-escape-newlines t) + (print-escape-control-characters t) (print-quoted t) (print-escape-nonascii t)) (dolist (elt form) @@ -348,6 +349,7 @@ put the output in." outbuf)) (terpri outbuf))) (let ((print-escape-newlines t) + (print-escape-control-characters t) (print-quoted t) (print-escape-nonascii t)) (print form outbuf))))))) @@ -368,7 +370,6 @@ FILE's name." ";;\n" ";;; Code:\n\n" (if lp - ;; `load-path' should contain only directory names. "(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))\n\n") "\n" @@ -379,7 +380,7 @@ FILE's name." (file-name-sans-extension basename)))) ";; Local Variables:\n" ";; version-control: never\n" - ";; no-byte-compile: t\n" + ";; no-byte-compile: t\n" ;; #$ is byte-compiled into nil. ";; no-update-autoloads: t\n" ";; coding: utf-8\n" ";; End:\n" @@ -605,7 +606,8 @@ Don't try to split prefixes that are already longer than that.") nil)))) prefixes))) `(if (fboundp 'register-definition-prefixes) - (register-definition-prefixes ,file ',(delq nil strings))))))) + (register-definition-prefixes ,file ',(sort (delq nil strings) + 'string<))))))) (defun autoload--setup-output (otherbuf outbuf absfile load-name) (let ((outbuf @@ -657,6 +659,21 @@ 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.") + ;; When called from `generate-file-autoloads' we should ignore ;; `generated-autoload-file' altogether. When called from ;; `update-file-autoloads' we don't know `outbuf'. And when called from @@ -755,17 +772,8 @@ FILE's modification time." (looking-at "(\\(def[^ ]+\\) ['(]*\\([^' ()\"\n]+\\)[\n \t]") (not (member (match-string 1) - '("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")))) - (push (match-string 2) defs)) + autoload-ignored-definitions))) + (push (match-string-no-properties 2) defs)) (forward-sexp 1) (forward-line 1))))))) @@ -810,7 +818,8 @@ FILE's modification time." (marker-buffer other-output-start) "actual autoloads are elsewhere" load-name relfile (if autoload-timestamps - (nth 5 (file-attributes absfile)) + (file-attribute-modification-time + (file-attributes absfile)) autoload--non-timestamp)) (insert ";;; Generated autoloads from " relfile "\n"))) (insert generate-autoload-section-trailer))))))) @@ -846,7 +855,8 @@ FILE's modification time." ;; `emacs-internal' instead. nil nil 'emacs-mule-unix) (if autoload-timestamps - (nth 5 (file-attributes relfile)) + (file-attribute-modification-time + (file-attributes relfile)) autoload--non-timestamp))) (insert ";;; Generated autoloads from " relfile "\n"))) (insert generate-autoload-section-trailer)))) @@ -859,7 +869,7 @@ FILE's modification time." ;; If the entries were added to some other buffer, then the file ;; doesn't add entries to OUTFILE. otherbuf)) - (nth 5 (file-attributes absfile)))) + (file-attribute-modification-time (file-attributes absfile)))) (error ;; Probably unbalanced parens in forward-sexp. In that case, the ;; condition is scan-error, and the signal data includes point @@ -940,7 +950,8 @@ removes any prior now out-of-date autoload entries." (existing-buffer (if buffer-file-name buf)) (output-file (autoload-generated-file)) (output-time (if (file-exists-p output-file) - (nth 5 (file-attributes output-file)))) + (file-attribute-modification-time + (file-attributes output-file)))) (found nil)) (with-current-buffer (autoload-find-generated-file) ;; This is to make generated-autoload-file have Unix EOLs, so @@ -962,7 +973,8 @@ removes any prior now out-of-date autoload entries." ;; Check if it is up to date. (let ((begin (match-beginning 0)) (last-time (nth 4 form)) - (file-time (nth 5 (file-attributes file)))) + (file-time (file-attribute-modification-time + (file-attributes file)))) (if (and (or (null existing-buffer) (not (buffer-modified-p existing-buffer))) (cond @@ -1055,7 +1067,8 @@ write its autoloads into the specified file instead." generated-autoload-file)) (output-time (if (file-exists-p generated-autoload-file) - (nth 5 (file-attributes generated-autoload-file))))) + (file-attribute-modification-time + (file-attributes generated-autoload-file))))) (with-current-buffer (autoload-find-generated-file) (save-excursion @@ -1076,7 +1089,8 @@ write its autoloads into the specified file instead." (if (member last-time (list t autoload--non-timestamp)) (setq last-time output-time)) (dolist (file file) - (let ((file-time (nth 5 (file-attributes file)))) + (let ((file-time (file-attribute-modification-time + (file-attributes file)))) (when (and file-time (not (time-less-p last-time file-time))) ;; file unchanged @@ -1095,7 +1109,8 @@ write its autoloads into the specified file instead." t autoload--non-timestamp)) output-time oldtime)) - (nth 5 (file-attributes file)))) + (file-attribute-modification-time + (file-attributes file)))) ;; File hasn't changed. nil) (t @@ -1108,8 +1123,17 @@ write its autoloads into the specified file instead." (push file done) (setq files (delete file files))))) ;; Elements remaining in FILES have no existing autoload sections yet. - (let ((no-autoloads-time (or last-time '(0 0 0 0))) file-time) + (let ((no-autoloads-time (or last-time '(0 0 0 0))) + (progress (make-progress-reporter + (byte-compile-info-string + (concat "Scraping files for " + (file-relative-name + generated-autoload-file))) + 0 (length files) nil 10)) + (file-count 0) + file-time) (dolist (file files) + (progress-reporter-update progress (setq file-count (1+ file-count))) (cond ;; Passing nil as second argument forces ;; autoload-generate-file-autoloads to look for the right @@ -1120,6 +1144,7 @@ write its autoloads into the specified file instead." (if (time-less-p no-autoloads-time file-time) (setq no-autoloads-time file-time))) (t (setq changed t)))) + (progress-reporter-done progress) (when no-autoloads ;; Sort them for better readability. @@ -1143,9 +1168,6 @@ write its autoloads into the specified file instead." ;; file-local autoload-generated-file settings. (autoload-save-buffers)))) -(define-obsolete-function-alias 'update-autoloads-from-directories - 'update-directory-autoloads "22.1") - ;;;###autoload (defun batch-update-autoloads () "Update loaddefs.el autoloads in batch mode. diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el new file mode 100644 index 00000000000..60d146e24a8 --- /dev/null +++ b/lisp/emacs-lisp/backtrace.el @@ -0,0 +1,918 @@ +;;; backtrace.el --- generic major mode for Elisp backtraces -*- lexical-binding: t -*- + +;; Copyright (C) 2018-2019 Free Software Foundation, Inc. + +;; Author: Gemini Lasswell +;; Keywords: lisp, tools, maint +;; Version: 1.0 + +;; 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 defines Backtrace mode, a generic major mode for displaying +;; Elisp stack backtraces, which can be used as is or inherited from +;; by another mode. + +;; For usage information, see the documentation of `backtrace-mode'. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'pcase)) +(eval-when-compile (require 'subr-x)) ; if-let +(require 'find-func) +(require 'help-mode) ; Define `help-function-def' button type. +(require 'lisp-mode) + +;;; Options + +(defgroup backtrace nil + "Viewing of Elisp backtraces." + :group 'lisp) + +(defcustom backtrace-fontify t + "If non-nil, fontify Backtrace buffers. +Set to nil to disable fontification, which may be necessary in +order to debug the code that does fontification." + :type 'boolean + :group 'backtrace + :version "27.1") + +(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." + :type 'integer + :group 'backtrace + :version "27.1") + +;;; Backtrace frame data structure + +(cl-defstruct + (backtrace-frame + (:constructor backtrace-make-frame)) + evald ; Non-nil if argument evaluation is complete. + fun ; The function called/to call in this frame. + args ; Either evaluated or unevaluated arguments to the function. + flags ; A plist, possible properties are :debug-on-exit and :source-available. + locals ; An alist containing variable names and values. + buffer ; If non-nil, the buffer in use by eval-buffer or eval-region. + pos ; The position in the buffer. + ) + +(cl-defun backtrace-get-frames + (&optional base &key (constructor #'backtrace-make-frame)) + "Collect all frames of current backtrace into a list. +The list will contain objects made by CONSTRUCTOR, which +defaults to `backtrace-make-frame' and which, if provided, should +be the constructor of a structure which includes +`backtrace-frame'. If non-nil, BASE should be a function, and +frames before its nearest activation frame are discarded." + (let ((frames nil) + (eval-buffers eval-buffer-list)) + (mapbacktrace (lambda (evald fun args flags) + (push (funcall constructor + :evald evald :fun fun + :args args :flags flags) + frames)) + (or base 'backtrace-get-frames)) + (setq frames (nreverse frames)) + ;; Add local variables to each frame, and the buffer position + ;; to frames containing eval-buffer or eval-region. + (dotimes (idx (length frames)) + (let ((frame (nth idx frames))) + ;; `backtrace--locals' gives an error when idx is 0. But the + ;; locals for frame 0 are not needed, because when we get here + ;; from debug-on-entry, the locals aren't bound yet, and when + ;; coming from Edebug or ERT there is an Edebug or ERT + ;; function at frame 0. + (when (> idx 0) + (setf (backtrace-frame-locals frame) + (backtrace--locals idx (or base 'backtrace-get-frames)))) + (when (and eval-buffers (memq (backtrace-frame-fun frame) + '(eval-buffer eval-region))) + ;; This will get the wrong result if there are two nested + ;; eval-region calls for the same buffer. That's not a very + ;; useful case. + (with-current-buffer (pop eval-buffers) + (setf (backtrace-frame-buffer frame) (current-buffer)) + (setf (backtrace-frame-pos frame) (point)))))) + frames)) + +;; Button definition for jumping to a buffer position. + +(define-button-type 'backtrace-buffer-pos + 'action #'backtrace--pop-to-buffer-pos + 'help-echo "mouse-2, RET: Show reading position") + +(defun backtrace--pop-to-buffer-pos (button) + "Pop to the buffer and position for the BUTTON at point." + (let* ((buffer (button-get button 'backtrace-buffer)) + (pos (button-get button 'backtrace-pos))) + (if (buffer-live-p buffer) + (progn + (pop-to-buffer buffer) + (goto-char (max (point-min) (min (point-max) pos)))) + (message "Buffer has been killed")))) + +;; Font Locking support + +(defconst backtrace--font-lock-keywords + '((backtrace--match-ellipsis-in-string + (1 'button prepend))) + "Expressions to fontify in Backtrace mode. +Fontify these in addition to the expressions Emacs Lisp mode +fontifies.") + +(defconst backtrace-font-lock-keywords + (append lisp-el-font-lock-keywords-for-backtraces + backtrace--font-lock-keywords) + "Default expressions to highlight in Backtrace mode.") +(defconst backtrace-font-lock-keywords-1 + (append lisp-el-font-lock-keywords-for-backtraces-1 + backtrace--font-lock-keywords) + "Subdued level highlighting for Backtrace mode.") +(defconst backtrace-font-lock-keywords-2 + (append lisp-el-font-lock-keywords-for-backtraces-2 + backtrace--font-lock-keywords) + "Gaudy level highlighting for Backtrace mode.") + +(defun backtrace--match-ellipsis-in-string (bound) + ;; Fontify ellipses within strings as buttons. + ;; This is necessary because ellipses are text property buttons + ;; instead of overlay buttons, which is done because there could + ;; be a large number of them. + (when (re-search-forward "\\(\\.\\.\\.\\)\"" bound t) + (and (get-text-property (- (point) 2) 'cl-print-ellipsis) + (get-text-property (- (point) 3) 'cl-print-ellipsis) + (get-text-property (- (point) 4) 'cl-print-ellipsis)))) + +;;; Xref support + +(defun backtrace--xref-backend () 'elisp) + +;;; Backtrace mode variables + +(defvar-local backtrace-frames nil + "Stack frames displayed in the current Backtrace buffer. +This should be a list of `backtrace-frame' objects.") + +(defvar-local backtrace-view nil + "A plist describing how to render backtrace frames. +Possible entries are :show-flags, :show-locals and :print-circle.") + +(defvar-local backtrace-insert-header-function nil + "Function for inserting a header for the current Backtrace buffer. +If nil, no header will be created. Note that Backtrace buffers +are fontified as in Emacs Lisp Mode, the header text included.") + +(defvar backtrace-revert-hook nil + "Hook run before reverting a Backtrace buffer. +This is commonly used to recompute `backtrace-frames'.") + +(defvar-local backtrace-print-function #'cl-prin1 + "Function used to print values in the current Backtrace buffer.") + +(defvar-local backtrace-goto-source-functions nil + "Abnormal hook used to jump to the source code for the current frame. +Each hook function is called with no argument, and should return +non-nil if it is able to switch to the buffer containing the +source code. Execution of the hook will stop if one of the +functions returns non-nil. When adding a function to this hook, +you should also set the :source-available flag for the backtrace +frames where the source code location is known.") + +(defvar backtrace-mode-map + (let ((map (copy-keymap special-mode-map))) + (set-keymap-parent map button-buffer-map) + (define-key map "n" 'backtrace-forward-frame) + (define-key map "p" 'backtrace-backward-frame) + (define-key map "v" 'backtrace-toggle-locals) + (define-key map "#" 'backtrace-toggle-print-circle) + (define-key map "s" 'backtrace-goto-source) + (define-key map "\C-m" 'backtrace-help-follow-symbol) + (define-key map "+" 'backtrace-multi-line) + (define-key map "-" 'backtrace-single-line) + (define-key map "." 'backtrace-expand-ellipses) + (define-key map [follow-link] 'mouse-face) + (define-key map [mouse-2] 'mouse-select-window) + (easy-menu-define nil map "" + '("Backtrace" + ["Next Frame" backtrace-forward-frame + :help "Move cursor forwards to the start of a backtrace frame"] + ["Previous Frame" backtrace-backward-frame + :help "Move cursor backwards to the start of a backtrace frame"] + "--" + ["Show Variables" backtrace-toggle-locals + :style toggle + :active (backtrace-get-index) + :selected (plist-get (backtrace-get-view) :show-locals) + :help "Show or hide the local variables for the frame at point"] + ["Expand \"...\"s" backtrace-expand-ellipses + :help "Expand all the abbreviated forms in the current frame"] + ["Show on Multiple Lines" backtrace-multi-line + :help "Use line breaks and indentation to make a form more readable"] + ["Show on Single Line" backtrace-single-line] + "--" + ["Go to Source" backtrace-goto-source + :active (and (backtrace-get-index) + (plist-get (backtrace-frame-flags + (nth (backtrace-get-index) backtrace-frames)) + :source-available)) + :help "Show the source code for the current frame"] + ["Help for Symbol" backtrace-help-follow-symbol + :help "Show help for symbol at point"] + ["Describe Backtrace Mode" describe-mode + :help "Display documentation for backtrace-mode"])) + map) + "Local keymap for `backtrace-mode' buffers.") + +(defconst backtrace--flags-width 2 + "Width in characters of the flags for a backtrace frame.") + +;;; Navigation and Text Properties + +;; This mode uses the following text properties: +;; backtrace-index: The index into the buffer-local variable +;; `backtrace-frames' for the frame at point, or nil if outside of a +;; frame (in the buffer header). +;; backtrace-view: A plist describing how the frame is printed. See +;; the docstring for the buffer-local variable `backtrace-view. +;; backtrace-section: The part of a frame which point is in. Either +;; `func' or `locals'. At the moment just used to show and hide the +;; local variables. Derived modes which do additional printing +;; could define their own frame sections. +;; backtrace-form: A value applied to each printed representation of a +;; top-level s-expression, which needs to be different for sexps +;; printed adjacent to each other, so the limits can be quickly +;; found for pretty-printing. + +(defsubst backtrace-get-index (&optional pos) + "Return the index of the backtrace frame at POS. +The value is an index into `backtrace-frames', or nil. +POS, if omitted or nil, defaults to point." + (get-text-property (or pos (point)) 'backtrace-index)) + +(defsubst backtrace-get-section (&optional pos) + "Return the section of a backtrace frame at POS. +POS, if omitted or nil, defaults to point." + (get-text-property (or pos (point)) 'backtrace-section)) + +(defsubst backtrace-get-view (&optional pos) + "Return the view plist of the backtrace frame at POS. +POS, if omitted or nil, defaults to point." + (get-text-property (or pos (point)) 'backtrace-view)) + +(defsubst backtrace-get-form (&optional pos) + "Return the backtrace form data for the form printed at POS. +POS, if omitted or nil, defaults to point." + (get-text-property (or pos (point)) 'backtrace-form)) + +(defun backtrace-get-frame-start (&optional pos) + "Return the beginning position of the frame at POS in the buffer. +POS, if omitted or nil, defaults to point." + (let ((posn (or pos (point)))) + (if (or (= (point-min) posn) + (not (eq (backtrace-get-index posn) + (backtrace-get-index (1- posn))))) + posn + (previous-single-property-change posn 'backtrace-index nil (point-min))))) + +(defun backtrace-get-frame-end (&optional pos) + "Return the position of the end of the frame at POS in the buffer. +POS, if omitted or nil, defaults to point." + (next-single-property-change (or pos (point)) + 'backtrace-index nil (point-max))) + +(defun backtrace-forward-frame () + "Move forward to the beginning of the next frame." + (interactive) + (let ((max (backtrace-get-frame-end))) + (when (= max (point-max)) + (user-error "No next stack frame")) + (goto-char max))) + +(defun backtrace-backward-frame () + "Move backward to the start of a stack frame." + (interactive) + (let ((current-index (backtrace-get-index)) + (min (backtrace-get-frame-start))) + (if (or (and (/= (point) (point-max)) (null current-index)) + (= min (point-min)) + (and (= min (point)) + (null (backtrace-get-index (1- min))))) + (user-error "No previous stack frame")) + (if (= min (point)) + (goto-char (backtrace-get-frame-start (1- min))) + (goto-char min)))) + +;; Other Backtrace mode commands + +(defun backtrace-revert (&rest _ignored) + "The `revert-buffer-function' for `backtrace-mode'. +It runs `backtrace-revert-hook', then calls `backtrace-print'." + (interactive) + (unless (derived-mode-p 'backtrace-mode) + (error "The current buffer is not in Backtrace mode")) + (run-hooks 'backtrace-revert-hook) + (backtrace-print t)) + +(defmacro backtrace--with-output-variables (view &rest body) + "Bind output variables according to VIEW and execute BODY." + (declare (indent 1)) + `(let ((print-escape-control-characters t) + (print-escape-newlines t) + (print-circle (plist-get ,view :print-circle)) + (standard-output (current-buffer))) + ,@body)) + +(defun backtrace-toggle-locals (&optional all) + "Toggle the display of local variables for the backtrace frame at point. +With prefix argument ALL, toggle the value of :show-locals in +`backtrace-view', which affects all of the backtrace frames in +the buffer." + (interactive "P") + (if all + (let ((pos (make-marker)) + (visible (not (plist-get backtrace-view :show-locals)))) + (setq backtrace-view (plist-put backtrace-view :show-locals visible)) + (set-marker-insertion-type pos t) + (set-marker pos (point)) + (goto-char (point-min)) + ;; Skip the header. + (unless (backtrace-get-index) + (goto-char (backtrace-get-frame-end))) + (while (< (point) (point-max)) + (backtrace--set-frame-locals-visible visible) + (goto-char (backtrace-get-frame-end))) + (goto-char pos) + (when (invisible-p pos) + (goto-char (backtrace-get-frame-start)))) + (let ((index (backtrace-get-index))) + (unless index + (user-error "Not in a stack frame")) + (backtrace--set-frame-locals-visible + (not (plist-get (backtrace-get-view) :show-locals)))))) + +(defun backtrace--set-frame-locals-visible (visible) + "Set the visibility of the local vars for the frame at point to VISIBLE." + (let ((pos (point)) + (index (backtrace-get-index)) + (start (backtrace-get-frame-start)) + (end (backtrace-get-frame-end)) + (view (copy-sequence (backtrace-get-view))) + (inhibit-read-only t)) + (setq view (plist-put view :show-locals visible)) + (goto-char (backtrace-get-frame-start)) + (while (not (or (= (point) end) + (eq (backtrace-get-section) 'locals))) + (goto-char (next-single-property-change (point) + 'backtrace-section nil end))) + (cond + ((and (= (point) end) visible) + ;; The locals section doesn't exist so create it. + (let ((standard-output (current-buffer))) + (backtrace--with-output-variables view + (backtrace--print-locals + (nth index backtrace-frames) view)) + (add-text-properties end (point) `(backtrace-index ,index)) + (goto-char pos))) + ((/= (point) end) + ;; The locals section does exist, so add or remove the overlay. + (backtrace--set-locals-visible-overlay (point) end visible) + (goto-char (if (invisible-p pos) start pos)))) + (add-text-properties start (backtrace-get-frame-end) + `(backtrace-view ,view)))) + +(defun backtrace--set-locals-visible-overlay (beg end visible) + (backtrace--change-button-skip beg end (not visible)) + (if visible + (remove-overlays beg end 'invisible t) + (let ((o (make-overlay beg end))) + (overlay-put o 'invisible t) + (overlay-put o 'evaporate t)))) + +(defun backtrace--change-button-skip (beg end value) + "Change the skip property on all buttons between BEG and END. +Set it to VALUE unless the button is a `backtrace-ellipsis' button." + (let ((inhibit-read-only t)) + (setq beg (next-button beg)) + (while (and beg (< beg end)) + (unless (eq (button-type beg) 'backtrace-ellipsis) + (button-put beg 'skip value)) + (setq beg (next-button beg))))) + +(defun backtrace-toggle-print-circle (&optional all) + "Toggle `print-circle' for the backtrace frame at point. +With prefix argument ALL, toggle the value of :print-circle in +`backtrace-view', which affects all of the backtrace frames in +the buffer." + (interactive "P") + (backtrace--toggle-feature :print-circle all)) + +(defun backtrace--toggle-feature (feature all) + "Toggle FEATURE for the current backtrace frame or for the buffer. +FEATURE should be one of the options in `backtrace-view'. If ALL +is non-nil, toggle FEATURE for all frames in the buffer. After +toggling the feature, reprint the affected frame(s). Afterwards +position point at the start of the frame it was in before." + (if all + (let ((index (backtrace-get-index)) + (pos (point)) + (at-end (= (point) (point-max))) + (value (not (plist-get backtrace-view feature)))) + (setq backtrace-view (plist-put backtrace-view feature value)) + (goto-char (point-min)) + ;; Skip the header. + (unless (backtrace-get-index) + (goto-char (backtrace-get-frame-end))) + (while (< (point) (point-max)) + (backtrace--set-feature feature value) + (goto-char (backtrace-get-frame-end))) + (if (not index) + (goto-char (if at-end (point-max) pos)) + (goto-char (point-min)) + (while (and (not (eql index (backtrace-get-index))) + (< (point) (point-max))) + (goto-char (backtrace-get-frame-end))))) + (let ((index (backtrace-get-index))) + (unless index + (user-error "Not in a stack frame")) + (backtrace--set-feature feature + (not (plist-get (backtrace-get-view) feature)))))) + +(defun backtrace--set-feature (feature value) + "Set FEATURE in the view plist of the frame at point to VALUE. +Reprint the frame with the new view plist." + (let ((inhibit-read-only t) + (view (copy-sequence (backtrace-get-view))) + (index (backtrace-get-index)) + (min (backtrace-get-frame-start)) + (max (backtrace-get-frame-end))) + (setq view (plist-put view feature value)) + (delete-region min max) + (goto-char min) + (backtrace-print-frame (nth index backtrace-frames) view) + (add-text-properties min (point) + `(backtrace-index ,index backtrace-view ,view)) + (goto-char min))) + +(defun backtrace-expand-ellipsis (button) + "Expand display of the elided form at BUTTON." + (interactive) + (goto-char (button-start button)) + (unless (get-text-property (point) 'cl-print-ellipsis) + (if (and (> (point) (point-min)) + (get-text-property (1- (point)) 'cl-print-ellipsis)) + (backward-char) + (user-error "No ellipsis to expand here"))) + (let* ((end (next-single-property-change (point) 'cl-print-ellipsis)) + (begin (previous-single-property-change end 'cl-print-ellipsis)) + (value (get-text-property begin 'cl-print-ellipsis)) + (props (backtrace-get-text-properties begin)) + (inhibit-read-only t)) + (backtrace--with-output-variables (backtrace-get-view) + (delete-region begin end) + (insert (cl-print-to-string-with-limit #'cl-print-expand-ellipsis value + backtrace-line-length)) + (setq end (point)) + (goto-char begin) + (while (< (point) end) + (let ((next (next-single-property-change (point) 'cl-print-ellipsis + nil end))) + (when (get-text-property (point) 'cl-print-ellipsis) + (make-text-button (point) next :type 'backtrace-ellipsis)) + (goto-char next))) + (goto-char begin) + (add-text-properties begin end props)))) + +(defun backtrace-expand-ellipses (&optional no-limit) + "Expand display of all \"...\"s in the backtrace frame at point. +\\<backtrace-mode-map> +Each ellipsis will be limited to `backtrace-line-length' +characters in its expansion. With optional prefix argument +NO-LIMIT, do not limit the number of characters. Note that with +or without the argument, using this command can result in very +long lines and very poor display performance. If this happens +and is a problem, use `\\[revert-buffer]' to return to the +initial state of the Backtrace buffer." + (interactive "P") + (save-excursion + (let ((start (backtrace-get-frame-start)) + (end (backtrace-get-frame-end)) + (backtrace-line-length (unless no-limit backtrace-line-length))) + (goto-char end) + (while (> (point) start) + (let ((next (previous-single-property-change (point) 'cl-print-ellipsis + nil start))) + (when (get-text-property (point) 'cl-print-ellipsis) + (push-button (point))) + (goto-char next)))))) + +(defun backtrace-multi-line () + "Show the top level s-expression at point on multiple lines with indentation." + (interactive) + (backtrace--reformat-sexp #'backtrace--multi-line)) + +(defun backtrace--multi-line () + "Pretty print the current buffer, then remove the trailing newline." + (set-syntax-table emacs-lisp-mode-syntax-table) + (pp-buffer) + (goto-char (1- (point-max))) + (delete-char 1)) + +(defun backtrace-single-line () + "Show the top level s-expression at point on one line." + (interactive) + (backtrace--reformat-sexp #'backtrace--single-line)) + +(defun backtrace--single-line () + "Replace line breaks and following indentation with spaces. +Works on the current buffer." + (goto-char (point-min)) + (while (re-search-forward "\n[[:blank:]]*" nil t) + (replace-match " "))) + +(defun backtrace--reformat-sexp (format-function) + "Reformat the top level sexp at point. +Locate the top level sexp at or following point on the same line, +and reformat it with FORMAT-FUNCTION, preserving the location of +point within the sexp. If no sexp is found before the end of +the line or buffer, signal an error. + +FORMAT-FUNCTION will be called without arguments, with the +current buffer set to a temporary buffer containing only the +content of the sexp." + (let* ((orig-pos (point)) + (pos (point)) + (tag (backtrace-get-form pos)) + (end (next-single-property-change pos 'backtrace-form)) + (begin (previous-single-property-change end 'backtrace-form + nil (point-min)))) + (unless tag + (when (or (= end (point-max)) (> end (point-at-eol))) + (user-error "No form here to reformat")) + (goto-char end) + (setq pos end + end (next-single-property-change pos 'backtrace-form) + begin (previous-single-property-change end 'backtrace-form + nil (point-min)))) + (let* ((offset (when (>= orig-pos begin) (- orig-pos begin))) + (offset-marker (when offset (make-marker))) + (content (buffer-substring begin end)) + (props (backtrace-get-text-properties begin)) + (inhibit-read-only t)) + (delete-region begin end) + (insert (with-temp-buffer + (insert content) + (when offset + (set-marker-insertion-type offset-marker t) + (set-marker offset-marker (+ (point-min) offset))) + (funcall format-function) + (when offset + (setq offset (- (marker-position offset-marker) (point-min)))) + (buffer-string))) + (when offset + (set-marker offset-marker (+ begin offset))) + (save-excursion + (goto-char begin) + (indent-sexp)) + (add-text-properties begin (point) props) + (if offset + (goto-char (marker-position offset-marker)) + (goto-char orig-pos))))) + +(defun backtrace-get-text-properties (pos) + "Return a plist of backtrace-mode's text properties at POS." + (apply #'append + (mapcar (lambda (prop) + (list prop (get-text-property pos prop))) + '(backtrace-section backtrace-index backtrace-view + backtrace-form)))) + +(defun backtrace-goto-source () + "If its location is known, jump to the source code for the frame at point." + (interactive) + (let* ((index (or (backtrace-get-index) (user-error "Not in a stack frame"))) + (frame (nth index backtrace-frames)) + (source-available (plist-get (backtrace-frame-flags frame) + :source-available))) + (unless (and source-available + (catch 'done + (dolist (func backtrace-goto-source-functions) + (when (funcall func) + (throw 'done t))))) + (user-error "Source code location not known")))) + +(defun backtrace-help-follow-symbol (&optional pos) + "Follow cross-reference at POS, defaulting to point. +For the cross-reference format, see `help-make-xrefs'." + (interactive "d") + (unless pos + (setq pos (point))) + (unless (push-button pos) + ;; Check if the symbol under point is a function or variable. + (let ((sym + (intern + (save-excursion + (goto-char pos) (skip-syntax-backward "w_") + (buffer-substring (point) + (progn (skip-syntax-forward "w_") + (point))))))) + (when (or (boundp sym) (fboundp sym) (facep sym)) + (describe-symbol sym))))) + +;; Print backtrace frames + +(defun backtrace-print (&optional remember-pos) + "Populate the current Backtrace mode buffer. +This erases the buffer and inserts printed representations of the +frames. Optional argument REMEMBER-POS, if non-nil, means to +move point to the entry with the same ID element as the current +line and recenter window line accordingly." + (let ((inhibit-read-only t) + entry-index saved-pt window-line) + (and remember-pos + (setq entry-index (backtrace-get-index)) + (when (eq (window-buffer) (current-buffer)) + (setq window-line + (count-screen-lines (window-start) (point))))) + (erase-buffer) + (when backtrace-insert-header-function + (funcall backtrace-insert-header-function)) + (dotimes (idx (length backtrace-frames)) + (let ((beg (point)) + (elt (nth idx backtrace-frames))) + (and entry-index + (equal entry-index idx) + (setq entry-index nil + saved-pt (point))) + (backtrace-print-frame elt backtrace-view) + (add-text-properties + beg (point) + `(backtrace-index ,idx backtrace-view ,backtrace-view)))) + (set-buffer-modified-p nil) + ;; If REMEMBER-POS was specified, move to the "old" location. + (if saved-pt + (progn (goto-char saved-pt) + (when window-line + (recenter window-line))) + (goto-char (point-min))))) + +;; Define button type used for ...'s. +;; Set skip property so you don't have to TAB through 100 of them to +;; get to the next function name. +(define-button-type 'backtrace-ellipsis + 'skip t 'action #'backtrace-expand-ellipsis + 'help-echo "mouse-2, RET: expand this ellipsis") + +(defun backtrace-print-to-string (obj &optional limit) + "Return a printed representation of OBJ formatted for backtraces. +Attempt to get the length of the returned string under LIMIT +charcters with appropriate settings of `print-level' and +`print-length.' LIMIT defaults to `backtrace-line-length'." + (backtrace--with-output-variables backtrace-view + (backtrace--print-to-string obj limit))) + +(defun backtrace--print-to-string (sexp &optional limit) + ;; This is for use by callers who wrap the call with + ;; backtrace--with-output-variables. + (setq limit (or limit backtrace-line-length)) + (with-temp-buffer + (insert (cl-print-to-string-with-limit #'backtrace--print sexp limit)) + ;; Add a unique backtrace-form property. + (put-text-property (point-min) (point) 'backtrace-form (gensym)) + ;; Make buttons from all the "..."s. Since there might be many of + ;; them, use text property buttons. + (goto-char (point-min)) + (while (< (point) (point-max)) + (let ((end (next-single-property-change (point) 'cl-print-ellipsis + nil (point-max)))) + (when (get-text-property (point) 'cl-print-ellipsis) + (make-text-button (point) end :type 'backtrace-ellipsis)) + (goto-char end))) + (buffer-string))) + +(defun backtrace-print-frame (frame view) + "Insert a backtrace FRAME at point formatted according to VIEW. +Tag the sections of the frame with the `backtrace-section' text +property for use by navigation." + (backtrace--with-output-variables view + (backtrace--print-flags frame view) + (backtrace--print-func-and-args frame view) + (backtrace--print-locals frame view))) + +(defun backtrace--print-flags (frame view) + "Print the flags of a backtrace FRAME if enabled in VIEW." + (let ((beg (point)) + (flag (plist-get (backtrace-frame-flags frame) :debug-on-exit)) + (source (plist-get (backtrace-frame-flags frame) :source-available))) + (when (plist-get view :show-flags) + (when source (insert ">")) + (when flag (insert "*"))) + (insert (make-string (- backtrace--flags-width (- (point) beg)) ?\s)) + (put-text-property beg (point) 'backtrace-section 'func))) + +(defun backtrace--print-func-and-args (frame _view) + "Print the function, arguments and buffer position of a backtrace FRAME. +Format it according to VIEW." + (let* ((beg (point)) + (evald (backtrace-frame-evald frame)) + (fun (backtrace-frame-fun frame)) + (args (backtrace-frame-args frame)) + (def (find-function-advised-original fun)) + (fun-file (or (symbol-file fun 'defun) + (and (subrp def) + (not (eq 'unevalled (cdr (subr-arity def)))) + (find-lisp-object-file-name fun def)))) + (fun-pt (point))) + (cond + ((and evald (not debugger-stack-frame-as-list)) + (if (atom fun) + (funcall backtrace-print-function fun) + (insert + (backtrace--print-to-string fun (when args (/ backtrace-line-length 2))))) + (if args + (insert (backtrace--print-to-string + args (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. + (let ((start (point))) + (insert "()") + (put-text-property start (point) 'backtrace-form t)))) + (t + (let ((fun-and-args (cons fun args))) + (insert (backtrace--print-to-string fun-and-args))) + (cl-incf fun-pt))) + (when fun-file + (make-text-button fun-pt (+ fun-pt + (length (backtrace--print-to-string fun))) + :type 'help-function-def + 'help-args (list fun fun-file))) + ;; After any frame that uses eval-buffer, insert a comment that + ;; states the buffer position it's reading at. + (when (backtrace-frame-pos frame) + (insert " ; Reading at ") + (let ((pos (point))) + (insert (format "buffer position %d" (backtrace-frame-pos frame))) + (make-button pos (point) :type 'backtrace-buffer-pos + 'backtrace-buffer (backtrace-frame-buffer frame) + 'backtrace-pos (backtrace-frame-pos frame)))) + (insert "\n") + (put-text-property beg (point) 'backtrace-section 'func))) + +(defun backtrace--print-locals (frame view) + "Print a backtrace FRAME's local variables according to VIEW. +Print them only if :show-locals is non-nil in the VIEW plist." + (when (plist-get view :show-locals) + (let* ((beg (point)) + (locals (backtrace-frame-locals frame))) + (if (null locals) + (insert " [no locals]\n") + (pcase-dolist (`(,symbol . ,value) locals) + (insert " ") + (backtrace--print symbol) + (insert " = ") + (insert (backtrace--print-to-string value)) + (insert "\n"))) + (put-text-property beg (point) 'backtrace-section 'locals)))) + +(defun backtrace--print (obj &optional stream) + "Attempt to print OBJ to STREAM using `backtrace-print-function'. +Fall back to `prin1' if there is an error." + (condition-case err + (funcall backtrace-print-function obj stream) + (error + (message "Error in backtrace printer: %S" err) + (prin1 obj stream)))) + +(defun backtrace-update-flags () + "Update the display of the flags in the backtrace frame at point." + (let ((view (backtrace-get-view)) + (begin (backtrace-get-frame-start))) + (when (plist-get view :show-flags) + (save-excursion + (goto-char begin) + (let ((props (backtrace-get-text-properties begin)) + (inhibit-read-only t) + (standard-output (current-buffer))) + (delete-char backtrace--flags-width) + (backtrace--print-flags (nth (backtrace-get-index) backtrace-frames) + view) + (add-text-properties begin (point) props)))))) + +(defun backtrace--filter-visible (beg end &optional _delete) + "Return the visible text between BEG and END." + (let ((result "")) + (while (< beg end) + (let ((next (next-single-char-property-change beg 'invisible))) + (unless (get-char-property beg 'invisible) + (setq result (concat result (buffer-substring beg (min end next))))) + (setq beg next))) + result)) + +;;; The mode definition + +(define-derived-mode backtrace-mode special-mode "Backtrace" + "Generic major mode for examining an Elisp stack backtrace. +This mode can be used directly, or other major modes can be +derived from it, using `define-derived-mode'. + +In this major mode, the buffer contains some optional lines of +header text followed by backtrace frames, each consisting of one +or more whole lines. + +Letters in this mode do not insert themselves; instead they are +commands. +\\<backtrace-mode-map> +\\{backtrace-mode-map} + +A mode which inherits from Backtrace mode, or a command which +creates a backtrace-mode buffer, should usually do the following: + + - Set `backtrace-revert-hook', if the buffer contents need + to be specially recomputed prior to `revert-buffer'. + - Maybe set `backtrace-insert-header-function' to a function to create + header text for the buffer. + - Set `backtrace-frames' (see below). + - Maybe modify `backtrace-view' (see below). + - Maybe set `backtrace-print-function'. + +A command which creates or switches to a Backtrace mode buffer, +such as `ert-results-pop-to-backtrace-for-test-at-point', should +initialize `backtrace-frames' to a list of `backtrace-frame' +objects (`backtrace-get-frames' is provided for that purpose, if +desired), and may optionally modify `backtrace-view', which is a +plist describing the appearance of the backtrace. Finally, it +should call `backtrace-print'. + +`backtrace-print' calls `backtrace-insert-header-function' +followed by `backtrace-print-frame', once for each stack frame." + :syntax-table emacs-lisp-mode-syntax-table + (when backtrace-fontify + (setq font-lock-defaults + '((backtrace-font-lock-keywords + backtrace-font-lock-keywords-1 + backtrace-font-lock-keywords-2) + nil nil nil nil + (font-lock-syntactic-face-function + . lisp-font-lock-syntactic-face-function)))) + (setq truncate-lines t) + (buffer-disable-undo) + ;; In debug.el, from 1998 to 2009 this was set to nil, reason stated + ;; was because of bytecode. Since 2009 it's been set to t, but the + ;; default is t so I think this isn't necessary. + ;; (set-buffer-multibyte t) + (setq-local revert-buffer-function #'backtrace-revert) + (setq-local filter-buffer-substring-function #'backtrace--filter-visible) + (setq-local indent-line-function 'lisp-indent-line) + (setq-local indent-region-function 'lisp-indent-region) + (add-hook 'xref-backend-functions #'backtrace--xref-backend nil t)) + +(put 'backtrace-mode 'mode-class 'special) + +;;; Backtrace printing + +;;;###autoload +(defun backtrace () + "Print a trace of Lisp function calls currently active. +Output stream used is value of `standard-output'." + (princ (backtrace-to-string (backtrace-get-frames 'backtrace))) + nil) + +(defun backtrace-to-string(&optional frames) + "Format FRAMES, a list of `backtrace-frame' objects, for output. +Return the result as a string. If FRAMES is nil, use all +function calls currently active." + (unless frames (setq frames (backtrace-get-frames 'backtrace-to-string))) + (let ((backtrace-fontify nil)) + (with-temp-buffer + (backtrace-mode) + (setq backtrace-view '(:show-flags t) + backtrace-frames frames + backtrace-print-function #'cl-prin1) + (backtrace-print) + (substring-no-properties (filter-buffer-substring (point-min) + (point-max)))))) + +(provide 'backtrace) + +;;; backtrace.el ends here diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index 9c2def7af6d..8f12858b033 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2003-2019 Free Software Foundation, Inc. -;; Author: Dave Love <fx@gnu.org> +;; Author: Dave Love <fx@gnu.org> ;; Keywords: lisp, extensions ;; This file is part of GNU Emacs. @@ -34,13 +34,11 @@ (defmacro benchmark-elapse (&rest forms) "Return the time in seconds elapsed for execution of FORMS." (declare (indent 0) (debug t)) - (let ((t1 (make-symbol "t1")) - (t2 (make-symbol "t2"))) - `(let (,t1 ,t2) + (let ((t1 (make-symbol "t1"))) + `(let (,t1) (setq ,t1 (current-time)) ,@forms - (setq ,t2 (current-time)) - (float-time (time-subtract ,t2 ,t1))))) + (float-time (time-since ,t1))))) ;;;###autoload (defmacro benchmark-run (&optional repetitions &rest forms) @@ -52,7 +50,7 @@ Return a list of the total elapsed time for execution, the number of garbage collections that ran, and the time taken by garbage collection. See also `benchmark-run-compiled'." (declare (indent 1) (debug t)) - (unless (natnump repetitions) + (unless (or (natnump repetitions) (and repetitions (symbolp repetitions))) (setq forms (cons repetitions forms) repetitions 1)) (let ((i (make-symbol "i")) @@ -60,7 +58,7 @@ See also `benchmark-run-compiled'." (gc (make-symbol "gc"))) `(let ((,gc gc-elapsed) (,gcs gcs-done)) - (list ,(if (> repetitions 1) + (list ,(if (or (symbolp repetitions) (> repetitions 1)) ;; Take account of the loop overhead. `(- (benchmark-elapse (dotimes (,i ,repetitions) ,@forms)) @@ -76,17 +74,17 @@ This is like `benchmark-run', but what is timed is a funcall of the byte code obtained by wrapping FORMS in a `lambda' and compiling the result. The overhead of the `lambda's is accounted for." (declare (indent 1) (debug t)) - (unless (natnump repetitions) + (unless (or (natnump repetitions) (and repetitions (symbolp repetitions))) (setq forms (cons repetitions forms) repetitions 1)) (let ((i (make-symbol "i")) (gcs (make-symbol "gcs")) (gc (make-symbol "gc")) (code (byte-compile `(lambda () ,@forms))) - (lambda-code (byte-compile `(lambda ())))) + (lambda-code (byte-compile '(lambda ())))) `(let ((,gc gc-elapsed) (,gcs gcs-done)) - (list ,(if (> repetitions 1) + (list ,(if (or (symbolp repetitions) (> repetitions 1)) ;; Take account of the loop overhead. `(- (benchmark-elapse (dotimes (,i ,repetitions) (funcall ,code))) @@ -103,7 +101,7 @@ the command prompts for the form to benchmark. For non-interactive use see also `benchmark-run' and `benchmark-run-compiled'." (interactive "p\nxForm: ") - (let ((result (eval `(benchmark-run ,repetitions ,form)))) + (let ((result (eval `(benchmark-run ,repetitions ,form) t))) (if (zerop (nth 1 result)) (message "Elapsed time: %fs" (car result)) (message "Elapsed time: %fs (%fs in %d GCs)" (car result) diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index fcfbec427e2..e0b12b53af2 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -205,22 +205,22 @@ (setq bindat-idx (1+ bindat-idx)))) (defun bindat--unpack-u16 () - (logior (lsh (bindat--unpack-u8) 8) (bindat--unpack-u8))) + (logior (ash (bindat--unpack-u8) 8) (bindat--unpack-u8))) (defun bindat--unpack-u24 () - (logior (lsh (bindat--unpack-u16) 8) (bindat--unpack-u8))) + (logior (ash (bindat--unpack-u16) 8) (bindat--unpack-u8))) (defun bindat--unpack-u32 () - (logior (lsh (bindat--unpack-u16) 16) (bindat--unpack-u16))) + (logior (ash (bindat--unpack-u16) 16) (bindat--unpack-u16))) (defun bindat--unpack-u16r () - (logior (bindat--unpack-u8) (lsh (bindat--unpack-u8) 8))) + (logior (bindat--unpack-u8) (ash (bindat--unpack-u8) 8))) (defun bindat--unpack-u24r () - (logior (bindat--unpack-u16r) (lsh (bindat--unpack-u8) 16))) + (logior (bindat--unpack-u16r) (ash (bindat--unpack-u8) 16))) (defun bindat--unpack-u32r () - (logior (bindat--unpack-u16r) (lsh (bindat--unpack-u16r) 16))) + (logior (bindat--unpack-u16r) (ash (bindat--unpack-u16r) 16))) (defun bindat--unpack-item (type len &optional vectype) (if (eq type 'ip) @@ -250,13 +250,13 @@ (if (/= 0 (logand m j)) (setq bits (cons bnum bits))) (setq bnum (1- bnum) - j (lsh j -1))))) + j (ash j -1))))) bits)) ((eq type 'str) (let ((s (substring bindat-raw bindat-idx (+ bindat-idx len)))) (setq bindat-idx (+ bindat-idx len)) (if (stringp s) s - (string-make-unibyte (concat s))))) + (apply #'unibyte-string s)))) ((eq type 'strz) (let ((i 0) s) (while (and (< i len) (/= (aref bindat-raw (+ bindat-idx i)) 0)) @@ -264,7 +264,7 @@ (setq s (substring bindat-raw bindat-idx (+ bindat-idx i))) (setq bindat-idx (+ bindat-idx len)) (if (stringp s) s - (string-make-unibyte (concat s))))) + (apply #'unibyte-string s)))) ((eq type 'vec) (let ((v (make-vector len 0)) (i 0) (vlen 1)) (if (consp vectype) @@ -459,30 +459,30 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (setq bindat-idx (1+ bindat-idx))) (defun bindat--pack-u16 (v) - (aset bindat-raw bindat-idx (logand (lsh v -8) 255)) + (aset bindat-raw bindat-idx (logand (ash v -8) 255)) (aset bindat-raw (1+ bindat-idx) (logand v 255)) (setq bindat-idx (+ bindat-idx 2))) (defun bindat--pack-u24 (v) - (bindat--pack-u8 (lsh v -16)) + (bindat--pack-u8 (ash v -16)) (bindat--pack-u16 v)) (defun bindat--pack-u32 (v) - (bindat--pack-u16 (lsh v -16)) + (bindat--pack-u16 (ash v -16)) (bindat--pack-u16 v)) (defun bindat--pack-u16r (v) - (aset bindat-raw (1+ bindat-idx) (logand (lsh v -8) 255)) + (aset bindat-raw (1+ bindat-idx) (logand (ash v -8) 255)) (aset bindat-raw bindat-idx (logand v 255)) (setq bindat-idx (+ bindat-idx 2))) (defun bindat--pack-u24r (v) (bindat--pack-u16r v) - (bindat--pack-u8 (lsh v -16))) + (bindat--pack-u8 (ash v -16))) (defun bindat--pack-u32r (v) (bindat--pack-u16r v) - (bindat--pack-u16r (lsh v -16))) + (bindat--pack-u16r (ash v -16))) (defun bindat--pack-item (v type len &optional vectype) (if (eq type 'ip) @@ -515,7 +515,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (if (memq bnum v) (setq m (logior m j))) (setq bnum (1- bnum) - j (lsh j -1)))) + j (ash j -1)))) (bindat--pack-u8 m)))) ((memq type '(str strz)) (let ((l (length v)) (i 0)) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 9f9ea8a43ce..ecaa845fd3e 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -255,7 +255,7 @@ (setq fn (or (symbol-function name) (cdr (assq name byte-compile-function-environment))))) (pcase fn - (`nil + ('nil (byte-compile-warn "attempt to inline `%s' before it was defined" name) form) @@ -436,11 +436,6 @@ (cons (byte-optimize-form (nth 1 form) for-effect) (byte-optimize-body (cdr (cdr form)) t))) (byte-optimize-form (nth 1 form) for-effect))) - ((eq fn 'prog2) - (cons 'prog2 - (cons (byte-optimize-form (nth 1 form) t) - (cons (byte-optimize-form (nth 2 form) for-effect) - (byte-optimize-body (cdr (cdr (cdr form))) t))))) ((memq fn '(save-excursion save-restriction save-current-buffer)) ;; those subrs which have an implicit progn; it's not quite good @@ -635,7 +630,7 @@ (setq form (car (last (cdr form))))) (cond ((consp form) (pcase (car form) - (`quote (cadr form)) + ('quote (cadr form)) ;; Can't use recursion in a defsubst. ;; (`progn (byte-compile-trueconstp (car (last (cdr form))))) )) @@ -649,22 +644,22 @@ (setq form (car (last (cdr form))))) (cond ((consp form) (pcase (car form) - (`quote (null (cadr form))) + ('quote (null (cadr form))) ;; Can't use recursion in a defsubst. ;; (`progn (byte-compile-nilconstp (car (last (cdr form))))) )) ((not (symbolp form)) nil) ((null form)))) -;; If the function is being called with constant numeric args, +;; If the function is being called with constant integer args, ;; evaluate as much as possible at compile-time. This optimizer -;; assumes that the function is associative, like + or *. +;; assumes that the function is associative, like min or max. (defun byte-optimize-associative-math (form) (let ((args nil) (constants nil) (rest (cdr form))) (while rest - (if (numberp (car rest)) + (if (integerp (car rest)) (setq constants (cons (car rest) constants)) (setq args (cons (car rest) args))) (setq rest (cdr rest))) @@ -678,187 +673,134 @@ (apply (car form) constants)) form))) -;; If the function is being called with constant numeric args, -;; evaluate as much as possible at compile-time. This optimizer -;; assumes that the function satisfies -;; (op x1 x2 ... xn) == (op ...(op (op x1 x2) x3) ...xn) -;; like - and /. -(defun byte-optimize-nonassociative-math (form) - (if (or (not (numberp (car (cdr form)))) - (not (numberp (car (cdr (cdr form)))))) - form - (let ((constant (car (cdr form))) - (rest (cdr (cdr form)))) - (while (numberp (car rest)) - (setq constant (funcall (car form) constant (car rest)) - rest (cdr rest))) - (if rest - (cons (car form) (cons constant rest)) - constant)))) - -;;(defun byte-optimize-associative-two-args-math (form) -;; (setq form (byte-optimize-associative-math form)) -;; (if (consp form) -;; (byte-optimize-two-args-left form) -;; form)) - -;;(defun byte-optimize-nonassociative-two-args-math (form) -;; (setq form (byte-optimize-nonassociative-math form)) -;; (if (consp form) -;; (byte-optimize-two-args-right form) -;; form)) - -(defun byte-optimize-approx-equal (x y) - (<= (* (abs (- x y)) 100) (abs (+ x y)))) - -;; Collect all the constants from FORM, after the STARTth arg, -;; and apply FUN to them to make one argument at the end. -;; For functions that can handle floats, that optimization -;; can be incorrect because reordering can cause an overflow -;; that would otherwise be avoided by encountering an arg that is a float. -;; We avoid this problem by (1) not moving float constants and -;; (2) not moving anything if it would cause an overflow. -(defun byte-optimize-delay-constants-math (form start fun) - ;; Merge all FORM's constants from number START, call FUN on them - ;; and put the result at the end. - (let ((rest (nthcdr (1- start) form)) - (orig form) - ;; t means we must check for overflow. - (overflow (memq fun '(+ *)))) - (while (cdr (setq rest (cdr rest))) - (if (integerp (car rest)) - (let (constants) - (setq form (copy-sequence form) - rest (nthcdr (1- start) form)) - (while (setq rest (cdr rest)) - (cond ((integerp (car rest)) - (setq constants (cons (car rest) constants)) - (setcar rest nil)))) - ;; If necessary, check now for overflow - ;; that might be caused by reordering. - (if (and overflow - ;; We have overflow if the result of doing the arithmetic - ;; on floats is not even close to the result - ;; of doing it on integers. - (not (byte-optimize-approx-equal - (apply fun (mapcar 'float constants)) - (float (apply fun constants))))) - (setq form orig) - (setq form (nconc (delq nil form) - (list (apply fun (nreverse constants))))))))) - form)) - -(defsubst byte-compile-butlast (form) - (nreverse (cdr (reverse form)))) +;; Portable Emacs integers fall in this range. +(defconst byte-opt--portable-max #x1fffffff) +(defconst byte-opt--portable-min (- -1 byte-opt--portable-max)) + +;; True if N is a number that works the same on all Emacs platforms. +;; Portable Emacs fixnums are exactly representable as floats on all +;; Emacs platforms, and (except for -0.0) any floating-point number +;; that equals one of these integers must be the same on all +;; platforms. Although other floating-point numbers such as 0.5 are +;; also portable, it can be tricky to characterize them portably so +;; they are not optimized. +(defun byte-opt--portable-numberp (n) + (and (numberp n) + (<= byte-opt--portable-min n byte-opt--portable-max) + (= n (floor n)) + (not (and (floatp n) (zerop n) + (condition-case () (< (/ n) 0) (error)))))) + +;; Use OP to reduce any leading prefix of portable numbers in the list +;; (cons ACCUM ARGS) down to a single portable number, and return the +;; resulting list A of arguments. The idea is that applying OP to A +;; is equivalent to (but likely more efficient than) applying OP to +;; (cons ACCUM ARGS), on any Emacs platform. Do not make any special +;; provision for (- X) or (/ X); for example, it is the caller’s +;; responsibility that (- 1 0) should not be "optimized" to (- 1). +(defun byte-opt--arith-reduce (op accum args) + (when (byte-opt--portable-numberp accum) + (let (accum1) + (while (and (byte-opt--portable-numberp (car args)) + (byte-opt--portable-numberp + (setq accum1 (condition-case () + (funcall op accum (car args)) + (error)))) + (= accum1 (funcall op (float accum) (car args)))) + (setq accum accum1) + (setq args (cdr args))))) + (cons accum args)) (defun byte-optimize-plus (form) - ;; Don't call `byte-optimize-delay-constants-math' (bug#1334). - ;;(setq form (byte-optimize-delay-constants-math form 1 '+)) - (if (memq 0 form) (setq form (delq 0 (copy-sequence form)))) - ;; For (+ constants...), byte-optimize-predicate does the work. - (when (memq nil (mapcar 'numberp (cdr form))) + (let ((args (remq 0 (byte-opt--arith-reduce #'+ 0 (cdr form))))) (cond + ;; (+) -> 0 + ((null args) 0) + ;; (+ n) -> n, where n is a number + ((and (null (cdr args)) (numberp (car args))) (car args)) ;; (+ x 1) --> (1+ x) and (+ x -1) --> (1- x). - ((and (= (length form) 3) - (or (memq (nth 1 form) '(1 -1)) - (memq (nth 2 form) '(1 -1)))) - (let (integer other) - (if (memq (nth 1 form) '(1 -1)) - (setq integer (nth 1 form) other (nth 2 form)) - (setq integer (nth 2 form) other (nth 1 form))) - (setq form - (list (if (eq integer 1) '1+ '1-) other)))) - ;; Here, we could also do - ;; (+ x y ... 1) --> (1+ (+ x y ...)) - ;; (+ x y ... -1) --> (1- (+ x y ...)) - ;; The resulting bytecode is smaller, but is it faster? -- cyd - )) - (byte-optimize-predicate form)) + ((and (null (cddr args)) (or (memq 1 args) (memq -1 args))) + (let* ((arg1 (car args)) (arg2 (cadr args)) + (integer-is-first (memq arg1 '(1 -1))) + (integer (if integer-is-first arg1 arg2)) + (other (if integer-is-first arg2 arg1))) + (list (if (eq integer 1) '1+ '1-) other))) + ;; not further optimized + ((equal args (cdr form)) form) + (t (cons '+ args))))) (defun byte-optimize-minus (form) - ;; Don't call `byte-optimize-delay-constants-math' (bug#1334). - ;;(setq form (byte-optimize-delay-constants-math form 2 '+)) - ;; Remove zeros. - (when (and (nthcdr 3 form) - (memq 0 (cddr form))) - (setq form (nconc (list (car form) (cadr form)) - (delq 0 (copy-sequence (cddr form))))) - ;; After the above, we must turn (- x) back into (- x 0) - (or (cddr form) - (setq form (nconc form (list 0))))) - ;; For (- constants..), byte-optimize-predicate does the work. - (when (memq nil (mapcar 'numberp (cdr form))) - (cond - ;; (- x 1) --> (1- x) - ((equal (nthcdr 2 form) '(1)) - (setq form (list '1- (nth 1 form)))) - ;; (- x -1) --> (1+ x) - ((equal (nthcdr 2 form) '(-1)) - (setq form (list '1+ (nth 1 form)))) - ;; (- 0 x) --> (- x) - ((and (eq (nth 1 form) 0) - (= (length form) 3)) - (setq form (list '- (nth 2 form)))) - ;; Here, we could also do - ;; (- x y ... 1) --> (1- (- x y ...)) - ;; (- x y ... -1) --> (1+ (- x y ...)) - ;; The resulting bytecode is smaller, but is it faster? -- cyd - )) - (byte-optimize-predicate form)) - -(defun byte-optimize-multiply (form) - (setq form (byte-optimize-delay-constants-math form 1 '*)) - ;; For (* constants..), byte-optimize-predicate does the work. - (when (memq nil (mapcar 'numberp (cdr form))) - ;; After `byte-optimize-predicate', if there is a INTEGER constant - ;; in FORM, it is in the last element. - (let ((last (car (reverse (cdr form))))) + (let ((args (cdr form))) + (if (and (cdr args) + (null (cdr (setq args (byte-opt--arith-reduce + #'- (car args) (cdr args))))) + (numberp (car args))) + ;; The entire argument list reduced to a constant; return it. + (car args) + ;; Remove non-leading zeros, except for (- x 0). + (when (memq 0 (cdr args)) + (setq args (cons (car args) (or (remq 0 (cdr args)) (list 0))))) (cond - ;; Would handling (* ... 0) here cause floating point errors? - ;; See bug#1334. - ((eq 1 last) (setq form (byte-compile-butlast form))) - ((eq -1 last) - (setq form (list '- (if (nthcdr 3 form) - (byte-compile-butlast form) - (nth 1 form)))))))) - (byte-optimize-predicate form)) + ;; (- x 1) --> (1- x) + ((equal (cdr args) '(1)) + (list '1- (car args))) + ;; (- x -1) --> (1+ x) + ((equal (cdr args) '(-1)) + (list '1+ (car args))) + ;; (- n) -> -n, where n and -n are portable numbers. + ;; This must be done separately since byte-opt--arith-reduce + ;; is not applied to (- n). + ((and (null (cdr args)) + (byte-opt--portable-numberp (car args)) + (byte-opt--portable-numberp (- (car args)))) + (- (car args))) + ;; not further optimized + ((equal args (cdr form)) form) + (t (cons '- args)))))) + +(defun byte-optimize-1+ (form) + (let ((args (cdr form))) + (when (null (cdr args)) + (let ((n (car args))) + (when (and (byte-opt--portable-numberp n) + (byte-opt--portable-numberp (1+ n))) + (setq form (1+ n)))))) + form) + +(defun byte-optimize-1- (form) + (let ((args (cdr form))) + (when (null (cdr args)) + (let ((n (car args))) + (when (and (byte-opt--portable-numberp n) + (byte-opt--portable-numberp (1- n))) + (setq form (1- n)))))) + form) -(defun byte-optimize-divide (form) - (setq form (byte-optimize-delay-constants-math form 2 '*)) - ;; After `byte-optimize-predicate', if there is a INTEGER constant - ;; in FORM, it is in the last element. - (let ((last (car (reverse (cdr (cdr form)))))) +(defun byte-optimize-multiply (form) + (let* ((args (remq 1 (byte-opt--arith-reduce #'* 1 (cdr form))))) (cond - ;; Runtime error (leave it intact). - ((or (null last) - (eq last 0) - (memql 0.0 (cddr form)))) - ;; No constants in expression - ((not (numberp last))) - ;; For (* constants..), byte-optimize-predicate does the work. - ((null (memq nil (mapcar 'numberp (cdr form))))) - ;; (/ x y.. 1) --> (/ x y..) - ((and (eq last 1) (nthcdr 3 form)) - (setq form (byte-compile-butlast form))) - ;; (/ x -1), (/ x .. -1) --> (- x), (- (/ x ..)) - ((eq last -1) - (setq form (list '- (if (nthcdr 3 form) - (byte-compile-butlast form) - (nth 1 form))))))) - (byte-optimize-predicate form)) - -(defun byte-optimize-logmumble (form) - (setq form (byte-optimize-delay-constants-math form 1 (car form))) - (byte-optimize-predicate - (cond ((memq 0 form) - (setq form (if (eq (car form) 'logand) - (cons 'progn (cdr form)) - (delq 0 (copy-sequence form))))) - ((and (eq (car-safe form) 'logior) - (memq -1 form)) - (cons 'progn (cdr form))) - (form)))) + ;; (*) -> 1 + ((null args) 1) + ;; (* n) -> n, where n is a number + ((and (null (cdr args)) (numberp (car args))) (car args)) + ;; not further optimized + ((equal args (cdr form)) form) + (t (cons '* args))))) +(defun byte-optimize-divide (form) + (let ((args (cdr form))) + (if (and (cdr args) + (null (cdr (setq args (byte-opt--arith-reduce + #'/ (car args) (cdr args))))) + (numberp (car args))) + ;; The entire argument list reduced to a constant; return it. + (car args) + ;; Remove non-leading 1s, except for (/ x 1). + (when (memq 1 (cdr args)) + (setq args (cons (car args) (or (remq 1 (cdr args)) (list 1))))) + (if (equal args (cdr form)) + form + (cons '/ args))))) (defun byte-optimize-binary-predicate (form) (cond @@ -892,7 +834,83 @@ (if (= 1 (length (cdr form))) "" "s")) form)) +(defun byte-optimize--constant-symbol-p (expr) + "Whether EXPR is a constant symbol." + (and (macroexp-const-p expr) (symbolp (eval expr)))) + +(defun byte-optimize-equal (form) + ;; Replace `equal' or `eql' with `eq' if at least one arg is a symbol. + (byte-optimize-binary-predicate + (if (= (length (cdr form)) 2) + (if (or (byte-optimize--constant-symbol-p (nth 1 form)) + (byte-optimize--constant-symbol-p (nth 2 form))) + (cons 'eq (cdr form)) + form) + ;; Arity errors reported elsewhere. + form))) + +(defun byte-optimize-member (form) + ;; Replace `member' or `memql' with `memq' if the first arg is a symbol, + ;; or the second arg is a list of symbols. + (if (= (length (cdr form)) 2) + (if (or (byte-optimize--constant-symbol-p (nth 1 form)) + (let ((arg2 (nth 2 form))) + (and (macroexp-const-p arg2) + (let ((listval (eval arg2))) + (and (listp listval) + (not (memq nil (mapcar #'symbolp listval)))))))) + (cons 'memq (cdr form)) + form) + ;; Arity errors reported elsewhere. + form)) + +(defun byte-optimize-memq (form) + ;; (memq foo '(bar)) => (and (eq foo 'bar) '(bar)) + (if (/= (length (cdr form)) 2) + (byte-compile-warn "memq called with %d arg%s, but requires 2" + (length (cdr form)) + (if (= 1 (length (cdr form))) "" "s")) + (let ((list (nth 2 form))) + (when (and (eq (car-safe list) 'quote) + (listp (setq list (cadr list))) + (= (length list) 1)) + (setq form (byte-optimize-and + `(and ,(byte-optimize-predicate + `(eq ,(nth 1 form) ',(nth 0 list))) + ',list))))) + (byte-optimize-predicate form))) + +(defun byte-optimize-concat (form) + "Merge adjacent constant arguments to `concat'." + (let ((args (cdr form)) + (newargs nil)) + (while args + (let ((strings nil) + val) + (while (and args (macroexp-const-p (car args)) + (progn + (setq val (eval (car args))) + (and (or (stringp val) + (and (or (listp val) (vectorp val)) + (not (memq nil + (mapcar #'characterp val)))))))) + (push val strings) + (setq args (cdr args))) + (when strings + (let ((s (apply #'concat (nreverse strings)))) + (when (not (zerop (length s))) + (push s newargs))))) + (when args + (push (car args) newargs) + (setq args (cdr args)))) + (if (= (length newargs) (length (cdr form))) + form ; No improvement. + (cons 'concat (nreverse newargs))))) + (put 'identity 'byte-optimizer 'byte-optimize-identity) +(put 'memq 'byte-optimizer 'byte-optimize-memq) +(put 'memql 'byte-optimizer 'byte-optimize-member) +(put 'member 'byte-optimizer 'byte-optimize-member) (put '+ 'byte-optimizer 'byte-optimize-plus) (put '* 'byte-optimizer 'byte-optimize-multiply) @@ -903,7 +921,8 @@ (put '= 'byte-optimizer 'byte-optimize-binary-predicate) (put 'eq 'byte-optimizer 'byte-optimize-binary-predicate) -(put 'equal 'byte-optimizer 'byte-optimize-binary-predicate) +(put 'eql 'byte-optimizer 'byte-optimize-equal) +(put 'equal 'byte-optimizer 'byte-optimize-equal) (put 'string= 'byte-optimizer 'byte-optimize-binary-predicate) (put 'string-equal 'byte-optimizer 'byte-optimize-binary-predicate) @@ -911,21 +930,21 @@ (put '> 'byte-optimizer 'byte-optimize-predicate) (put '<= 'byte-optimizer 'byte-optimize-predicate) (put '>= 'byte-optimizer 'byte-optimize-predicate) -(put '1+ 'byte-optimizer 'byte-optimize-predicate) -(put '1- 'byte-optimizer 'byte-optimize-predicate) +(put '1+ 'byte-optimizer 'byte-optimize-1+) +(put '1- 'byte-optimizer 'byte-optimize-1-) (put 'not 'byte-optimizer 'byte-optimize-predicate) (put 'null 'byte-optimizer 'byte-optimize-predicate) -(put 'memq 'byte-optimizer 'byte-optimize-predicate) (put 'consp 'byte-optimizer 'byte-optimize-predicate) (put 'listp 'byte-optimizer 'byte-optimize-predicate) (put 'symbolp 'byte-optimizer 'byte-optimize-predicate) (put 'stringp 'byte-optimizer 'byte-optimize-predicate) (put 'string< 'byte-optimizer 'byte-optimize-predicate) -(put 'string-lessp 'byte-optimizer 'byte-optimize-predicate) +(put 'string-lessp 'byte-optimizer 'byte-optimize-predicate) +(put 'proper-list-p 'byte-optimizer 'byte-optimize-predicate) -(put 'logand 'byte-optimizer 'byte-optimize-logmumble) -(put 'logior 'byte-optimizer 'byte-optimize-logmumble) -(put 'logxor 'byte-optimizer 'byte-optimize-logmumble) +(put 'logand 'byte-optimizer 'byte-optimize-predicate) +(put 'logior 'byte-optimizer 'byte-optimize-predicate) +(put 'logxor 'byte-optimizer 'byte-optimize-predicate) (put 'lognot 'byte-optimizer 'byte-optimize-predicate) (put 'car 'byte-optimizer 'byte-optimize-predicate) @@ -933,6 +952,7 @@ (put 'car-safe 'byte-optimizer 'byte-optimize-predicate) (put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate) +(put 'concat 'byte-optimizer 'byte-optimize-concat) ;; I'm not convinced that this is necessary. Doesn't the optimizer loop ;; take care of this? - Jamie @@ -967,8 +987,7 @@ ;; Throw away nil's, and simplify if less than 2 args. ;; If there is a literal non-nil constant in the args to `or', throw away all ;; following forms. - (if (memq nil form) - (setq form (delq nil (copy-sequence form)))) + (setq form (remq nil form)) (let ((rest form)) (while (cdr (setq rest (cdr rest))) (if (byte-compile-trueconstp (car rest)) @@ -985,9 +1004,8 @@ (let (rest) ;; This must be first, to reduce (cond (t ...) (nil)) to (progn t ...) (while (setq rest (assq nil (cdr form))) - (setq form (delq rest (copy-sequence form)))) - (if (memq nil (cdr form)) - (setq form (delq nil (copy-sequence form)))) + (setq form (remq rest form))) + (setq form (remq nil form)) (setq rest form) (while (setq rest (cdr rest)) (cond ((byte-compile-trueconstp (car-safe (car rest))) @@ -1022,8 +1040,7 @@ ;; (if <test> <then> nil) ==> (if <test> <then>) (let ((clause (nth 1 form))) (cond ((and (eq (car-safe clause) 'progn) - ;; `clause' is a proper list. - (null (cdr (last clause)))) + (proper-list-p clause)) (if (null (cddr clause)) ;; A trivial `progn'. (byte-optimize-if `(if ,(cadr clause) ,@(nthcdr 2 form))) @@ -1186,6 +1203,7 @@ char-equal char-to-string char-width compare-strings compare-window-configurations concat coordinates-in-window-p copy-alist copy-sequence copy-marker cos count-lines + current-time-string current-time-zone decode-char decode-time default-boundp default-value documentation downcase elt encode-char exp expt encode-time error-message-string @@ -1199,8 +1217,9 @@ hash-table-count int-to-string intern-soft keymap-parent - length local-variable-if-set-p local-variable-p log log10 logand - logb logior lognot logxor lsh langinfo + length line-beginning-position line-end-position + local-variable-if-set-p local-variable-p locale-info + log log10 logand logb logcount logior lognot logxor lsh make-list make-string make-symbol marker-buffer max member memq min minibuffer-selected-window minibuffer-window mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string @@ -1210,7 +1229,7 @@ radians-to-degrees rassq rassoc read-from-string regexp-quote region-beginning region-end reverse round sin sqrt string string< string= string-equal string-lessp string-to-char - string-to-int string-to-number substring + string-to-number substring sxhash sxhash-equal sxhash-eq sxhash-eql symbol-function symbol-name symbol-plist symbol-value string-make-unibyte string-make-multibyte string-as-multibyte string-as-unibyte @@ -1234,23 +1253,22 @@ window-width zerop)) (side-effect-and-error-free-fns '(arrayp atom - bobp bolp bool-vector-p + bignump bobp bolp bool-vector-p buffer-end buffer-list buffer-size buffer-string bufferp car-safe case-table-p cdr-safe char-or-string-p characterp charsetp commandp cons consp current-buffer current-global-map current-indentation current-local-map current-minor-mode-maps current-time - current-time-string current-time-zone eobp eolp eq equal eventp - floatp following-char framep + fixnump floatp following-char framep get-largest-window get-lru-window hash-table-p identity ignore integerp integer-or-marker-p interactive-p invocation-directory invocation-name keymapp keywordp - line-beginning-position line-end-position list listp + list listp make-marker mark mark-marker markerp max-char - memory-limit minibuffer-window + memory-limit mouse-movement-p natnump nlistp not null number-or-marker-p numberp one-window-p overlayp @@ -1275,13 +1293,24 @@ nil) -;; pure functions are side-effect free functions whose values depend -;; only on their arguments. For these functions, calls with constant -;; arguments can be evaluated at compile time. This may shift run time -;; errors to compile time. +;; Pure functions are side-effect free functions whose values depend +;; only on their arguments, not on the platform. For these functions, +;; calls with constant arguments can be evaluated at compile time. +;; This may shift runtime errors to compile time. For example, logand +;; is pure since its results are machine-independent, whereas ash is +;; not pure because (ash 1 29)'s value depends on machine word size. +;; +;; When deciding whether a function is pure, do not worry about +;; mutable strings or markers, as they are so unlikely in real code +;; that they are not worth worrying about. Thus string-to-char is +;; pure even though it might return different values if a string is +;; changed, and logand is pure even though it might return different +;; values if a marker is moved. (let ((pure-fns - '(concat symbol-name regexp-opt regexp-quote string-to-syntax))) + '(% concat logand logcount logior lognot logxor + regexp-opt regexp-quote + string-to-char string-to-syntax symbol-name))) (while pure-fns (put (car pure-fns) 'pure t) (setq pure-fns (cdr pure-fns))) @@ -1312,7 +1341,7 @@ (setq bytedecomp-ptr (1+ bytedecomp-ptr)) (+ (aref bytes bytedecomp-ptr) (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) - (lsh (aref bytes bytedecomp-ptr) 8)))) + (ash (aref bytes bytedecomp-ptr) 8)))) (t tem)))) ;Offset was in opcode. ((>= bytedecomp-op byte-constant) (prog1 (- bytedecomp-op byte-constant) ;Offset in opcode. @@ -1326,7 +1355,7 @@ (setq bytedecomp-ptr (1+ bytedecomp-ptr)) (+ (aref bytes bytedecomp-ptr) (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) - (lsh (aref bytes bytedecomp-ptr) 8)))) + (ash (aref bytes bytedecomp-ptr) 8)))) ((and (>= bytedecomp-op byte-listN) (<= bytedecomp-op byte-discardN)) (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;Offset in next byte. @@ -1409,11 +1438,15 @@ do (setq last-constant (copy-hash-table e)) and return nil) ;; Replace all addresses with TAGs. - (maphash #'(lambda (value tag) - (let (newtag) - (setq newtag (byte-compile-make-tag)) - (push (cons tag newtag) tags) - (puthash value newtag last-constant))) + (maphash #'(lambda (value offset) + (let ((match (assq offset tags))) + (puthash value + (if match + (cdr match) + (let ((tag (byte-compile-make-tag))) + (push (cons offset tag) tags) + tag)) + last-constant))) last-constant) ;; Replace the hash table referenced in the lapcode with our ;; modified one. @@ -1755,13 +1788,10 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." keep-going t) ;; replace references to tag in jump tables, if any (dolist (table byte-compile-jump-tables) - (catch 'break (maphash #'(lambda (value tag) (when (equal tag lap0) - ;; each tag occurs only once in the jump table - (puthash value lap1 table) - (throw 'break nil))) - table)))) + (puthash value lap1 table))) + table))) ;; ;; unused-TAG: --> <deleted> ;; diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 3e9e0808b57..1115c096679 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -45,7 +45,10 @@ So far, FUNCTION can only be a symbol, not a lambda expression." ;; `macro-declaration-function' are both obsolete (as marked at the end of this ;; file) but used in many .elc files. -(defvar macro-declaration-function #'macro-declaration-function +;; We don't use #' here, because it's an obsolete function, and we +;; can't use `with-suppressed-warnings' here due to how this file is +;; used in the bootstrapping process. +(defvar macro-declaration-function 'macro-declaration-function "Function to process declarations in a macro definition. The function will be called with two args MACRO and DECL. MACRO is the name of the macro being defined. @@ -116,7 +119,10 @@ If `error-free', drop calls even if `byte-compile-delete-errors' is nil.") (if (not (eq (car-safe compiler-function) 'lambda)) `(eval-and-compile (function-put ',f 'compiler-macro #',compiler-function)) - (let ((cfname (intern (concat (symbol-name f) "--anon-cmacro")))) + (let ((cfname (intern (concat (symbol-name f) "--anon-cmacro"))) + ;; Avoid cadr/cddr so we can use `compiler-macro' before + ;; defining cadr/cddr. + (data (cdr compiler-function))) `(progn (eval-and-compile (function-put ',f 'compiler-macro #',cfname)) @@ -125,8 +131,8 @@ If `error-free', drop calls even if `byte-compile-delete-errors' is nil.") ;; if needed. :autoload-end (eval-and-compile - (defun ,cfname (,@(cadr compiler-function) ,@args) - ,@(cddr compiler-function)))))))) + (defun ,cfname (,@(car data) ,@args) + ,@(cdr data)))))))) (list 'doc-string #'(lambda (f _args pos) (list 'function-put (list 'quote f) @@ -420,7 +426,7 @@ variable (this is due to the way `defvaralias' works). If provided, WHEN should be a string indicating when the variable was first made obsolete, for example a date or a release number. -For the benefit of `custom-set-variables', if OBSOLETE-NAME has +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'." @@ -491,6 +497,69 @@ is enabled." ;; The implementation for the interpreter is basically trivial. (car (last body))) +(defmacro with-suppressed-warnings (warnings &rest body) + "Like `progn', but prevents compiler WARNINGS in BODY. + +WARNINGS is an associative list where the first element of each +item is a warning type, and the rest of the elements in each item +are symbols they apply to. For instance, if you want to suppress +byte compilation warnings about the two obsolete functions `foo' +and `bar', as well as the function `zot' being called with the +wrong number of parameters, say + +\(with-suppressed-warnings ((obsolete foo bar) + (callargs zot)) + (foo (bar)) + (zot 1 2)) + +The warnings that can be suppressed are a subset of the warnings +in `byte-compile-warning-types'; see this variable for a fuller +explanation of the warning types. The types that can be +suppressed with this macro are `free-vars', `callargs', +`redefine', `obsolete', `interactive-only', `lexical', `mapcar', +`constants' and `suspicious'. + +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)) + (if (not (and (featurep 'macroexp) + (boundp 'byte-compile--suppressed-warnings))) + ;; If `macroexp' is not yet loaded, we're in the middle of + ;; bootstrapping, so better risk emitting too many warnings + ;; than risk breaking the bootstrap. + `(progn ,@body) + ;; We need to let-bind byte-compile--suppressed-warnings here, so as to + ;; silence warnings emitted during macro-expansion performed outside of + ;; byte-compilation. + (let ((byte-compile--suppressed-warnings + (append warnings byte-compile--suppressed-warnings))) + (macroexpand-all (macroexp-progn body) + macroexpand-all-environment)))) + +(defun byte-run--unescaped-character-literals-warning () + "Return a warning about unescaped character literals. +If there were any unescaped character literals in the last form +read, return an appropriate warning message as a string. +Otherwise, return nil. For internal use only." + ;; This is called from lread.c and therefore needs to be preloaded. + (if lread--unescaped-character-literals + (let ((sorted (sort lread--unescaped-character-literals #'<))) + (format-message "unescaped character literals %s detected, %s expected!" + (mapconcat (lambda (char) (format "`?%c'" char)) + sorted ", ") + (mapconcat (lambda (char) (format "`?\\%c'" char)) + sorted ", "))))) + +(defun byte-compile-info-string (&rest args) + "Format ARGS in a way that looks pleasing in the compilation output." + (format " %-9s%s" "INFO" (apply #'format args))) + +(defun byte-compile-info-message (&rest args) + "Message format ARGS in a way that looks pleasing in the compilation output." + (message "%s" (apply #'byte-compile-info-string args))) + ;; I nuked this because it's not a good idea for users to think of using it. ;; These options are a matter of installation preference, and have nothing to diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 9273626c805..6dcd4c6846a 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -124,17 +124,11 @@ (require 'backquote) (require 'macroexp) (require 'cconv) -(require 'cl-lib) - -;; During bootstrap, cl-loaddefs.el is not created yet, so loading cl-lib -;; doesn't setup autoloads for things like cl-every, which is why we have to -;; require cl-extra as well (bug#18804). -(or (fboundp 'cl-every) - (require 'cl-extra)) - -(or (fboundp 'defsubst) - ;; This really ought to be loaded already! - (load "byte-run")) +(eval-when-compile (require 'compile)) +;; Refrain from using cl-lib at run-time here, since it otherwise prevents +;; us from emitting warnings when compiling files which use cl-lib without +;; requiring it! (bug#30635) +(eval-when-compile (require 'cl-lib)) ;; The feature of compiling in a specific target Emacs version ;; has been turned off because compile time options are a bad idea. @@ -148,7 +142,6 @@ If you change this, you might want to set `byte-compile-dest-file-function'. \(Note that the assumption of a \".elc\" suffix for compiled files is hard-coded in various places in Emacs.)" ;; Eg is_elc in Fload. - :group 'bytecomp :type 'regexp) (defcustom byte-compile-dest-file-function nil @@ -158,7 +151,6 @@ file name, and return the name of the compiled file. \(Note that the assumption that the source and compiled files are found in the same directory is hard-coded in various places in Emacs.)" ;; Eg load-prefer-newer, documentation lookup IIRC. - :group 'bytecomp :type '(choice (const nil) function) :version "23.2") @@ -212,7 +204,6 @@ otherwise adds \".elc\"." (defcustom byte-compile-verbose (and (not noninteractive) (> baud-rate search-slow-speed)) "Non-nil means print messages describing progress of byte-compiler." - :group 'bytecomp :type 'boolean) (defcustom byte-optimize t @@ -222,7 +213,6 @@ Possible values are: t - all optimizations `source' - source-level optimizations only `byte' - code-level optimizations only" - :group 'bytecomp :type '(choice (const :tag "none" nil) (const :tag "all" t) (const :tag "source-level" source) @@ -231,13 +221,11 @@ Possible values are: (defcustom byte-compile-delete-errors nil "If non-nil, the optimizer may delete forms that may signal an error. This includes variable references and calls to functions such as `car'." - :group 'bytecomp :type 'boolean) -(defcustom byte-compile-cond-use-jump-table nil +(defcustom byte-compile-cond-use-jump-table t "Compile `cond' clauses to a jump table implementation (using a hash-table)." - :version "26.3" ;; Disabled due to Bug#35770. - :group 'bytecomp + :version "26.1" :type 'boolean) (defvar byte-compile-dynamic nil @@ -252,6 +240,7 @@ For example, add -*-byte-compile-dynamic: t;-*- on the first line. When this option is true, if you load the compiled file and then move it, the functions you loaded will not be able to run.") +(make-obsolete-variable 'byte-compile-dynamic "not worthwhile any more." "27.1") ;;;###autoload(put 'byte-compile-dynamic 'safe-local-variable 'booleanp) (defvar byte-compile-disable-print-circle nil @@ -273,7 +262,6 @@ in the source file. For example, add this to the first line: You can also set the variable globally. This option is enabled by default because it reduces Emacs memory usage." - :group 'bytecomp :type 'boolean) ;;;###autoload(put 'byte-compile-dynamic-docstrings 'safe-local-variable 'booleanp) @@ -285,7 +273,6 @@ This option is enabled by default because it reduces Emacs memory usage." If this is `source', then only source-level optimizations will be logged. If it is `byte', then only byte-level optimizations will be logged. The information is logged to `byte-compile-log-buffer'." - :group 'bytecomp :type '(choice (const :tag "none" nil) (const :tag "all" t) (const :tag "source-level" source) @@ -293,7 +280,6 @@ The information is logged to `byte-compile-log-buffer'." (defcustom byte-compile-error-on-warn nil "If true, the byte-compiler reports warnings with `error'." - :group 'bytecomp :type 'boolean) ;; This needs to be autoloaded because it needs to be available to ;; Emacs before the byte compiler is loaded, otherwise Emacs will not @@ -331,24 +317,32 @@ Elements of the list may be: If the list begins with `not', then the remaining elements specify warnings to suppress. For example, (not mapcar) will suppress warnings about mapcar." - :group 'bytecomp :type `(choice (const :tag "All" t) (set :menu-tag "Some" ,@(mapcar (lambda (x) `(const ,x)) byte-compile-warning-types)))) +(defvar byte-compile--suppressed-warnings nil + "Dynamically bound by `with-suppressed-warnings' to suppress warnings.") + ;;;###autoload (put 'byte-compile-warnings 'safe-local-variable (lambda (v) (or (symbolp v) (null (delq nil (mapcar (lambda (x) (not (symbolp x))) v)))))) -(defun byte-compile-warning-enabled-p (warning) +(defun byte-compile-warning-enabled-p (warning &optional symbol) "Return non-nil if WARNING is enabled, according to `byte-compile-warnings'." - (or (eq byte-compile-warnings t) - (if (eq (car byte-compile-warnings) 'not) - (not (memq warning byte-compile-warnings)) - (memq warning byte-compile-warnings)))) + (let ((suppress nil)) + (dolist (elem byte-compile--suppressed-warnings) + (when (and (eq (car elem) warning) + (memq symbol (cdr elem))) + (setq suppress t))) + (and (not suppress) + (or (eq byte-compile-warnings t) + (if (eq (car byte-compile-warnings) 'not) + (not (memq warning byte-compile-warnings)) + (memq warning byte-compile-warnings)))))) ;;;###autoload (defun byte-compile-disable-warning (warning) @@ -411,7 +405,6 @@ not reported. The call tree also lists those functions which are not known to be called \(that is, to which no calls have been compiled). Functions which can be invoked interactively are excluded from this list." - :group 'bytecomp :type '(choice (const :tag "Yes" t) (const :tag "No" nil) (other :tag "Ask" lambda))) @@ -429,7 +422,6 @@ FUNCTION.") "If non-nil, sort the call tree. The values `name', `callers', `calls', `calls+callers' specify different fields to sort on." - :group 'bytecomp :type '(choice (const name) (const callers) (const calls) (const calls+callers) (const nil))) @@ -508,7 +500,23 @@ Return the compile-time value of FORM." form macroexpand-all-environment))) (eval expanded lexical-binding) - expanded)))))) + expanded))))) + (with-suppressed-warnings + . ,(lambda (warnings &rest body) + ;; We let-bind `byte-compile--suppressed-warnings' here in order + ;; to affect warnings emitted during macroexpansion. + ;; Later `internal--with-suppressed-warnings' binds it again, this + ;; time in order to affect warnings emitted during the + ;; compilation itself. + (let ((byte-compile--suppressed-warnings + (append warnings byte-compile--suppressed-warnings))) + ;; This function doesn't exist, but is just a placeholder + ;; symbol to hook up with the + ;; `byte-hunk-handler'/`byte-defop-compiler-1' machinery. + `(internal--with-suppressed-warnings + ',warnings + ,(macroexpand-all `(progn ,@body) + macroexpand-all-environment)))))) "The default macro-environment passed to macroexpand by the compiler. Placing a macro here will cause a macro to have different semantics when expanded by the compiler as when expanded by the interpreter.") @@ -842,7 +850,7 @@ all the arguments. (defmacro byte-compile-push-bytecode-const2 (opcode const2 bytes pc) "Push OPCODE and the two-byte constant CONST2 onto BYTES, and add 3 to PC. CONST2 may be evaluated multiple times." - `(byte-compile-push-bytecodes ,opcode (logand ,const2 255) (lsh ,const2 -8) + `(byte-compile-push-bytecodes ,opcode (logand ,const2 255) (ash ,const2 -8) ,bytes ,pc)) (defun byte-compile-lapcode (lap) @@ -932,9 +940,9 @@ CONST2 may be evaluated multiple times." ;; Splits PC's value into 2 bytes. The jump address is ;; "reconstructed" by the `FETCH2' macro in `bytecode.c'. (setcar (cdr bytes-tail) (logand pc 255)) - (setcar bytes-tail (lsh pc -8)) + (setcar bytes-tail (ash pc -8)) ;; FIXME: Replace this by some workaround. - (if (> (car bytes-tail) 255) (error "Bytecode overflow"))) + (or (<= 0 (car bytes-tail) 255) (error "Bytecode overflow"))) ;; Similarly, replace TAGs in all jump tables with the correct PC index. (dolist (hash-table byte-compile-jump-tables) @@ -1013,6 +1021,33 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." ;;; byte compiler messages +(defun emacs-lisp-compilation-file-name-or-buffer (str) + "Return file name or buffer given by STR. +If STR is a \"normal\" filename, just return it. +If STR is something like \"Buffer foo.el\", return #<buffer foo.el> +\(if it is still live) or the string \"foo.el\" otherwise." + (if (string-match "Buffer \\(.*\\)\\'" str) + (or (get-buffer (match-string-no-properties 1 str)) + (match-string-no-properties 1 str)) + str)) + +(defconst emacs-lisp-compilation-parse-errors-filename-function + #'emacs-lisp-compilation-file-name-or-buffer + "The value for `compilation-parse-errors-filename-function' for when +we go into emacs-lisp-compilation-mode.") + +(defcustom emacs-lisp-compilation-search-path '(nil) + "Directories to search for files named in byte-compile error messages. +Value should be a list of directory names, not file names of +directories. The value nil as an element means the byte-compile +message buffer `default-directory'." + :version "27.1" + :type '(repeat (choice (const :tag "Default" nil) + (string :tag "Directory")))) + +(define-compilation-mode emacs-lisp-compilation-mode "elisp-compile" + "The variant of `compilation-mode' used for emacs-lisp compilation buffers.") + (defvar byte-compile-current-form nil) (defvar byte-compile-dest-file nil) (defvar byte-compile-current-file nil) @@ -1172,7 +1207,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (with-current-buffer (get-buffer-create byte-compile-log-buffer) (goto-char (point-max)) (let* ((inhibit-read-only t) - (dir (and byte-compile-current-file + (dir (and (stringp byte-compile-current-file) (file-name-directory byte-compile-current-file))) (was-same (equal default-directory dir)) pt) @@ -1187,10 +1222,10 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (insert "\f\nCompiling " (if (stringp byte-compile-current-file) (concat "file " byte-compile-current-file) - (concat "buffer " + (concat "in buffer " (buffer-name byte-compile-current-file))) " at " (current-time-string) "\n") - (insert "\f\nCompiling no file at " (current-time-string) "\n")) + (insert "\f\nCompiling internal form(s) at " (current-time-string) "\n")) (when dir (setq default-directory dir) (unless was-same @@ -1199,7 +1234,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (setq byte-compile-last-logged-file byte-compile-current-file byte-compile-last-warned-form nil) ;; Do this after setting default-directory. - (unless (derived-mode-p 'compilation-mode) (compilation-mode)) + (unless (derived-mode-p 'compilation-mode) + (emacs-lisp-compilation-mode)) (compilation-forget-errors) pt)))) @@ -1246,7 +1282,7 @@ function directly; use `byte-compile-warn' or (defun byte-compile-warn-obsolete (symbol) "Warn that SYMBOL (a variable or function) is obsolete." - (when (byte-compile-warning-enabled-p 'obsolete) + (when (byte-compile-warning-enabled-p 'obsolete symbol) (let* ((funcp (get symbol 'byte-obsolete-info)) (msg (macroexp--obsolete-warning symbol @@ -1357,7 +1393,8 @@ when printing the error message." (defun byte-compile-function-warn (f nargs def) (byte-compile-set-symbol-position f) - (when (get f 'byte-obsolete-info) + (when (and (get f 'byte-obsolete-info) + (byte-compile-warning-enabled-p 'obsolete f)) (byte-compile-warn-obsolete f)) ;; Check to see if the function will be available at runtime @@ -1561,7 +1598,10 @@ extra args." (while syms (setq s (symbol-name (pop syms)) L (+ L (length s) 2)) - (if (< L (1- fill-column)) + (if (< L (1- (buffer-local-value 'fill-column + (or (get-buffer + byte-compile-log-buffer) + (current-buffer))))) (setq str (concat str " " s (and syms ","))) (setq str (concat str "\n " s (and syms ",")) L (+ (length s) 4)))) @@ -1706,8 +1746,8 @@ that already has a `.elc' file." (with-current-buffer (get-buffer-create byte-compile-log-buffer) (setq default-directory (expand-file-name directory)) ;; compilation-mode copies value of default-directory. - (unless (eq major-mode 'compilation-mode) - (compilation-mode)) + (unless (derived-mode-p 'compilation-mode) + (emacs-lisp-compilation-mode)) (let ((directories (list default-directory)) (default-directory default-directory) (skip-count 0) @@ -1739,8 +1779,8 @@ that already has a `.elc' file." (file-name-nondirectory source)))) (progn (cl-incf (pcase (byte-recompile-file source force arg) - (`no-byte-compile skip-count) - (`t file-count) + ('no-byte-compile skip-count) + ('t file-count) (_ fail-count))) (or noninteractive (message "Checking %s..." directory)) @@ -1990,7 +2030,7 @@ With argument ARG, insert value in current buffer after the form." (save-excursion (end-of-defun) (beginning-of-defun) - (let* ((byte-compile-current-file nil) + (let* ((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) @@ -2071,20 +2111,10 @@ With argument ARG, insert value in current buffer after the form." (not (eobp))) (setq byte-compile-read-position (point) byte-compile-last-position byte-compile-read-position) - (let* ((lread--old-style-backquotes nil) - (lread--unescaped-character-literals nil) - (form (read inbuffer))) - ;; Warn about the use of old-style backquotes. - (when lread--old-style-backquotes - (byte-compile-warn "!! The file uses old-style backquotes !! -This functionality has been obsolete for more than 10 years already -and will be removed soon. See (elisp)Backquote in the manual.")) - (when lread--unescaped-character-literals - (byte-compile-warn - "unescaped character literals %s detected!" - (mapconcat (lambda (char) (format "`?%c'" char)) - (sort lread--unescaped-character-literals #'<) - ", "))) + (let* ((lread--unescaped-character-literals nil) + (form (read inbuffer)) + (warning (byte-run--unescaped-character-literals-warning))) + (when warning (byte-compile-warn "%s" warning)) (byte-compile-toplevel-file-form form))) ;; Compile pending forms at end of file. (byte-compile-flush-pending) @@ -2411,7 +2441,7 @@ list that represents a doc string reference. (defun byte-compile--declare-var (sym) (when (and (symbolp sym) (not (string-match "[-*/:$]" (symbol-name sym))) - (byte-compile-warning-enabled-p 'lexical)) + (byte-compile-warning-enabled-p 'lexical sym)) (byte-compile-warn "global/dynamic var `%s' lacks a prefix" sym)) (when (memq sym byte-compile-lexical-variables) @@ -2441,6 +2471,16 @@ list that represents a doc string reference. (defun byte-compile-file-form-defvar-function (form) (pcase-let (((or `',name (let name nil)) (nth 1 form))) (if name (byte-compile--declare-var name))) + ;; Variable aliases are better declared before the corresponding variable, + ;; since it makes it more likely that only one of the two vars has a value + ;; before the `defvaralias' gets executed, which avoids the need to + ;; merge values. + (pcase form + (`(defvaralias ,_ ',newname . ,_) + (when (memq newname byte-compile-bound-variables) + (if (byte-compile-warning-enabled-p 'suspicious) + (byte-compile-warn + "Alias for `%S' should be declared before its referent" newname))))) (byte-compile-keep-pending form)) (put 'custom-declare-variable 'byte-hunk-handler @@ -2486,9 +2526,8 @@ list that represents a doc string reference. (put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn) (put 'prog1 'byte-hunk-handler 'byte-compile-file-form-progn) -(put 'prog2 'byte-hunk-handler 'byte-compile-file-form-progn) (defun byte-compile-file-form-progn (form) - (mapc 'byte-compile-file-form (cdr form)) + (mapc #'byte-compile-file-form (cdr form)) ;; Return nil so the forms are not output twice. nil) @@ -2500,6 +2539,21 @@ list that represents a doc string reference. (mapc 'byte-compile-file-form (cdr form)) nil)) +(put 'internal--with-suppressed-warnings 'byte-hunk-handler + 'byte-compile-file-form-with-suppressed-warnings) +(defun byte-compile-file-form-with-suppressed-warnings (form) + ;; cf byte-compile-file-form-progn. + (let ((byte-compile--suppressed-warnings + (append (cadadr form) byte-compile--suppressed-warnings))) + (mapc 'byte-compile-file-form (cddr form)) + nil)) + +;; Automatically evaluate define-obsolete-function-alias etc at top-level. +(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) @@ -2532,7 +2586,7 @@ not to take responsibility for the actual compilation of the code." (setq byte-compile-call-tree (cons (list name nil nil) byte-compile-call-tree)))) - (if (byte-compile-warning-enabled-p 'redefine) + (if (byte-compile-warning-enabled-p 'redefine name) (byte-compile-arglist-warn name arglist macro)) (if byte-compile-verbose @@ -2544,7 +2598,7 @@ not to take responsibility for the actual compilation of the code." ;; This also silences "multiple definition" warnings for defmethods. nil) (that-one - (if (and (byte-compile-warning-enabled-p 'redefine) + (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 @@ -2552,7 +2606,7 @@ not to take responsibility for the actual compilation of the code." name)) (setcdr that-one nil)) (this-one - (when (and (byte-compile-warning-enabled-p 'redefine) + (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))) @@ -2561,7 +2615,7 @@ not to take responsibility for the actual compilation of the code." name))) ((eq (car-safe (symbol-function name)) (if macro 'lambda 'macro)) - (when (byte-compile-warning-enabled-p 'redefine) + (when (byte-compile-warning-enabled-p 'redefine name) (byte-compile-warn "%s `%s' being redefined as a %s" (if macro "function" "macro") name @@ -2726,7 +2780,11 @@ If FORM is a lambda or a macro, byte-compile it as a function." (setq fun (byte-compile-top-level fun nil 'eval)) (if macro (push 'macro fun)) (if (symbolp form) - (fset form fun) + ;; 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. + (fset form (eval fun t)) fun))))))) (defun byte-compile-sexp (sexp) @@ -2746,15 +2804,12 @@ If FORM is a lambda or a macro, byte-compile it as a function." (macroexp--const-symbol-p arg t)) (error "Invalid lambda variable %s" arg)) ((eq arg '&rest) - (unless (cdr list) - (error "&rest without variable name")) (when (cddr list) - (error "Garbage following &rest VAR in lambda-list"))) + (error "Garbage following &rest VAR in lambda-list")) + (when (memq (cadr list) '(&optional &rest)) + (error "%s following &rest in lambda-list" (cadr list)))) ((eq arg '&optional) - (when (or (null (cdr list)) - (memq (cadr list) '(&optional &rest))) - (error "Variable name missing after &optional")) - (when (memq '&optional (cddr list)) + (when (memq '&optional (cdr list)) (error "Duplicate &optional"))) ((memq arg vars) (byte-compile-warn "repeated variable %s in lambda-list" arg)) @@ -2795,8 +2850,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if (> mandatory 127) (byte-compile-report-error "Too many (>127) mandatory arguments") (logior mandatory - (lsh nonrest 8) - (lsh rest 7))))) + (ash nonrest 8) + (ash rest 7))))) (defun byte-compile-lambda (fun &optional add-lambda reserved-csts) @@ -2847,9 +2902,10 @@ for symbols generated by the byte compiler itself." (setq form (cdr form))) (setq form (car form))) (if (and (eq (car-safe form) 'list) - ;; The spec is evalled in callint.c in dynamic-scoping - ;; mode, so just leaving the form unchanged would mean - ;; it won't be eval'd in the right mode. + ;; 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). (not lexical-binding)) nil (setq int `(interactive ,newform))))) @@ -2930,7 +2986,6 @@ for symbols generated by the byte compiler itself." lexenv reserved-csts) ;; OUTPUT-TYPE advises about how form is expected to be used: ;; 'eval or nil -> a single form, - ;; 'progn or t -> a list of forms, ;; 'lambda -> body of a lambda, ;; 'file -> used at file-level. (let ((byte-compile--for-effect for-effect) @@ -2961,6 +3016,7 @@ for symbols generated by the byte compiler itself." (byte-compile-out-toplevel byte-compile--for-effect output-type))) (defun byte-compile-out-toplevel (&optional for-effect output-type) + ;; OUTPUT-TYPE can be like that of `byte-compile-top-level'. (if for-effect ;; The stack is empty. Push a value to be returned from (byte-code ..). (if (eq (car (car byte-compile-output)) 'byte-discard) @@ -2989,12 +3045,8 @@ for symbols generated by the byte compiler itself." ;; Note that even (quote foo) must be parsed just as any subr by the ;; interpreter, so quote should be compiled into byte-code in some contexts. ;; What to leave uncompiled: - ;; lambda -> never. we used to leave it uncompiled if the body was - ;; a single atom, but that causes confusion if the docstring - ;; uses the (file . pos) syntax. Besides, now that we have - ;; the Lisp_Compiled type, the compiled form is faster. + ;; lambda -> never. The compiled form is always faster. ;; eval -> atom, quote or (function atom atom atom) - ;; progn -> as <<same-as-eval>> or (progn <<same-as-eval>> atom) ;; file -> as progn, but takes both quotes and atoms, and longer forms. (let (rest (maycall (not (eq output-type 'lambda))) ; t if we may make a funcall. @@ -3024,8 +3076,9 @@ for symbols generated by the byte compiler itself." (null (nthcdr 3 rest)) (setq tmp (get (car (car rest)) 'byte-opcode-invert)) (or (null (cdr rest)) - (and (memq output-type '(file progn t)) + (and (eq output-type 'file) (cdr (cdr rest)) + (eql (length body) (cdr (car rest))) ;bug#34757 (eq (car (nth 1 rest)) 'byte-discard) (progn (setq rest (cdr rest)) t)))) (setq maycall nil) ; Only allow one real function call. @@ -3120,9 +3173,15 @@ for symbols generated by the byte compiler itself." (when (assq var byte-compile-lexical-variables) (byte-compile-report-error (format-message "%s cannot use lexical var `%s'" fn var)))))) - (when (macroexp--const-symbol-p fn) + ;; Warn about using obsolete hooks. + (if (memq fn '(add-hook remove-hook)) + (let ((hook (car-safe (cdr form)))) + (if (eq (car-safe hook) 'quote) + (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)) - (when (and (byte-compile-warning-enabled-p 'interactive-only) + (when (and (byte-compile-warning-enabled-p 'interactive-only fn) interactive-only) (byte-compile-warn "`%s' is for interactive use only%s" fn @@ -3163,8 +3222,8 @@ for symbols generated by the byte compiler itself." (byte-compile-discard)))) (defun byte-compile-normal-call (form) - (when (and (byte-compile-warning-enabled-p 'callargs) - (symbolp (car form))) + (when (and (symbolp (car form)) + (byte-compile-warning-enabled-p 'callargs (car form))) (if (memq (car form) '(custom-declare-group custom-declare-variable custom-declare-face)) @@ -3173,7 +3232,7 @@ for symbols generated by the byte compiler itself." (if byte-compile-generate-call-tree (byte-compile-annotate-call-tree form)) (when (and byte-compile--for-effect (eq (car form) 'mapcar) - (byte-compile-warning-enabled-p 'mapcar)) + (byte-compile-warning-enabled-p 'mapcar 'mapcar)) (byte-compile-set-symbol-position 'mapcar) (byte-compile-warn "`mapcar' called for effect; use `mapc' or `dolist' instead")) @@ -3253,7 +3312,7 @@ for symbols generated by the byte compiler itself." (fun (car form)) (fargs (aref fun 0)) (start-depth byte-compile-depth) - (fmax2 (if (numberp fargs) (lsh fargs -7))) ;2*max+rest. + (fmax2 (if (numberp fargs) (ash fargs -7))) ;2*max+rest. ;; (fmin (if (numberp fargs) (logand fargs 127))) (alen (length (cdr form))) (dynbinds ()) @@ -3272,8 +3331,8 @@ for symbols generated by the byte compiler itself." (cl-assert (listp fargs)) (while fargs (pcase (car fargs) - (`&optional (setq fargs (cdr fargs))) - (`&rest (setq fmax2 (+ (* 2 (length dynbinds)) 1)) + ('&optional (setq fargs (cdr fargs))) + ('&rest (setq fmax2 (+ (* 2 (length dynbinds)) 1)) (push (cadr fargs) dynbinds) (setq fargs nil)) (_ (push (pop fargs) dynbinds)))) @@ -3309,7 +3368,8 @@ for symbols generated by the byte compiler itself." (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) + (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'") @@ -3320,8 +3380,8 @@ for symbols generated by the byte compiler itself." (not (memq var byte-compile-not-obsolete-vars)) (not (memq var byte-compile-global-not-obsolete-vars)) (or (pcase (nth 1 od) - (`set (not (eq access-type 'reference))) - (`get (eq access-type 'reference)) + ('set (not (eq access-type 'reference))) + ('get (eq access-type 'reference)) (_ t))))) (byte-compile-warn-obsolete var)))) @@ -3346,7 +3406,7 @@ for symbols generated by the byte compiler itself." ;; VAR is lexically bound (byte-compile-stack-ref (cdr lex-binding)) ;; VAR is dynamically bound - (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) + (unless (or (not (byte-compile-warning-enabled-p 'free-vars var)) (boundp var) (memq var byte-compile-bound-variables) (memq var byte-compile-free-references)) @@ -3362,7 +3422,7 @@ for symbols generated by the byte compiler itself." ;; VAR is lexically bound. (byte-compile-stack-set (cdr lex-binding)) ;; VAR is dynamically bound. - (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) + (unless (or (not (byte-compile-warning-enabled-p 'free-vars var)) (boundp var) (memq var byte-compile-bound-variables) (memq var byte-compile-free-assignments)) @@ -3509,7 +3569,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler (>= byte-geq) 2-and) (byte-defop-compiler get 2) (byte-defop-compiler nth 2) -(byte-defop-compiler substring 2-3) +(byte-defop-compiler substring 1-3) (byte-defop-compiler (move-marker byte-set-marker) 2-3) (byte-defop-compiler set-marker 2-3) (byte-defop-compiler match-beginning 1) @@ -3577,7 +3637,8 @@ These implicitly `and' together a bunch of two-arg bytecodes." (cond ((< l 3) (byte-compile-form `(progn ,(nth 1 form) t))) ((= l 3) (byte-compile-two-args form)) - ((cl-every #'macroexp-copyable-p (nthcdr 2 form)) + ;; Don't use `cl-every' here (see comment where we require cl-lib). + ((not (memq nil (mapcar #'macroexp-copyable-p (nthcdr 2 form)))) (byte-compile-form `(and (,(car form) ,(nth 1 form) ,(nth 2 form)) (,(car form) ,@(nthcdr 2 form))))) (t (byte-compile-normal-call form))))) @@ -3846,7 +3907,7 @@ discarding." (defun byte-compile-function-form (form) (let ((f (nth 1 form))) (when (and (symbolp f) - (byte-compile-warning-enabled-p 'callargs)) + (byte-compile-warning-enabled-p 'callargs f)) (byte-compile-function-warn f t (byte-compile-fdefinition f nil))) (byte-compile-constant (if (eq 'lambda (car-safe f)) @@ -3884,7 +3945,6 @@ discarding." (byte-defop-compiler-1 setq) -(byte-defop-compiler-1 setq-default) (byte-defop-compiler-1 quote) (defun byte-compile-setq (form) @@ -3909,34 +3969,21 @@ discarding." (byte-compile-form nil byte-compile--for-effect))) (setq byte-compile--for-effect nil))) -(defun byte-compile-setq-default (form) - (setq form (cdr form)) - (if (null form) ; (setq-default), with no arguments - (byte-compile-form nil byte-compile--for-effect) - (if (> (length form) 2) - (let ((setters ())) - (while (consp form) - (push `(setq-default ,(pop form) ,(pop form)) setters)) - (byte-compile-form (cons 'progn (nreverse setters)))) - (let ((var (car form))) - (and (or (not (symbolp var)) - (macroexp--const-symbol-p var t)) - (byte-compile-warning-enabled-p 'constants) - (byte-compile-warn - "variable assignment to %s `%s'" - (if (symbolp var) "constant" "nonvariable") - (prin1-to-string var))) - (byte-compile-normal-call `(set-default ',var ,@(cdr form))))))) - (byte-defop-compiler-1 set-default) (defun byte-compile-set-default (form) (let ((varexp (car-safe (cdr-safe form)))) (if (eq (car-safe varexp) 'quote) - ;; If the varexp is constant, compile it as a setq-default - ;; so we get more warnings. - (byte-compile-setq-default `(setq-default ,(car-safe (cdr varexp)) - ,@(cddr form))) - (byte-compile-normal-call form)))) + ;; If the varexp is constant, check the var's name. + (let ((var (car-safe (cdr varexp)))) + (and (or (not (symbolp var)) + (macroexp--const-symbol-p var t)) + (byte-compile-warning-enabled-p 'constants + (and (symbolp var) var)) + (byte-compile-warn + "variable assignment to %s `%s'" + (if (symbolp var) "constant" "nonvariable") + (prin1-to-string var))))) + (byte-compile-normal-call form))) (defun byte-compile-quote (form) (byte-compile-constant (car (cdr form)))) @@ -3960,7 +4007,6 @@ discarding." (byte-defop-compiler-1 inline byte-compile-progn) (byte-defop-compiler-1 progn) (byte-defop-compiler-1 prog1) -(byte-defop-compiler-1 prog2) (byte-defop-compiler-1 if) (byte-defop-compiler-1 cond) (byte-defop-compiler-1 and) @@ -3977,11 +4023,6 @@ discarding." (byte-compile-form-do-effect (car (cdr form))) (byte-compile-body (cdr (cdr form)) t)) -(defun byte-compile-prog2 (form) - (byte-compile-form (nth 1 form) t) - (byte-compile-form-do-effect (nth 2 form)) - (byte-compile-body (cdr (cdr (cdr form))) t)) - (defmacro byte-compile-goto-if (cond discard tag) `(byte-compile-goto (if ,cond @@ -4078,170 +4119,183 @@ that suppresses all warnings during execution of BODY." (byte-compile-out-tag donetag)))) (setq byte-compile--for-effect nil)) -(defun byte-compile-cond-vars (obj1 obj2) +(defun byte-compile--cond-vars (obj1 obj2) ;; We make sure that of OBJ1 and OBJ2, one of them is a symbol, ;; and the other is a constant expression whose value can be ;; compared with `eq' (with `macroexp-const-p'). (or - (and (symbolp obj1) (macroexp-const-p obj2) (cons obj1 obj2)) - (and (symbolp obj2) (macroexp-const-p obj1) (cons obj2 obj1)))) - -(defconst byte-compile--default-val (cons nil nil) "A unique object.") - -(defun byte-compile-cond-jump-table-info (clauses) - "If CLAUSES is a `cond' form where: -The condition for each clause is of the form (TEST VAR VALUE). -VAR is a variable. -TEST and VAR are the same throughout all conditions. -VALUE satisfies `macroexp-const-p'. - -Return a list of the form ((TEST . VAR) ((VALUE BODY) ...))" - (let ((cases '()) - (ok t) - prev-var prev-test) - (and (catch 'break - (dolist (clause (cdr clauses) ok) - (let* ((condition (car clause)) - (test (car-safe condition)) - (vars (when (consp condition) - (byte-compile-cond-vars (cadr condition) (cl-caddr condition)))) - (obj1 (car-safe vars)) - (obj2 (cdr-safe vars)) - (body (cdr-safe clause))) - (unless prev-var - (setq prev-var obj1)) - (unless prev-test - (setq prev-test test)) - (if (and obj1 (memq test '(eq eql equal)) - (consp condition) - (eq test prev-test) - (eq obj1 prev-var) - ;; discard duplicate clauses - (not (assq obj2 cases))) - (push (list (if (consp obj2) (eval obj2) obj2) body) cases) - (if (and (macroexp-const-p condition) condition) - (progn (push (list byte-compile--default-val - (or body `(,condition))) - cases) - (throw 'break t)) - (setq ok nil) - (throw 'break nil)))))) - (list (cons prev-test prev-var) (nreverse cases))))) - -(defun byte-compile-cond-jump-table (clauses) - (let* ((table-info (byte-compile-cond-jump-table-info clauses)) - (test (caar table-info)) - (var (cdar table-info)) - (cases (cadr table-info)) - jump-table test-obj body tag donetag default-tag default-case) - (when (and cases (not (= (length cases) 1))) - ;; TODO: Once :linear-search is implemented for `make-hash-table' - ;; set it to `t' for cond forms with a small number of cases. + (and (symbolp obj1) (macroexp-const-p obj2) (cons obj1 (eval obj2))) + (and (symbolp obj2) (macroexp-const-p obj1) (cons obj2 (eval obj1))))) + +(defun byte-compile--common-test (test-1 test-2) + "Most specific common test of `eq', `eql' and `equal'" + (cond ((or (eq test-1 'equal) (eq test-2 'equal)) 'equal) + ((or (eq test-1 'eql) (eq test-2 'eql)) 'eql) + (t 'eq))) + +(defun byte-compile--cond-switch-prefix (clauses) + "Find a switch corresponding to a prefix of CLAUSES, or nil if none. +Return (TAIL VAR TEST CASES), where: + TAIL is the remaining part of CLAUSES after the switch, including + any default clause, + VAR is the variable being switched on, + TEST is the equality test (`eq', `eql' or `equal'), + CASES is a list of (VALUES . BODY) where VALUES is a list of values + corresponding to BODY (always non-empty)." + (let ((cases nil) ; Reversed list of (VALUES BODY). + (keys nil) ; Switch keys seen so far. + (switch-var nil) + (switch-test 'eq)) + (while (pcase (car clauses) + (`((,fn ,expr1 ,expr2) . ,body) + (let* ((vars (byte-compile--cond-vars expr1 expr2)) + (var (car vars)) + (value (cdr vars))) + (and var (or (eq var switch-var) (not switch-var)) + (cond + ((memq fn '(eq eql equal)) + (setq switch-var var) + (setq switch-test + (byte-compile--common-test switch-test fn)) + (unless (member value keys) + (push value keys) + (push (cons (list value) (or body '(t))) cases)) + t) + ((and (memq fn '(memq memql member)) + (listp value) + ;; Require a non-empty body, since the member + ;; function value depends on the switch + ;; argument. + body) + (setq switch-var var) + (setq switch-test + (byte-compile--common-test + switch-test (cdr (assq fn '((memq . eq) + (memql . eql) + (member . equal)))))) + (let ((vals nil)) + (dolist (elem value) + (unless (funcall fn elem keys) + (push elem vals))) + (when vals + (setq keys (append vals keys)) + (push (cons (nreverse vals) body) cases))) + t)))))) + (setq clauses (cdr clauses))) + ;; Assume that a single switch is cheaper than two or more discrete + ;; compare clauses. This could be tuned, possibly taking into + ;; account the total number of values involved. + (and (> (length cases) 1) + (list clauses switch-var switch-test (nreverse cases))))) + +(defun byte-compile-cond-jump-table (switch donetag) + "Generate code for SWITCH, ending at DONETAG." + (let* ((var (car switch)) + (test (nth 1 switch)) + (cases (nth 2 switch)) + jump-table test-objects body tag default-tag) + ;; TODO: Once :linear-search is implemented for `make-hash-table' + ;; set it to `t' for cond forms with a small number of cases. + (let ((nvalues (apply #'+ (mapcar (lambda (case) (length (car case))) + cases)))) (setq jump-table (make-hash-table :test test :purecopy t - :size (if (assq byte-compile--default-val cases) - (1- (length cases)) - (length cases))) - default-tag (byte-compile-make-tag) - donetag (byte-compile-make-tag)) - ;; The structure of byte-switch code: - ;; - ;; varref var - ;; constant #s(hash-table purecopy t data (val1 (TAG1) val2 (TAG2))) - ;; switch - ;; goto DEFAULT-TAG - ;; TAG1 - ;; <clause body> - ;; goto DONETAG - ;; TAG2 - ;; <clause body> - ;; goto DONETAG - ;; DEFAULT-TAG - ;; <body for `t' clause, if any (else `constant nil')> - ;; DONETAG - - (byte-compile-variable-ref var) - (byte-compile-push-constant jump-table) - (byte-compile-out 'byte-switch) - - ;; When the opcode argument is `byte-goto', `byte-compile-goto' sets - ;; `byte-compile-depth' to `nil'. However, we need `byte-compile-depth' - ;; to be non-nil for generating tags for all cases. Since - ;; `byte-compile-depth' will increase by at most 1 after compiling - ;; all of the clause (which is further enforced by cl-assert below) - ;; it should be safe to preserve its value. - (let ((byte-compile-depth byte-compile-depth)) - (byte-compile-goto 'byte-goto default-tag)) - - (let ((default-match (assq byte-compile--default-val cases))) - (when default-match - (setq default-case (cadr default-match) - cases (butlast cases)))) - - (dolist (case cases) - (setq tag (byte-compile-make-tag) - test-obj (nth 0 case) - body (nth 1 case)) - (byte-compile-out-tag tag) - (puthash test-obj tag jump-table) - - (let ((byte-compile-depth byte-compile-depth) - (init-depth byte-compile-depth)) - ;; Since `byte-compile-body' might increase `byte-compile-depth' - ;; by 1, not preserving its value will cause it to potentially - ;; increase by one for every clause body compiled, causing - ;; depth/tag conflicts or violating asserts down the road. - ;; To make sure `byte-compile-body' itself doesn't violate this, - ;; we use `cl-assert'. - (if (null body) - (byte-compile-form t byte-compile--for-effect) - (byte-compile-body body byte-compile--for-effect)) - (cl-assert (or (= byte-compile-depth init-depth) - (= byte-compile-depth (1+ init-depth)))) - (byte-compile-goto 'byte-goto donetag) - (setcdr (cdr donetag) nil))) - - (byte-compile-out-tag default-tag) - (if default-case - (byte-compile-body-do-effect default-case) - (byte-compile-constant nil)) - (byte-compile-out-tag donetag) - (push jump-table byte-compile-jump-tables)))) + :size nvalues))) + (setq default-tag (byte-compile-make-tag)) + ;; The structure of byte-switch code: + ;; + ;; varref var + ;; constant #s(hash-table purecopy t data (val1 (TAG1) val2 (TAG2))) + ;; switch + ;; goto DEFAULT-TAG + ;; TAG1 + ;; <clause body> + ;; goto DONETAG + ;; TAG2 + ;; <clause body> + ;; goto DONETAG + ;; DEFAULT-TAG + ;; <body for remaining (non-switch) clauses> + ;; DONETAG + + (byte-compile-variable-ref var) + (byte-compile-push-constant jump-table) + (byte-compile-out 'byte-switch) + + ;; When the opcode argument is `byte-goto', `byte-compile-goto' sets + ;; `byte-compile-depth' to `nil'. However, we need `byte-compile-depth' + ;; to be non-nil for generating tags for all cases. Since + ;; `byte-compile-depth' will increase by at most 1 after compiling + ;; all of the clause (which is further enforced by cl-assert below) + ;; it should be safe to preserve its value. + (let ((byte-compile-depth byte-compile-depth)) + (byte-compile-goto 'byte-goto default-tag)) + + (dolist (case cases) + (setq tag (byte-compile-make-tag) + test-objects (car case) + body (cdr case)) + (byte-compile-out-tag tag) + (dolist (value test-objects) + (puthash value tag jump-table)) + + (let ((byte-compile-depth byte-compile-depth) + (init-depth byte-compile-depth)) + ;; Since `byte-compile-body' might increase `byte-compile-depth' + ;; by 1, not preserving its value will cause it to potentially + ;; increase by one for every clause body compiled, causing + ;; depth/tag conflicts or violating asserts down the road. + ;; To make sure `byte-compile-body' itself doesn't violate this, + ;; we use `cl-assert'. + (byte-compile-body body byte-compile--for-effect) + (cl-assert (or (= byte-compile-depth init-depth) + (= byte-compile-depth (1+ init-depth)))) + (byte-compile-goto 'byte-goto donetag) + (setcdr (cdr donetag) nil))) + + (byte-compile-out-tag default-tag) + (push jump-table byte-compile-jump-tables))) (defun byte-compile-cond (clauses) - (or (and byte-compile-cond-use-jump-table - (byte-compile-cond-jump-table clauses)) - (let ((donetag (byte-compile-make-tag)) - nexttag clause) - (while (setq clauses (cdr clauses)) - (setq clause (car clauses)) - (cond ((or (eq (car clause) t) - (and (eq (car-safe (car clause)) 'quote) - (car-safe (cdr-safe (car clause))))) - ;; Unconditional clause - (setq clause (cons t clause) - clauses nil)) - ((cdr clauses) - (byte-compile-form (car clause)) - (if (null (cdr clause)) - ;; First clause is a singleton. - (byte-compile-goto-if t byte-compile--for-effect donetag) - (setq nexttag (byte-compile-make-tag)) - (byte-compile-goto 'byte-goto-if-nil nexttag) - (byte-compile-maybe-guarded (car clause) - (byte-compile-body (cdr clause) byte-compile--for-effect)) - (byte-compile-goto 'byte-goto donetag) - (byte-compile-out-tag nexttag))))) - ;; Last clause - (let ((guard (car clause))) - (and (cdr clause) (not (eq guard t)) - (progn (byte-compile-form guard) - (byte-compile-goto-if nil byte-compile--for-effect donetag) - (setq clause (cdr clause)))) - (byte-compile-maybe-guarded guard - (byte-compile-body-do-effect clause))) - (byte-compile-out-tag donetag)))) + (let ((donetag (byte-compile-make-tag)) + nexttag clause) + (setq clauses (cdr clauses)) + (while clauses + (let ((switch-prefix (and byte-compile-cond-use-jump-table + (byte-compile--cond-switch-prefix clauses)))) + (if switch-prefix + (progn + (byte-compile-cond-jump-table (cdr switch-prefix) donetag) + (setq clauses (car switch-prefix))) + (setq clause (car clauses)) + (cond ((or (eq (car clause) t) + (and (eq (car-safe (car clause)) 'quote) + (car-safe (cdr-safe (car clause))))) + ;; Unconditional clause + (setq clause (cons t clause) + clauses nil)) + ((cdr clauses) + (byte-compile-form (car clause)) + (if (null (cdr clause)) + ;; First clause is a singleton. + (byte-compile-goto-if t byte-compile--for-effect donetag) + (setq nexttag (byte-compile-make-tag)) + (byte-compile-goto 'byte-goto-if-nil nexttag) + (byte-compile-maybe-guarded (car clause) + (byte-compile-body (cdr clause) byte-compile--for-effect)) + (byte-compile-goto 'byte-goto donetag) + (byte-compile-out-tag nexttag)))) + (setq clauses (cdr clauses))))) + ;; Last clause + (let ((guard (car clause))) + (and (cdr clause) (not (eq guard t)) + (progn (byte-compile-form guard) + (byte-compile-goto-if nil byte-compile--for-effect donetag) + (setq clause (cdr clause)))) + (byte-compile-maybe-guarded guard + (byte-compile-body-do-effect clause))) + (byte-compile-out-tag donetag))) (defun byte-compile-and (form) (let ((failtag (byte-compile-make-tag)) @@ -4599,7 +4653,7 @@ 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)) + (byte-compile-warning-enabled-p 'suspicious 'set-buffer)) (byte-compile-warn "Use `with-current-buffer' rather than save-excursion+set-buffer")) (byte-compile-out 'byte-save-excursion 0) @@ -4640,7 +4694,7 @@ binding slots have been popped." ;; 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)) + (byte-compile-warning-enabled-p 'lexical (nth 1 form))) (byte-compile-warn "global/dynamic var `%s' lacks a prefix" (nth 1 form))) (let ((fun (nth 0 form)) @@ -4725,7 +4779,7 @@ binding slots have been popped." arg) ;; `lam' is the lambda expression in `fun' (or nil if not ;; recognized). - ((or `(,(or `quote `function) ,lam) (let lam nil)) + ((or `(,(or 'quote 'function) ,lam) (let lam nil)) fun) ;; `arglist' is the list of arguments (or t if not recognized). ;; `body' is the body of `lam' (or t if not recognized). @@ -4757,6 +4811,13 @@ binding slots have been popped." (let (byte-compile-warnings) (byte-compile-form (cons 'progn (cdr form))))) +(byte-defop-compiler-1 internal--with-suppressed-warnings + byte-compile-suppressed-warnings) +(defun byte-compile-suppressed-warnings (form) + (let ((byte-compile--suppressed-warnings + (append (cadadr form) byte-compile--suppressed-warnings))) + (byte-compile-form (macroexp-progn (cddr form))))) + ;; Warn about misuses of make-variable-buffer-local. (byte-defop-compiler-1 make-variable-buffer-local byte-compile-make-variable-buffer-local) @@ -4912,18 +4973,18 @@ invoked interactively." (setq byte-compile-call-tree (sort byte-compile-call-tree (pcase byte-compile-call-tree-sort - (`callers + ('callers (lambda (x y) (< (length (nth 1 x)) - (length (nth 1 y))))) - (`calls + (length (nth 1 y))))) + ('calls (lambda (x y) (< (length (nth 2 x)) - (length (nth 2 y))))) - (`calls+callers + (length (nth 2 y))))) + ('calls+callers (lambda (x y) (< (+ (length (nth 1 x)) - (length (nth 2 x))) - (+ (length (nth 1 y)) - (length (nth 2 y)))))) - (`name + (length (nth 2 x))) + (+ (length (nth 1 y)) + (length (nth 2 y)))))) + ('name (lambda (x y) (string< (car x) (car y)))) (_ (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode" byte-compile-call-tree-sort)))))) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 80f6b06a289..58ca9d5f57e 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -206,7 +206,6 @@ Returns a form where all lambdas don't have any free variables." (cl-assert (equal body (caar cconv-freevars-alist))) (let* ((fvs (cdr (pop cconv-freevars-alist))) (body-new '()) - (letbind '()) (envector ()) (i 0) (new-env ())) @@ -227,25 +226,8 @@ Returns a form where all lambdas don't have any free variables." (setq envector (nreverse envector)) (setq new-env (nreverse new-env)) - (dolist (arg args) - (if (not (member (cons (list arg) parentform) cconv-captured+mutated)) - (if (assq arg new-env) (push `(,arg) new-env)) - (push `(,arg . (car-safe ,arg)) new-env) - (push `(,arg (list ,arg)) letbind))) - - (setq body-new (mapcar (lambda (form) - (cconv-convert form new-env nil)) - body)) - - (when letbind - (let ((special-forms '())) - ;; Keep special forms at the beginning of the body. - (while (or (stringp (car body-new)) ;docstring. - (memq (car-safe (car body-new)) '(interactive declare))) - (push (pop body-new) special-forms)) - (setq body-new - `(,@(nreverse special-forms) (let ,letbind . ,body-new))))) - + (setq body-new (cconv--convert-funcbody + args body new-env parentform)) (cond ((not (or envector docstring)) ;If no freevars - do nothing. `(function (lambda ,args . ,body-new))) @@ -279,6 +261,30 @@ Returns a form where all lambdas don't have any free variables." (nthcdr 3 mapping))))) new-env)) +(defun cconv--convert-funcbody (funargs funcbody env parentform) + "Run `cconv-convert' on FUNCBODY, the forms of a lambda expression. +PARENTFORM is the form containing the lambda expression. ENV is a +lexical environment (same format as for `cconv-convert'), not +including FUNARGS, the function's argument list. Return a list +of converted forms." + (let ((letbind ())) + (dolist (arg funargs) + (if (not (member (cons (list arg) parentform) cconv-captured+mutated)) + (if (assq arg env) (push `(,arg . nil) env)) + (push `(,arg . (car-safe ,arg)) env) + (push `(,arg (list ,arg)) letbind))) + (setq funcbody (mapcar (lambda (form) + (cconv-convert form env nil)) + funcbody)) + (if letbind + (let ((special-forms '())) + ;; Keep special forms at the beginning of the body. + (while (or (stringp (car funcbody)) ;docstring. + (memq (car-safe (car funcbody)) '(interactive declare))) + (push (pop funcbody) special-forms)) + `(,@(nreverse special-forms) (let ,letbind . ,funcbody))) + funcbody))) + (defun cconv-convert (form env extend) ;; This function actually rewrites the tree. "Return FORM with all its lambdas changed so they are closed. @@ -292,6 +298,9 @@ ENV is a list where each entry takes the shape either: environment's Nth slot. (VAR . (apply-partially F ARG1 ARG2 ..)): VAR has been λ-lifted and takes additional arguments ARGs. + (VAR . nil): VAR is accessed normally. This is the same as VAR + being absent from ENV, but an explicit nil entry is useful + for shadowing VAR for a specific scope. EXTEND is a list of variables which might need to be accessed even from places where they are shadowed, because some part of ENV causes them to be used at places where they originally did not directly appear." @@ -313,7 +322,7 @@ places where they originally did not directly appear." ;; so we never touch it(unless we enter to the other closure). ;;(if (listp form) (print (car form)) form) (pcase form - (`(,(and letsym (or `let* `let)) ,binders . ,body) + (`(,(and letsym (or 'let* 'let)) ,binders . ,body) ; let and let* special forms (let ((binders-new '()) @@ -360,10 +369,8 @@ places where they originally did not directly appear." (not (memq fv funargs))) (push `(,fv . (car-safe ,fv)) funcbody-env))) `(function (lambda ,funcvars . - ,(mapcar (lambda (form) - (cconv-convert - form funcbody-env nil)) - funcbody))))) + ,(cconv--convert-funcbody + funargs funcbody funcbody-env value))))) ;; Check if it needs to be turned into a "ref-cell". ((member (cons binder form) cconv-captured+mutated) @@ -447,10 +454,13 @@ places where they originally did not directly appear." (`(function . ,_) form) ;defconst, defvar - (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,forms) + (`(,(and sym (or 'defconst 'defvar)) ,definedsymbol . ,forms) `(,sym ,definedsymbol - . ,(mapcar (lambda (form) (cconv-convert form env extend)) - forms))) + . ,(when (consp forms) + (cons (cconv-convert (car forms) env extend) + ;; The rest (i.e. docstring, of any) is not evaluated, + ;; and may be an invalid expression (e.g. ($# . 678)). + (cdr forms))))) ;condition-case ((and `(condition-case ,var ,protected-form . ,handlers) @@ -486,8 +496,8 @@ places where they originally did not directly appear." `((let ((,var (list ,var))) ,@body)))))) handlers)))) - (`(,(and head (or (and `catch (guard byte-compile--use-old-handlers)) - `unwind-protect)) + (`(,(and head (or (and 'catch (guard byte-compile--use-old-handlers)) + 'unwind-protect)) ,form . ,body) `(,head ,(cconv-convert form env extend) :fun-body ,(cconv--convert-function () body env form))) @@ -516,7 +526,7 @@ places where they originally did not directly appear." `(progn . ,(nreverse prognlist)) (car prognlist))))) - (`(,(and (or `funcall `apply) callsym) ,fun . ,args) + (`(,(and (or 'funcall 'apply) callsym) ,fun . ,args) ;; These are not special forms but we treat them separately for the needs ;; of lambda lifting. (let ((mapping (cdr (assq fun env)))) @@ -546,7 +556,7 @@ places where they originally did not directly appear." (`(,func . ,forms) ;; First element is function or whatever function-like forms are: or, and, - ;; if, catch, progn, prog1, prog2, while, until + ;; if, catch, progn, prog1, while, until `(,func . ,(mapcar (lambda (form) (cconv-convert form env extend)) forms))) @@ -645,7 +655,7 @@ This function does not return anything but instead fills the and updates the data stored in ENV." (pcase form ; let special form - (`(,(and (or `let* `let) letsym) ,binders . ,body-forms) + (`(,(and (or 'let* 'let) letsym) ,binders . ,body-forms) (let ((orig-env env) (newvars nil) @@ -729,18 +739,18 @@ and updates the data stored in ENV." form "variable")))) ;; FIXME: The bytecode for unwind-protect forces us to wrap the unwind. - (`(,(or (and `catch (guard byte-compile--use-old-handlers)) - `unwind-protect) + (`(,(or (and 'catch (guard byte-compile--use-old-handlers)) + 'unwind-protect) ,form . ,body) (cconv-analyze-form form env) (cconv--analyze-function () body env form)) (`(defvar ,var) (push var byte-compile-bound-variables)) - (`(,(or `defconst `defvar) ,var ,value . ,_) + (`(,(or 'defconst 'defvar) ,var ,value . ,_) (push var byte-compile-bound-variables) (cconv-analyze-form value env)) - (`(,(or `funcall `apply) ,fun . ,args) + (`(,(or 'funcall 'apply) ,fun . ,args) ;; Here we ignore fun because funcall and apply are the only two ;; functions where we can pass a candidate for lambda lifting as ;; argument. So, if we see fun elsewhere, we'll delete it from diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index 708f41237b5..354830d9112 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1996, 1998-1999, 2001, 2004-2005, 2007-2019 Free ;; Software Foundation, Inc. -;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 ;; Keywords: OO, chart, graph @@ -704,7 +704,7 @@ SORT-PRED if desired." (cntlst nil)) (save-excursion (goto-char (point-min)) - (while (re-search-forward "\\-[A-Z][a-z][a-z] +\\(\\w+\\)@\\w+" nil t) + (while (re-search-forward "-[A-Z][a-z][a-z] +\\(\\w+\\)@\\w+" nil t) (let* ((nam (buffer-substring (match-beginning 1) (match-end 1))) (m (member nam nmlst))) (message "Scanned username %s" nam) diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index 8445950311b..903b4e12a2f 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -33,7 +33,7 @@ ;;; TODO: ;; 1. Warn about functions marked as obsolete, eg -;; password-read-and-add in smime.el. +;; password-read-and-add in password-cache.el. ;; 2. defmethod, defclass argument checking. ;; 3. defclass also defines -p and -child-p. @@ -148,7 +148,7 @@ is a string giving details of the error." (setq re (format (if cflag "^[ \t]*\\(DEFUN\\)[ \t]*([ \t]*\"%s\"" "^[ \t]*(\\(fset[ \t]+'\\|\ -cl-def\\(?:generic\\|method\\)\\|\ +cl-def\\(?:generic\\|method\\|un\\)\\|\ def\\(?:un\\|subst\\|foo\\|method\\|class\\|\ ine-\\(?:derived\\|generic\\|\\(?:global\\(?:ized\\)?-\\)?minor\\)-mode\\|\ \\(?:ine-obsolete-function-\\)?alias[ \t]+'\\|\ diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 72fb47ba679..830743f5f89 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -171,8 +171,10 @@ (defvar checkdoc-version "0.6.1" "Release version of checkdoc you are currently running.") +(require 'cl-lib) (require 'help-mode) ;; for help-xref-info-regexp (require 'thingatpt) ;; for handy thing-at-point-looking-at +(require 'lisp-mnt) (defvar compilation-error-regexp-alist) (defvar compilation-mode-font-lock-keywords) @@ -436,23 +438,6 @@ be re-created.") st) "Syntax table used by checkdoc in document strings.") -;;; Compatibility -;; -(defalias 'checkdoc-make-overlay - (if (featurep 'xemacs) #'make-extent #'make-overlay)) -(defalias 'checkdoc-overlay-put - (if (featurep 'xemacs) #'set-extent-property #'overlay-put)) -(defalias 'checkdoc-delete-overlay - (if (featurep 'xemacs) #'delete-extent #'delete-overlay)) -(defalias 'checkdoc-overlay-start - (if (featurep 'xemacs) #'extent-start #'overlay-start)) -(defalias 'checkdoc-overlay-end - (if (featurep 'xemacs) #'extent-end #'overlay-end)) -(defalias 'checkdoc-mode-line-update - (if (featurep 'xemacs) #'redraw-modeline #'force-mode-line-update)) -(defalias 'checkdoc-char= - (if (featurep 'xemacs) #'char= #'=)) - ;;; User level commands ;; ;;;###autoload @@ -475,32 +460,31 @@ the users will view as each check is completed." tmp) (checkdoc-display-status-buffer status) ;; check the comments - (if (not buffer-file-name) - (setcar status "Not checked") - (if (checkdoc-file-comments-engine) - (setcar status "Errors") - (setcar status "Ok"))) - (setcar (cdr status) "Checking...") + (setf (nth 0 status) + (cond + ((not buffer-file-name) "Not checked") + ((checkdoc-file-comments-engine) "Errors") + (t "Ok"))) + (setf (nth 1 status) "Checking...") (checkdoc-display-status-buffer status) ;; Check the documentation (setq tmp (checkdoc-interactive nil t)) - (if tmp - (setcar (cdr status) (format "%d Errors" (length tmp))) - (setcar (cdr status) "Ok")) - (setcar (cdr (cdr status)) "Checking...") + (setf (nth 1 status) + (if tmp (format "%d Errors" (length tmp)) "Ok")) + (setf (nth 2 status) "Checking...") (checkdoc-display-status-buffer status) ;; Check the message text - (if (setq tmp (checkdoc-message-interactive nil t)) - (setcar (cdr (cdr status)) (format "%d Errors" (length tmp))) - (setcar (cdr (cdr status)) "Ok")) - (setcar (cdr (cdr (cdr status))) "Checking...") + (setf (nth 2 status) + (if (setq tmp (checkdoc-message-interactive nil t)) + (format "%d Errors" (length tmp)) + "Ok")) + (setf (nth 3 status) "Checking...") (checkdoc-display-status-buffer status) ;; Rogue spacing - (if (condition-case nil - (checkdoc-rogue-spaces nil t) - (error t)) - (setcar (cdr (cdr (cdr status))) "Errors") - (setcar (cdr (cdr (cdr status))) "Ok")) + (setf (nth 3 status) + (if (ignore-errors (checkdoc-rogue-spaces nil t)) + "Errors" + "Ok")) (checkdoc-display-status-buffer status))) (defun checkdoc-display-status-buffer (check) @@ -592,16 +576,16 @@ style." (while err-list (goto-char (cdr (car err-list))) ;; The cursor should be just in front of the offending doc string - (if (stringp (car (car err-list))) - (setq cdo (save-excursion (checkdoc-make-overlay + (setq cdo (if (stringp (car (car err-list))) + (save-excursion (make-overlay (point) (progn (forward-sexp 1) - (point))))) - (setq cdo (checkdoc-make-overlay + (point)))) + (make-overlay (checkdoc-error-start (car (car err-list))) (checkdoc-error-end (car (car err-list)))))) (unwind-protect (progn - (checkdoc-overlay-put cdo 'face 'highlight) + (overlay-put cdo 'face 'highlight) ;; Make sure the whole doc string is visible if possible. (sit-for 0) (if (and (= (following-char) ?\") @@ -627,10 +611,10 @@ style." (if (not (integerp c)) (setq c ??)) (cond ;; Exit condition - ((checkdoc-char= c ?\C-g) (signal 'quit nil)) + ((eq c ?\C-g) (signal 'quit nil)) ;; Request an auto-fix - ((or (checkdoc-char= c ?y) (checkdoc-char= c ?f)) - (checkdoc-delete-overlay cdo) + ((memq c '(?y ?f)) + (delete-overlay cdo) (setq cdo nil) (goto-char (cdr (car err-list))) ;; `automatic-then-never' tells the autofix function @@ -659,7 +643,7 @@ style." "No Additional style errors. Continuing...") (sit-for 2)))))) ;; Move to the next error (if available) - ((or (checkdoc-char= c ?n) (checkdoc-char= c ?\s)) + ((memq c '(?n ?\s)) (let ((ne (funcall findfunc nil))) (if (not ne) (if showstatus @@ -671,7 +655,7 @@ style." (sit-for 2)) (setq err-list (cons ne err-list))))) ;; Go backwards in the list of errors - ((or (checkdoc-char= c ?p) (checkdoc-char= c ?\C-?)) + ((memq c '(?p ?\C-?)) (if (/= (length err-list) 1) (progn (setq err-list (cdr err-list)) @@ -680,10 +664,10 @@ style." (message "No Previous Errors.") (sit-for 2))) ;; Edit the buffer recursively. - ((checkdoc-char= c ?e) + ((eq c ?e) (checkdoc-recursive-edit (checkdoc-error-text (car (car err-list)))) - (checkdoc-delete-overlay cdo) + (delete-overlay cdo) (setq err-list (cdr err-list)) ;back up the error found. (beginning-of-defun) (let ((ne (funcall findfunc nil))) @@ -695,7 +679,7 @@ style." (sit-for 2)) (setq err-list (cons ne err-list))))) ;; Quit checkdoc - ((checkdoc-char= c ?q) + ((eq c ?q) (setq returnme err-list err-list nil begin (point))) @@ -723,7 +707,7 @@ style." "C-h - Toggle this help buffer."))) (shrink-window-if-larger-than-buffer (get-buffer-window "*Checkdoc Help*")))))) - (if cdo (checkdoc-delete-overlay cdo))))) + (if cdo (delete-overlay cdo))))) (goto-char begin) (if (get-buffer "*Checkdoc Help*") (kill-buffer "*Checkdoc Help*")) (message "Checkdoc: Done.") @@ -945,7 +929,10 @@ don't move point." (pcase (save-excursion (condition-case nil (read (current-buffer)) ;; Conservatively skip syntax errors. - (invalid-read-syntax))) + (invalid-read-syntax) + ;; Don't bug out if the file is empty (or a + ;; definition ends prematurely. + (end-of-file))) (`(,(or 'defun 'defvar 'defcustom 'defmacro 'defconst 'defsubst 'defadvice) ,(pred symbolp) ;; Require an initializer, i.e. ignore single-argument `defvar' @@ -1146,6 +1133,15 @@ Prefix argument is the same as for `checkdoc-defun'" ;; features and behaviors, so we need some ways of specifying ;; them, and making them easier to use in the wacked-out interfaces ;; people are requesting + +(cl-defstruct (checkdoc-error + (:constructor nil) + (:constructor checkdoc--create-error (text start end &optional unfixable))) + (text nil :read-only t) + (start nil :read-only t) + (end nil :read-only t) + (unfixable nil :read-only t)) + (defvar checkdoc-create-error-function #'checkdoc--create-error-for-checkdoc "Function called when Checkdoc encounters an error. Should accept as arguments (TEXT START END &optional UNFIXABLE). @@ -1154,7 +1150,7 @@ TEXT is the descriptive text of the error. START and END define the region it is sensible to highlight when describing the problem. Optional argument UNFIXABLE means that the error has no auto-fix available. -A list of the form (TEXT START END UNFIXABLE) is returned if we are not +An object of type `checkdoc-error' is returned if we are not generating a buffered list of errors.") (defun checkdoc-create-error (text start end &optional unfixable) @@ -1170,27 +1166,7 @@ TEXT, START, END and UNFIXABLE conform to (if checkdoc-generate-compile-warnings-flag (progn (checkdoc-error start text) nil) - (list text start end unfixable))) - -(defun checkdoc-error-text (err) - "Return the text specified in the checkdoc ERR." - ;; string-p part is for backwards compatibility - (if (stringp err) err (car err))) - -(defun checkdoc-error-start (err) - "Return the start point specified in the checkdoc ERR." - ;; string-p part is for backwards compatibility - (if (stringp err) nil (nth 1 err))) - -(defun checkdoc-error-end (err) - "Return the end point specified in the checkdoc ERR." - ;; string-p part is for backwards compatibility - (if (stringp err) nil (nth 2 err))) - -(defun checkdoc-error-unfixable (err) - "Return the t if we cannot autofix the error specified in the checkdoc ERR." - ;; string-p part is for backwards compatibility - (if (stringp err) nil (nth 3 err))) + (checkdoc--create-error text start end unfixable))) ;;; Minor Mode specification ;; @@ -1201,9 +1177,8 @@ TEXT, START, END and UNFIXABLE conform to ;; Override some bindings (define-key map "\C-\M-x" 'checkdoc-eval-defun) (define-key map "\C-x`" 'checkdoc-continue) - (if (not (featurep 'xemacs)) - (define-key map [menu-bar emacs-lisp eval-buffer] - 'checkdoc-eval-current-buffer)) + (define-key map [menu-bar emacs-lisp eval-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) @@ -1256,17 +1231,11 @@ TEXT, START, END and UNFIXABLE conform to ["Check Defun" checkdoc-defun t] ["Check and Spell Defun" checkdoc-ispell-defun t] ["Check and Evaluate Defun" checkdoc-eval-defun t] - ["Check and Evaluate Buffer" checkdoc-eval-current-buffer t] - )) -;; XEmacs requires some weird stuff to add this menu in a minor mode. -;; What is it? + ["Check and Evaluate Buffer" checkdoc-eval-current-buffer t])) ;;;###autoload (define-minor-mode checkdoc-minor-mode "Toggle automatic docstring checking (Checkdoc minor mode). -With a prefix argument ARG, enable Checkdoc minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. 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 @@ -1341,7 +1310,7 @@ See the style guide in the Emacs Lisp manual for more details." (if (and (not (nth 1 fp)) ; not a variable (or (nth 2 fp) ; is interactive checkdoc-force-docstrings-flag) ;or we always complain - (not (checkdoc-char= (following-char) ?\"))) ; no doc string + (not (eq (following-char) ?\"))) ; no doc string ;; Sometimes old code has comments where the documentation should ;; be. Let's see if we can find the comment, and offer to turn it ;; into documentation for them. @@ -1470,9 +1439,9 @@ regexp short cuts work. FP is the function defun information." (if (> (point) e) (goto-char e)) ;of the form (defun n () "doc" nil) (forward-char -1) (cond - ((and (checkdoc-char= (following-char) ?\") + ((and (eq (following-char) ?\") ;; A backslashed double quote at the end of a sentence - (not (checkdoc-char= (preceding-char) ?\\))) + (not (eq (preceding-char) ?\\))) ;; We might have to add a period in this case (forward-char -1) (if (looking-at "[.!?]") @@ -1541,7 +1510,7 @@ may require more formatting") (line-end-position)))))))) ;; Continuation of above. Make sure our sentence is capitalized. (save-excursion - (skip-chars-forward "\"\\*") + (skip-chars-forward "\"*") (if (looking-at "[a-z]") (if (checkdoc-autofix-ask-replace (match-beginning 0) (match-end 0) @@ -1795,7 +1764,7 @@ function,command,variable,option or symbol." ms1)))))) (let ((lim (save-excursion (end-of-line) ;; check string-continuation - (if (checkdoc-char= (preceding-char) ?\\) + (if (eq (preceding-char) ?\\) (line-end-position 2) (point)))) (rs nil) replace original (case-fold-search t)) @@ -2236,21 +2205,10 @@ News agents may remove it" ;; (defvar generate-autoload-cookie) -(eval-when-compile (require 'lisp-mnt)) ; expand silly defsubsts -(declare-function lm-summary "lisp-mnt" (&optional file)) -(declare-function lm-section-start "lisp-mnt" (header &optional after)) -(declare-function lm-section-end "lisp-mnt" (header)) - (defun checkdoc-file-comments-engine () "Return a message list if this file does not match the Emacs standard. This checks for style only, such as the first line, Commentary:, Code:, and others referenced in the style guide." - (if (featurep 'lisp-mnt) - nil - (require 'lisp-mnt) - ;; Old XEmacs don't have `lm-commentary-mark' - (if (and (not (fboundp 'lm-commentary-mark)) (fboundp 'lm-commentary)) - (defalias 'lm-commentary-mark #'lm-commentary))) (save-excursion (let* ((f1 (file-name-nondirectory (buffer-file-name))) (fn (file-name-sans-extension f1)) @@ -2295,7 +2253,10 @@ Code:, and others referenced in the style guide." (re-search-forward "^(require" nil t) (re-search-forward "^(" nil t)) (beginning-of-line)) - (t (re-search-forward ";;; .* --- .*\n"))) + ((not (re-search-forward ";;; .* --- .*\n" nil t)) + (checkdoc-create-error + "You should have a summary line (\";;; .* --- .*\")" + nil nil t))) (if (checkdoc-y-or-n-p "You should have a \";;; Commentary:\", add one? ") (insert "\n;;; Commentary:\n;; \n\n") @@ -2311,7 +2272,7 @@ Code:, and others referenced in the style guide." (if (or (not checkdoc-force-history-flag) (file-exists-p "ChangeLog") (file-exists-p "../ChangeLog") - (and (fboundp 'lm-history-mark) (funcall #'lm-history-mark))) + (lm-history-mark)) nil (progn (goto-char (or (lm-commentary-mark) (point-min))) @@ -2592,12 +2553,12 @@ This function returns non-nil if the text was replaced. This function will not modify `match-data'." (if (and checkdoc-autofix-flag (not (eq checkdoc-autofix-flag 'never))) - (let ((o (checkdoc-make-overlay start end)) + (let ((o (make-overlay start end)) (ret nil) (md (match-data))) (unwind-protect (progn - (checkdoc-overlay-put o 'face 'highlight) + (overlay-put o 'face 'highlight) (if (or (eq checkdoc-autofix-flag 'automatic) (eq checkdoc-autofix-flag 'automatic-then-never) (and (eq checkdoc-autofix-flag 'semiautomatic) @@ -2614,9 +2575,9 @@ This function will not modify `match-data'." (insert replacewith) (if checkdoc-bouncy-flag (sit-for 0)) (setq ret t))) - (checkdoc-delete-overlay o) + (delete-overlay o) (set-match-data md)) - (checkdoc-delete-overlay o) + (delete-overlay o) (set-match-data md)) (if (eq checkdoc-autofix-flag 'automatic-then-never) (setq checkdoc-autofix-flag 'never)) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index b0f9cfdcfa0..ca33c56a958 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -332,10 +332,9 @@ If so, return the true (non-nil) value returned by PREDICATE. ;;;###autoload (defun cl-isqrt (x) - "Return the integer square root of the argument." + "Return the integer square root of the (integer) argument." (if (and (integerp x) (> x 0)) - (let ((g (cond ((<= x 100) 10) ((<= x 10000) 100) - ((<= x 1000000) 1000) (t x))) + (let ((g (ash 2 (/ (logb x) 2))) g2) (while (< (setq g2 (/ (+ g (/ x g)) 2)) g) (setq g g2)) @@ -438,9 +437,7 @@ as an integer unless JUNK-ALLOWED is non-nil." ;; Random numbers. (defun cl--random-time () - (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) - (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i)))) - v)) + (car (encode-time nil t))) ;;;###autoload (autoload 'cl-random-state-p "cl-extra") (cl-defstruct (cl--random-state @@ -472,7 +469,7 @@ Optional second arg STATE is a random-state object." (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j)))))) (if (integerp lim) (if (<= lim 512) (% n lim) - (if (> lim 8388607) (setq n (+ (lsh n 9) (cl-random 512 state)))) + (if (> lim 8388607) (setq n (+ (ash n 9) (cl-random 512 state)))) (let ((mask 1023)) (while (< mask (1- lim)) (setq mask (1+ (+ mask mask)))) (if (< (setq n (logand n mask)) lim) n (cl-random lim state)))) @@ -576,9 +573,9 @@ too large if positive or too small if negative)." "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. \n(fn TYPE SEQUENCE...)" (pcase type - (`vector (apply #'vconcat sequences)) - (`string (apply #'concat sequences)) - (`list (apply #'append (append sequences '(nil)))) + ('vector (apply #'vconcat sequences)) + ('string (apply #'concat sequences)) + ('list (apply #'append (append sequences '(nil)))) (_ (error "Not a sequence type name: %S" type)))) ;;; List functions. @@ -596,10 +593,10 @@ too large if positive or too small if negative)." ;;;###autoload (defun cl-list-length (x) "Return the length of list X. Return nil if list is circular." - (let ((n 0) (fast x) (slow x)) - (while (and (cdr fast) (not (and (eq fast slow) (> n 0)))) - (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow))) - (if fast (if (cdr fast) nil (1+ n)) n))) + (cl-check-type x list) + (condition-case nil + (length x) + (circular-list))) ;;;###autoload (defun cl-tailp (sublist list) @@ -742,7 +739,7 @@ including `cl-block' and `cl-eval-when'." (with-eval-after-load 'find-func (defvar find-function-regexp-alist) (add-to-list 'find-function-regexp-alist - `(define-type . cl--typedef-regexp))) + '(define-type . cl--typedef-regexp))) (define-button-type 'cl-help-type :supertype 'help-function-def @@ -940,7 +937,6 @@ Outputs to the current buffer." (run-hooks 'cl-extra-load-hook) ;; Local variables: -;; byte-compile-dynamic: t ;; generated-autoload-file: "cl-loaddefs.el" ;; End: diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 3cdfba3f723..10190f49339 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -238,6 +238,7 @@ DEFAULT-BODY, if present, is used as the body of a default method. (push `(,args ,@options-and-methods) methods)) (when (eq 'setf (car-safe name)) (require 'gv) + (declare-function gv-setter "gv" (name)) (setq name (gv-setter (cadr name)))) `(prog1 (progn @@ -345,6 +346,9 @@ 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)))) ;; First macroexpand away the cl-function stuff (e.g. &key and ;; destructuring args, `declare' and whatnot). (pcase (macroexpand fun macroenv) @@ -440,12 +444,13 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (setq args (pop body))) (when (eq 'setf (car-safe name)) (require 'gv) + (declare-function gv-setter "gv" (name)) (setq name (gv-setter (cadr name)))) (pcase-let* ((`(,uses-cnm . ,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)) + (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") @@ -808,22 +813,26 @@ methods.") ;; able to preload cl-generic without also preloading the byte-compiler, ;; So we use `eval-when-compile' so as not keep it available longer than ;; strictly needed. -(defmacro cl--generic-prefill-dispatchers (arg-or-context specializer) +(defmacro cl--generic-prefill-dispatchers (arg-or-context &rest specializers) (unless (integerp arg-or-context) (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 ,@(cl-generic-generalizers specializer) - ,cl--generic-t-generalizer)))) + `(,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 ;; to the compile-time one, in which case `fun' may not be correct ;; any more! - `(let ((dispatch `(,',arg-or-context - ,@(cl-generic-generalizers ',specializer) - ,cl--generic-t-generalizer))) + `(let ((dispatch + `(,',arg-or-context + ,@(apply #'append + (mapcar #'cl-generic-generalizers ',specializers)) + ,cl--generic-t-generalizer))) ;; (message "Prefilling for %S with \n%S" dispatch ',fun) (puthash dispatch ',fun cl--generic-dispatchers))))) @@ -931,7 +940,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (add-to-list 'find-function-regexp-alist `(cl-defmethod . ,#'cl--generic-search-method)) (add-to-list 'find-function-regexp-alist - `(cl-defgeneric . cl--generic-find-defgeneric-regexp))) + '(cl-defgeneric . cl--generic-find-defgeneric-regexp))) (defun cl--generic-method-info (method) (let* ((specializers (cl--generic-method-specializers method)) @@ -1156,45 +1165,19 @@ These match if the argument is `eql' to VAL." ;;; Dispatch on "system types". -(defconst cl--generic-typeof-types - ;; Hand made from the source code of `type-of'. - '((integer number number-or-marker 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) - (buffer atom) (char-table array sequence atom) - (bool-vector array sequence atom) - (frame atom) (hash-table atom) (terminal atom) - (thread atom) (mutex atom) (condvar atom) - (font-spec atom) (font-entity atom) (font-object atom) - (vector array sequence atom) - ;; Plus, really hand made: - (null symbol list sequence atom)) - "Alist of supertypes. -Each element has the form (TYPE . SUPERTYPES) where TYPE is one of -the symbols returned by `type-of', and SUPERTYPES is the list of its -supertypes from the most specific to least specific.") - -(defconst cl--generic-all-builtin-types - (delete-dups (copy-sequence (apply #'append cl--generic-typeof-types)))) - (cl-generic-define-generalizer cl--generic-typeof-generalizer ;; FIXME: We could also change `type-of' to return `null' for nil. 10 (lambda (name &rest _) `(if ,name (type-of ,name) 'null)) (lambda (tag &rest _) - (and (symbolp tag) (assq tag cl--generic-typeof-types)))) + (and (symbolp tag) (assq tag cl--typeof-types)))) (cl-defmethod cl-generic-generalizers :extra "typeof" (type) "Support for dispatch on builtin types. -See the full list and their hierarchy in `cl--generic-typeof-types'." +See the full list and their hierarchy in `cl--typeof-types'." ;; FIXME: Add support for other types accepted by `cl-typep' such ;; as `character', `face', `function', ... (or - (and (memq type cl--generic-all-builtin-types) + (and (memq type cl--all-builtin-types) (progn ;; FIXME: While this wrinkle in the semantics can be occasionally ;; problematic, this warning is more often annoying than helpful. @@ -1205,6 +1188,7 @@ See the full list and their hierarchy in `cl--generic-typeof-types'." (cl-call-next-method))) (cl--generic-prefill-dispatchers 0 integer) +(cl--generic-prefill-dispatchers 0 cl--generic-generalizer integer) ;;; Dispatch on major mode. diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index 10af440008d..ad5f31713af 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -593,7 +593,7 @@ optional\\|rest\\|key\\|allow-other-keys\\|aux\\|whole\\|body\\|environment\ (null (cdr method))) (lisp-indent-report-bad-format method)) - (cond ((and tail (not (consp tem))) + (cond ((and tail (not (or (consp tem) (symbolp tem)))) ;; indent tail of &rest in same way as first elt of rest (throw 'exit normal-indent)) ((eq tem '&body) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 0f5f3c78695..7b22fa8483a 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -189,12 +189,16 @@ that the containing function should return. \(fn &rest VALUES)") -(cl--defalias 'cl-values-list #'identity +(defun cl-values-list (list) "Return multiple values, Common Lisp style, taken from a list. -LIST specifies the list of values -that the containing function should return. +LIST specifies the list of values that the containing function +should return. -\(fn LIST)") +Note that Emacs Lisp doesn't really support multiple values, so +all this function does is return LIST." + (unless (listp list) + (signal 'wrong-type-argument list)) + list) (defsubst cl-multiple-value-list (expression) "Return a list of the multiple values produced by EXPRESSION. @@ -365,13 +369,6 @@ SEQ, this is like `mapcar'. With several, it is like the Common Lisp (cl--defalias 'cl-second 'cadr) (cl--defalias 'cl-rest 'cdr) -(defun cl-endp (x) - "Return true if X is the empty list; false if it is a cons. -Signal an error if X is not a list." - (if (listp x) - (null x) - (signal 'wrong-type-argument (list 'listp x 'x)))) - (cl--defalias 'cl-third 'cl-caddr "Return the third element of the list X.") (cl--defalias 'cl-fourth 'cl-cadddr "Return the fourth element of the list X.") @@ -531,8 +528,9 @@ If ALIST is non-nil, the new pairs are prepended to it." ;; Some more Emacs-related place types. (gv-define-simple-setter buffer-file-name set-visited-file-name t) (gv-define-setter buffer-modified-p (flag &optional buf) - `(with-current-buffer ,buf - (set-buffer-modified-p ,flag))) + (macroexp-let2 nil buffer `(or ,buf (current-buffer)) + `(with-current-buffer ,buffer + (set-buffer-modified-p ,flag)))) (gv-define-simple-setter buffer-name rename-buffer t) (gv-define-setter buffer-string (store) `(insert (prog1 ,store (erase-buffer)))) @@ -666,8 +664,4 @@ of record objects." (t (advice-remove 'type-of #'cl--old-struct-type-of)))) -;; Local variables: -;; byte-compile-dynamic: t -;; End: - ;;; cl-lib.el ends here diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index b594887ee72..1ae72666244 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -498,7 +498,7 @@ its argument list allows full Common Lisp conventions." ;; `&aux' args aren't arguments, so let's just drop them from the ;; usage info. (setq arglist (cl-subseq arglist 0 aux)))) - (if (cdr-safe (last arglist)) ;Not a proper list. + (if (not (proper-list-p arglist)) (let* ((last (last arglist)) (tail (cdr last))) (unwind-protect @@ -555,7 +555,7 @@ its argument list allows full Common Lisp conventions." (if (memq '&environment args) (error "&environment used incorrectly")) (let ((restarg (memq '&rest args)) (safety (if (cl--compiling-file) cl--optimize-safety 3)) - (keys nil) + (keys t) (laterarg nil) (exactarg nil) minarg) (or num (setq num 0)) (setq restarg (if (listp (cadr restarg)) @@ -610,6 +610,7 @@ its argument list allows full Common Lisp conventions." (+ ,num (length ,restarg))))) cl--bind-forms))) (while (and (eq (car args) '&key) (pop args)) + (unless (listp keys) (setq keys nil)) (while (and args (not (memq (car args) cl--lambda-list-keywords))) (let ((arg (pop args))) (or (consp arg) (setq arg (list arg))) @@ -648,23 +649,32 @@ its argument list allows full Common Lisp conventions." `'(nil ,(cl--const-expr-val def)) `(list nil ,def)))))))) (push karg keys))))) - (setq keys (nreverse keys)) + (when (consp keys) (setq keys (nreverse keys))) (or (and (eq (car args) '&allow-other-keys) (pop args)) - (null keys) (= safety 0) - (let* ((var (make-symbol "--cl-keys--")) - (allow '(:allow-other-keys)) - (check `(while ,var - (cond - ((memq (car ,var) ',(append keys allow)) - (setq ,var (cdr (cdr ,var)))) - ((car (cdr (memq (quote ,@allow) ,restarg))) - (setq ,var nil)) - (t - (error - ,(format "Keyword argument %%s not one of %s" - keys) - (car ,var))))))) - (push `(let ((,var ,restarg)) ,check) cl--bind-forms))) + (= safety 0) + (cond + ((eq keys t) nil) ;No &keys at all + ((null keys) ;A &key but no actual keys specified. + (push `(when ,restarg + (error ,(format "Keyword argument %%s not one of %s" + keys) + (car ,restarg))) + cl--bind-forms)) + (t + (let* ((var (make-symbol "--cl-keys--")) + (allow '(:allow-other-keys)) + (check `(while ,var + (cond + ((memq (car ,var) ',(append keys allow)) + (setq ,var (cdr (cdr ,var)))) + ((car (cdr (memq (quote ,@allow) ,restarg))) + (setq ,var nil)) + (t + (error + ,(format "Keyword argument %%s not one of %s" + keys) + (car ,var))))))) + (push `(let ((,var ,restarg)) ,check) cl--bind-forms))))) (cl--do-&aux args) nil))) @@ -685,8 +695,11 @@ its argument list allows full Common Lisp conventions." "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))) - (let* ((cl--bind-lets nil) (cl--bind-forms nil) - (cl--bind-defs nil) (cl--bind-block 'cl-none) (cl--bind-enquote nil)) + (let* ((cl--bind-lets nil) + (cl--bind-forms nil) + (cl--bind-defs nil) + (cl--bind-block args) + (cl--bind-enquote nil)) (cl--do-arglist (or args '(&aux)) expr) (macroexp-let* (nreverse cl--bind-lets) (macroexp-progn (append (nreverse cl--bind-forms) body))))) @@ -884,7 +897,7 @@ This is compatible with Common Lisp, but note that `defun' and (defvar cl--loop-name) (defvar cl--loop-result) (defvar cl--loop-result-explicit) (defvar cl--loop-result-var) (defvar cl--loop-steps) -(defvar cl--loop-symbol-macs) +(defvar cl--loop-symbol-macs) (defvar cl--loop-guard-cond) (defun cl--loop-set-iterator-function (kind iterator) (if cl--loop-iterator-function @@ -953,7 +966,7 @@ For more details, see Info node `(cl)Loop Facility'. (cl--loop-accum-var nil) (cl--loop-accum-vars nil) (cl--loop-initially nil) (cl--loop-finally nil) (cl--loop-iterator-function nil) (cl--loop-first-flag nil) - (cl--loop-symbol-macs nil)) + (cl--loop-symbol-macs nil) (cl--loop-guard-cond nil)) ;; Here is more or less how those dynbind vars are used after looping ;; over cl--parse-loop-clause: ;; @@ -988,7 +1001,24 @@ For more details, see Info node `(cl)Loop Facility'. (list (or cl--loop-result-explicit cl--loop-result)))) (ands (cl--loop-build-ands (nreverse cl--loop-body))) - (while-body (nconc (cadr ands) (nreverse cl--loop-steps))) + (while-body + (nconc + (cadr ands) + (if (or (not cl--loop-guard-cond) (not cl--loop-first-flag)) + (nreverse cl--loop-steps) + ;; Right after update the loop variable ensure that the loop + ;; condition, i.e. (car ands), is still satisfied; otherwise, + ;; set `cl--loop-first-flag' nil and skip the remaining + ;; body forms (#Bug#29799). + ;; + ;; (last cl--loop-steps) updates the loop var + ;; (car (butlast cl--loop-steps)) sets `cl--loop-first-flag' nil + ;; (nreverse (cdr (butlast cl--loop-steps))) are the + ;; remaining body forms. + (append (last cl--loop-steps) + `((and ,(car ands) + ,@(nreverse (cdr (butlast cl--loop-steps))))) + `(,(car (butlast cl--loop-steps))))))) (body (append (nreverse cl--loop-initially) (list (if cl--loop-iterator-function @@ -1309,11 +1339,13 @@ For more details, see Info node `(cl)Loop Facility'. ((memq word '(across across-ref)) (let ((temp-vec (make-symbol "--cl-vec--")) + (temp-len (make-symbol "--cl-len--")) (temp-idx (make-symbol "--cl-idx--"))) (push (list temp-vec (pop cl--loop-args)) loop-for-bindings) + (push (list temp-len `(length ,temp-vec)) loop-for-bindings) (push (list temp-idx -1) loop-for-bindings) (push `(< (setq ,temp-idx (1+ ,temp-idx)) - (length ,temp-vec)) + ,temp-len) cl--loop-body) (if (eq word 'across-ref) (push (list var `(aref ,temp-vec ,temp-idx)) @@ -1328,6 +1360,7 @@ For more details, see Info node `(cl)Loop Facility'. (error "Expected `of'")))) (seq (cl--pop2 cl--loop-args)) (temp-seq (make-symbol "--cl-seq--")) + (temp-len (make-symbol "--cl-len--")) (temp-idx (if (eq (car cl--loop-args) 'using) (if (and (= (length (cadr cl--loop-args)) 2) @@ -1338,16 +1371,19 @@ For more details, see Info node `(cl)Loop Facility'. (push (list temp-seq seq) loop-for-bindings) (push (list temp-idx 0) loop-for-bindings) (if ref - (let ((temp-len (make-symbol "--cl-len--"))) + (progn (push (list temp-len `(length ,temp-seq)) loop-for-bindings) (push (list var `(elt ,temp-seq ,temp-idx)) cl--loop-symbol-macs) (push `(< ,temp-idx ,temp-len) cl--loop-body)) + ;; Evaluate seq length just if needed, that is, when seq is not a cons. + (push (list temp-len (or (consp seq) `(length ,temp-seq))) + loop-for-bindings) (push (list var nil) loop-for-bindings) (push `(and ,temp-seq (or (consp ,temp-seq) - (< ,temp-idx (length ,temp-seq)))) + (< ,temp-idx ,temp-len))) cl--loop-body) (push (list var `(if (consp ,temp-seq) (pop ,temp-seq) @@ -1492,10 +1528,11 @@ For more details, see Info node `(cl)Loop Facility'. ,(cl--loop-let (nreverse loop-for-sets) 'setq ands) t) cl--loop-body)) - (if loop-for-steps - (push (cons (if ands 'cl-psetq 'setq) - (apply 'append (nreverse loop-for-steps))) - cl--loop-steps)))) + (when loop-for-steps + (setq cl--loop-guard-cond t) + (push (cons (if ands 'cl-psetq 'setq) + (apply 'append (nreverse loop-for-steps))) + cl--loop-steps)))) ((eq word 'repeat) (let ((temp (make-symbol "--cl-var--"))) @@ -1868,7 +1905,7 @@ Labels have lexical scope and dynamic extent." (push (nreverse block) blocks) (setq block (list label-or-stmt)))) (unless (eq 'go (car-safe (car-safe block))) - (push `(go cl--exit) block)) + (push '(go cl--exit) block)) (push (nreverse block) blocks)) (let ((catch-tag (make-symbol "cl--tagbody-tag")) (cl--tagbody-alist cl--tagbody-alist)) @@ -2084,10 +2121,7 @@ This is like `cl-flet', but for macros instead of functions. \(fn ((NAME ARGLIST BODY...) ...) FORM...)" (declare (indent 1) - (debug - ((&rest (&define name (&rest arg) cl-declarations-or-string - def-body)) - cl-declarations body))) + (debug (cl-macrolet-expr))) (if (cdr bindings) `(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body)) (if (null bindings) (macroexp-progn body) @@ -2099,93 +2133,137 @@ This is like `cl-flet', but for macros instead of functions. (eval `(cl-function (lambda ,@(cdr res))) t)) macroexpand-all-environment)))))) -(defconst cl--old-macroexpand - (if (and (boundp 'cl--old-macroexpand) - (eq (symbol-function 'macroexpand) - #'cl--sm-macroexpand)) - cl--old-macroexpand - (symbol-function 'macroexpand))) - -(defun cl--sm-macroexpand (exp &optional env) - "Special macro expander used inside `cl-symbol-macrolet'. -This function replaces `macroexpand' during macro expansion -of `cl-symbol-macrolet', and does the same thing as `macroexpand' -except that it additionally expands symbol macros." +(defun cl--sm-macroexpand (orig-fun exp &optional env) + "Special macro expander advice used inside `cl-symbol-macrolet'. +This function extends `macroexpand' during macro expansion +of `cl-symbol-macrolet' to additionally expand symbol macros." (let ((macroexpand-all-environment env) (venv (alist-get :cl-symbol-macros env))) (while (progn - (setq exp (funcall cl--old-macroexpand exp env)) + (setq exp (funcall orig-fun exp env)) (pcase exp ((pred symbolp) ;; Perform symbol-macro expansion. (let ((symval (assq exp venv))) (when symval (setq exp (cadr symval))))) - (`(setq . ,_) + (`(setq . ,args) ;; Convert setq to setf if required by symbol-macro expansion. - (let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f env)) - (cdr exp))) - (p args)) - (while (and p (symbolp (car p))) (setq p (cddr p))) - (if p (setq exp (cons 'setf args)) - (setq exp (cons 'setq args)) - ;; Don't loop further. - nil))) - (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare)) - ;; CL's symbol-macrolet treats re-bindings as candidates for - ;; expansion (turning the let into a letf if needed), contrary to - ;; Common-Lisp where such re-bindings hide the symbol-macro. - (let ((letf nil) (found nil) (nbs ())) - (dolist (binding bindings) - (let* ((var (if (symbolp binding) binding (car binding))) - (sm (assq var venv))) - (push (if (not (cdr sm)) - binding - (let ((nexp (cadr sm))) - (setq found t) - (unless (symbolp nexp) (setq letf t)) - (cons nexp (cdr-safe binding)))) - nbs))) - (when found - (setq exp `(,(if letf - (if (eq (car exp) 'let) 'cl-letf 'cl-letf*) - (car exp)) - ,(nreverse nbs) - ,@body))))) - ;; FIXME: The behavior of CL made sense in a dynamically scoped - ;; language, but for lexical scoping, Common-Lisp's behavior might - ;; make more sense (and indeed, CL behaves like Common-Lisp w.r.t - ;; lexical-let), so maybe we should adjust the behavior based on - ;; the use of lexical-binding. + (let ((convert nil) + (rargs nil)) + (while args + (let ((place (pop args))) + ;; Here, we know `place' should be a symbol. + (while + (let ((symval (assq place venv))) + (when symval + (setq place (cadr symval)) + (if (symbolp place) + t ;Repeat. + (setq convert t) + nil)))) + (push place rargs) + (push (pop args) rargs))) + (setq exp (cons (if convert 'setf 'setq) + (nreverse rargs))) + convert)) + ;; CL's symbol-macrolet used to treat re-bindings as candidates for + ;; expansion (turning the let into a letf if needed), contrary to + ;; Common-Lisp where such re-bindings hide the symbol-macro. + ;; Not sure if there actually is code out there which depends + ;; on this behavior (haven't found any yet). + ;; Such code should explicitly use `cl-letf' instead, I think. + ;; ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare)) - ;; (let ((nbs ()) (found nil)) + ;; (let ((letf nil) (found nil) (nbs ())) ;; (dolist (binding bindings) ;; (let* ((var (if (symbolp binding) binding (car binding))) - ;; (name (symbol-name var)) - ;; (val (and found (consp binding) (eq 'let* (car exp)) - ;; (list (macroexpand-all (cadr binding) - ;; env))))) - ;; (push (if (assq name env) - ;; ;; This binding should hide its symbol-macro, - ;; ;; but given the way macroexpand-all works, we - ;; ;; can't prevent application of `env' to the - ;; ;; sub-expressions, so we need to α-rename this - ;; ;; variable instead. - ;; (let ((nvar (make-symbol - ;; (copy-sequence name)))) - ;; (setq found t) - ;; (push (list name nvar) env) - ;; (cons nvar (or val (cdr-safe binding)))) - ;; (if val (cons var val) binding)) + ;; (sm (assq var venv))) + ;; (push (if (not (cdr sm)) + ;; binding + ;; (let ((nexp (cadr sm))) + ;; (setq found t) + ;; (unless (symbolp nexp) (setq letf t)) + ;; (cons nexp (cdr-safe binding)))) ;; nbs))) ;; (when found - ;; (setq exp `(,(car exp) + ;; (setq exp `(,(if letf + ;; (if (eq (car exp) 'let) 'cl-letf 'cl-letf*) + ;; (car exp)) ;; ,(nreverse nbs) - ;; ,@(macroexp-unprogn - ;; (macroexpand-all (macroexp-progn body) - ;; env))))) - ;; nil)) + ;; ,@body))))) + ;; + ;; We implement the Common-Lisp behavior, instead (see bug#26073): + ;; The behavior of CL made sense in a dynamically scoped + ;; language, but nowadays, lexical scoping semantics is more often + ;; expected. + (`(,(or 'let 'let*) . ,(or `(,bindings . ,body) dontcare)) + (let ((nbs ()) (found nil)) + (dolist (binding bindings) + (let* ((var (if (symbolp binding) binding (car binding))) + (val (and found (consp binding) (eq 'let* (car exp)) + (list (macroexpand-all (cadr binding) + env))))) + (push (if (assq var venv) + ;; This binding should hide "its" surrounding + ;; symbol-macro, but given the way macroexpand-all + ;; works (i.e. the `env' we receive as input will + ;; be (re)applied to the code we return), we can't + ;; prevent application of `env' to the + ;; sub-expressions, so we need to α-rename this + ;; variable instead. + (let ((nvar (make-symbol (symbol-name var)))) + (setq found t) + (push (list var nvar) venv) + (push (cons :cl-symbol-macros venv) env) + (cons nvar (or val (cdr-safe binding)))) + (if val (cons var val) binding)) + nbs))) + (when found + (setq exp `(,(car exp) + ,(nreverse nbs) + ,@(macroexp-unprogn + (macroexpand-all (macroexp-progn body) + env))))) + nil)) + ;; Do the same as for `let' but for variables introduced + ;; via other means, such as `lambda' and `condition-case'. + (`(function (lambda ,args . ,body)) + (let ((nargs ()) (found nil)) + (dolist (var args) + (push (cond + ((memq var '(&optional &rest)) var) + ((assq var venv) + (let ((nvar (make-symbol (symbol-name var)))) + (setq found t) + (push (list var nvar) venv) + (push (cons :cl-symbol-macros venv) env) + nvar)) + (t var)) + nargs)) + (when found + (setq exp `(function + (lambda ,(nreverse nargs) + . ,(mapcar (lambda (exp) + (macroexpand-all exp env)) + body))))) + nil)) + ((and `(condition-case ,var ,exp . ,clauses) + (guard (assq var venv))) + (let ((nvar (make-symbol (symbol-name var)))) + (push (list var nvar) venv) + (push (cons :cl-symbol-macros venv) env) + (setq exp + `(condition-case ,nvar ,(macroexpand-all exp env) + . ,(mapcar + (lambda (clause) + `(,(car clause) + . ,(mapcar (lambda (exp) + (macroexpand-all exp env)) + (cdr clause)))) + clauses))) + nil)) ))) exp)) @@ -2197,16 +2275,18 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). \(fn ((NAME EXPANSION) ...) FORM...)" (declare (indent 1) (debug ((&rest (symbolp sexp)) cl-declarations body))) - (let ((previous-macroexpand (symbol-function 'macroexpand)) - (malformed-bindings nil)) + (let ((malformed-bindings nil) + (advised (advice-member-p #'cl--sm-macroexpand 'macroexpand))) (dolist (binding bindings) (unless (and (consp binding) (symbolp (car binding)) (consp (cdr binding)) (null (cddr binding))) (push binding malformed-bindings))) (unwind-protect (progn - (fset 'macroexpand #'cl--sm-macroexpand) - (let* ((venv (cdr (assq :cl-symbol-macros macroexpand-all-environment))) + (unless advised + (advice-add 'macroexpand :around #'cl--sm-macroexpand)) + (let* ((venv (cdr (assq :cl-symbol-macros + macroexpand-all-environment))) (expansion (macroexpand-all (macroexp-progn body) (cons (cons :cl-symbol-macros @@ -2218,7 +2298,8 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (nreverse malformed-bindings)) expansion) expansion))) - (fset 'macroexpand previous-macroexpand)))) + (unless advised + (advice-remove 'macroexpand #'cl--sm-macroexpand))))) ;;; Multiple values. @@ -2469,10 +2550,11 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x)) (funcall setter vold))) binds)))) - (let ((binding (car bindings))) - (gv-letplace (getter setter) (car binding) + (let* ((binding (car bindings)) + (place (macroexpand (car binding) macroexpand-all-environment))) + (gv-letplace (getter setter) place (macroexp-let2 nil vnew (cadr binding) - (if (symbolp (car binding)) + (if (symbolp place) ;; Special-case for simple variables. (cl--letf (cdr bindings) (cons `(,getter ,(if (cdr binding) vnew getter)) @@ -2499,7 +2581,9 @@ the PLACE is not modified before executing BODY. (declare (indent 1) (debug ((&rest [&or (symbolp form) (gate gv-place &optional form)]) body))) - (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings))) + (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings)) + (not (assq (caar bindings) + (alist-get :cl-symbol-macros macroexpand-all-environment)))) `(let ,bindings ,@body) (cl--letf bindings () () body))) @@ -2516,8 +2600,9 @@ rather than all at the end (i.e. like `let*' rather than like `let')." ;;;###autoload (defmacro cl-callf (func place &rest args) "Set PLACE to (FUNC PLACE ARGS...). -FUNC should be an unquoted function name. PLACE may be a symbol, -or any generalized variable allowed by `setf'." +FUNC should be an unquoted function name or a lambda expression. +PLACE may be a symbol, or any generalized variable allowed by +`setf'." (declare (indent 2) (debug (cl-function place &rest form))) (gv-letplace (getter setter) place (let* ((rargs (cons getter args))) @@ -2616,6 +2701,9 @@ The function's arguments should be treated as immutable. ;; for bootstrapping reasons. (defvar cl--struct-default-parent nil) +(defvar cl--struct-inline t + "If non-nil, `cl-defstruct' will define inlinable functions.") + ;;;###autoload (defmacro cl-defstruct (struct &rest descs) "Define a struct type. @@ -2626,16 +2714,20 @@ You can use the accessors to set the corresponding slots, via `setf'. NAME may instead take the form (NAME OPTIONS...), where each OPTION is either a single keyword or (KEYWORD VALUE) where -KEYWORD can be one of :conc-name, :constructor, :copier, :predicate, -:type, :named, :initial-offset, :print-function, or :include. +KEYWORD can be one of `:conc-name', `:constructor', `:copier', +`:predicate', `:type', `:named', `:initial-offset', +`:print-function', `:noinline', or `:include'. See Info +node `(cl)Structures' for the description of the options. Each SLOT may instead take the form (SNAME SDEFAULT SOPTIONS...), where SDEFAULT is the default value of that slot and SOPTIONS are keyword-value pairs for that slot. -Currently, only one keyword is supported, `:read-only'. If this has a -non-nil value, that slot cannot be set via `setf'. +Supported keywords for slots are: +- `:read-only': If this has a non-nil value, that slot cannot be set via `setf'. +- `:documentation': this is a docstring describing the slot. +- `:type': the type of the field; currently unused. -\(fn NAME SLOTS...)" +\(fn NAME &optional DOCSTRING &rest SLOTS)" (declare (doc-string 2) (indent 1) (debug (&define ;Makes top-level form not be wrapped. @@ -2686,9 +2778,14 @@ non-nil value, that slot cannot be set via `setf'. (include-name nil) (type nil) ;nil here means not specified explicitly. (named nil) + (cldefsym (if cl--struct-inline 'cl-defsubst 'cl-defun)) + (defsym (if cl--struct-inline 'cl-defsubst 'defun)) (forms nil) (docstring (if (stringp (car descs)) (pop descs))) pred-form pred-check) + ;; Can't use `cl-check-type' yet. + (unless (cl--struct-name-p name) + (signal 'wrong-type-argument (list 'cl-struct-name-p name 'name))) (setq descs (cons '(cl-tag-slot) (mapcar (function (lambda (x) (if (consp x) x (list x)))) descs))) @@ -2729,6 +2826,8 @@ non-nil value, that slot cannot be set via `setf'. (error "Invalid :type specifier: %s" type))) ((eq opt :named) (setq named t)) + ((eq opt :noinline) + (setq defsym 'defun) (setq cldefsym 'cl-defun)) ((eq opt :initial-offset) (setq descs (nconc (make-list (car args) '(cl-skip-slot)) descs))) @@ -2787,7 +2886,7 @@ non-nil value, that slot cannot be set via `setf'. (cons 'and (cl-cdddr pred-form)) `(,predicate cl-x)))) (when pred-form - (push `(cl-defsubst ,predicate (cl-x) + (push `(,defsym ,predicate (cl-x) (declare (side-effect-free error-free)) ,(if (eq (car pred-form) 'and) (append pred-form '(t)) @@ -2805,14 +2904,17 @@ non-nil value, that slot cannot be set via `setf'. defaults)) (if (assq slot descp) (error "Duplicate slots named %s in %s" slot name)) - (let ((accessor (intern (format "%s%s" conc-name slot)))) + (let ((accessor (intern (format "%s%s" conc-name slot))) + (default-value (pop desc)) + (doc (plist-get desc :documentation))) (push slot slots) - (push (pop desc) defaults) + (push default-value defaults) ;; The arg "cl-x" is referenced by name in eg pred-form ;; and pred-check, so changing it is not straightforward. - (push `(cl-defsubst ,accessor (cl-x) - ,(format "Access slot \"%s\" of `%s' struct CL-X." - slot struct) + (push `(,defsym ,accessor (cl-x) + ,(format "Access slot \"%s\" of `%s' struct CL-X.%s" + slot name + (if doc (concat "\n" doc) "")) (declare (side-effect-free t)) ,@(and pred-check (list `(or ,pred-check @@ -2881,7 +2983,7 @@ non-nil value, that slot cannot be set via `setf'. (let* ((anames (cl--arglist-args args)) (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) slots defaults))) - (push `(cl-defsubst ,cname + (push `(,cldefsym ,cname (&cl-defs (nil ,@descs) ,@args) ,(if (stringp doc) doc (format "Constructor for objects of type `%s'." name)) @@ -2947,7 +3049,7 @@ the form NAME which is a shorthand for (NAME NAME)." (defun cl--defstruct-predicate (type) (let ((cons (assq (cl-struct-sequence-type type) - `((list . consp) + '((list . consp) (vector . vectorp) (nil . recordp))))) (if cons @@ -3281,7 +3383,7 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (put ',name 'cl-deftype-handler (cl-function (lambda (&cl-defs ('*) ,@arglist) ,@body))))) -(cl-deftype extended-char () `(and character (not base-char))) +(cl-deftype extended-char () '(and character (not base-char))) ;;; Additional functions that we can now define because we've defined ;;; `cl-defsubst' and `cl-typep'. @@ -3305,7 +3407,6 @@ STRUCT and SLOT-NAME are symbols. INST is a structure instance." (run-hooks 'cl-macs-load-hook) ;; Local variables: -;; byte-compile-dynamic: t ;; generated-autoload-file: "cl-loaddefs.el" ;; End: diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index e3de8e16ae2..4bd22facc2f 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -50,6 +50,39 @@ (apply #'error string (append sargs args)) (signal 'cl-assertion-failed `(,form ,@sargs))))) +(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) + (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) + (module-function function atom) + (buffer atom) (char-table array sequence atom) + (bool-vector array sequence atom) + (frame atom) (hash-table atom) (terminal atom) + (thread atom) (mutex atom) (condvar atom) + (font-spec atom) (font-entity atom) (font-object atom) + (vector array sequence atom) + (user-ptr atom) + ;; Plus, really hand made: + (null symbol list sequence atom)) + "Alist of supertypes. +Each element has the form (TYPE . SUPERTYPES) where TYPE is one of +the symbols returned by `type-of', and SUPERTYPES is the list of its +supertypes from the most specific to least specific.") + +(defconst cl--all-builtin-types + (delete-dups (copy-sequence (apply #'append cl--typeof-types)))) + +(defun cl--struct-name-p (name) + "Return t if NAME is a valid structure name for `cl-defstruct'." + (and name (symbolp name) (not (keywordp name)) + (not (memq name cl--all-builtin-types)))) + ;; When we load this (compiled) file during pre-loading, the cl--struct-class ;; code below will need to access the `cl-struct' info, since it's considered ;; already as its parent (because `cl-struct' was defined while the file was @@ -61,7 +94,7 @@ (fset 'cl--make-slot-desc ;; To break circularity, we pre-define the slot constructor by hand. ;; It's redefined a bit further down as part of the cl-defstruct of - ;; cl--slot-descriptor. + ;; cl-slot-descriptor. ;; BEWARE: Obviously, it's important to keep the two in sync! (lambda (name &optional initform type props) (record 'cl-slot-descriptor @@ -110,6 +143,7 @@ ;;;###autoload (defun cl-struct-define (name docstring parent type named slots children-sym tag print) + (cl-check-type name cl--struct-name) (unless type ;; Legacy defstruct, using tagged vectors. Enable backward compatibility. (cl-old-struct-compat-mode 1)) @@ -194,7 +228,7 @@ (name nil :type symbol) ;The type name. (docstring nil :type string) (parents nil :type (list-of cl--class)) ;The included struct. - (slots nil :type (vector cl--slot-descriptor)) + (slots nil :type (vector cl-slot-descriptor)) (index-table nil :type hash-table) (tag nil :type symbol) ;Placed in cl-tag-slot. Holds the struct-class object. (type nil :type (memq (vector list))) diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 51437de0d4f..5fe3dd1b912 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -55,10 +55,19 @@ call other entry points instead, such as `cl-prin1'." ;; we should only use it for objects which don't have nesting. (prin1 object stream)) +(cl-defgeneric cl-print-object-contents (_object _start _stream) + "Dispatcher to print the contents of OBJECT on STREAM. +Print the contents starting with the item at START, without +delimiters." + ;; Every cl-print-object method which can print an ellipsis should + ;; have a matching cl-print-object-contents method to expand an + ;; ellipsis. + (error "Missing cl-print-object-contents method")) + (cl-defmethod cl-print-object ((object cons) stream) (if (and cl-print--depth (natnump print-level) (> cl-print--depth print-level)) - (princ "..." stream) + (cl-print-insert-ellipsis object 0 stream) (let ((car (pop object)) (count 1)) (if (and print-quoted @@ -84,23 +93,60 @@ call other entry points instead, such as `cl-prin1'." (princ " " stream) (if (or (not (natnump print-length)) (> print-length count)) (cl-print-object (pop object) stream) - (princ "..." stream) + (cl-print-insert-ellipsis object print-length stream) (setq object nil)) (cl-incf count)) (when object (princ " . " stream) (cl-print-object object stream)) (princ ")" stream))))) +(cl-defmethod cl-print-object-contents ((object cons) _start stream) + (let ((count 0)) + (while (and (consp object) + (not (cond + (cl-print--number-table + (numberp (gethash object cl-print--number-table))) + ((memq object cl-print--currently-printing)) + (t (push object cl-print--currently-printing) + nil)))) + (unless (zerop count) + (princ " " stream)) + (if (or (not (natnump print-length)) (> print-length count)) + (cl-print-object (pop object) stream) + (cl-print-insert-ellipsis object print-length stream) + (setq object nil)) + (cl-incf count)) + (when object + (princ " . " stream) (cl-print-object object stream)))) + (cl-defmethod cl-print-object ((object vector) stream) - (princ "[" stream) - (let ((count (length object))) - (dotimes (i (if (natnump print-length) - (min print-length count) count)) - (unless (zerop i) (princ " " stream)) - (cl-print-object (aref object i) stream)) - (when (and (natnump print-length) (< print-length count)) - (princ " ..." stream))) - (princ "]" stream)) + (if (and cl-print--depth (natnump print-level) + (> cl-print--depth print-level)) + (cl-print-insert-ellipsis object 0 stream) + (princ "[" stream) + (let* ((len (length object)) + (limit (if (natnump print-length) + (min print-length len) len))) + (dotimes (i limit) + (unless (zerop i) (princ " " stream)) + (cl-print-object (aref object i) stream)) + (when (< limit len) + (princ " " stream) + (cl-print-insert-ellipsis object limit stream))) + (princ "]" stream))) + +(cl-defmethod cl-print-object-contents ((object vector) start stream) + (let* ((len (length object)) + (limit (if (natnump print-length) + (min (+ start print-length) len) len)) + (i start)) + (while (< i limit) + (unless (= i start) (princ " " stream)) + (cl-print-object (aref object i) stream) + (cl-incf i)) + (when (< limit len) + (princ " " stream) + (cl-print-insert-ellipsis object limit stream)))) (cl-defmethod cl-print-object ((object hash-table) stream) (princ "#<hash-table " stream) @@ -109,7 +155,7 @@ call other entry points instead, such as `cl-prin1'." (princ (hash-table-count object) stream) (princ "/" stream) (princ (hash-table-size object) stream) - (princ (format " 0x%x" (sxhash object)) stream) + (princ (format " %#x" (sxhash object)) stream) (princ ">" stream)) (define-button-type 'help-byte-code @@ -166,7 +212,7 @@ into a button whose action shows the function's disassembly.") (let ((button-start (and cl-print-compiled-button (bufferp stream) (with-current-buffer stream (point))))) - (princ (format "#<bytecode 0x%x>" (sxhash object)) stream) + (princ (format "#<bytecode %#x>" (sxhash object)) stream) (when (eq cl-print-compiled 'static) (princ " " stream) (cl-print-object (aref object 2) stream)) @@ -199,21 +245,135 @@ into a button whose action shows the function's disassembly.") (princ ")" stream))) (cl-defmethod cl-print-object ((object cl-structure-object) stream) - (princ "#s(" stream) + (if (and cl-print--depth (natnump print-level) + (> cl-print--depth print-level)) + (cl-print-insert-ellipsis object 0 stream) + (princ "#s(" stream) + (let* ((class (cl-find-class (type-of object))) + (slots (cl--struct-class-slots class)) + (len (length slots)) + (limit (if (natnump print-length) + (min print-length len) len))) + (princ (cl--struct-class-name class) stream) + (dotimes (i limit) + (let ((slot (aref slots i))) + (princ " :" stream) + (princ (cl--slot-descriptor-name slot) stream) + (princ " " stream) + (cl-print-object (aref object (1+ i)) stream))) + (when (< limit len) + (princ " " stream) + (cl-print-insert-ellipsis object limit stream))) + (princ ")" stream))) + +(cl-defmethod cl-print-object-contents ((object cl-structure-object) start stream) (let* ((class (cl-find-class (type-of object))) (slots (cl--struct-class-slots class)) - (count (length slots))) - (princ (cl--struct-class-name class) stream) - (dotimes (i (if (natnump print-length) - (min print-length count) count)) + (len (length slots)) + (limit (if (natnump print-length) + (min (+ start print-length) len) len)) + (i start)) + (while (< i limit) (let ((slot (aref slots i))) - (princ " :" stream) + (unless (= i start) (princ " " stream)) + (princ ":" stream) (princ (cl--slot-descriptor-name slot) stream) (princ " " stream) - (cl-print-object (aref object (1+ i)) stream))) - (when (and (natnump print-length) (< print-length count)) - (princ " ..." stream))) - (princ ")" stream)) + (cl-print-object (aref object (1+ i)) stream)) + (cl-incf i)) + (when (< limit len) + (princ " " stream) + (cl-print-insert-ellipsis object limit stream)))) + +(cl-defmethod cl-print-object ((object string) stream) + (unless stream (setq stream standard-output)) + (let* ((has-properties (or (text-properties-at 0 object) + (next-property-change 0 object))) + (len (length object)) + (limit (if (natnump print-length) (min print-length len) len))) + (if (and has-properties + cl-print--depth + (natnump print-level) + (> cl-print--depth print-level)) + (cl-print-insert-ellipsis object 0 stream) + ;; Print all or part of the string + (when has-properties + (princ "#(" stream)) + (if (= limit len) + (prin1 (if has-properties (substring-no-properties object) object) + stream) + (let ((part (concat (substring-no-properties object 0 limit) "..."))) + (prin1 part stream) + (when (bufferp stream) + (with-current-buffer stream + (cl-print-propertize-ellipsis object limit + (- (point) 4) + (- (point) 1) stream))))) + ;; Print the property list. + (when has-properties + (let* ((interval-limit (and (natnump print-length) + (max 1 (/ print-length 3)))) + (interval-count 0) + (start-pos (if (text-properties-at 0 object) + 0 (next-property-change 0 object))) + (end-pos (next-property-change start-pos object len))) + (while (and (or (null interval-limit) + (< interval-count interval-limit)) + (< start-pos len)) + (let ((props (text-properties-at start-pos object))) + (when props + (princ " " stream) (princ start-pos stream) + (princ " " stream) (princ end-pos stream) + (princ " " stream) (cl-print-object props stream) + (cl-incf interval-count)) + (setq start-pos end-pos + end-pos (next-property-change start-pos object len)))) + (when (< start-pos len) + (princ " " stream) + (cl-print-insert-ellipsis object (list start-pos) stream))) + (princ ")" stream))))) + +(cl-defmethod cl-print-object-contents ((object string) start stream) + ;; If START is an integer, it is an index into the string, and the + ;; ellipsis that needs to be expanded is part of the string. If + ;; START is a cons, its car is an index into the string, and the + ;; ellipsis that needs to be expanded is in the property list. + (let* ((len (length object))) + (if (atom start) + ;; Print part of the string. + (let* ((limit (if (natnump print-length) + (min (+ start print-length) len) len)) + (substr (substring-no-properties object start limit)) + (printed (prin1-to-string substr)) + (trimmed (substring printed 1 (1- (length printed))))) + (princ trimmed) + (when (< limit len) + (cl-print-insert-ellipsis object limit stream))) + + ;; Print part of the property list. + (let* ((first t) + (interval-limit (and (natnump print-length) + (max 1 (/ print-length 3)))) + (interval-count 0) + (start-pos (car start)) + (end-pos (next-property-change start-pos object len))) + (while (and (or (null interval-limit) + (< interval-count interval-limit)) + (< start-pos len)) + (let ((props (text-properties-at start-pos object))) + (when props + (if first + (setq first nil) + (princ " " stream)) + (princ start-pos stream) + (princ " " stream) (princ end-pos stream) + (princ " " stream) (cl-print-object props stream) + (cl-incf interval-count)) + (setq start-pos end-pos + end-pos (next-property-change start-pos object len)))) + (when (< start-pos len) + (princ " " stream) + (cl-print-insert-ellipsis object (list start-pos) stream)))))) ;;; Circularity and sharing. @@ -275,8 +435,17 @@ into a button whose action shows the function's disassembly.") (push cdr stack) (push car stack)) ((pred stringp) - ;; We presumably won't print its text-properties. - nil) + (let* ((len (length object)) + (start (if (text-properties-at 0 object) + 0 (next-property-change 0 object))) + (end (and start + (next-property-change start object len)))) + (while (and start (< start len)) + (let ((props (text-properties-at start object))) + (when props + (push props stack)) + (setq start end + end (next-property-change start object len)))))) ((or (pred arrayp) (pred byte-code-function-p)) ;; FIXME: Inefficient for char-tables! (dotimes (i (length object)) @@ -291,6 +460,48 @@ into a button whose action shows the function's disassembly.") (cl-print--find-sharing object print-number-table))) print-number-table)) +(defun cl-print-insert-ellipsis (object start stream) + "Print \"...\" to STREAM with the `cl-print-ellipsis' text property. +Save state in the text property in order to print the elided part +of OBJECT later. START should be 0 if the whole OBJECT is being +elided, otherwise it should be an index or other pointer into the +internals of OBJECT which can be passed to +`cl-print-object-contents' at a future time." + (unless stream (setq stream standard-output)) + (let ((ellipsis-start (and (bufferp stream) + (with-current-buffer stream (point))))) + (princ "..." stream) + (when ellipsis-start + (with-current-buffer stream + (cl-print-propertize-ellipsis object start ellipsis-start (point) + stream))))) + +(defun cl-print-propertize-ellipsis (object start beg end stream) + "Add the `cl-print-ellipsis' property between BEG and END. +STREAM should be a buffer. OBJECT and START are as described in +`cl-print-insert-ellipsis'." + (let ((value (list object start cl-print--number-table + cl-print--currently-printing))) + (with-current-buffer stream + (put-text-property beg end 'cl-print-ellipsis value stream)))) + +;;;###autoload +(defun cl-print-expand-ellipsis (value stream) + "Print the expansion of an ellipsis to STREAM. +VALUE should be the value of the `cl-print-ellipsis' text property +which was attached to the ellipsis by `cl-prin1'." + (let ((cl-print--depth 1) + (object (nth 0 value)) + (start (nth 1 value)) + (cl-print--number-table (nth 2 value)) + (print-number-table (nth 2 value)) + (cl-print--currently-printing (nth 3 value))) + (when (eq object (car cl-print--currently-printing)) + (pop cl-print--currently-printing)) + (if (equal start 0) + (cl-print-object object stream) + (cl-print-object-contents object start stream)))) + ;;;###autoload (defun cl-prin1 (object &optional stream) "Print OBJECT on STREAM according to its type. @@ -298,12 +509,13 @@ Output is further controlled by the variables `cl-print-readably', `cl-print-compiled', along with output variables for the standard printing functions. See Info node `(elisp)Output Variables'." - (cond - (cl-print-readably (prin1 object stream)) - ((not print-circle) (cl-print-object object stream)) - (t - (let ((cl-print--number-table (cl-print--preprocess object))) - (cl-print-object object stream))))) + (if cl-print-readably + (prin1 object stream) + (with-demoted-errors "cl-prin1: %S" + (if (not print-circle) + (cl-print-object object stream) + (let ((cl-print--number-table (cl-print--preprocess object))) + (cl-print-object object stream)))))) ;;;###autoload (defun cl-prin1-to-string (object) @@ -312,5 +524,45 @@ node `(elisp)Output Variables'." (cl-prin1 object (current-buffer)) (buffer-string))) +;;;###autoload +(defun cl-print-to-string-with-limit (print-function value limit) + "Return a string containing a printed representation of VALUE. +Attempt to get the length of the returned string under LIMIT +characters with appropriate settings of `print-level' and +`print-length.' Use PRINT-FUNCTION to print, which should take +the arguments VALUE and STREAM and which should respect +`print-length' and `print-level'. LIMIT may be nil or zero in +which case PRINT-FUNCTION will be called with `print-level' and +`print-length' bound to nil. + +Use this function with `cl-prin1' to print an object, +abbreviating it with ellipses to fit within a size limit. Use +this function with `cl-prin1-expand-ellipsis' to expand an +ellipsis, abbreviating the expansion to stay within a size +limit." + (setq limit (and (natnump limit) + (not (zerop limit)) + limit)) + ;; Since this is used by the debugger when stack space may be + ;; limited, if you increase print-level here, add more depth in + ;; call_debugger (bug#31919). + (let* ((print-length (when limit (min limit 50))) + (print-level (when limit (min 8 (truncate (log limit))))) + (delta (when limit + (max 1 (truncate (/ print-length print-level)))))) + (with-temp-buffer + (catch 'done + (while t + (erase-buffer) + (funcall print-function value (current-buffer)) + ;; Stop when either print-level is too low or the value is + ;; successfully printed in the space allowed. + (when (or (not limit) + (< (- (point-max) (point-min)) limit) + (= print-level 2)) + (throw 'done (buffer-string))) + (cl-decf print-level) + (cl-decf print-length delta)))))) + (provide 'cl-print) ;;; cl-print.el ends here diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 31ad8111858..a15c994bc1a 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -113,6 +113,13 @@ (defvar cl-key) ;;;###autoload +(defun cl-endp (x) + "Return true if X is the empty list; false if it is a cons. +Signal an error if X is not a list." + (cl-check-type x list) + (null x)) + +;;;###autoload (defun cl-reduce (cl-func cl-seq &rest cl-keys) "Reduce two-argument FUNCTION across SEQ. \nKeywords supported: :start :end :from-end :initial-value :key @@ -696,9 +703,7 @@ Return the sublist of LIST whose car is ITEM. (while (and cl-list (not (cl--check-test cl-item (car cl-list)))) (setq cl-list (cdr cl-list))) cl-list) - (if (and (numberp cl-item) (not (integerp cl-item))) - (member cl-item cl-list) - (memq cl-item cl-list)))) + (memql cl-item cl-list))) (autoload 'cl--compiler-macro-member "cl-macs") ;;;###autoload @@ -737,7 +742,7 @@ Return the sublist of LIST whose car matches. (not (cl--check-test cl-item (car (car cl-alist)))))) (setq cl-alist (cdr cl-alist))) (and cl-alist (car cl-alist))) - (if (and (numberp cl-item) (not (integerp cl-item))) + (if (and (numberp cl-item) (not (fixnump cl-item))) (assoc cl-item cl-alist) (assq cl-item cl-alist)))) (autoload 'cl--compiler-macro-assoc "cl-macs") @@ -1033,7 +1038,6 @@ Atoms are compared by `eql'; cons cells are compared recursively. (run-hooks 'cl-seq-load-hook) ;; Local variables: -;; byte-compile-dynamic: t ;; generated-autoload-file: "cl-loaddefs.el" ;; End: diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index 58cda67e2ba..be335838e33 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -52,7 +52,7 @@ This is useful for ChangeLogs." (defcustom copyright-regexp "\\(©\\|@copyright{}\\|[Cc]opyright\\s *:?\\s *\\(?:(C)\\)?\ \\|[Cc]opyright\\s *:?\\s *©\\)\ -\\s *\\(?:[^0-9\n]*\\s *\\)?\ +\\s *[^0-9\n]*\\s *\ \\([1-9]\\([-0-9, ';/*%#\n\t]\\|\\s<\\|\\s>\\)*[0-9]+\\)" "What your copyright notice looks like. The second \\( \\) construct must match the years." @@ -186,9 +186,10 @@ skips to the end of all the years." (substring copyright-current-year -2)) (if (or noquery (save-window-excursion - (switch-to-buffer (current-buffer)) - ;; Fixes some point-moving oddness (bug#2209). + ;; switch-to-buffer might move point when + ;; switch-to-buffer-preserve-window-point is non-nil. (save-excursion + (switch-to-buffer (current-buffer)) (y-or-n-p (if replace (concat "Replace copyright year(s) by " copyright-current-year "? ") diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index cfae02817f4..40567e141d3 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -263,7 +263,8 @@ with empty strings removed." (input (read-from-minibuffer prompt initial-input map nil hist def inherit-input-method))) - (and def (string-equal input "") (setq input 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))) (remove-hook 'choose-completion-string-functions diff --git a/lisp/emacs-lisp/cursor-sensor.el b/lisp/emacs-lisp/cursor-sensor.el index a21d78998ac..66b940f7fb3 100644 --- a/lisp/emacs-lisp/cursor-sensor.el +++ b/lisp/emacs-lisp/cursor-sensor.el @@ -160,7 +160,7 @@ By convention, this is a list of symbols where each symbol stands for the (setcdr old nil)) (if (or (and (null new) (null (cdr old))) (and (eq new (cdr old)) - (eq (next-single-property-change + (eq (next-single-char-property-change start 'cursor-sensor-functions nil end) end))) ;; Clearly nothing to do. @@ -172,7 +172,7 @@ By convention, this is a list of symbols where each symbol stands for the (let ((pos start) (missing nil)) (while (< pos end) - (setq pos (next-single-property-change + (setq pos (next-single-char-property-change pos 'cursor-sensor-functions nil end)) (unless (memq f (get-char-property diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index abfbfa81511..8989aa07196 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -27,6 +27,8 @@ ;;; Code: +(require 'cl-lib) +(require 'backtrace) (require 'button) (defgroup debugger nil @@ -132,6 +134,25 @@ where CAUSE can be: - exit: called because of exit of a flagged function. - error: called because of `debug-on-error'.") +(cl-defstruct (debugger--buffer-state + (:constructor debugger--save-buffer-state + (&aux (mode major-mode) + (header backtrace-insert-header-function) + (frames backtrace-frames) + (content (buffer-string)) + (pos (point))))) + mode header frames content pos) + +(defun debugger--restore-buffer-state (state) + (unless (derived-mode-p (debugger--buffer-state-mode state)) + (funcall (debugger--buffer-state-mode state))) + (setq backtrace-insert-header-function (debugger--buffer-state-header state) + backtrace-frames (debugger--buffer-state-frames state)) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (debugger--buffer-state-content state))) + (goto-char (debugger--buffer-state-pos state))) + ;;;###autoload (setq debugger 'debug) ;;;###autoload @@ -144,16 +165,36 @@ You may call with no args, or you may pass nil as the first arg and any other args you like. In that case, the list of args after the first will be printed into the backtrace buffer." (interactive) - (if inhibit-redisplay - ;; Don't really try to enter debugger within an eval from redisplay. - debugger-value + (cond + (inhibit-redisplay + ;; Don't really try to enter debugger within an eval from redisplay. + debugger-value) + ((and (eq t (framep (selected-frame))) + (equal "initial_terminal" (terminal-name))) + ;; We're in the initial-frame (where `message' just outputs to stdout) so + ;; there's no tty or GUI frame to display the backtrace and interact with + ;; it: just dump a backtrace to stdout. + ;; This happens for example while handling an error in code from + ;; early-init.el with --debug-init. + (message "Error: %S" args) + (let ((print-escape-newlines t) + (print-escape-control-characters t) + (print-level 8) + (print-length 50) + (skip t)) ;Skip the first frame (i.e. the `debug' frame)! + (mapbacktrace (lambda (_evald func args _flags) + (if skip + (setq skip nil) + (message " %S" (cons func args)))) + 'debug))) + (t (unless noninteractive (message "Entering debugger...")) (let (debugger-value (debugger-previous-state (if (get-buffer "*Backtrace*") (with-current-buffer (get-buffer "*Backtrace*") - (list major-mode (buffer-string))))) + (debugger--save-buffer-state)))) (debugger-args args) (debugger-buffer (get-buffer-create "*Backtrace*")) (debugger-old-buffer (current-buffer)) @@ -195,14 +236,37 @@ first will be printed into the backtrace buffer." ;; Place an extra debug-on-exit for macro's. (when (eq 'lambda (car-safe (cadr (backtrace-frame 4)))) (backtrace-debug 5 t))) + (with-current-buffer debugger-buffer + (unless (derived-mode-p 'debugger-mode) + (debugger-mode)) + (debugger-setup-buffer debugger-args) + (when noninteractive + ;; If the backtrace is long, save the beginning + ;; and the end, but discard the middle. + (when (> (count-lines (point-min) (point-max)) + debugger-batch-max-lines) + (goto-char (point-min)) + (forward-line (/ 2 debugger-batch-max-lines)) + (let ((middlestart (point))) + (goto-char (point-max)) + (forward-line (- (/ 2 debugger-batch-max-lines) + debugger-batch-max-lines)) + (delete-region middlestart (point))) + (insert "...\n")) + (goto-char (point-min)) + (message "%s" (buffer-string)) + (kill-emacs -1))) (pop-to-buffer debugger-buffer `((display-buffer-reuse-window - display-buffer-in-previous-window) - . (,(when (and (window-live-p debugger-previous-window) - (frame-visible-p - (window-frame debugger-previous-window))) - `(previous-window . ,debugger-previous-window))))) + display-buffer-in-previous-window + display-buffer-below-selected) + . ((window-min-height . 10) + (window-height . fit-window-to-buffer) + ,@(when (and (window-live-p debugger-previous-window) + (frame-visible-p + (window-frame debugger-previous-window))) + `((previous-window . ,debugger-previous-window)))))) (setq debugger-window (selected-window)) (if (eq debugger-previous-window debugger-window) (when debugger-jumping-flag @@ -215,24 +279,6 @@ first will be printed into the backtrace buffer." (window-total-height debugger-window))) (error nil))) (setq debugger-previous-window debugger-window)) - (debugger-mode) - (debugger-setup-buffer debugger-args) - (when noninteractive - ;; If the backtrace is long, save the beginning - ;; and the end, but discard the middle. - (when (> (count-lines (point-min) (point-max)) - debugger-batch-max-lines) - (goto-char (point-min)) - (forward-line (/ 2 debugger-batch-max-lines)) - (let ((middlestart (point))) - (goto-char (point-max)) - (forward-line (- (/ 2 debugger-batch-max-lines) - debugger-batch-max-lines)) - (delete-region middlestart (point))) - (insert "...\n")) - (goto-char (point-min)) - (message "%s" (buffer-string)) - (kill-emacs -1)) (message "") (let ((standard-output nil) (buffer-read-only t)) @@ -259,127 +305,100 @@ first will be printed into the backtrace buffer." (setq debugger-previous-window nil)) ;; Restore previous state of debugger-buffer in case we were ;; in a recursive invocation of the debugger, otherwise just - ;; erase the buffer and put it into fundamental mode. + ;; erase the buffer. (when (buffer-live-p debugger-buffer) (with-current-buffer debugger-buffer - (let ((inhibit-read-only t)) - (erase-buffer) - (if (null debugger-previous-state) - (fundamental-mode) - (insert (nth 1 debugger-previous-state)) - (funcall (nth 0 debugger-previous-state)))))) + (if debugger-previous-state + (debugger--restore-buffer-state debugger-previous-state) + (setq backtrace-insert-header-function nil) + (setq backtrace-frames nil) + (backtrace-print)))) (with-timeout-unsuspend debugger-with-timeout-suspend) (set-match-data debugger-outer-match-data))) (setq debug-on-next-call debugger-step-after-exit) - debugger-value))) + debugger-value)))) - -(defun debugger-insert-backtrace (frames do-xrefs) - "Format and insert the backtrace FRAMES at point. -Make functions into cross-reference buttons if DO-XREFS is non-nil." - (let ((standard-output (current-buffer)) - (eval-buffers eval-buffer-list)) - (require 'help-mode) ; Define `help-function-def' button type. - (pcase-dolist (`(,evald ,fun ,args ,flags) frames) - (insert (if (plist-get flags :debug-on-exit) - "* " " ")) - (let ((fun-file (and do-xrefs (symbol-file fun 'defun))) - (fun-pt (point))) - (cond - ((and evald (not debugger-stack-frame-as-list)) - (funcall debugger-print-function fun) - (if args (funcall debugger-print-function args) (princ "()"))) - (t - (funcall debugger-print-function (cons fun args)) - (cl-incf fun-pt))) - (when fun-file - (make-text-button fun-pt (+ fun-pt (length (symbol-name fun))) - :type 'help-function-def - 'help-args (list fun fun-file)))) - ;; After any frame that uses eval-buffer, insert a line that - ;; states the buffer position it's reading at. - (when (and eval-buffers (memq fun '(eval-buffer eval-region))) - (insert (format " ; Reading at buffer position %d" - ;; This will get the wrong result if there are - ;; two nested eval-region calls for the same - ;; buffer. That's not a very useful case. - (with-current-buffer (pop eval-buffers) - (point))))) - (insert "\n")))) +(defun debugger--print (obj &optional stream) + (condition-case err + (funcall debugger-print-function obj stream) + (error + (message "Error in debug printer: %S" err) + (prin1 obj stream)))) (defun debugger-setup-buffer (args) "Initialize the `*Backtrace*' buffer for entry to the debugger. -That buffer should be current already." - (setq buffer-read-only nil) - (erase-buffer) - (set-buffer-multibyte t) ;Why was it nil ? -stef - (setq buffer-undo-list t) +That buffer should be current already and in debugger-mode." + (setq backtrace-frames (nthcdr + ;; Remove debug--implement-debug-on-entry and the + ;; advice's `apply' frame. + (if (eq (car args) 'debug) 3 1) + (backtrace-get-frames 'debug))) + (when (eq (car-safe args) 'exit) + (setq debugger-value (nth 1 args)) + (setf (cl-getf (backtrace-frame-flags (car backtrace-frames)) + :debug-on-exit) + nil)) + + (setq backtrace-view (plist-put backtrace-view :show-flags t) + backtrace-insert-header-function (lambda () + (debugger--insert-header args)) + backtrace-print-function debugger-print-function) + (backtrace-print) + ;; Place point on "stack frame 0" (bug#15101). + (goto-char (point-min)) + (search-forward ":" (line-end-position) t) + (when (and (< (point) (line-end-position)) + (= (char-after) ?\s)) + (forward-char))) + +(defun debugger--insert-header (args) + "Insert the header for the debugger's Backtrace buffer. +Include the reason for debugger entry from ARGS." (insert "Debugger entered") - (let ((frames (nthcdr - ;; Remove debug--implement-debug-on-entry and the - ;; advice's `apply' frame. - (if (eq (car args) 'debug) 3 1) - (backtrace-frames 'debug))) - (print-escape-newlines t) - (print-escape-control-characters t) - ;; If you increase print-level, add more depth in call_debugger. - (print-level 8) - (print-length 50) - (pos (point))) - (pcase (car args) - ;; lambda is for debug-on-call when a function call is next. - ;; debug is for debug-on-entry function called. - ((or `lambda `debug) - (insert "--entering a function:\n") - (setq pos (1- (point)))) - ;; Exiting a function. - (`exit - (insert "--returning value: ") - (setq pos (point)) - (setq debugger-value (nth 1 args)) - (funcall debugger-print-function debugger-value (current-buffer)) - (setf (cl-getf (nth 3 (car frames)) :debug-on-exit) nil) - (insert ?\n)) - ;; Watchpoint triggered. - ((and `watchpoint (let `(,symbol ,newval . ,details) (cdr args))) - (insert - "--" - (pcase details - (`(makunbound nil) (format "making %s void" symbol)) - (`(makunbound ,buffer) (format "killing local value of %s in buffer %s" - symbol buffer)) - (`(defvaralias ,_) (format "aliasing %s to %s" symbol newval)) - (`(let ,_) (format "let-binding %s to %S" symbol newval)) - (`(unlet ,_) (format "ending let-binding of %s" symbol)) - (`(set nil) (format "setting %s to %S" symbol newval)) - (`(set ,buffer) (format "setting %s in buffer %s to %S" - symbol buffer newval)) - (_ (error "unrecognized watchpoint triggered %S" (cdr args)))) - ": ") - (setq pos (point)) - (insert ?\n)) - ;; Debugger entered for an error. - (`error - (insert "--Lisp error: ") - (setq pos (point)) - (funcall debugger-print-function (nth 1 args) (current-buffer)) - (insert ?\n)) - ;; debug-on-call, when the next thing is an eval. - (`t - (insert "--beginning evaluation of function call form:\n") - (setq pos (1- (point)))) - ;; User calls debug directly. - (_ - (insert ": ") - (setq pos (point)) - (funcall debugger-print-function - (if (eq (car args) 'nil) - (cdr args) args) - (current-buffer)) - (insert ?\n))) - (debugger-insert-backtrace frames t) - ;; Place point on "stack frame 0" (bug#15101). - (goto-char pos))) + (pcase (car args) + ;; lambda is for debug-on-call when a function call is next. + ;; debug is for debug-on-entry function called. + ((or 'lambda 'debug) + (insert "--entering a function:\n")) + ;; Exiting a function. + ('exit + (insert "--returning value: ") + (insert (backtrace-print-to-string debugger-value)) + (insert ?\n)) + ;; Watchpoint triggered. + ((and 'watchpoint (let `(,symbol ,newval . ,details) (cdr args))) + (insert + "--" + (pcase details + ('(makunbound nil) (format "making %s void" symbol)) + (`(makunbound ,buffer) (format "killing local value of %s in buffer %s" + symbol buffer)) + (`(defvaralias ,_) (format "aliasing %s to %s" symbol newval)) + (`(let ,_) (format "let-binding %s to %s" symbol + (backtrace-print-to-string newval))) + (`(unlet ,_) (format "ending let-binding of %s" symbol)) + ('(set nil) (format "setting %s to %s" symbol + (backtrace-print-to-string newval))) + (`(set ,buffer) (format "setting %s in buffer %s to %s" + symbol buffer + (backtrace-print-to-string newval))) + (_ (error "unrecognized watchpoint triggered %S" (cdr args)))) + ": ") + (insert ?\n)) + ;; Debugger entered for an error. + ('error + (insert "--Lisp error: ") + (insert (backtrace-print-to-string (nth 1 args))) + (insert ?\n)) + ;; debug-on-call, when the next thing is an eval. + ('t + (insert "--beginning evaluation of function call form:\n")) + ;; User calls debug directly. + (_ + (insert ": ") + (insert (backtrace-print-to-string (if (eq (car args) 'nil) + (cdr args) args))) + (insert ?\n)))) (defun debugger-step-through () @@ -399,12 +418,12 @@ Enter another debugger on next entry to eval, apply or funcall." (unless debugger-may-continue (error "Cannot continue")) (message "Continuing.") - (save-excursion - ;; Check to see if we've flagged some frame for debug-on-exit, in which - ;; case we'll probably come back to the debugger soon. - (goto-char (point-min)) - (if (re-search-forward "^\\* " nil t) - (setq debugger-will-be-back t))) + + ;; Check to see if we've flagged some frame for debug-on-exit, in which + ;; case we'll probably come back to the debugger soon. + (dolist (frame backtrace-frames) + (when (plist-get (backtrace-frame-flags frame) :debug-on-exit) + (setq debugger-will-be-back t))) (exit-recursive-edit)) (defun debugger-return-value (val) @@ -418,13 +437,12 @@ will be used, such as in a debug on exit from a frame." "from an error" "at function entrance"))) (setq debugger-value val) (princ "Returning " t) - (prin1 debugger-value) - (save-excursion + (debugger--print debugger-value) ;; Check to see if we've flagged some frame for debug-on-exit, in which ;; case we'll probably come back to the debugger soon. - (goto-char (point-min)) - (if (re-search-forward "^\\* " nil t) - (setq debugger-will-be-back t))) + (dolist (frame backtrace-frames) + (when (plist-get (backtrace-frame-flags frame) :debug-on-exit) + (setq debugger-will-be-back t))) (exit-recursive-edit)) (defun debugger-jump () @@ -446,63 +464,40 @@ removes itself from that hook." (defun debugger-frame-number (&optional skip-base) "Return number of frames in backtrace before the one point points at." - (save-excursion - (beginning-of-line) - (if (looking-at " *;;;\\|[a-z]") - (error "This line is not a function call")) - (let ((opoint (point)) - (count 0)) - (unless skip-base + (let ((index (backtrace-get-index)) + (count 0)) + (unless index + (error "This line is not a function call")) + (unless skip-base (while (not (eq (cadr (backtrace-frame count)) 'debug)) (setq count (1+ count))) ;; Skip debug--implement-debug-on-entry frame. (when (eq 'debug--implement-debug-on-entry (cadr (backtrace-frame (1+ count)))) (setq count (+ 2 count)))) - (goto-char (point-min)) - (when (looking-at "Debugger entered--\\(Lisp error\\|returning value\\):") - (goto-char (match-end 0)) - (forward-sexp 1)) - (forward-line 1) - (while (progn - (forward-char 2) - (cond ((debugger--locals-visible-p) - (goto-char (next-single-char-property-change - (point) 'locals-visible))) - ((= (following-char) ?\() - (forward-sexp 1)) - (t - (forward-sexp 2))) - (forward-line 1) - (<= (point) opoint)) - (if (looking-at " *;;;") - (forward-line 1)) - (setq count (1+ count))) - count))) + (+ count index))) (defun debugger-frame () "Request entry to debugger when this frame exits. Applies to the frame whose line point is on in the backtrace." (interactive) (backtrace-debug (debugger-frame-number) t) - (beginning-of-line) - (if (= (following-char) ? ) - (let ((inhibit-read-only t)) - (delete-char 1) - (insert ?*))) - (beginning-of-line)) + (setf + (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames)) + :debug-on-exit) + t) + (backtrace-update-flags)) (defun debugger-frame-clear () "Do not enter debugger when this frame exits. Applies to the frame whose line point is on in the backtrace." (interactive) (backtrace-debug (debugger-frame-number) nil) - (beginning-of-line) - (if (= (following-char) ?*) - (let ((inhibit-read-only t)) - (delete-char 1) - (insert ? ))) - (beginning-of-line)) + (setf + (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames)) + :debug-on-exit) + nil) + (backtrace-update-flags)) (defmacro debugger-env-macro (&rest body) "Run BODY in original environment." @@ -533,73 +528,14 @@ The environment used is the one when entering the activation frame at point." (debugger-env-macro (let ((val (backtrace-eval exp nframe base))) (prog1 - (prin1 val t) + (debugger--print val t) (let ((str (eval-expression-print-format val))) (if str (princ str t)))))))) -(defun debugger--locals-visible-p () - "Are the local variables of the current stack frame visible?" - (save-excursion - (move-to-column 2) - (get-text-property (point) 'locals-visible))) - -(defun debugger--insert-locals (locals) - "Insert the local variables LOCALS at point." - (cond ((null locals) - (insert "\n [no locals]")) - (t - (let ((print-escape-newlines t)) - (dolist (s+v locals) - (let ((symbol (car s+v)) - (value (cdr s+v))) - (insert "\n ") - (prin1 symbol (current-buffer)) - (insert " = ") - (prin1 value (current-buffer)))))))) - -(defun debugger--show-locals () - "For the frame at point, insert locals and add text properties." - (let* ((nframe (1+ (debugger-frame-number 'skip-base))) - (base (debugger--backtrace-base)) - (locals (backtrace--locals nframe base)) - (inhibit-read-only t)) - (save-excursion - (let ((start (progn - (move-to-column 2) - (point)))) - (end-of-line) - (debugger--insert-locals locals) - (add-text-properties start (point) '(locals-visible t)))))) - -(defun debugger--hide-locals () - "Delete local variables and remove the text property." - (let* ((col (current-column)) - (end (progn - (move-to-column 2) - (next-single-char-property-change (point) 'locals-visible))) - (start (previous-single-char-property-change end 'locals-visible)) - (inhibit-read-only t)) - (remove-text-properties start end '(locals-visible)) - (goto-char start) - (end-of-line) - (delete-region (point) end) - (move-to-column col))) - -(defun debugger-toggle-locals () - "Show or hide local variables of the current stack frame." - (interactive) - (cond ((debugger--locals-visible-p) - (debugger--hide-locals)) - (t - (debugger--show-locals)))) - (defvar debugger-mode-map - (let ((map (make-keymap)) - (menu-map (make-sparse-keymap))) - (set-keymap-parent map button-buffer-map) - (suppress-keymap map) - (define-key map "-" 'negative-argument) + (let ((map (make-keymap))) + (set-keymap-parent map backtrace-mode-map) (define-key map "b" 'debugger-frame) (define-key map "c" 'debugger-continue) (define-key map "j" 'debugger-jump) @@ -607,63 +543,47 @@ The environment used is the one when entering the activation frame at point." (define-key map "u" 'debugger-frame-clear) (define-key map "d" 'debugger-step-through) (define-key map "l" 'debugger-list-functions) - (define-key map "h" 'describe-mode) - (define-key map "q" 'top-level) + (define-key map "q" 'debugger-quit) (define-key map "e" 'debugger-eval-expression) - (define-key map "v" 'debugger-toggle-locals) ; "v" is for "variables". - (define-key map " " 'next-line) (define-key map "R" 'debugger-record-expression) - (define-key map "\C-m" 'debug-help-follow) (define-key map [mouse-2] 'push-button) - (define-key map [menu-bar debugger] (cons "Debugger" menu-map)) - (define-key menu-map [deb-top] - '(menu-item "Quit" top-level - :help "Quit debugging and return to top level")) - (define-key menu-map [deb-s0] '("--")) - (define-key menu-map [deb-descr] - '(menu-item "Describe Debugger Mode" describe-mode - :help "Display documentation for debugger-mode")) - (define-key menu-map [deb-hfol] - '(menu-item "Help Follow" debug-help-follow - :help "Follow cross-reference")) - (define-key menu-map [deb-nxt] - '(menu-item "Next Line" next-line - :help "Move cursor down")) - (define-key menu-map [deb-s1] '("--")) - (define-key menu-map [deb-lfunc] - '(menu-item "List debug on entry functions" debugger-list-functions - :help "Display a list of all the functions now set to debug on entry")) - (define-key menu-map [deb-fclear] - '(menu-item "Cancel debug frame" debugger-frame-clear - :help "Do not enter debugger when this frame exits")) - (define-key menu-map [deb-frame] - '(menu-item "Debug frame" debugger-frame - :help "Request entry to debugger when this frame exits")) - (define-key menu-map [deb-s2] '("--")) - (define-key menu-map [deb-ret] - '(menu-item "Return value..." debugger-return-value - :help "Continue, specifying value to return.")) - (define-key menu-map [deb-rec] - '(menu-item "Display and Record Expression" debugger-record-expression - :help "Display a variable's value and record it in `*Backtrace-record*' buffer")) - (define-key menu-map [deb-eval] - '(menu-item "Eval Expression..." debugger-eval-expression - :help "Eval an expression, in an environment like that outside the debugger")) - (define-key menu-map [deb-jump] - '(menu-item "Jump" debugger-jump - :help "Continue to exit from this frame, with all debug-on-entry suspended")) - (define-key menu-map [deb-cont] - '(menu-item "Continue" debugger-continue - :help "Continue, evaluating this expression without stopping")) - (define-key menu-map [deb-step] - '(menu-item "Step through" debugger-step-through - :help "Proceed, stepping through subexpressions of this expression")) + (easy-menu-define nil map "" + '("Debugger" + ["Step through" debugger-step-through + :help "Proceed, stepping through subexpressions of this expression"] + ["Continue" debugger-continue + :help "Continue, evaluating this expression without stopping"] + ["Jump" debugger-jump + :help "Continue to exit from this frame, with all debug-on-entry suspended"] + ["Eval Expression..." debugger-eval-expression + :help "Eval an expression, in an environment like that outside the debugger"] + ["Display and Record Expression" debugger-record-expression + :help "Display a variable's value and record it in `*Backtrace-record*' buffer"] + ["Return value..." debugger-return-value + :help "Continue, specifying value to return."] + "--" + ["Debug frame" debugger-frame + :help "Request entry to debugger when this frame exits"] + ["Cancel debug frame" debugger-frame-clear + :help "Do not enter debugger when this frame exits"] + ["List debug on entry functions" debugger-list-functions + :help "Display a list of all the functions now set to debug on entry"] + "--" + ["Next Line" next-line + :help "Move cursor down"] + ["Help for Symbol" backtrace-help-follow-symbol + :help "Show help for symbol at point"] + ["Describe Debugger Mode" describe-mode + :help "Display documentation for debugger-mode"] + "--" + ["Quit" debugger-quit + :help "Quit debugging and return to top level"])) map)) (put 'debugger-mode 'mode-class 'special) -(define-derived-mode debugger-mode fundamental-mode "Debugger" - "Mode for backtrace buffers, selected in debugger. +(define-derived-mode debugger-mode backtrace-mode "Debugger" + "Mode for debugging Emacs Lisp using a backtrace. \\<debugger-mode-map> A line starts with `*' if exiting that frame will call the debugger. Type \\[debugger-frame] or \\[debugger-frame-clear] to set or remove the `*'. @@ -677,8 +597,6 @@ which functions will enter the debugger when called. Complete list of commands: \\{debugger-mode-map}" - (setq truncate-lines t) - (set-syntax-table emacs-lisp-mode-syntax-table) (add-hook 'kill-buffer-hook (lambda () (if (> (recursion-depth) 0) (top-level))) nil t) @@ -705,27 +623,6 @@ Complete list of commands: (buffer-substring (line-beginning-position 0) (line-end-position 0))))) -(defun debug-help-follow (&optional pos) - "Follow cross-reference at POS, defaulting to point. - -For the cross-reference format, see `help-make-xrefs'." - (interactive "d") - ;; Ideally we'd just do (call-interactively 'help-follow) except that this - ;; assumes we're already in a *Help* buffer and reuses it, so it ends up - ;; incorrectly "reusing" the *Backtrace* buffer to show the help info. - (unless pos - (setq pos (point))) - (unless (push-button pos) - ;; check if the symbol under point is a function or variable - (let ((sym - (intern - (save-excursion - (goto-char pos) (skip-syntax-backward "w_") - (buffer-substring (point) - (progn (skip-syntax-forward "w_") - (point))))))) - (when (or (boundp sym) (fboundp sym) (facep sym)) - (describe-symbol sym))))) ;; When you change this, you may also need to change the number of ;; frames that the debugger skips. @@ -826,6 +723,13 @@ To specify a nil argument interactively, exit with an empty minibuffer." ;;(princ "be set to debug on entry, even if it is in the list.") ))))) +(defun debugger-quit () + "Quit debugging and return to the top level." + (interactive) + (if (= (recursion-depth) 0) + (quit-window) + (top-level))) + (defun debug--implement-debug-watch (symbol newval op where) "Conditionally call the debugger. This function is called when SYMBOL's value is modified." diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index c6c4430efd3..a6578e33086 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -113,9 +113,9 @@ ;;;###autoload (defmacro define-derived-mode (child parent name &optional docstring &rest body) - "Create a new mode as a variant of an existing mode. + "Create a new mode CHILD which is a variant of an existing mode PARENT. -The arguments to this command are as follow: +The arguments are as follows: CHILD: the name of the command for the derived mode. PARENT: the name of the command for the parent mode (e.g. `text-mode') @@ -123,24 +123,28 @@ PARENT: the name of the command for the parent mode (e.g. `text-mode') NAME: a string which will appear in the status line (e.g. \"Hypertext\") DOCSTRING: an optional documentation string--if you do not supply one, the function will attempt to invent something useful. +KEYWORD-ARGS: + optional arguments in the form of pairs of keyword and value. + The following keyword arguments are currently supported: + + :group GROUP + Declare the customization group that corresponds + to this mode. The command `customize-mode' uses this. + :syntax-table TABLE + Use TABLE instead of the default (CHILD-syntax-table). + A nil value means to simply use the same syntax-table + as the parent. + :abbrev-table TABLE + Use TABLE instead of the default (CHILD-abbrev-table). + A nil value means to simply use the same abbrev-table + as the parent. + :after-hook FORM + A single lisp form which is evaluated after the mode + hooks have been run. It should not be quoted. + BODY: forms to execute just before running the hooks for the new mode. Do not use `interactive' here. -BODY can start with a bunch of keyword arguments. The following keyword - arguments are currently understood: -:group GROUP - Declare the customization group that corresponds to this mode. - The command `customize-mode' uses this. -:syntax-table TABLE - Use TABLE instead of the default (CHILD-syntax-table). - A nil value means to simply use the same syntax-table as the parent. -:abbrev-table TABLE - Use TABLE instead of the default (CHILD-abbrev-table). - A nil value means to simply use the same abbrev-table as the parent. -:after-hook FORM - A single lisp form which is evaluated after the mode hooks have been - run. It should not be quoted. - Here is how you could define LaTeX-Thesis mode as a variant of LaTeX mode: (define-derived-mode LaTeX-thesis-mode LaTeX-mode \"LaTeX-Thesis\") @@ -149,7 +153,7 @@ You could then make new key bindings for `LaTeX-thesis-mode-map' without changing regular LaTeX mode. In this example, BODY is empty, and DOCSTRING is generated by default. -On a more complicated level, the following command uses `sgml-mode' as +As a more complex example, the following command uses `sgml-mode' as the parent, and then sets the variable `case-fold-search' to nil: (define-derived-mode article-mode sgml-mode \"Article\" @@ -162,7 +166,9 @@ been generated automatically, with a reference to the keymap. The new mode runs the hook constructed by the function `derived-mode-hook-name'. -See Info node `(elisp)Derived Modes' for more details." +See Info node `(elisp)Derived Modes' for more details. + +\(fn CHILD PARENT NAME [DOCSTRING] [KEYWORD-ARGS...] &rest BODY)" (declare (debug (&define name symbolp sexp [&optional stringp] [&rest keywordp sexp] def-body)) (doc-string 4) @@ -193,10 +199,10 @@ See Info node `(elisp)Derived Modes' for more details." ;; Process the keyword args. (while (keywordp (car body)) (pcase (pop body) - (`:group (setq group (pop body))) - (`:abbrev-table (setq abbrev (pop body)) (setq declare-abbrev nil)) - (`:syntax-table (setq syntax (pop body)) (setq declare-syntax nil)) - (`:after-hook (setq after-hook (pop body))) + (:group (setq group (pop body))) + (:abbrev-table (setq abbrev (pop body)) (setq declare-abbrev nil)) + (:syntax-table (setq syntax (pop body)) (setq declare-syntax nil)) + (:after-hook (setq after-hook (pop body))) (_ (pop body)))) (setq docstring (derived-mode-make-docstring @@ -281,25 +287,10 @@ No problems result if this variable is not bound. ; Splice in the body (if any). ,@body ) - ;; Run the hooks, if any. - (run-mode-hooks ',hook) - ,@(when after-hook - `((if delay-mode-hooks - (push (lambda () ,after-hook) delayed-after-hook-functions) - ,after-hook))))))) - -;; PUBLIC: find the ultimate class of a derived mode. - -(defun derived-mode-class (mode) - "Find the class of a major MODE. -A mode's class is the first ancestor which is NOT a derived mode. -Use the `derived-mode-parent' property of the symbol to trace backwards. -Since major-modes might all derive from `fundamental-mode', this function -is not very useful." - (declare (obsolete derived-mode-p "22.1")) - (while (get mode 'derived-mode-parent) - (setq mode (get mode 'derived-mode-parent))) - mode) + ,@(when after-hook + `((push (lambda () ,after-hook) delayed-after-hook-functions))) + ;; Run the hooks (and delayed-after-hook-functions), if any. + (run-mode-hooks ',hook))))) ;;; PRIVATE diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 3fc22247fa6..2faad60865f 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -36,6 +36,7 @@ ;;; Code: (require 'macroexp) +(require 'cl-lib) ;; The variable byte-code-vector is defined by the new bytecomp.el. ;; The function byte-decompile-lapcode is defined in byte-opt.el. @@ -168,7 +169,8 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (fetch-bytecode obj) (setq bytes (aref obj 1) constvec (aref obj 2))) - (let ((lap (byte-decompile-bytecode (string-as-unibyte bytes) constvec)) + (cl-assert (not (multibyte-string-p bytes))) + (let ((lap (byte-decompile-bytecode bytes constvec)) op arg opname pc-value) (let ((tagno 0) tmp diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 4aa12ceec60..be531aab849 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -81,6 +81,26 @@ replacing its case-insensitive matches with the literal string in LIGHTER." ;; space.) (replace-regexp-in-string (regexp-quote lighter) lighter name t t)))) +(defconst easy-mmode--arg-docstring + " + +If called interactively, enable %s if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise.") + +(defun easy-mmode--mode-docstring (doc mode-pretty-name keymap-sym) + (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 ((argdoc (format easy-mmode--arg-docstring + mode-pretty-name))) + (replace-regexp-in-string "\\(\n\n\\|\\'\\)\\(.\\|\n\\)*\\'" + (concat argdoc "\\1") + doc nil nil 1))))) + ;;;###autoload (defalias 'easy-mmode-define-minor-mode 'define-minor-mode) ;;;###autoload @@ -101,7 +121,9 @@ non-positive integer, and enables the mode otherwise (including if the argument is omitted or nil or a positive integer). If DOC is nil, give the mode command a basic doc-string -documenting what its argument does. +documenting what its argument does. If the word \"ARG\" does not +appear in DOC, a paragraph is added to DOC explaining +usage of the mode argument. Optional INIT-VALUE is the initial value of the mode's variable. Optional LIGHTER is displayed in the mode line when the mode is on. @@ -195,30 +217,30 @@ For example, you could write (while (keywordp (setq keyw (car body))) (setq body (cdr body)) (pcase keyw - (`:init-value (setq init-value (pop body))) - (`:lighter (setq lighter (purecopy (pop body)))) - (`:global (setq globalp (pop body)) - (when (and globalp (symbolp mode)) - (setq setter `(setq-default ,mode)) - (setq getter `(default-value ',mode)))) - (`:extra-args (setq extra-args (pop body))) - (`:set (setq set (list :set (pop body)))) - (`:initialize (setq initialize (list :initialize (pop body)))) - (`:group (setq group (nconc group (list :group (pop body))))) - (`:type (setq type (list :type (pop body)))) - (`:require (setq require (pop body))) - (`:keymap (setq keymap (pop body))) - (`:variable (setq variable (pop body)) - (if (not (and (setq tmp (cdr-safe variable)) - (or (symbolp tmp) - (functionp tmp)))) - ;; PLACE is not of the form (GET . SET). - (progn - (setq setter `(setf ,variable)) - (setq getter variable)) - (setq getter (car variable)) - (setq setter `(funcall #',(cdr variable))))) - (`:after-hook (setq after-hook (pop body))) + (:init-value (setq init-value (pop body))) + (:lighter (setq lighter (purecopy (pop body)))) + (:global (setq globalp (pop body)) + (when (and globalp (symbolp mode)) + (setq setter `(setq-default ,mode)) + (setq getter `(default-value ',mode)))) + (:extra-args (setq extra-args (pop body))) + (:set (setq set (list :set (pop body)))) + (:initialize (setq initialize (list :initialize (pop body)))) + (:group (setq group (nconc group (list :group (pop body))))) + (:type (setq type (list :type (pop body)))) + (:require (setq require (pop body))) + (:keymap (setq keymap (pop body))) + (:variable (setq variable (pop body)) + (if (not (and (setq tmp (cdr-safe variable)) + (or (symbolp tmp) + (functionp tmp)))) + ;; PLACE is not of the form (GET . SET). + (progn + (setq setter `(setf ,variable)) + (setq getter variable)) + (setq getter (car variable)) + (setq setter `(funcall #',(cdr variable))))) + (:after-hook (setq after-hook (pop body))) (_ (push keyw extra-keywords) (push (pop body) extra-keywords)))) (setq keymap-sym (if (and keymap (symbolp keymap)) keymap @@ -270,12 +292,7 @@ or call the function `%s'.")))) ;; The actual function. (defun ,modefun (&optional arg ,@extra-args) - ,(or doc - (format (concat "Toggle %s on or off. -With a prefix argument ARG, enable %s if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'. -\\{%s}") pretty-name pretty-name keymap-sym)) + ,(easy-mmode--mode-docstring doc pretty-name keymap-sym) ;; Use `toggle' rather than (if ,mode 0 1) so that using ;; repeat-command still does the toggling correctly. (interactive (list (or current-prefix-arg 'toggle))) @@ -390,16 +407,10 @@ on if the hook has explicitly disabled it." (while (keywordp (setq keyw (car keys))) (setq keys (cdr keys)) (pcase keyw - (`:group (setq group (nconc group (list :group (pop keys))))) - (`:global (setq keys (cdr keys))) + (:group (setq group (nconc group (list :group (pop keys))))) + (:global (setq keys (cdr keys))) (_ (push keyw extra-keywords) (push (pop keys) extra-keywords)))) - (unless group - ;; We might as well provide a best-guess default group. - (setq group - `(:group ',(intern (replace-regexp-in-string - "-mode\\'" "" (symbol-name mode)))))) - `(progn (progn :autoload-end @@ -516,11 +527,11 @@ Valid keywords and arguments are: (let ((key (pop args)) (val (pop args))) (pcase key - (`:name (setq name val)) - (`:dense (setq dense val)) - (`:inherit (setq inherit val)) - (`:suppress (setq suppress val)) - (`:group) + (:name (setq name val)) + (:dense (setq dense val)) + (:inherit (setq inherit val)) + (:suppress (setq suppress val)) + (:group) (_ (message "Unknown argument %s in defmap" key))))) (unless (keymapp m) (setq bs (append m bs)) @@ -549,6 +560,7 @@ Valid keywords and arguments are: "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)) `(defconst ,m (easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args)) ,doc)) @@ -575,6 +587,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)) `(progn (autoload 'easy-mmode-define-syntax "easy-mmode") (defconst ,st (easy-mmode-define-syntax ,css ,(cons 'list args)) ,doc))) @@ -605,15 +618,15 @@ BODY is executed after moving to the destination location." (when-narrowed (lambda (body) (if (null narrowfun) body - `(let ((was-narrowed - (prog1 (or (< (- (point-max) (point-min)) (buffer-size))) - (widen)))) + `(let ((was-narrowed (prog1 (buffer-narrowed-p) (widen)))) ,body (when was-narrowed (funcall #',narrowfun))))))) (unless name (setq name base-name)) + ;; FIXME: Move most of those functions's bodies to helper functions! `(progn (defun ,next-sym (&optional count) - ,(format "Go to the next COUNT'th %s." name) + ,(format "Go to the next COUNT'th %s. +Interactively, COUNT is the prefix numeric argument, and defaults to 1." name) (interactive "p") (unless count (setq count 1)) (if (< count 0) (,prev-sym (- count)) @@ -631,11 +644,17 @@ BODY is executed after moving to the destination location." `(re-search-forward ,re nil t 2))) (point-max)))) (unless (pos-visible-in-window-p endpt nil t) - (recenter '(0))))))) + (let ((ws (window-start))) + (recenter '(0)) + (if (< (window-start) ws) + ;; recenter scrolled in the wrong direction! + (set-window-start nil ws)))))))) ,@body)) (put ',next-sym 'definition-name ',base) (defun ,prev-sym (&optional count) - ,(format "Go to the previous COUNT'th %s" (or name base-name)) + ,(format "Go to the previous COUNT'th %s. +Interactively, COUNT is the prefix numeric argument, and defaults to 1." + (or name base-name)) (interactive "p") (unless count (setq count 1)) (if (< count 0) (,next-sym (- count)) diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el index 255a0436203..5bf046d41db 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -226,14 +226,14 @@ possibly preceded by keyword pairs as described in `easy-menu-define'." (let ((arg (cadr menu-items))) (setq menu-items (cddr menu-items)) (pcase keyword - (`:filter + (:filter (setq filter (lambda (menu) (easy-menu-filter-return (funcall arg menu) menu-name)))) - ((or `:enable `:active) (setq enable (or arg ''nil))) - (`:label (setq label arg)) - (`:help (setq help arg)) - ((or `:included `:visible) (setq visible (or arg ''nil)))))) + ((or :enable :active) (setq enable (or arg ''nil))) + (:label (setq label arg)) + (:help (setq help arg)) + ((or :included :visible) (setq visible (or arg ''nil)))))) (if (equal visible ''nil) nil ; Invisible menu entry, return nil. (if (and visible (not (easy-menu-always-true-p visible))) @@ -325,15 +325,15 @@ ITEM defines an item as in `easy-menu-define'." (setq arg (aref item (1+ count))) (setq count (+ 2 count)) (pcase keyword - ((or `:included `:visible) (setq visible (or arg ''nil))) - (`:key-sequence (setq cache arg cache-specified t)) - (`:keys (setq keys arg no-name nil)) - (`:label (setq label arg)) - ((or `:active `:enable) (setq active (or arg ''nil))) - (`:help (setq prop (cons :help (cons arg prop)))) - (`:suffix (setq suffix arg)) - (`:style (setq style arg)) - (`:selected (setq selected (or arg ''nil))))) + ((or :included :visible) (setq visible (or arg ''nil))) + (:key-sequence (setq cache arg cache-specified t)) + (:keys (setq keys arg no-name nil)) + (:label (setq label arg)) + ((or :active :enable) (setq active (or arg ''nil))) + (:help (setq prop (cons :help (cons arg prop)))) + (:suffix (setq suffix arg)) + (:style (setq style arg)) + (:selected (setq selected (or arg ''nil))))) (if suffix (setq label (if (stringp suffix) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 144bd3286ba..c898da3d39f 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 edebug-global-prefix "\C-xX") +;; (setq global-edebug-prefix "\C-xX") ;; Edebug was written by ;; Daniel LaLiberte @@ -52,6 +52,7 @@ ;;; Code: +(require 'backtrace) (require 'macroexp) (require 'cl-lib) (eval-when-compile (require 'pcase)) @@ -69,8 +70,7 @@ Each time it is set to a new value, Edebug will call those functions once and then reset `edebug-setup-hook' to nil. You could use this to load up Edebug specifications associated with a package you are using, but only when you also use Edebug." - :type 'hook - :group 'edebug) + :type 'hook) ;; edebug-all-defs and edebug-all-forms need to be autoloaded ;; because the byte compiler binds them; as a result, if edebug @@ -87,8 +87,7 @@ 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'." - :type 'boolean - :group 'edebug) + :type 'boolean) ;; edebug-all-defs and edebug-all-forms need to be autoloaded ;; because the byte compiler binds them; as a result, if edebug @@ -99,8 +98,7 @@ variable. You may wish to make it local to each buffer with "Non-nil means evaluation of all forms will instrument for Edebug. This doesn't apply to loading or evaluations in the minibuffer. Use the command `edebug-all-forms' to toggle the value of this option." - :type 'boolean - :group 'edebug) + :type 'boolean) (defcustom edebug-eval-macro-args nil "Non-nil means all macro call arguments may be evaluated. @@ -109,8 +107,7 @@ macro call arguments as if they will be evaluated. For each macro, an `edebug-form-spec' overrides this option. So to specify exceptions for macros that have some arguments evaluated and some not, use `def-edebug-spec' to specify an `edebug-form-spec'." - :type 'boolean - :group 'edebug) + :type 'boolean) (defcustom edebug-max-depth 150 "Maximum recursion depth when instrumenting code. @@ -121,7 +118,6 @@ the error message \"Too deep - perhaps infinite loop in spec?\". Make this limit larger to countermand that, but you may also need to increase `max-lisp-eval-depth' and `max-specpdl-size'." :type 'integer - :group 'edebug :version "26.1") (defcustom edebug-save-windows t @@ -133,8 +129,7 @@ If the value is a list, only the listed windows are saved and restored. `edebug-toggle-save-windows' may be used to change this variable." - :type '(choice boolean (repeat string)) - :group 'edebug) + :type '(choice boolean (repeat string))) (defcustom edebug-save-displayed-buffer-points nil "If non-nil, save and restore point in all displayed buffers. @@ -147,8 +142,7 @@ window, the buffer's point will be changed to the window's point. Saving and restoring point in all buffers is expensive, since it requires selecting each window twice, so enable this only if you need it." - :type 'boolean - :group 'edebug) + :type 'boolean) (defcustom edebug-initial-mode 'step "Initial execution mode for Edebug, if non-nil. @@ -158,8 +152,7 @@ go, Go-nonstop, trace, Trace-fast, continue, and Continue-fast." :type '(choice (const step) (const next) (const go) (const Go-nonstop) (const trace) (const Trace-fast) (const continue) - (const Continue-fast)) - :group 'edebug) + (const Continue-fast))) (defcustom edebug-trace nil "Non-nil means display a trace of function entry and exit. @@ -168,8 +161,7 @@ function entry or exit per line, indented by the recursion level. You can customize by replacing functions `edebug-print-trace-before' and `edebug-print-trace-after'." - :type 'boolean - :group 'edebug) + :type 'boolean) (defcustom edebug-test-coverage nil "If non-nil, Edebug tests coverage of all expressions debugged. @@ -179,37 +171,30 @@ results are found. Use `edebug-display-freq-count' to display the frequency count and coverage information for a definition." - :type 'boolean - :group 'edebug) + :type 'boolean) (defcustom edebug-continue-kbd-macro nil "If non-nil, continue defining or executing any keyboard macro. Use this with caution since it is not debugged." - :type 'boolean - :group 'edebug) + :type 'boolean) (defcustom edebug-print-length 50 "If non-nil, default value of `print-length' for printing results in Edebug." - :type '(choice integer (const nil)) - :group 'edebug) + :type '(choice integer (const nil))) (defcustom edebug-print-level 50 "If non-nil, default value of `print-level' for printing results in Edebug." - :type '(choice integer (const nil)) - :group 'edebug) + :type '(choice integer (const nil))) (defcustom edebug-print-circle t "If non-nil, default value of `print-circle' for printing results in Edebug." - :type 'boolean - :group 'edebug) + :type 'boolean) (defcustom edebug-unwrap-results nil "Non-nil if Edebug should unwrap results of expressions. That is, Edebug will try to remove its own instrumentation from the result. This is useful when debugging macros where the results of expressions -are instrumented expressions. But don't do this when results might be -circular or an infinite loop will result." - :type 'boolean - :group 'edebug) +are instrumented expressions." + :type 'boolean) (defcustom edebug-on-error t "Value bound to `debug-on-error' while Edebug is active. @@ -225,30 +210,25 @@ After execution is resumed, the error is signaled again." (repeat :menu-tag "When" :value (nil) (symbol :format "%v")) - (const :tag "always" t)) - :group 'edebug) + (const :tag "always" t))) (defcustom edebug-on-quit t "Value bound to `debug-on-quit' while Edebug is active." - :type 'boolean - :group 'edebug) + :type 'boolean) (defcustom edebug-global-break-condition nil "If non-nil, an expression to test for at every stop point. If the result is non-nil, then break. Errors are ignored." :type 'sexp - :risky t - :group 'edebug) + :risky t) (defcustom edebug-sit-for-seconds 1 "Number of seconds to pause when execution mode is `trace' or `continue'." - :type 'number - :group 'edebug) + :type 'number) (defcustom edebug-sit-on-break t "Whether or not to pause for `edebug-sit-for-seconds' on reaching a break." :type 'boolean - :group 'edebug :version "26.1") ;;; Form spec utilities. @@ -373,6 +353,8 @@ Return the result of the last expression in BODY." (t (split-window (minibuffer-selected-window))))) (set-window-buffer window buffer) (select-window window) + (unless (memq (framep (selected-frame)) '(nil t pc)) + (x-focus-frame (selected-frame))) (set-window-hscroll window 0)) ;; should this be?? (defun edebug-get-displayed-buffer-points () @@ -545,8 +527,13 @@ already is one.)" (edebug-read-top-level-form))))) +(defvar edebug-active nil) ;; Non-nil when edebug is active + (defun edebug-read-top-level-form () - (let ((starting-point (point))) + (let ((starting-point (point)) + ;; Don't enter Edebug while doing that, in case we're trying to + ;; instrument things like end-of-defun. + (edebug-active t)) (end-of-defun) (beginning-of-defun) (prog1 @@ -584,7 +571,7 @@ already is one.)" (defun edebug-uninstall-read-eval-functions () (interactive) (remove-function load-read-function #'edebug--read) - (advice-remove 'eval-defun 'edebug-eval-defun)) + (advice-remove 'eval-defun #'edebug-eval-defun)) ;;; Edebug internal data @@ -894,8 +881,7 @@ circular objects. Let `read' read everything else." (while (and (>= (following-char) ?0) (<= (following-char) ?9)) (forward-char 1)) (let ((n (string-to-number (buffer-substring start (point))))) - (when (and read-circle - (<= n most-positive-fixnum)) + (when read-circle (cond ((eq ?= (following-char)) ;; Make a placeholder for #n# to use temporarily. @@ -910,7 +896,7 @@ circular objects. Let `read' read everything else." (throw 'return (setf (cdr elem) obj))))) ((eq ?# (following-char)) ;; #n# returns a previously read object. - (let ((elem (assq n edebug-read-objects))) + (let ((elem (assoc n edebug-read-objects))) (when (consp elem) (forward-char 1) (throw 'return (cdr elem)))))))))) @@ -1066,6 +1052,32 @@ circular objects. Let `read' read everything else." (defvar edebug-error-point nil) (defvar edebug-best-error nil) +;; Functions which may be used to extend Edebug's functionality. See +;; Testcover for an example. +(defvar edebug-after-instrumentation-function #'identity + "Function to run on code after instrumentation for debugging. +The function is called with one argument, a FORM which has just +been instrumented for Edebugging, and it should return either FORM +or a replacement form to use in its place.") + +(defvar edebug-new-definition-function #'edebug-new-definition + "Function to call after Edebug wraps a new definition. +After Edebug has initialized its own data, this function is +called with one argument, the symbol associated with the +definition, which may be the actual symbol defined or one +generated by Edebug.") + +(defvar edebug-behavior-alist + '((edebug edebug-default-enter edebug-slow-before edebug-slow-after)) + "Alist describing the runtime behavior of Edebug's instrumented code. +Each definition instrumented by Edebug will have a +`edebug-behavior' property which is a key to this alist. When +the instrumented code is running, Edebug will look here for the +implementations of `edebug-enter', `edebug-before', and +`edebug-after'. Edebug's instrumentation may be used for a new +purpose by adding an entry to this alist, and setting +`edebug-new-definition-function' to a function which sets +`edebug-behavior' for the definition.") (defun edebug-read-and-maybe-wrap-form () ;; Read a form and wrap it with edebug calls, if the conditions are right. @@ -1125,53 +1137,55 @@ circular objects. Let `read' read everything else." (eq 'symbol (edebug-next-token-class))) (read (current-buffer)))))) ;;;(message "all defs: %s all forms: %s" edebug-all-defs edebug-all-forms) - (cond - (defining-form-p - (if (or edebug-all-defs edebug-all-forms) - ;; If it is a defining form and we are edebugging defs, - ;; then let edebug-list-form start it. - (let ((cursor (edebug-new-cursor - (list (edebug-read-storing-offsets (current-buffer))) - (list edebug-offsets)))) - (car - (edebug-make-form-wrapper - cursor - (edebug-before-offset cursor) - (1- (edebug-after-offset cursor)) - (list (cons (symbol-name def-kind) (cdr spec)))))) - - ;; Not edebugging this form, so reset the symbol's edebug - ;; property to be just a marker at the definition's source code. - ;; This only works for defs with simple names. - (put def-name 'edebug (point-marker)) - ;; Also nil out dependent defs. - '(mapcar (function - (lambda (def) - (put def-name 'edebug nil))) - (get def-name 'edebug-dependents)) - (edebug-read-sexp))) - - ;; If all forms are being edebugged, explicitly wrap it. - (edebug-all-forms - (let ((cursor (edebug-new-cursor - (list (edebug-read-storing-offsets (current-buffer))) - (list edebug-offsets)))) - (edebug-make-form-wrapper - cursor - (edebug-before-offset cursor) - (edebug-after-offset cursor) - nil))) - - ;; Not a defining form, and not edebugging. - (t (edebug-read-sexp))) - )) - + (let ((result + (cond + (defining-form-p + (if (or edebug-all-defs edebug-all-forms) + ;; If it is a defining form and we are edebugging defs, + ;; then let edebug-list-form start it. + (let ((cursor (edebug-new-cursor + (list (edebug-read-storing-offsets (current-buffer))) + (list edebug-offsets)))) + (car + (edebug-make-form-wrapper + cursor + (edebug-before-offset cursor) + (1- (edebug-after-offset cursor)) + (list (cons (symbol-name def-kind) (cdr spec)))))) + + ;; Not edebugging this form, so reset the symbol's edebug + ;; property to be just a marker at the definition's source code. + ;; This only works for defs with simple names. + (put def-name 'edebug (point-marker)) + ;; Also nil out dependent defs. + '(mapcar (function + (lambda (def) + (put def-name 'edebug nil))) + (get def-name 'edebug-dependents)) + (edebug-read-sexp))) + + ;; If all forms are being edebugged, explicitly wrap it. + (edebug-all-forms + (let ((cursor (edebug-new-cursor + (list (edebug-read-storing-offsets (current-buffer))) + (list edebug-offsets)))) + (edebug-make-form-wrapper + cursor + (edebug-before-offset cursor) + (edebug-after-offset cursor) + nil))) + + ;; Not a defining form, and not edebugging. + (t (edebug-read-sexp))))) + (funcall edebug-after-instrumentation-function result)))) (defvar edebug-def-args) ; args of defining form. (defvar edebug-def-interactive) ; is it an emacs interactive function? (defvar edebug-inside-func) ;; whether code is inside function context. ;; Currently def-form sets this to nil; def-body sets it to t. +(defvar edebug--cl-macrolet-defs) ;; Fully defined below. + (defun edebug-interactive-p-name () ;; Return a unique symbol for the variable used to store the ;; status of interactive-p for this function. @@ -1237,25 +1251,59 @@ circular objects. Let `read' read everything else." (defun edebug-unwrap (sexp) "Return the unwrapped SEXP or return it as is if it is not wrapped. The SEXP might be the result of wrapping a body, which is a list of -expressions; a `progn' form will be returned enclosing these forms." - (if (consp sexp) - (cond - ((eq 'edebug-after (car sexp)) - (nth 3 sexp)) - ((eq 'edebug-enter (car sexp)) - (macroexp-progn (nthcdr 2 (nth 1 (nth 3 sexp))))) - (t sexp);; otherwise it is not wrapped, so just return it. - ) - sexp)) +expressions; a `progn' form will be returned enclosing these forms. +Does not unwrap inside vectors, records, structures, or hash tables." + (pcase sexp + (`(edebug-after ,_before-form ,_after-index ,form) + form) + (`(lambda ,args (edebug-enter ',_sym ,_arglist + (function (lambda nil . ,body)))) + `(lambda ,args ,@body)) + (`(closure ,env ,args (edebug-enter ',_sym ,_arglist + (function (lambda nil . ,body)))) + `(closure ,env ,args ,@body)) + (`(edebug-enter ',_sym ,_args (function (lambda nil . ,body))) + (macroexp-progn body)) + (_ sexp))) (defun edebug-unwrap* (sexp) "Return the SEXP recursively unwrapped." + (let ((ht (make-hash-table :test 'eq))) + (edebug--unwrap1 sexp ht))) + +(defun edebug--unwrap1 (sexp hash-table) + "Unwrap SEXP using HASH-TABLE of things already unwrapped. +HASH-TABLE contains the results of unwrapping cons cells within +SEXP, which are reused to avoid infinite loops when SEXP is or +contains a circular object." (let ((new-sexp (edebug-unwrap sexp))) (while (not (eq sexp new-sexp)) (setq sexp new-sexp new-sexp (edebug-unwrap sexp))) (if (consp new-sexp) - (mapcar #'edebug-unwrap* new-sexp) + (let ((result (gethash new-sexp hash-table nil))) + (unless result + (let ((remainder new-sexp) + current) + (setq result (cons nil nil) + current result) + (while + (progn + (puthash remainder current hash-table) + (setf (car current) + (edebug--unwrap1 (car remainder) hash-table)) + (setq remainder (cdr remainder)) + (cond + ((atom remainder) + (setf (cdr current) + (edebug--unwrap1 remainder hash-table)) + nil) + ((gethash remainder hash-table nil) + (setf (cdr current) (gethash remainder hash-table nil)) + nil) + (t (setq current + (setf (cdr current) (cons nil nil))))))))) + result) new-sexp))) @@ -1333,7 +1381,6 @@ expressions; a `progn' form will be returned enclosing these forms." ;; (message "defining: %s" edebug-def-name) (sit-for 2) (edebug-make-top-form-data-entry form-data-entry) - (message "Edebug: %s" edebug-def-name) ;;(debug edebug-def-name) ;; Destructively reverse edebug-offset-list and make vector from it. @@ -1359,9 +1406,16 @@ expressions; a `progn' form will be returned enclosing these forms." edebug-offset-list edebug-top-window-data )) + + (funcall edebug-new-definition-function edebug-def-name) result ))) +(defun edebug-new-definition (def-name) + "Set up DEF-NAME to use Edebug's instrumentation functions." + (put def-name 'edebug-behavior 'edebug) + (message "Edebug: %s" def-name)) + (defun edebug-clear-frequency-count (name) ;; Create initial frequency count vector. @@ -1374,7 +1428,7 @@ expressions; a `progn' form will be returned enclosing these forms." ;; Create initial coverage vector. ;; Only need one per expression, but it is simpler to use stop points. (put name 'edebug-coverage - (make-vector (length edebug-offset-list) 'unknown))) + (make-vector (length edebug-offset-list) 'edebug-unknown))) (defun edebug-form (cursor) @@ -1431,6 +1485,11 @@ expressions; a `progn' form will be returned enclosing these forms." ;; Helper for edebug-list-form (let ((spec (get-edebug-spec head))) (cond + ;; Treat cl-macrolet bindings like macros with no spec. + ((member head edebug--cl-macrolet-defs) + (if edebug-eval-macro-args + (edebug-forms cursor) + (edebug-sexps cursor))) (spec (cond ((consp spec) @@ -1619,6 +1678,9 @@ expressions; a `progn' form will be returned enclosing these forms." ;; (function . edebug-match-function) (lambda-expr . edebug-match-lambda-expr) (cl-generic-method-args . edebug-match-cl-generic-method-args) + (cl-macrolet-expr . edebug-match-cl-macrolet-expr) + (cl-macrolet-name . edebug-match-cl-macrolet-name) + (cl-macrolet-body . edebug-match-cl-macrolet-body) (¬ . edebug-match-¬) (&key . edebug-match-&key) (place . edebug-match-place) @@ -1922,6 +1984,43 @@ expressions; a `progn' form will be returned enclosing these forms." (edebug-move-cursor cursor) (list args))) +(defvar edebug--cl-macrolet-defs nil + "List of symbols found within the bindings of enclosing `cl-macrolet' forms.") +(defvar edebug--current-cl-macrolet-defs nil + "List of symbols found within the bindings of the current `cl-macrolet' form.") + +(defun edebug-match-cl-macrolet-expr (cursor) + "Match a `cl-macrolet' form at CURSOR." + (let (edebug--current-cl-macrolet-defs) + (edebug-match cursor + '((&rest (&define cl-macrolet-name cl-macro-list + cl-declarations-or-string + def-body)) + cl-declarations cl-macrolet-body)))) + +(defun edebug-match-cl-macrolet-name (cursor) + "Match the name in a `cl-macrolet' binding at CURSOR. +Collect the names in `edebug--cl-macrolet-defs' where they +will be checked by `edebug-list-form-args' and treated as +macros without a spec." + (let ((name (edebug-top-element-required cursor "Expected name"))) + (when (not (symbolp name)) + (edebug-no-match cursor "Bad name:" name)) + ;; Change edebug-def-name to avoid conflicts with + ;; names at global scope. + (setq edebug-def-name (gensym "edebug-anon")) + (edebug-move-cursor cursor) + (push name edebug--current-cl-macrolet-defs) + (list name))) + +(defun edebug-match-cl-macrolet-body (cursor) + "Match the body of a `cl-macrolet' expression at CURSOR. +Put the definitions collected in `edebug--current-cl-macrolet-defs' +into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." + (let ((edebug--cl-macrolet-defs (nconc edebug--current-cl-macrolet-defs + edebug--cl-macrolet-defs))) + (edebug-match-body cursor))) + (defun edebug-match-arg (cursor) ;; set the def-args bound in edebug-defining-form (let ((edebug-arg (edebug-top-element-required cursor "Expected arg"))) @@ -2051,7 +2150,6 @@ expressions; a `progn' form will be returned enclosing these forms." (def-edebug-spec let* let) (def-edebug-spec setq (&rest symbolp form)) -(def-edebug-spec setq-default setq) (def-edebug-spec cond (&rest (&rest form))) @@ -2112,8 +2210,6 @@ expressions; a `progn' form will be returned enclosing these forms." ;;; The debugger itself -(defvar edebug-active nil) ;; Non-nil when edebug is active - (defvar edebug-stack nil) ;; Stack of active functions evaluated via edebug. ;; Should be nil at the top level. @@ -2181,7 +2277,21 @@ error is signaled again." ;;; Entering Edebug -(defun edebug-enter (function args body) +(defun edebug-enter (func args body) + "Enter Edebug for a function. +FUNC should be the symbol with the Edebug information, ARGS is +the list of arguments and BODY is the code. + +Look up the `edebug-behavior' for FUNC in `edebug-behavior-alist' +and run its entry function, and set up `edebug-before' and +`edebug-after'." + (cl-letf* ((behavior (get func 'edebug-behavior)) + (functions (cdr (assoc behavior edebug-behavior-alist))) + ((symbol-function 'edebug-before) (nth 1 functions)) + ((symbol-function 'edebug-after) (nth 2 functions))) + (funcall (nth 0 functions) func args body))) + +(defun edebug-default-enter (function args body) ;; Entering FUNC. The arguments are ARGS, and the body is BODY. ;; Setup edebug variables and evaluate BODY. This function is called ;; when a function evaluated with edebug-eval-top-level-form is entered. @@ -2202,17 +2312,21 @@ error is signaled again." (debugger edebug-debugger) ; only while edebug is active. (edebug-outside-debug-on-error debug-on-error) (edebug-outside-debug-on-quit debug-on-quit) + (outside-frame (selected-frame)) ;; Binding these may not be the right thing to do. ;; We want to allow the global values to be changed. (debug-on-error (or debug-on-error edebug-on-error)) (debug-on-quit edebug-on-quit)) (unwind-protect - (let ((signal-hook-function 'edebug-signal)) + (let ((signal-hook-function #'edebug-signal)) (setq edebug-execution-mode (or edebug-next-execution-mode edebug-initial-mode edebug-execution-mode) edebug-next-execution-mode nil) - (edebug-enter function args body)))) + (edebug-default-enter function args body)) + (if (and (frame-live-p outside-frame) + (not (memq (framep outside-frame) '(nil t pc)))) + (x-focus-frame outside-frame)))) (let* ((edebug-data (get function 'edebug)) (edebug-def-mark (car edebug-data)) ; mark at def start @@ -2331,32 +2445,37 @@ MSG is printed after `::::} '." value (edebug-debugger after-index 'after value) ))) - (defun edebug-fast-after (_before-index _after-index value) ;; Do nothing but return the value. value) (defun edebug-run-slow () - (defalias 'edebug-before 'edebug-slow-before) - (defalias 'edebug-after 'edebug-slow-after)) + "Set up Edebug's normal behavior." + (setf (cdr (assq 'edebug edebug-behavior-alist)) + '(edebug-default-enter edebug-slow-before edebug-slow-after))) ;; This is not used, yet. (defun edebug-run-fast () - (defalias 'edebug-before 'edebug-fast-before) - (defalias 'edebug-after 'edebug-fast-after)) - -(edebug-run-slow) + "Disable Edebug without de-instrumenting code." + (setf (cdr (assq 'edebug edebug-behavior-alist)) + '(edebug-default-enter edebug-fast-before edebug-fast-after))) +(defalias 'edebug-before nil + "Function called by Edebug before a form is evaluated. +See `edebug-behavior-alist' for implementations.") +(defalias 'edebug-after nil + "Function called by Edebug after a form is evaluated. +See `edebug-behavior-alist' for implementations.") (defun edebug--update-coverage (after-index value) (let ((old-result (aref edebug-coverage after-index))) (cond - ((eq 'ok-coverage old-result)) - ((eq 'unknown old-result) + ((eq 'edebug-ok-coverage old-result)) + ((eq 'edebug-unknown old-result) (aset edebug-coverage after-index value)) ;; Test if a different result. ((not (eq value old-result)) - (aset edebug-coverage after-index 'ok-coverage))))) + (aset edebug-coverage after-index 'edebug-ok-coverage))))) ;; Dynamically declared unbound variables. @@ -2516,6 +2635,8 @@ MSG is printed after `::::} '." (edebug-eval-display eval-result-list) ;; The evaluation list better not have deleted edebug-window-data. (select-window (car edebug-window-data)) + (if (not (memq (framep (selected-frame)) '(nil t pc))) + (x-focus-frame (selected-frame))) (set-buffer edebug-buffer) (setq edebug-buffer-outside-point (point)) @@ -2767,7 +2888,7 @@ MSG is printed after `::::} '." (recursive-edit) ; <<<<<<<<<< Recursive edit ;; Do the following, even if quit occurs. - (setq signal-hook-function 'edebug-signal) + (setq signal-hook-function #'edebug-signal) (if edebug-backtrace-buffer (kill-buffer edebug-backtrace-buffer)) @@ -3463,9 +3584,7 @@ Return the result of the last expression." "Evaluate an expression in the outside environment. If interactive, prompt for the expression. Print result in minibuffer." - (interactive (list (read-from-minibuffer - "Eval: " nil read-expression-map t - 'read-expression-history))) + (interactive (list (read--expression "Eval: "))) (princ (edebug-outside-excursion (setq values (cons (edebug-eval expr) values)) @@ -3495,14 +3614,14 @@ This prints the value into current buffer." ;;; Edebug Minor Mode +(define-obsolete-variable-alias 'gud-inhibit-global-bindings + 'edebug-inhibit-emacs-lisp-mode-bindings "24.3") + (defvar edebug-inhibit-emacs-lisp-mode-bindings nil "If non-nil, inhibit Edebug bindings on the C-x C-a key. By default, loading the `edebug' library causes these bindings to be installed in `emacs-lisp-mode-map'.") -(define-obsolete-variable-alias 'gud-inhibit-global-bindings - 'edebug-inhibit-emacs-lisp-mode-bindings "24.3") - ;; Global GUD bindings for all emacs-lisp-mode buffers. (unless edebug-inhibit-emacs-lisp-mode-bindings (define-key emacs-lisp-mode-map "\C-x\C-a\C-s" 'edebug-step-mode) @@ -3560,7 +3679,7 @@ be installed in `emacs-lisp-mode-map'.") ;; misc (define-key map "?" 'edebug-help) - (define-key map "d" 'edebug-backtrace) + (define-key map "d" 'edebug-pop-to-backtrace) (define-key map "-" 'negative-argument) @@ -3674,7 +3793,7 @@ Options: (if (consp setting) (set (car setting) (cdr setting)) (kill-local-variable setting)))) - (remove-hook 'kill-buffer-hook 'edebug-kill-buffer t)) + (remove-hook 'kill-buffer-hook #'edebug-kill-buffer t)) (pcase-dolist (`(,var . ,val) '((buffer-read-only . t))) (push (if (local-variable-p var) (cons var (symbol-value var)) var) @@ -3682,7 +3801,7 @@ Options: (set (make-local-variable var) val)) ;; Append `edebug-kill-buffer' to the hook to avoid interfering with ;; other entries that are unguarded against deleted buffer. - (add-hook 'kill-buffer-hook 'edebug-kill-buffer t t))) + (add-hook 'kill-buffer-hook #'edebug-kill-buffer t t))) (defun edebug-kill-buffer () "Used on `kill-buffer-hook' when Edebug is operating in a buffer of Lisp code." @@ -3818,8 +3937,10 @@ Global commands prefixed by `global-edebug-prefix': ;; (setq debugger 'debug) ; use the standard debugger ;; Note that debug and its utilities must be byte-compiled to work, -;; since they depend on the backtrace looking a certain way. But -;; edebug is not dependent on this, yet. +;; since they depend on the backtrace looking a certain way. Edebug +;; will work if not byte-compiled, but it will not be able correctly +;; remove its instrumentation from backtraces unless it is +;; byte-compiled. (defun edebug (&optional arg-mode &rest args) "Replacement for `debug'. @@ -3849,49 +3970,136 @@ Otherwise call `debug' normally." (apply #'debug arg-mode args) )) - -(defun edebug-backtrace () - "Display a non-working backtrace. Better than nothing..." +;;; Backtrace buffer + +(defvar-local edebug-backtrace-frames nil + "Stack frames of the current Edebug Backtrace buffer without instrumentation. +This should be a list of `edebug---frame' objects.") +(defvar-local edebug-instrumented-backtrace-frames nil + "Stack frames of the current Edebug Backtrace buffer with instrumentation. +This should be a list of `edebug---frame' objects.") + +;; Data structure for backtrace frames with information +;; from Edebug instrumentation found in the backtrace. +(cl-defstruct + (edebug--frame + (:constructor edebug--make-frame) + (:include backtrace-frame)) + def-name before-index after-index) + +(defun edebug-pop-to-backtrace () + "Display the current backtrace in a `backtrace-mode' window." (interactive) (if (or (not edebug-backtrace-buffer) (null (buffer-name edebug-backtrace-buffer))) (setq edebug-backtrace-buffer - (generate-new-buffer "*Backtrace*")) + (generate-new-buffer "*Edebug Backtrace*")) ;; Else, could just display edebug-backtrace-buffer. ) - (with-output-to-temp-buffer (buffer-name edebug-backtrace-buffer) - (setq edebug-backtrace-buffer standard-output) - (let ((print-escape-newlines t) - (print-length 50) ; FIXME cf edebug-safe-prin1-to-string - last-ok-point) - (backtrace) - - ;; Clean up the backtrace. - ;; Not quite right for current edebug scheme. - (set-buffer edebug-backtrace-buffer) - (setq truncate-lines t) - (goto-char (point-min)) - (setq last-ok-point (point)) - (if t (progn - - ;; Delete interspersed edebug internals. - (while (re-search-forward "^ (?edebug" nil t) - (beginning-of-line) - (cond - ((looking-at "^ (edebug-after") - ;; Previous lines may contain code, so just delete this line. - (setq last-ok-point (point)) - (forward-line 1) - (delete-region last-ok-point (point))) - - ((looking-at (if debugger-stack-frame-as-list - "^ (edebug" - "^ edebug")) - (forward-line 1) - (delete-region last-ok-point (point)) - ))) - ))))) + (pop-to-buffer edebug-backtrace-buffer) + (unless (derived-mode-p 'backtrace-mode) + (backtrace-mode) + (add-hook 'backtrace-goto-source-functions #'edebug--backtrace-goto-source)) + (setq edebug-instrumented-backtrace-frames + (backtrace-get-frames 'edebug-debugger + :constructor #'edebug--make-frame) + edebug-backtrace-frames (edebug--strip-instrumentation + edebug-instrumented-backtrace-frames) + backtrace-frames edebug-backtrace-frames) + (backtrace-print) + (goto-char (point-min))) + +(defun edebug--strip-instrumentation (frames) + "Return a new list of backtrace frames with instrumentation removed. +Remove frames for Edebug's functions and the lambdas in +`edebug-enter' wrappers. Fill in the def-name, before-index +and after-index fields in both FRAMES and the returned list +of deinstrumented frames, for those frames where the source +code location is known." + (let (skip-next-lambda def-name before-index after-index results + (index (length frames))) + (dolist (frame (reverse frames)) + (let ((new-frame (copy-edebug--frame frame)) + (fun (edebug--frame-fun frame)) + (args (edebug--frame-args frame))) + (cl-decf index) + (pcase fun + ('edebug-enter + (setq skip-next-lambda t + def-name (nth 0 args))) + ('edebug-after + (setq before-index (if (consp (nth 0 args)) + (nth 1 (nth 0 args)) + (nth 0 args)) + after-index (nth 1 args))) + ((pred edebug--symbol-not-prefixed-p) + (edebug--unwrap-frame new-frame) + (edebug--add-source-info new-frame def-name before-index after-index) + (edebug--add-source-info frame def-name before-index after-index) + (push new-frame results) + (setq before-index nil + after-index nil)) + (`(,(or 'lambda 'closure) . ,_) + (unless skip-next-lambda + (edebug--unwrap-frame new-frame) + (edebug--add-source-info frame def-name before-index after-index) + (edebug--add-source-info new-frame def-name before-index after-index) + (push new-frame results)) + (setq before-index nil + after-index nil + skip-next-lambda nil))))) + results)) + +(defun edebug--symbol-not-prefixed-p (sym) + "Return non-nil if SYM is a symbol not prefixed by \"edebug-\"." + (and (symbolp sym) + (not (string-prefix-p "edebug-" (symbol-name sym))))) + +(defun edebug--unwrap-frame (frame) + "Remove Edebug's instrumentation from FRAME. +Strip it from the function and any unevaluated arguments." + (setf (edebug--frame-fun frame) (edebug-unwrap* (edebug--frame-fun frame))) + (unless (edebug--frame-evald frame) + (let (results) + (dolist (arg (edebug--frame-args frame)) + (push (edebug-unwrap* arg) results)) + (setf (edebug--frame-args frame) (nreverse results))))) + +(defun edebug--add-source-info (frame def-name before-index after-index) + "Update FRAME with the additional info needed by an edebug--frame. +Save DEF-NAME, BEFORE-INDEX and AFTER-INDEX in FRAME." + (when (and before-index def-name) + (setf (edebug--frame-flags frame) + (plist-put (copy-sequence (edebug--frame-flags frame)) + :source-available t))) + (setf (edebug--frame-def-name frame) (and before-index def-name)) + (setf (edebug--frame-before-index frame) before-index) + (setf (edebug--frame-after-index frame) after-index)) + +(defun edebug--backtrace-goto-source () + (let* ((index (backtrace-get-index)) + (frame (nth index backtrace-frames))) + (when (edebug--frame-def-name frame) + (let* ((data (get (edebug--frame-def-name frame) 'edebug)) + (marker (nth 0 data)) + (offsets (nth 2 data))) + (pop-to-buffer (marker-buffer marker)) + (goto-char (+ (marker-position marker) + (aref offsets (edebug--frame-before-index frame)))))))) + +(defun edebug-backtrace-show-instrumentation () + "Show Edebug's instrumentation in an Edebug Backtrace buffer." + (interactive) + (unless (eq backtrace-frames edebug-instrumented-backtrace-frames) + (setq backtrace-frames edebug-instrumented-backtrace-frames) + (revert-buffer))) +(defun edebug-backtrace-hide-instrumentation () + "Hide Edebug's instrumentation in an Edebug Backtrace buffer." + (interactive) + (unless (eq backtrace-frames edebug-backtrace-frames) + (setq backtrace-frames edebug-backtrace-frames) + (revert-buffer))) ;;; Trace display @@ -3996,7 +4204,7 @@ reinstrument it." (max 0 (- col (- (point) start-of-count-line))) ?\s) (if (and (< 0 count) (not (memq coverage - '(unknown ok-coverage)))) + '(edebug-unknown edebug-ok-coverage)))) "=" "") (if (= count last-count) "" (int-to-string count)) " ") @@ -4065,7 +4273,7 @@ It is removed when you hit any char." ["Bounce to Current Point" edebug-bounce-point t] ["View Outside Windows" edebug-view-outside t] ["Previous Result" edebug-previous-result t] - ["Show Backtrace" edebug-backtrace t] + ["Show Backtrace" edebug-pop-to-backtrace t] ["Display Freq Count" edebug-display-freq-count t]) ("Eval" @@ -4171,8 +4379,8 @@ With prefix argument, make it a temporary breakpoint." ;; We still want to run unload-feature to completion (run-with-idle-timer 0 nil #'(lambda () (unload-feature 'edebug))))) (remove-hook 'called-interactively-p-functions - 'edebug--called-interactively-skip) - (remove-hook 'cl-read-load-hooks 'edebug--require-cl-read) + #'edebug--called-interactively-skip) + (remove-hook 'cl-read-load-hooks #'edebug--require-cl-read) (edebug-uninstall-read-eval-functions) ;; Continue standard unloading. nil) diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 62f4c82026e..534613811d4 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -3,7 +3,7 @@ ;;; Copyright (C) 2000-2002, 2004-2005, 2007-2019 Free Software ;;; Foundation, Inc. -;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Keywords: OO, lisp ;; Package: eieio @@ -71,7 +71,7 @@ All slots are unbound, except those initialized with PARAMS." (let ((nobj (if (stringp (car params)) (cl-call-next-method obj (pop params)) (cl-call-next-method obj)))) - (dolist (descriptor (eieio-class-slots (class-of nobj))) + (dolist (descriptor (eieio-class-slots (eieio-object-class nobj))) (let ((slot (eieio-slot-descriptor-name descriptor))) (slot-makeunbound nobj slot))) (when params @@ -506,12 +506,21 @@ instance." (cl-defmethod eieio-object-name-string ((obj eieio-named)) "Return a string which is OBJ's name." (or (slot-value obj 'object-name) - (symbol-name (eieio-object-class obj)))) + (cl-call-next-method))) -(cl-defmethod eieio-object-set-name-string ((obj eieio-named) name) +(cl-defgeneric eieio-object-set-name-string (obj name) "Set the string which is OBJ's NAME." + (declare (obsolete "inherit from `eieio-named' and use (setf (slot-value OBJ \\='object-name) NAME) instead" "25.1")) (cl-check-type name string) - (eieio-oset obj 'object-name name)) + (setf (gethash obj eieio--object-names) name)) +(define-obsolete-function-alias + 'object-set-name-string 'eieio-object-set-name-string "24.4") + +(with-suppressed-warnings ((obsolete eieio-object-set-name-string)) + (cl-defmethod eieio-object-set-name-string ((obj eieio-named) name) + "Set the string which is OBJ's NAME." + (cl-check-type name string) + (eieio-oset obj 'object-name name))) (cl-defmethod clone ((obj eieio-named) &rest params) "Clone OBJ, initializing `:parent' to OBJ. diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index 6d70e03381a..ea5a2839691 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el @@ -182,11 +182,11 @@ Summary: ;; `no-applicable-method', which have slightly different calling ;; convention than their cl-generic counterpart. (pcase method - (`no-next-method + ('no-next-method (setq method 'cl-no-next-method) (setq specializers `(generic method ,@specializers)) (lambda (_generic _method &rest args) (apply code args))) - (`no-applicable-method + ('no-applicable-method (setq method 'cl-no-applicable-method) (setq specializers `(generic ,@specializers)) (lambda (generic arg &rest args) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 4d55ed6e1d1..620b47e68d2 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -391,9 +391,9 @@ See `defclass' for more information." ;; Clean up the meaning of protection. (setq prot (pcase prot - ((or 'nil 'public ':public) nil) - ((or 'protected ':protected) 'protected) - ((or 'private ':private) 'private) + ((or 'nil 'public :public) nil) + ((or 'protected :protected) 'protected) + ((or 'private :private) 'private) (_ (signal 'invalid-slot-type (list :protection prot))))) ;; The default type specifier is supposed to be t, meaning anything. @@ -866,7 +866,6 @@ reverse-lookup that name, and recurse with the associated slot value." (if fn ;; Accessing a slot via its :initarg is accepted by EIEIO ;; (but not CLOS) but is a bad idea (for one: it's slower). - ;; FIXME: We should emit a compile-time warning when this happens! (eieio--slot-name-index class fn) nil))))) @@ -1086,6 +1085,11 @@ method invocation orders of the involved classes." These match if the argument is the name of a subclass of CLASS." (list eieio--generic-subclass-generalizer)) +(defmacro eieio-declare-slots (&rest slots) + "Declare that SLOTS are known eieio object slot names." + `(eval-when-compile + (setq eieio--known-slot-names (append ',slots eieio--known-slot-names)))) + (provide 'eieio-core) ;;; eieio-core.el ends here diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index e018883b442..350fca6d9ab 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -37,11 +37,6 @@ ;;; Compatibility -;; (eval-and-compile -;; (if (featurep 'xemacs) -;; (defalias 'eieio-overlay-lists (lambda () (list (extent-list)))) -;; (defalias 'eieio-overlay-lists 'overlay-lists))) - ;;; Code: (defclass eieio-widget-test-class nil ((a-string :initarg :a-string @@ -317,7 +312,8 @@ Optional argument IGNORE is an extraneous parameter." (car (widget-apply (car chil) :value-inline)))) (setq chil (cdr chil)))))) ;; Set any name updates on it. - (if name (eieio-object-set-name-string obj name)) + (when name + (setf (slot-value obj 'object-name) name)) ;; This is the same object we had before. obj)) @@ -466,8 +462,13 @@ Return the symbol for the group, or nil" ;; Make the association list (setq g (mapcar (lambda (g) (cons (symbol-name g) g)) g)) (cdr (assoc - (completing-read (concat (oref obj name) " Custom Group: ") - g nil t nil 'eieio-read-custom-group-history) + (completing-read + (concat + (if (slot-exists-p obj 'name) + (concat (slot-value obj (intern "name" obarray)) "") + "") + "Custom Group: ") + g nil t nil 'eieio-read-custom-group-history) g))))) (provide 'eieio-custom) diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index e93d317d936..f08c1de936b 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -32,6 +32,10 @@ (require 'find-func) (require 'speedbar) +;; We require cl-extra here instead of cl-lib because we need the +;; internal `cl--describe-class' function. +(require 'cl-extra) + ;;; Code: ;;;###autoload (defun eieio-browse (&optional root-class) @@ -155,8 +159,7 @@ are not abstract." (insert "\n\n[Class description not available until class definition is loaded.]\n") (save-excursion (insert (propertize "\n\nClass description:\n" 'face 'bold)) - (eieio-help-class ctr)) - )))) + (cl--describe-class ctr)))))) ;;; METHOD STATS @@ -327,7 +330,7 @@ current expansion depth." (defun eieio-sb-expand (text class indent) "For button TEXT, expand CLASS at the current location. Argument INDENT is the depth of indentation." - (cond ((string-match "+" text) ;we have to expand this file + (cond ((string-match "\\+" text) ;we have to expand this file (speedbar-change-expand-button-char ?-) (speedbar-with-writable (save-excursion diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el index 52dd6fea3fc..2dd9a5eda64 100644 --- a/lisp/emacs-lisp/eieio-speedbar.el +++ b/lisp/emacs-lisp/eieio-speedbar.el @@ -348,7 +348,7 @@ The object is at indentation level INDENT." (defun eieio-speedbar-object-expand (text token indent) "Expand object represented by TEXT. TOKEN is the object. INDENT is the current indentation level." - (cond ((string-match "+" text) ;we have to expand this file + (cond ((string-match "\\+" text) ;we have to expand this file (speedbar-change-expand-button-char ?-) (oset token expanded t) (speedbar-with-writable diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 864ac2616b9..4b899cdc64a 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -377,38 +377,37 @@ contents of field NAME is matched against PAT, or they can be of (define-obsolete-function-alias 'object-class-fast #'eieio-object-class "24.4") +;; In the past, every EIEIO object had a `name' field, so we had the +;; two methods `eieio-object-name-string' and +;; `eieio-object-set-name-string' "for free". Since this field is +;; very rarely used, we got rid of it and instead we keep it in a weak +;; hash-tables, for those very rare objects that use it. +;; Really, those rare objects should inherit from `eieio-named' instead! +(defconst eieio--object-names (make-hash-table :test #'eq :weakness 'key)) + (cl-defgeneric eieio-object-name-string (obj) "Return a string which is OBJ's name." - (declare (obsolete eieio-named "25.1"))) + (or (gethash obj eieio--object-names) + (format "%s-%x" (eieio-object-class obj) (sxhash-eq obj)))) + +(define-obsolete-function-alias + 'object-name-string #'eieio-object-name-string "24.4") (defun eieio-object-name (obj &optional extra) "Return a printed representation for object OBJ. If EXTRA, include that in the string returned to represent the symbol." (cl-check-type obj eieio-object) (format "#<%s %s%s>" (eieio-object-class obj) - (eieio-object-name-string obj) (or extra ""))) + (eieio-object-name-string obj) + (cond + ((null extra) + "") + ((listp extra) + (concat " " (mapconcat #'identity extra " "))) + (t + extra)))) (define-obsolete-function-alias 'object-name #'eieio-object-name "24.4") -(defconst eieio--object-names (make-hash-table :test #'eq :weakness 'key)) - -;; In the past, every EIEIO object had a `name' field, so we had the two method -;; below "for free". Since this field is very rarely used, we got rid of it -;; and instead we keep it in a weak hash-tables, for those very rare objects -;; that use it. -(cl-defmethod eieio-object-name-string (obj) - (or (gethash obj eieio--object-names) - (symbol-name (eieio-object-class obj)))) -(define-obsolete-function-alias - 'object-name-string #'eieio-object-name-string "24.4") - -(cl-defmethod eieio-object-set-name-string (obj name) - "Set the string which is OBJ's NAME." - (declare (obsolete eieio-named "25.1")) - (cl-check-type name string) - (setf (gethash obj eieio--object-names) name)) -(define-obsolete-function-alias - 'object-set-name-string 'eieio-object-set-name-string "24.4") - (defun eieio-object-class (obj) "Return the class struct defining OBJ." ;; FIXME: We say we return a "struct" but we return a symbol instead! @@ -829,8 +828,9 @@ Implement this method to customize the summary." (declare (obsolete cl-print-object "26.1")) (format "%S" this)) -(cl-defmethod object-print ((this eieio-default-superclass) &rest strings) - "Pretty printer for object THIS. Call function `object-name' with STRINGS. +(with-suppressed-warnings ((obsolete object-print)) + (cl-defmethod object-print ((this eieio-default-superclass) &rest strings) + "Pretty printer for object THIS. Call function `object-name' with STRINGS. The default method for printing object THIS is to use the function `object-name'. @@ -841,16 +841,28 @@ Implement this function and specify STRINGS in a call to `call-next-method' to provide additional summary information. When passing in extra strings from child classes, always remember to prepend a space." - (eieio-object-name this (apply #'concat strings))) + (eieio-object-name this (apply #'concat strings)))) +(with-suppressed-warnings ((obsolete object-print)) + (cl-defmethod cl-print-object ((object eieio-default-superclass) stream) + "Default printer for EIEIO objects." + ;; Fallback to the old `object-print'. There should be no + ;; `object-print' methods in the Emacs tree, but there may be some + ;; out-of-tree. + (princ (object-print object) stream))) -(cl-defmethod cl-print-object ((object eieio-default-superclass) stream) - "Default printer for EIEIO objects." - ;; Fallback to the old `object-print'. - (princ (object-print object) stream)) (defvar eieio-print-depth 0 - "When printing, keep track of the current indentation depth.") + "The current indentation depth while printing. +Ignored if `eieio-print-indentation' is nil.") + +(defvar eieio-print-indentation t + "When non-nil, indent contents of printed objects.") + +(defvar eieio-print-object-name t + "When non-nil write the object name in `object-write'. +Does not affect objects subclassing `eieio-named'. Note that +Emacs<26 requires that object names be present.") (cl-defgeneric object-write (this &optional comment) "Write out object THIS to the current stream. @@ -862,10 +874,11 @@ This writes out the vector version of this object. Complex and recursive object are discouraged from being written. If optional COMMENT is non-nil, include comments when outputting this object." - (when comment + (when (and comment eieio-print-object-name) (princ ";; Object ") (princ (eieio-object-name-string this)) - (princ "\n") + (princ "\n")) + (when comment (princ comment) (princ "\n")) (let* ((cl (eieio-object-class this)) @@ -874,12 +887,14 @@ this object." ;; It should look like this: ;; (<constructor> <name> <slot> <slot> ... ) ;; Each slot's slot is writen using its :writer. - (princ (make-string (* eieio-print-depth 2) ? )) + (when eieio-print-indentation + (princ (make-string (* eieio-print-depth 2) ? ))) (princ "(") (princ (symbol-name (eieio--class-constructor (eieio-object-class this)))) - (princ " ") - (prin1 (eieio-object-name-string this)) - (princ "\n") + (when eieio-print-object-name + (princ " ") + (prin1 (eieio-object-name-string this)) + (princ "\n")) ;; Loop over all the public slots (let ((slots (eieio--class-slots cv)) (eieio-print-depth (1+ eieio-print-depth))) @@ -892,7 +907,8 @@ this object." (unless (or (not i) (equal v (cl--slot-descriptor-initform slot))) (unless (bolp) (princ "\n")) - (princ (make-string (* eieio-print-depth 2) ? )) + (when eieio-print-indentation + (princ (make-string (* eieio-print-depth 2) ? ))) (princ (symbol-name i)) (if (alist-get :printer (cl--slot-descriptor-props slot)) ;; Use our public printer @@ -907,7 +923,7 @@ this object." "\n" " ")) (eieio-override-prin1 v)))))))) (princ ")") - (when (= eieio-print-depth 0) + (when (zerop eieio-print-depth) (princ "\n")))) (defun eieio-override-prin1 (thing) @@ -945,14 +961,16 @@ this object." (progn (princ "'") (prin1 list)) - (princ (make-string (* eieio-print-depth 2) ? )) + (when eieio-print-indentation + (princ (make-string (* eieio-print-depth 2) ? ))) (princ "(list") (let ((eieio-print-depth (1+ eieio-print-depth))) (while list (princ "\n") (if (eieio-object-p (car list)) (object-write (car list)) - (princ (make-string (* eieio-print-depth 2) ? )) + (when eieio-print-indentation + (princ (make-string (* eieio-print-depth) ? ))) (eieio-override-prin1 (car list))) (setq list (cdr list)))) (princ ")"))) diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 37db28f2a50..16b58632099 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1996-2019 Free Software Foundation, Inc. ;; Author: Noah Friedman <friedman@splode.com> -;; Maintainer: friedman@splode.com ;; Keywords: extensions ;; Created: 1995-10-06 @@ -177,9 +176,6 @@ printed after commands contained in this obarray." ;;;###autoload (define-minor-mode eldoc-mode "Toggle echo area display of Lisp objects at point (ElDoc mode). -With a prefix argument ARG, enable ElDoc mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable ElDoc mode -if ARG is omitted or nil. ElDoc mode is a buffer-local minor mode. When enabled, the echo area displays information about a function or variable in the @@ -360,12 +356,15 @@ return any documentation.") ;; This is run from post-command-hook or some idle timer thing, ;; so we need to be careful that errors aren't ignored. (with-demoted-errors "eldoc error: %s" - (and (or (eldoc-display-message-p) - ;; Erase the last message if we won't display a new one. - (when eldoc-last-message - (eldoc-message nil) - nil)) - (eldoc-message (funcall eldoc-documentation-function))))) + (if (not (eldoc-display-message-p)) + ;; Erase the last message if we won't display a new one. + (when eldoc-last-message + (eldoc-message nil)) + (let ((non-essential t)) + ;; Only keep looking for the info as long as the user hasn't + ;; requested our attention. This also locally disables inhibit-quit. + (while-no-input + (eldoc-message (funcall eldoc-documentation-function))))))) ;; If the entire line cannot fit in the echo area, the symbol name may be ;; truncated or eliminated entirely from the output to make room for the diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index a80d769415d..6927921bdac 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -463,21 +463,9 @@ Return nil if there are no more forms, t otherwise." ;; Import variable definitions ((memq (car form) '(require cc-require cc-require-when-compile)) (let ((name (eval (cadr form))) - (file (eval (nth 2 form))) - (elint-doing-cl (bound-and-true-p elint-doing-cl))) + (file (eval (nth 2 form)))) (unless (memq name elint-features) (add-to-list 'elint-features name) - ;; cl loads cl-macs in an opaque manner. - ;; Since cl-macs requires cl, we can just process cl-macs. - ;; FIXME: AFAIK, `cl' now behaves properly and does not need any - ;; special treatment any more. Can someone who understands this - ;; code confirm? --Stef - (and (eq name 'cl) (not elint-doing-cl) - ;; We need cl if elint-form is to be able to expand cl macros. - (require 'cl) - (setq name 'cl-macs - file nil - elint-doing-cl t)) ; blech (setq elint-env (elint-add-required-env elint-env name file)))))) elint-env) @@ -566,6 +554,7 @@ Return nil if there are no more forms, t otherwise." (defcustom . elint-check-defcustom-form) (macro . elint-check-macro-form) (condition-case . elint-check-condition-case-form) + (condition-case-unless-debug . elint-check-condition-case-form) (if . elint-check-conditional-form) (when . elint-check-conditional-form) (unless . elint-check-conditional-form) @@ -949,7 +938,7 @@ Does basic handling of `featurep' tests." ((and (memq func '(unless or)) (equal test '(featurep (quote emacs))))) ((and (eq func 'if) - (or (null test) ; eg custom-browse-insert-prefix + (or (null test) (member test '((featurep (quote xemacs)) (not (featurep (quote emacs))))) (and (eq (car-safe test) 'and) @@ -1107,7 +1096,7 @@ Marks the function with their arguments, and returns a list of variables." (set-buffer (get-buffer-create docbuf)) (insert-file-contents-literally (expand-file-name internal-doc-file-name doc-directory))) - (while (re-search-forward "\\([VF]\\)" nil t) + (while (re-search-forward "\^_\\([VF]\\)" nil t) (when (setq sym (intern-soft (buffer-substring (point) (line-end-position)))) (if (string-equal (match-string 1) "V") @@ -1116,7 +1105,7 @@ Marks the function with their arguments, and returns a list of variables." (if (boundp sym) (setq vars (cons sym vars))) ;; Function. (when (fboundp sym) - (when (re-search-forward "\\(^(fn.*)\\)?" nil t) + (when (re-search-forward "\\(^(fn.*)\\)?\^_" nil t) (backward-char 1) ;; FIXME distinguish no args from not found. (and (setq args (match-string 1)) diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index 2e83dce063d..f0dcb51af89 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -383,14 +383,13 @@ original definition, use \\[elp-restore-function] or \\[elp-restore-all]." ;; and return the results. (setq result (apply func args)) ;; we are recording times - (let (enter-time exit-time) + (let (enter-time) ;; increment the call-counter (cl-incf (aref info 0)) (setq enter-time (current-time) - result (apply func args) - exit-time (current-time)) + result (apply func args)) ;; calculate total time in function - (cl-incf (aref info 1) (elp-elapsed-time enter-time exit-time)) + (cl-incf (aref info 1) (elp-elapsed-time enter-time nil)) )) ;; turn off recording if this is the master function (if (and elp-master diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 6293abfeefa..da241e6304f 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -60,6 +60,7 @@ (require 'cl-lib) (require 'button) (require 'debug) +(require 'backtrace) (require 'easymenu) (require 'ewoc) (require 'find-func) @@ -472,18 +473,6 @@ Errors during evaluation are caught and handled like nil." ;; buffer. Perhaps explanations should be reported through `ert-info' ;; rather than as part of the condition. -(defun ert--proper-list-p (x) - "Return non-nil if X is a proper list, nil otherwise." - (cl-loop - for firstp = t then nil - for fast = x then (cddr fast) - for slow = x then (cdr slow) do - (when (null fast) (cl-return t)) - (when (not (consp fast)) (cl-return nil)) - (when (null (cdr fast)) (cl-return t)) - (when (not (consp (cdr fast))) (cl-return nil)) - (when (and (not firstp) (eq fast slow)) (cl-return nil)))) - (defun ert--explain-format-atom (x) "Format the atom X for `ert--explain-equal'." (pcase x @@ -494,17 +483,17 @@ 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." - (if (not (equal (type-of a) (type-of b))) + (if (not (eq (type-of a) (type-of b))) `(different-types ,a ,b) (pcase-exhaustive a ((pred consp) - (let ((a-proper-p (ert--proper-list-p a)) - (b-proper-p (ert--proper-list-p b))) - (if (not (eql (not a-proper-p) (not b-proper-p))) + (let ((a-length (proper-list-p a)) + (b-length (proper-list-p b))) + (if (not (eq (not a-length) (not b-length))) `(one-list-proper-one-improper ,a ,b) - (if a-proper-p - (if (not (equal (length a) (length b))) - `(proper-lists-of-different-length ,(length a) ,(length b) + (if a-length + (if (/= a-length b-length) + `(proper-lists-of-different-length ,a-length ,b-length ,a ,b first-mismatch-at ,(cl-mismatch a b :test 'equal)) @@ -523,7 +512,7 @@ Returns nil if they are." (cl-assert (equal a b) t) nil)))))))) ((pred arrayp) - (if (not (equal (length a) (length b))) + (if (/= (length a) (length b)) `(arrays-of-different-length ,(length a) ,(length b) ,a ,b ,@(unless (char-table-p a) @@ -676,6 +665,7 @@ and is displayed in front of the value of MESSAGE-FORM." (cl-defstruct ert-test-result (messages nil) (should-forms nil) + (duration 0) ) (cl-defstruct (ert-test-passed (:include ert-test-result))) (cl-defstruct (ert-test-result-with-condition (:include ert-test-result)) @@ -688,13 +678,6 @@ and is displayed in front of the value of MESSAGE-FORM." (cl-defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) -(defun ert--print-backtrace (backtrace do-xrefs) - "Format the backtrace BACKTRACE to the current buffer." - (let ((print-escape-newlines t) - (print-level 8) - (print-length 50)) - (debugger-insert-backtrace backtrace do-xrefs))) - ;; A container for the state of the execution of a single test and ;; environment data needed during its execution. (cl-defstruct ert--test-execution-info @@ -743,7 +726,7 @@ run. ARGS are the arguments to `debugger'." ;; use. ;; ;; Grab the frames above the debugger. - (backtrace (cdr (backtrace-frames debugger))) + (backtrace (cdr (backtrace-get-frames debugger))) (infos (reverse ert--infos))) (setf (ert--test-execution-info-result info) (cl-ecase type @@ -809,13 +792,13 @@ This mainly sets up debugger-related bindings." This can be useful after reducing the value of `message-log-max'." (with-current-buffer (messages-buffer) ;; This is a reimplementation of this part of message_dolog() in xdisp.c: - ;; if (NATNUMP (Vmessage_log_max)) + ;; if (FIXNATP (Vmessage_log_max)) ;; { ;; scan_newline (Z, Z_BYTE, BEG, BEG_BYTE, - ;; -XFASTINT (Vmessage_log_max) - 1, 0); - ;; del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, 0); + ;; -XFIXNAT (Vmessage_log_max) - 1, false); + ;; del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, false); ;; } - (when (and (integerp message-log-max) (>= message-log-max 0)) + (when (natnump message-log-max) (let ((begin (point-min)) (end (save-excursion (goto-char (point-max)) @@ -988,7 +971,7 @@ contained in UNIVERSE." test (ert-test-most-recent-result test)))) universe)) - (:unexpected (ert-select-tests `(not :expected) universe)) + (:unexpected (ert-select-tests '(not :expected) universe)) ((pred stringp) (pcase-exhaustive universe (`t (mapcar #'ert-get-test @@ -1230,6 +1213,11 @@ SELECTOR is the selector that was used to select TESTS." (ert-run-test test) (setf (aref (ert--stats-test-end-times stats) pos) (current-time)) (let ((result (ert-test-most-recent-result test))) + (setf (ert-test-result-duration result) + (float-time + (time-subtract + (aref (ert--stats-test-end-times stats) pos) + (aref (ert--stats-test-start-times stats) pos)))) (ert--stats-set-test-and-result stats pos test result) (funcall listener 'test-ended stats test result)) (setf (ert--stats-current-test stats) nil)))) @@ -1333,6 +1321,9 @@ RESULT must be an `ert-test-result-with-condition'." ;;; Running tests in batch mode. +(defvar ert-quiet nil + "Non-nil makes ERT only print important information in batch mode.") + ;;;###autoload (defun ert-run-tests-batch (&optional selector) "Run the tests specified by SELECTOR, printing results to the terminal. @@ -1349,28 +1340,32 @@ Returns the stats object." (lambda (event-type &rest event-args) (cl-ecase event-type (run-started - (cl-destructuring-bind (stats) event-args - (message "Running %s tests (%s)" - (length (ert--stats-tests stats)) - (ert--format-time-iso8601 (ert--stats-start-time stats))))) + (unless ert-quiet + (cl-destructuring-bind (stats) event-args + (message "Running %s tests (%s, selector `%S')" + (length (ert--stats-tests stats)) + (ert--format-time-iso8601 (ert--stats-start-time stats)) + selector)))) (run-ended (cl-destructuring-bind (stats abortedp) event-args (let ((unexpected (ert-stats-completed-unexpected stats)) (skipped (ert-stats-skipped stats)) (expected-failures (ert--stats-failed-expected stats))) - (message "\n%sRan %s tests, %s results as expected%s%s (%s)%s\n" + (message "\n%sRan %s tests, %s results as expected, %s unexpected%s (%s, %f sec)%s\n" (if (not abortedp) "" "Aborted: ") (ert-stats-total stats) (ert-stats-completed-expected stats) - (if (zerop unexpected) - "" - (format ", %s unexpected" unexpected)) + unexpected (if (zerop skipped) "" (format ", %s skipped" skipped)) (ert--format-time-iso8601 (ert--stats-end-time stats)) + (float-time + (time-subtract + (ert--stats-end-time stats) + (ert--stats-start-time stats))) (if (zerop expected-failures) "" (format "\n%s expected failures" expected-failures))) @@ -1403,9 +1398,8 @@ Returns the stats object." (ert-test-result-with-condition (message "Test %S backtrace:" (ert-test-name test)) (with-temp-buffer - (ert--print-backtrace - (ert-test-result-with-condition-backtrace result) - nil) + (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) @@ -1438,16 +1432,18 @@ Returns the stats object." (ert-test-name test))) (ert-test-quit (message "Quit during %S" (ert-test-name test))))) - (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) - (format-string (concat "%9s %" - (prin1-to-string (length max)) - "s/" max " %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))))))) + (unless ert-quiet + (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) + (format-string (concat "%9s %" + (prin1-to-string (length max)) + "s/" max " %S (%f sec)"))) + (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)))))))) nil)) ;;;###autoload @@ -1474,20 +1470,23 @@ the tests)." (kill-emacs 2)))) -(defun ert-summarize-tests-batch-and-exit () +(defun ert-summarize-tests-batch-and-exit (&optional high) "Summarize the results of testing. Expects to be called in batch mode, with logfiles as command-line arguments. The logfiles should have the `ert-run-tests-batch' format. When finished, -this exits Emacs, with status as per `ert-run-tests-batch-and-exit'." +this exits Emacs, with status as per `ert-run-tests-batch-and-exit'. + +If HIGH is a natural number, the HIGH long lasting tests are summarized." (or noninteractive (user-error "This function is only for use in batch mode")) + (or (natnump high) (setq high 0)) ;; Better crash loudly than attempting to recover from undefined ;; behavior. (setq attempt-stack-overflow-recovery nil attempt-orderly-shutdown-on-fatal-signal nil) (let ((nlogs (length command-line-args-left)) (ntests 0) (nrun 0) (nexpected 0) (nunexpected 0) (nskipped 0) - nnotrun logfile notests badtests unexpected skipped) + nnotrun logfile notests badtests unexpected skipped tests) (with-temp-buffer (while (setq logfile (pop command-line-args-left)) (erase-buffer) @@ -1504,36 +1503,52 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ (setq nrun (+ nrun (string-to-number (match-string 2))) nexpected (+ nexpected (string-to-number (match-string 3)))) (when (match-string 4) - (push logfile unexpected) - (setq nunexpected (+ nunexpected - (string-to-number (match-string 4))))) + (let ((n (string-to-number (match-string 4)))) + (unless (zerop n) + (push logfile unexpected) + (setq nunexpected (+ nunexpected n))))) (when (match-string 5) (push logfile skipped) (setq nskipped (+ nskipped - (string-to-number (match-string 5))))))))) + (string-to-number (match-string 5))))) + (unless (zerop high) + (goto-char (point-min)) + (while (< (point) (point-max)) + (if (looking-at "^\\s-+\\w+\\s-+[[:digit:]]+/[[:digit:]]+\\s-+\\S-+\\s-+(\\([.[:digit:]]+\\)\\s-+sec)$") + (push (cons (string-to-number (match-string 1)) + (match-string 0)) + tests)) + (forward-line))))))) (setq nnotrun (- ntests nrun)) (message "\nSUMMARY OF TEST RESULTS") (message "-----------------------") (message "Files examined: %d" nlogs) - (message "Ran %d tests%s, %d results as expected%s%s" + (message "Ran %d tests%s, %d results as expected, %d unexpected, %d skipped" nrun (if (zerop nnotrun) "" (format ", %d failed to run" nnotrun)) - nexpected - (if (zerop nunexpected) - "" - (format ", %d unexpected" nunexpected)) - (if (zerop nskipped) - "" - (format ", %d skipped" nskipped))) + nexpected nunexpected nskipped) (when notests (message "%d files did not contain any tests:" (length notests)) (mapc (lambda (l) (message " %s" l)) notests)) (when badtests (message "%d files did not finish:" (length badtests)) - (mapc (lambda (l) (message " %s" l)) badtests)) + (mapc (lambda (l) (message " %s" l)) badtests) + (if (getenv "EMACS_HYDRA_CI") + (with-temp-buffer + (dolist (f badtests) + (erase-buffer) + (insert-file-contents f) + (message "Contents of unfinished file %s:" f) + (message "-----\n%s\n-----" (buffer-string)))))) (when unexpected (message "%d files contained unexpected results:" (length unexpected)) (mapc (lambda (l) (message " %s" l)) unexpected)) + (unless (or (null tests) (zerop high)) + (message "\nLONG-RUNNING TESTS") + (message "------------------") + (setq tests (sort tests (lambda (x y) (> (car x) (car y))))) + (when (< high (length tests)) (setcdr (nthcdr (1- high) tests) nil)) + (message "%s" (mapconcat 'cdr tests "\n"))) ;; More details on hydra, where the logs are harder to get to. (when (and (getenv "EMACS_HYDRA_CI") (not (zerop (+ nunexpected nskipped)))) @@ -1541,7 +1556,8 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ (message "-------") (with-temp-buffer (dolist (x (list (list skipped "skipped" "SKIPPED") - (list unexpected "unexpected" "FAILED"))) + (list unexpected "unexpected" + "\\(?:FAILED\\|PASSED\\)"))) (mapc (lambda (l) (erase-buffer) (insert-file-contents l) @@ -1799,13 +1815,13 @@ determines how frequently the progress display is updated.") (force-mode-line-update) (redisplay t) (setf (ert--stats-next-redisplay stats) - (+ (float-time) ert-test-run-redisplay-interval-secs))) + (float-time (time-add nil ert-test-run-redisplay-interval-secs)))) (defun ert--results-update-stats-display-maybe (ewoc stats) "Call `ert--results-update-stats-display' if not called recently. EWOC and STATS are arguments for `ert--results-update-stats-display'." - (when (>= (float-time) (ert--stats-next-redisplay stats)) + (unless (time-less-p nil (ert--stats-next-redisplay stats)) (ert--results-update-stats-display ewoc stats))) (defun ert--tests-running-mode-line-indicator () @@ -2075,7 +2091,9 @@ and how to display message." ;;; Commands and button actions for the results buffer. (define-derived-mode ert-results-mode special-mode "ERT-Results" - "Major mode for viewing results of ERT test runs.") + "Major mode for viewing results of ERT test runs." + (setq-local revert-buffer-function + (lambda (&rest _) (ert-results-rerun-all-tests)))) (cl-loop for (key binding) in '( ;; Stuff that's not in the menu. @@ -2421,20 +2439,20 @@ To be used in the ERT results buffer." (cl-etypecase result (ert-test-passed (error "Test passed, no backtrace available")) (ert-test-result-with-condition - (let ((backtrace (ert-test-result-with-condition-backtrace result)) - (buffer (get-buffer-create "*ERT Backtrace*"))) + (let ((buffer (get-buffer-create "*ERT Backtrace*"))) (pop-to-buffer buffer) - (let ((inhibit-read-only t)) - (buffer-disable-undo) - (erase-buffer) - (ert-simple-view-mode) - (set-buffer-multibyte t) ; mimic debugger-setup-buffer - (setq truncate-lines t) - (ert--print-backtrace backtrace t) - (goto-char (point-min)) - (insert (substitute-command-keys "Backtrace for test `")) - (ert-insert-test-name-button (ert-test-name test)) - (insert (substitute-command-keys "':\n")))))))) + (unless (derived-mode-p 'backtrace-mode) + (backtrace-mode)) + (setq backtrace-insert-header-function + (lambda () (ert--insert-backtrace-header (ert-test-name test))) + backtrace-frames (ert-test-result-with-condition-backtrace result)) + (backtrace-print) + (goto-char (point-min))))))) + +(defun ert--insert-backtrace-header (name) + (insert (substitute-command-keys "Backtrace for test `")) + (ert-insert-test-name-button name) + (insert (substitute-command-keys "':\n"))) (defun ert-results-pop-to-messages-for-test-at-point () "Display the part of the *Messages* buffer generated during the test at point. @@ -2544,8 +2562,6 @@ To be used in the ERT results buffer." (defun ert-describe-test (test-or-test-name) "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)." (interactive (list (ert-read-test-name-at-point "Describe test"))) - (when (< emacs-major-version 24) - (user-error "Requires Emacs 24 or later")) (let (test-name test-definition) (cl-etypecase test-or-test-name @@ -2582,7 +2598,9 @@ To be used in the ERT results buffer." (insert (substitute-command-keys (or (ert-test-documentation test-definition) "It is not documented.")) - "\n"))))))) + "\n") + ;; For describe-symbol-backends. + (buffer-string))))))) (defun ert-results-describe-test-at-point () "Display the documentation of the test at point. @@ -2594,6 +2612,11 @@ To be used in the ERT results buffer." ;;; Actions on load/unload. +(require 'help-mode) +(add-to-list 'describe-symbol-backends + `("ERT test" ,#'ert-test-boundp + ,(lambda (s _b _f) (ert-describe-test s)))) + (add-to-list 'find-function-regexp-alist '(ert--test . ert--find-test-regexp)) (add-to-list 'minor-mode-alist '(ert--current-run-stats (:eval @@ -2608,7 +2631,7 @@ To be used in the ERT results buffer." 'ert--activate-font-lock-keywords) nil) -(defvar ert-unload-hook '()) +(defvar ert-unload-hook ()) (add-hook 'ert-unload-hook #'ert--unload-function) diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el index c454d150aaf..597afdd66f2 100644 --- a/lisp/emacs-lisp/ewoc.el +++ b/lisp/emacs-lisp/ewoc.el @@ -4,7 +4,7 @@ ;; Author: Per Cederqvist <ceder@lysator.liu.se> ;; Inge Wallin <inge@lysator.liu.se> -;; Maintainer: monnier@gnu.org +;; Maintainer: Stefan Monnier <monnier@gnu.org> ;; Created: 3 Aug 1992 ;; Keywords: extensions, lisp @@ -500,7 +500,7 @@ Return the node (or nil if we just passed the last node)." (defun ewoc-goto-node (ewoc node) "Move point to NODE in EWOC." - (ewoc--set-buffer-bind-dll ewoc + (with-current-buffer (ewoc--buffer ewoc) (goto-char (ewoc--node-start-marker node)) (if goal-column (move-to-column goal-column)) (setf (ewoc--last-node ewoc) node))) diff --git a/lisp/emacs-lisp/faceup.el b/lisp/emacs-lisp/faceup.el new file mode 100644 index 00000000000..7527f532c57 --- /dev/null +++ b/lisp/emacs-lisp/faceup.el @@ -0,0 +1,1180 @@ +;;; faceup.el --- Markup language for faces and font-lock regression testing -*- lexical-binding: t -*- + +;; Copyright (C) 2013-2019 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Version: 0.0.6 +;; Created: 2013-01-21 +;; Keywords: faces languages +;; URL: https://github.com/Lindydancer/faceup + +;; 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: + +;; Emacs is capable of highlighting buffers based on language-specific +;; `font-lock' rules. This package makes it possible to perform +;; regression test for packages that provide font-lock rules. +;; +;; The underlying idea is to convert text with highlights ("faces") +;; into a plain text representation using the Faceup markup +;; language. This language is semi-human readable, for example: +;; +;; «k:this» is a keyword +;; +;; By comparing the current highlight with a highlight performed with +;; stable versions of a package, it's possible to automatically find +;; problems that otherwise would have been hard to spot. +;; +;; This package is designed to be used in conjunction with Ert, the +;; standard Emacs regression test system. +;; +;; The Faceup markup language is a generic markup language, regression +;; testing is merely one way to use it. + +;; Regression test examples: +;; +;; This section describes the two typical ways regression testing with +;; this package is performed. +;; +;; +;; Full source file highlighting: +;; +;; The most straight-forward way to perform regression testing is to +;; collect a number of representative source files. From each source +;; file, say `alpha.mylang', you can use `M-x faceup-write-file RET' +;; to generate a Faceup file named `alpha.mylang.faceup', this file +;; use the Faceup markup language to represent the text with +;; highlights and is used as a reference in future tests. +;; +;; An Ert test case can be defined as follows: +;; +;; (require 'faceup) +;; +;; (defvar mylang-font-lock-test-dir (faceup-this-file-directory)) +;; +;; (defun mylang-font-lock-test-apps (file) +;; "Test that the mylang FILE is fontifies as the .faceup file describes." +;; (faceup-test-font-lock-file 'mylang-mode +;; (concat mylang-font-lock-test-dir file))) +;; (faceup-defexplainer mylang-font-lock-test-apps) +;; +;; (ert-deftest mylang-font-lock-file-test () +;; (should (mylang-font-lock-test-apps "apps/FirstApp/alpha.mylang")) +;; ;; ... Add more test files here ... +;; ) +;; +;; To execute the tests, run something like `M-x ert RET t RET'. +;; +;; +;; Source snippets: +;; +;; To test smaller snippets of code, you can use the +;; `faceup-test-font-lock-string'. It takes a major mode and a string +;; written using the Faceup markup language. The functions strips away +;; the Faceup markup, inserts the plain text into a temporary buffer, +;; highlights it, converts the result back into the Faceup markup +;; language, and finally compares the result with the original Faceup +;; string. +;; +;; For example: +;; +;; (defun mylang-font-lock-test (faceup) +;; (faceup-test-font-lock-string 'mylang-mode faceup)) +;; (faceup-defexplainer mylang-font-lock-test) +;; +;; (ert-deftest mylang-font-lock-test-simple () +;; "Simple MyLang font-lock tests." +;; (should (mylang-font-lock-test "«k:this» is a keyword")) +;; (should (mylang-font-lock-test "«k:function» «f:myfunc» («v:var»)"))) +;; + +;; Executing the tests: +;; +;; Once the tests have been defined, you can use `M-x ert RET t RET' +;; to execute them. Hopefully, you will be given the "all clear". +;; However, if there is a problem, you will be presented with +;; something like: +;; +;; F mylang-font-lock-file-test +;; (ert-test-failed +;; ((should +;; (mylang-font-lock-test-apps "apps/FirstApp/alpha.mylang")) +;; :form +;; (mylang-font-lock-test-apps "apps/FirstApp/alpha.mylang") +;; :value nil :explanation +;; ((on-line 2 +;; ("but_«k:this»_is_not_a_keyword") +;; ("but_this_is_not_a_keyword"))))) +;; +;; You should read this that on line 2, the old font-lock rules +;; highlighted `this' inside `but_this_is_not_a_keyword' (which is +;; clearly wrong), whereas the new doesn't. Of course, if this is the +;; desired result (for example, the result of a recent change) you can +;; simply regenerate the .faceup file and store it as the reference +;; file for the future. + +;; The Faceup markup language: +;; +;; The Faceup markup language is designed to be human-readable and +;; minimalistic. +;; +;; The two special characters `«' and `»' marks the start and end of a +;; range of a face. +;; +;; +;; Compact format for special faces: +;; +;; The compact format `«<LETTER>:text»' is used for a number of common +;; faces. For example, `«U:abc»' means that the text `abc' is +;; underlined. +;; +;; See `faceup-face-short-alist' for the known faces and the +;; corresponding letter. +;; +;; +;; Full format: +;; +;; The format `«:<NAME OF FACE>:text»' is used use to encode other +;; faces. +;; +;; For example `«:my-special-face:abc»' meanst that `abc' has the face +;; `my-special-face'. +;; +;; +;; Anonymous faces: +;; +;; An "anonymous face" is when the `face' property contains a property +;; list (plist) on the form `(:key value)'. This is represented using +;; a variant of the full format: `«:(:key value):text»'. +;; +;; For example, `«:(:background "red"):abc»' represent the text `abc' +;; with a red background. +;; +;; +;; Multiple properties: +;; +;; In case a text contains more than one face property, they are +;; represented using nested sections. +;; +;; For example: +;; +;; * `«B:abc«U:def»»' represent the text `abcdef' that is both *bold* +;; and *underlined*. +;; +;; * `«W:abc«U:def»ghi»' represent the text `abcdefghi' where the +;; entire text is in *warning* face and `def' is *underlined*. +;; +;; In case two faces partially overlap, the ranges will be split when +;; represented in Faceup. For example: +;; +;; * `«B:abc«U:def»»«U:ghi»' represent the text `abcdefghi' where +;; `abcdef' is bold and `defghi' is underlined. +;; +;; +;; Escaping start and end markers: +;; +;; Any occurrence of the start or end markers in the original text +;; will be escaped using the start marker in the Faceup +;; representation. In other words, the sequences `««' and `«»' +;; represent a start and end marker, respectively. +;; +;; +;; Other properties: +;; +;; In addition to representing the `face' property (or, more +;; correctly, the value of `faceup-default-property') other properties +;; can be encoded. The variable `faceup-properties' contains a list of +;; properties to track. If a property behaves like the `face' +;; property, it is encoded as described above, with the addition of +;; the property name placed in parentheses, for example: +;; `«(my-face)U:abd»'. +;; +;; The variable `faceup-face-like-properties' contains a list of +;; properties considered face-like. +;; +;; Properties that are not considered face-like are always encoded +;; using the full format and the don't nest. For example: +;; `«(my-fibonacci-property):(1 1 2 3 5 8):abd»'. +;; +;; Examples of properties that could be tracked are: +;; +;; * `font-lock-face' -- an alias to `face' when `font-lock-mode' is +;; enabled. +;; +;; * `syntax-table' -- used by a custom `syntax-propertize' to +;; override the default syntax table. +;; +;; * `help-echo' -- provides tooltip text displayed when the mouse is +;; held over a text. + +;; Reference section: +;; +;; Faceup commands and functions: +;; +;; `M-x faceup-write-file RET' - generate a Faceup file based on the +;; current buffer. +;; +;; `M-x faceup-view-file RET' - view the current buffer converted to +;; Faceup. +;; +;; `faceup-markup-{string,buffer}' - convert text with properties to +;; the Faceup markup language. +;; +;; `faceup-render-view-buffer' - convert buffer with Faceup markup to +;; a buffer with real text properties and display it. +;; +;; `faceup-render-string' - return string with real text properties +;; from a string with Faceup markup. +;; +;; `faceup-render-to-{buffer,string}' - convert buffer with Faceup +;; markup to a buffer/string with real text properties. +;; +;; `faceup-clean-{buffer,string}' - remove Faceup markup from buffer +;; or string. +;; +;; +;; Regression test support: +;; +;; The following functions can be used as Ert test functions, or can +;; be used to implement new Ert test functions. +;; +;; `faceup-test-equal' - Test function, work like Ert:s `equal', but +;; more ergonomically when reporting multi-line string errors. +;; Concretely, it breaks down multi-line strings into lines and +;; reports which line number the error occurred on and the content of +;; that line. +;; +;; `faceup-test-font-lock-buffer' - Test that a buffer is highlighted +;; according to a reference Faceup text, for a specific major mode. +;; +;; `faceup-test-font-lock-string' - Test that a text with Faceup +;; markup is refontified to match the original Faceup markup. +;; +;; `faceup-test-font-lock-file' - Test that a file is highlighted +;; according to a reference .faceup file. +;; +;; `faceup-defexplainer' - Macro, define an explainer function and set +;; the `ert-explainer' property on the original function, for +;; functions based on the above test functions. +;; +;; `faceup-this-file-directory' - Macro, the directory of the current +;; file. + +;; Real-world examples: +;; +;; The following are examples of real-world package that use faceup to +;; test their font-lock keywords. +;; +;; * [cmake-font-lock](https://github.com/Lindydancer/cmake-font-lock) +;; an advanced set of font-lock keywords for the CMake language +;; +;; * [objc-font-lock](https://github.com/Lindydancer/objc-font-lock) +;; highlight Objective-C function calls. +;; + +;; Other Font Lock Tools: +;; +;; This package is part of a suite of font-lock tools. The other +;; tools in the suite are: +;; +;; +;; Font Lock Studio: +;; +;; Interactive debugger for font-lock keywords (Emacs syntax +;; highlighting rules). +;; +;; Font Lock Studio lets you *single-step* Font Lock keywords -- +;; matchers, highlights, and anchored rules, so that you can see what +;; happens when a buffer is fontified. You can set *breakpoints* on +;; or inside rules and *run* until one has been hit. When inside a +;; rule, matches are *visualized* using a palette of background +;; colors. The *explainer* can describe a rule in plain-text English. +;; Tight integration with *Edebug* allows you to step into Lisp +;; expressions that are part of the Font Lock keywords. +;; +;; +;; Font Lock Profiler: +;; +;; A profiler for font-lock keywords. This package measures time and +;; counts the number of times each part of a font-lock keyword is +;; used. For matchers, it counts the total number and the number of +;; successful matches. +;; +;; The result is presented in table that can be sorted by count or +;; time. The table can be expanded to include each part of the +;; font-lock keyword. +;; +;; In addition, this package can generate a log of all font-lock +;; events. This can be used to verify font-lock implementations, +;; concretely, this is used for back-to-back tests of the real +;; font-lock engine and Font Lock Studio, an interactive debugger for +;; font-lock keywords. +;; +;; +;; Highlight Refontification: +;; +;; Minor mode that visualizes how font-lock refontifies a buffer. +;; This is useful when developing or debugging font-lock keywords, +;; especially for keywords that span multiple lines. +;; +;; The background of the buffer is painted in a rainbow of colors, +;; where each band in the rainbow represent a region of the buffer +;; that has been refontified. When the buffer is modified, the +;; rainbow is updated. +;; +;; +;; Face Explorer: +;; +;; Library and tools for faces and text properties. +;; +;; This library is useful for packages that convert syntax highlighted +;; buffers to other formats. The functions can be used to determine +;; how a face or a face text property looks, in terms of primitive +;; face attributes (e.g. foreground and background colors). Two sets +;; of functions are provided, one for existing frames and one for +;; fictitious displays, like 8 color tty. +;; +;; In addition, the following tools are provided: +;; +;; - `face-explorer-list-faces' -- list all available faces. Like +;; `list-faces-display' but with information on how a face is +;; defined. In addition, a sample for the selected frame and for a +;; fictitious display is shown. +;; +;; - `face-explorer-describe-face' -- Print detailed information on +;; how a face is defined, and list all underlying definitions. +;; +;; - `face-explorer-describe-face-prop' -- Describe the `face' text +;; property at the point in terms of primitive face attributes. +;; Also show how it would look on a fictitious display. +;; +;; - `face-explorer-list-display-features' -- Show which features a +;; display supports. Most graphical displays support all, or most, +;; features. However, many tty:s don't support, for example, +;; strike-through. Using specially constructed faces, the resulting +;; buffer will render differently in different displays, e.g. a +;; graphical frame and a tty connected using `emacsclient -nw'. +;; +;; - `face-explorer-list-face-prop-examples' -- Show a buffer with an +;; assortment of `face' text properties. A sample text is shown in +;; four variants: Native, a manually maintained reference vector, +;; the result of `face-explorer-face-prop-attributes' and +;; `face-explorer-face-prop-attributes-for-fictitious-display'. Any +;; package that convert a buffer to another format (like HTML, ANSI, +;; or LaTeX) could use this buffer to ensure that everything work as +;; intended. +;; +;; - `face-explorer-list-overlay-examples' -- Show a buffer with a +;; number of examples of overlays, some are mixed with `face' text +;; properties. Any package that convert a buffer to another format +;; (like HTML, ANSI, or LaTeX) could use this buffer to ensure that +;; everything work as intended. +;; +;; - `face-explorer-tooltip-mode' -- Minor mode that shows tooltips +;; containing text properties and overlays at the mouse pointer. +;; +;; - `face-explorer-simulate-display-mode' -- Minor mode for make a +;; buffer look like it would on a fictitious display. Using this +;; you can, for example, see how a theme would look in using dark or +;; light background, a 8 color tty, or on a grayscale graphical +;; monitor. +;; +;; +;; Font Lock Regression Suite: +;; +;; A collection of example source files for a large number of +;; programming languages, with ERT tests to ensure that syntax +;; highlighting does not accidentally change. +;; +;; For each source file, font-lock reference files are provided for +;; various Emacs versions. The reference files contains a plain-text +;; representation of source file with syntax highlighting, using the +;; format "faceup". +;; +;; Of course, the collection source file can be used for other kinds +;; of testing, not limited to font-lock regression testing. + +;;; Code: + + +(defvar faceup-default-property 'face + "The property that should be represented in Faceup without the (prop) part.") + +(defvar faceup-properties '(face) + "List of properties that should be converted to the Faceup format. + +Only face-like property use the short format. All other use the +non-nesting full format. (See `faceup-face-like-properties'.)" ) + + +(defvar faceup-face-like-properties '(face font-lock-face) + "List of properties that behave like `face'. + +The following properties are assumed about face-like properties: + +* Elements are either symbols or property lists, or lists thereof. + +* A plain element and a list containing the same element are + treated as equal + +* Property lists and sequences of property lists are considered + equal. For example: + + ((:underline t :foreground \"red\")) + + and + + ((:underline t) (:foreground \"red\")) + +Face-like properties are converted to faceup in a nesting fashion. + +For example, the string AAAXXXAAA (where the property `prop' has +the value `(a)' on the A:s and `(a b)' on the X:s) is converted +as follows, when treated as a face-like property: + + «(prop):a:AAA«(prop):b:XXX»AAAA» + +When treated as a non-face-like property: + + «(prop):(a):AAA»«(prop):(a b):XXX»«(prop):(a):AAA»") + + +(defvar faceup-markup-start-char ?«) +(defvar faceup-markup-end-char ?») + +(defvar faceup-face-short-alist + '(;; Generic faces (uppercase letters) + (bold . "B") + (bold-italic . "Q") + (default . "D") + (error . "E") + (highlight . "H") + (italic . "I") + (underline . "U") + (warning . "W") + ;; font-lock-specific faces (lowercase letters) + (font-lock-builtin-face . "b") + (font-lock-comment-delimiter-face . "m") + (font-lock-comment-face . "x") + (font-lock-constant-face . "c") + (font-lock-doc-face . "d") + (font-lock-function-name-face . "f") + (font-lock-keyword-face . "k") + (font-lock-negation-char-face . "n") + (font-lock-preprocessor-face . "p") + (font-lock-regexp-grouping-backslash . "h") + (font-lock-regexp-grouping-construct . "o") + (font-lock-string-face . "s") + (font-lock-type-face . "t") + (font-lock-variable-name-face . "v") + (font-lock-warning-face . "w")) + "Alist from faces to one-character representation.") + + +;; Plain: «W....» +;; Nested: «W...«W...»» + +;; Overlapping: xxxxxxxxxx +;; yyyyyyyyyyyy +;; «X..«Y..»»«Y...» + + +(defun faceup-markup-string (s) + "Return the faceup version of the string S." + (with-temp-buffer + (insert s) + (faceup-markup-buffer))) + + +;;;###autoload +(defun faceup-view-buffer () + "Display the faceup representation of the current buffer." + (interactive) + (let ((buffer (get-buffer-create "*FaceUp*"))) + (with-current-buffer buffer + (delete-region (point-min) (point-max))) + (faceup-markup-to-buffer buffer) + (display-buffer buffer))) + + +;;;###autoload +(defun faceup-write-file (&optional file-name confirm) + "Save the faceup representation of the current buffer to the file FILE-NAME. + +Unless a name is given, the file will be named xxx.faceup, where +xxx is the file name associated with the buffer. + +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 + (let ((suggested-name (and (buffer-file-name) + (concat (buffer-file-name) + ".faceup")))) + (list (read-file-name "Write faceup file: " + default-directory + suggested-name + nil + (file-name-nondirectory suggested-name)) + (not current-prefix-arg)))) + (unless file-name + (setq file-name (concat (buffer-file-name) ".faceup"))) + (let ((buffer (current-buffer))) + (with-temp-buffer + (faceup-markup-to-buffer (current-buffer) buffer) + ;; Note: Must set `require-final-newline' inside + ;; `with-temp-buffer', otherwise the value will be overridden by + ;; the buffers local value. + ;; + ;; Clear `window-size-change-functions' as a workaround for + ;; Emacs bug#19576 (`write-file' saves the wrong buffer if a + ;; function in the list change current buffer). + (let ((require-final-newline nil) + (window-size-change-functions '())) + (write-file file-name confirm))))) + + +(defun faceup-markup-buffer () + "Return a string with the content of the buffer using faceup markup." + (let ((buf (current-buffer))) + (with-temp-buffer + (faceup-markup-to-buffer (current-buffer) buf) + (buffer-substring-no-properties (point-min) (point-max))))) + + +;; Idea: +;; +;; Typically, only one face is used. However, when two faces are used, +;; the one of top is typically shorter. Hence, the faceup variant +;; should treat the inner group of nested ranges the upper (i.e. the +;; one towards the front.) For example: +;; +;; «f:aaaaaaa«U:xxxx»aaaaaa» + +(defun faceup-copy-and-quote (start end to-buffer) + "Quote and insert the text between START and END into TO-BUFFER." + (let ((not-markup (concat "^" + (make-string 1 faceup-markup-start-char) + (make-string 1 faceup-markup-end-char)))) + (save-excursion + (goto-char start) + (while (< (point) end) + (let ((old (point))) + (skip-chars-forward not-markup end) + (let ((s (buffer-substring-no-properties old (point)))) + (with-current-buffer to-buffer + (insert s)))) + ;; Quote stray markup characters. + (unless (= (point) end) + (let ((next-char (following-char))) + (with-current-buffer to-buffer + (insert faceup-markup-start-char) + (insert next-char))) + (forward-char)))))) + + +;; A face (string or symbol) can be on the top level. +;; +;; A face text property can be a arbitrary deep lisp structure. Each +;; list in the tree structure contains faces (symbols or strings) up +;; to the first keyword, e.g. :foreground, thereafter the list is +;; considered a property list, regardless of the content. A special +;; case are `(foreground-color . COLOR)' and `(background-color +;; . COLOR)', old forms used to represent the foreground and +;; background colors, respectively. +;; +;; Some of this is undocumented, and took some effort to reverse +;; engineer. +(defun faceup-normalize-face-property (value) + "Normalize VALUES into a list of faces and (KEY VALUE) entries." + (cond ((null value) + '()) + ((symbolp value) + (list value)) + ((stringp value) + (list (intern value))) + ((consp value) + (cond ((eq (car value) 'foreground-color) + (list (list :foreground (cdr value)))) + ((eq (car value) 'background-color) + (list (list :background (cdr value)))) + (t + ;; A list + (if (keywordp (car value)) + ;; Once a keyword has been seen, the rest of the + ;; list is treated as a property list, regardless + ;; of what it contains. + (let ((res '())) + (while value + (let ((key (pop value)) + (val (pop value))) + (when (keywordp key) + (push (list key val) res)))) + res) + (append + (faceup-normalize-face-property (car value)) + (faceup-normalize-face-property (cdr value))))))) + (t + (error "Unexpected text property %s" value)))) + + +(defun faceup-get-text-properties (pos) + "Alist of properties and values at POS. + +Face-like properties are normalized -- value is a list of +faces (symbols) and short (KEY VALUE) lists. The list is +reversed to that later elements take precedence over earlier." + (let ((res '())) + (dolist (prop faceup-properties) + (let ((value (get-text-property pos prop))) + (when value + (when (memq prop faceup-face-like-properties) + ;; Normalize face-like properties. + (setq value (reverse (faceup-normalize-face-property value)))) + (push (cons prop value) res)))) + res)) + + +(defun faceup-markup-to-buffer (to-buffer &optional buffer) + "Convert content of BUFFER to faceup form and insert in TO-BUFFER." + (save-excursion + (if buffer + (set-buffer buffer)) + ;; Font-lock often only fontifies the visible sections. This + ;; ensures that the entire buffer is fontified before converting + ;; it. + (if (and font-lock-mode + ;; Prevent clearing out face attributes explicitly + ;; inserted by functions like `list-faces-display'. + ;; (Font-lock mode is enabled, for some reason, in those + ;; buffers.) + (not (and (eq major-mode 'help-mode) + (not font-lock-defaults)))) + (font-lock-fontify-region (point-min) (point-max))) + (let ((last-pos (point-min)) + (pos nil) + ;; List of (prop . value), representing open faceup blocks. + (state '())) + (while (setq pos (faceup-next-property-change pos)) + ;; Insert content. + (faceup-copy-and-quote last-pos pos to-buffer) + (setq last-pos pos) + (let ((prop-values (faceup-get-text-properties pos))) + (let ((next-state '())) + (setq state (reverse state)) + ;; Find all existing sequences that should continue. + (let ((cont t)) + (while (and state + prop-values + cont) + (let* ((prop (car (car state))) + (value (cdr (car state))) + (pair (assq prop prop-values))) + (if (memq prop faceup-face-like-properties) + ;; Element by element. + (if (equal value (car (cdr pair))) + (setcdr pair (cdr (cdr pair))) + (setq cont nil)) + ;; Full value. + ;; + ;; Note: Comparison is done by `eq', since (at + ;; least) the `display' property treats + ;; eq-identical values differently than when + ;; comparing using `equal'. See "Display Specs + ;; That Replace The Text" in the elisp manual. + (if (eq value (cdr pair)) + (setq prop-values (delq pair prop-values)) + (setq cont nil)))) + (when cont + (push (pop state) next-state)))) + ;; End values that should not be included in the next state. + (while state + (with-current-buffer to-buffer + (insert (make-string 1 faceup-markup-end-char))) + (pop state)) + ;; Start new ranges. + (with-current-buffer to-buffer + (while prop-values + (let ((pair (pop prop-values))) + (if (memq (car pair) faceup-face-like-properties) + ;; Face-like. + (dolist (element (cdr pair)) + (insert (make-string 1 faceup-markup-start-char)) + (unless (eq (car pair) faceup-default-property) + (insert "(") + (insert (symbol-name (car pair))) + (insert "):")) + (if (symbolp element) + (let ((short + (assq element faceup-face-short-alist))) + (if short + (insert (cdr short) ":") + (insert ":" (symbol-name element) ":"))) + (insert ":") + (prin1 element (current-buffer)) + (insert ":")) + (push (cons (car pair) element) next-state)) + ;; Not face-like. + (insert (make-string 1 faceup-markup-start-char)) + (insert "(") + (insert (symbol-name (car pair))) + (insert "):") + (prin1 (cdr pair) (current-buffer)) + (insert ":") + (push pair next-state))))) + ;; Insert content. + (setq state next-state)))) + ;; Insert whatever is left after the last face change. + (faceup-copy-and-quote last-pos (point-max) to-buffer)))) + + + +;; Some basic facts: +;; +;; (get-text-property (point-max) ...) always return nil. To check the +;; last character in the buffer, use (- (point-max) 1). +;; +;; If a text has more than one face, the first one in the list +;; takes precedence, when being viewed in Emacs. +;; +;; (let ((s "ABCDEF")) +;; (set-text-properties 1 4 +;; '(face (font-lock-warning-face font-lock-variable-name-face)) s) +;; (insert s)) +;; +;; => ABCDEF +;; +;; Where DEF is drawn in "warning" face. + + +(defun faceup-has-any-text-property (pos) + "True if any properties in `faceup-properties' are defined at POS." + (let ((res nil)) + (dolist (prop faceup-properties) + (when (get-text-property pos prop) + (setq res t))) + res)) + + +(defun faceup-next-single-property-change (pos) + "Next position a property in `faceup-properties' changes after POS, or nil." + (let ((res nil)) + (dolist (prop faceup-properties) + (let ((next (next-single-property-change pos prop))) + (when next + (setq res (if res + (min res next) + next))))) + res)) + + +(defun faceup-next-property-change (pos) + "Next position after POS where one of the tracked properties change. + +If POS is nil, also include `point-min' in the search. +If last character contains a tracked property, return `point-max'. + +See `faceup-properties' for a list of tracked properties." + (if (eq pos (point-max)) + ;; Last search returned `point-max'. There is no more to search + ;; for. + nil + (if (and (null pos) + (faceup-has-any-text-property (point-min))) + ;; `pos' is `nil' and the character at `point-min' contains a + ;; tracked property, return `point-min'. + (point-min) + (unless pos + ;; Start from the beginning. + (setq pos (point-min))) + ;; Do a normal search. Compensate for that + ;; `next-single-property-change' does not include the end of the + ;; buffer, even when a property reach it. + (let ((res (faceup-next-single-property-change pos))) + (if (and (not res) ; No more found. + (not (eq pos (point-max))) ; Not already at the end. + (not (eq (point-min) (point-max))) ; Not an empty buffer. + (faceup-has-any-text-property (- (point-max) 1))) + ;; If a property goes all the way to the end of the + ;; buffer, return `point-max'. + (point-max) + res))))) + + +;; ---------------------------------------------------------------------- +;; Renderer +;; + +;; Functions to convert from the faceup textual representation to text +;; with real properties. + +(defun faceup-render-string (faceup) + "Return string with properties from FACEUP written with Faceup markup." + (with-temp-buffer + (insert faceup) + (faceup-render-to-string))) + + +;;;###autoload +(defun faceup-render-view-buffer (&optional buffer) + "Convert BUFFER containing Faceup markup to a new buffer and display it." + (interactive) + (with-current-buffer (or buffer (current-buffer)) + (let ((dest-buffer (get-buffer-create "*FaceUp rendering*"))) + (with-current-buffer dest-buffer + (delete-region (point-min) (point-max))) + (faceup-render-to-buffer dest-buffer) + (display-buffer dest-buffer)))) + + +(defun faceup-render-to-string (&optional buffer) + "Convert BUFFER containing faceup markup to a string with faces." + (unless buffer + (setq buffer (current-buffer))) + (with-temp-buffer + (faceup-render-to-buffer (current-buffer) buffer) + (buffer-substring (point-min) (point-max)))) + + +(defun faceup-render-to-buffer (to-buffer &optional buffer) + "Convert BUFFER containing faceup markup into text with faces in TO-BUFFER." + (with-current-buffer (or buffer (current-buffer)) + (goto-char (point-min)) + (let ((last-point (point)) + (state '()) ; List of (prop . element) + (not-markup (concat + "^" + (make-string 1 faceup-markup-start-char) + (make-string 1 faceup-markup-end-char)))) + (while (progn + (skip-chars-forward not-markup) + (if (not (eq last-point (point))) + (let ((text (buffer-substring-no-properties + last-point (point))) + (prop-elements-alist '())) + ;; Accumulate all values for each property. + (dolist (prop-element state) + (let ((property (car prop-element)) + (element (cdr prop-element))) + (let ((pair (assq property prop-elements-alist))) + (unless pair + (setq pair (cons property '())) + (push pair prop-elements-alist)) + (push element (cdr pair))))) + ;; Apply all properties. + (dolist (pair prop-elements-alist) + (let ((property (car pair)) + (elements (reverse (cdr pair)))) + ;; Create one of: + ;; (property element) or + ;; (property (element element ...)) + (when (eq (length elements) 1) + ;; This ensures that non-face-like + ;; properties are restored to their + ;; original state. + (setq elements (car elements))) + (add-text-properties 0 (length text) + (list property elements) + text))) + (with-current-buffer to-buffer + (insert text)) + (setq last-point (point)))) + (not (eobp))) + (if (eq (following-char) faceup-markup-start-char) + ;; Start marker. + (progn + (forward-char) + (if (or (eq (following-char) faceup-markup-start-char) + (eq (following-char) faceup-markup-end-char)) + ;; Escaped markup character. + (progn + (setq last-point (point)) + (forward-char)) + ;; Markup sequence. + (let ((property faceup-default-property)) + (when (eq (following-char) ?\( ) + (forward-char) ; "(" + (let ((p (point))) + (forward-sexp) + (setq property (intern (buffer-substring p (point))))) + (forward-char)) ; ")" + (let ((element + (if (eq (following-char) ?:) + ;; :element: + (progn + (forward-char) + (prog1 + (let ((p (point))) + (forward-sexp) + ;; Note: (read (current-buffer)) + ;; doesn't work, as it reads more + ;; than a sexp. + (read (buffer-substring p (point)))) + (forward-char))) + ;; X: + (prog1 + (car (rassoc (buffer-substring-no-properties + (point) (+ (point) 1)) + faceup-face-short-alist)) + (forward-char 2))))) + (push (cons property element) state))) + (setq last-point (point)))) + ;; End marker. + (pop state) + (forward-char) + (setq last-point (point))))))) + +;; ---------------------------------------------------------------------- + +;;;###autoload +(defun faceup-clean-buffer () + "Remove faceup markup from buffer." + (interactive) + (goto-char (point-min)) + (let ((not-markup (concat + "^" + (make-string 1 faceup-markup-start-char) + (make-string 1 faceup-markup-end-char)))) + (while (progn (skip-chars-forward not-markup) + (not (eobp))) + (if (eq (following-char) faceup-markup-end-char) + ;; End markers are always on their own. + (delete-char 1) + ;; Start marker. + (delete-char 1) + (if (or (eq (following-char) faceup-markup-start-char) + (eq (following-char) faceup-markup-end-char)) + ;; Escaped markup character, delete the escape and skip + ;; the original character. + (forward-char) + ;; Property name (if present) + (if (eq (following-char) ?\( ) + (let ((p (point))) + (forward-sexp) + (delete-region p (point)))) + ;; Markup sequence. + (if (eq (following-char) ?:) + ;; :value: + (let ((p (point))) + (forward-char) + (forward-sexp) + (unless (eobp) + (forward-char)) + (delete-region p (point))) + ;; X: + (delete-char 1) ; The one-letter form. + (delete-char 1))))))) ; The colon. + + +(defun faceup-clean-string (s) + "Remove faceup markup from string S." + (with-temp-buffer + (insert s) + (faceup-clean-buffer) + (buffer-substring (point-min) (point-max)))) + + +;; ---------------------------------------------------------------------- +;; Regression test support +;; + +(defvar faceup-test-explain nil + "When non-nil, tester functions returns a text description on failure. + +Of course, this only work for test functions aware of this +variable, like `faceup-test-equal' and functions based on this +function. + +This is intended to be used to simplify `ert' explain functions, +which could be defined as: + + (defun my-test (args...) ...) + (defun my-test-explain (args...) + (let ((faceup-test-explain t)) + (the-test args...))) + (put 'my-test 'ert-explainer 'my-test-explain) + +Alternative, you can use the macro `faceup-defexplainer' as follows: + + (defun my-test (args...) ...) + (faceup-defexplainer my-test) + +Test functions, like `faceup-test-font-lock-buffer', built on top +of `faceup-test-equal', and other functions that adhere to this +variable, can easily define their own explainer functions.") + +;;;###autoload +(defmacro faceup-defexplainer (function) + "Define an Ert explainer function for FUNCTION. + +FUNCTION must return an explanation when the test fails and +`faceup-test-explain' is set." + (let ((name (intern (concat (symbol-name function) "-explainer")))) + `(progn + (defun ,name (&rest args) + (let ((faceup-test-explain t)) + (apply (quote ,function) args))) + (put (quote ,function) 'ert-explainer (quote ,name))))) + + +;; ------------------------------ +;; Multi-line string support. +;; + +(defun faceup-test-equal (lhs rhs) + "Compares two (multi-line) strings, LHS and RHS, for equality. + +This is intended to be used in Ert regression test rules. + +When `faceup-test-explain' is non-nil, instead of returning nil +on inequality, a list is returned with a explanation what +differs. Currently, this function reports 1) if the number of +lines in the strings differ. 2) the lines and the line numbers on +which the string differed. + +For example: + (let ((a \"ABC\\nDEF\\nGHI\") + (b \"ABC\\nXXX\\nGHI\\nZZZ\") + (faceup-test-explain t)) + (message \"%s\" (faceup-test-equal a b))) + + ==> (4 3 number-of-lines-differ (on-line 2 (DEF) (XXX))) + +When used in an `ert' rule, the output is as below: + + (ert-deftest faceup-test-equal-example () + (let ((a \"ABC\\nDEF\\nGHI\") + (b \"ABC\\nXXX\\nGHI\\nZZZ\")) + (should (faceup-test-equal a b)))) + + F faceup-test-equal-example + (ert-test-failed + ((should + (faceup-test-equal a b)) + :form + (faceup-test-equal \"ABC\\nDEF\\nGHI\" \"ABC\\nXXX\\nGHI\\nZZZ\") + :value nil :explanation + (4 3 number-of-lines-differ + (on-line 2 + (\"DEF\") + (\"XXX\")))))" + (if (equal lhs rhs) + t + (if faceup-test-explain + (let ((lhs-lines (split-string lhs "\n")) + (rhs-lines (split-string rhs "\n")) + (explanation '()) + (line 1)) + (unless (= (length lhs-lines) (length rhs-lines)) + (setq explanation (list 'number-of-lines-differ + (length lhs-lines) (length rhs-lines)))) + (while lhs-lines + (let ((one (pop lhs-lines)) + (two (pop rhs-lines))) + (unless (equal one two) + (setq explanation + (cons (list 'on-line line (list one) (list two)) + explanation))) + (setq line (+ line 1)))) + (nreverse explanation)) + nil))) + +(faceup-defexplainer faceup-test-equal) + + +;; ------------------------------ +;; Font-lock regression test support. +;; + +(defun faceup-test-font-lock-buffer (mode faceup &optional buffer) + "Verify that BUFFER is fontified as FACEUP for major mode MODE. + +If BUFFER is not specified the current buffer is used. + +Note that the major mode of the buffer is set to MODE and that +the buffer is fontified. + +If MODE is a list, the first element is the major mode, the +remaining are additional functions to call, e.g. minor modes." + (save-excursion + (if buffer + (set-buffer buffer)) + (if (listp mode) + (dolist (m mode) + (funcall m)) + (funcall mode)) + (font-lock-fontify-region (point-min) (point-max)) + (let ((result (faceup-markup-buffer))) + (faceup-test-equal faceup result)))) + +(faceup-defexplainer faceup-test-font-lock-buffer) + + +(defun faceup-test-font-lock-string (mode faceup) + "True if FACEUP is re-fontified as the faceup markup for major mode MODE. + +The string FACEUP is stripped from markup, inserted into a +buffer, the requested major mode activated, the buffer is +fontified, the result is again converted to the faceup form, and +compared with the original string." + (with-temp-buffer + (insert faceup) + (faceup-clean-buffer) + (faceup-test-font-lock-buffer mode faceup))) + +(faceup-defexplainer faceup-test-font-lock-string) + + +(defun faceup-test-font-lock-file (mode file &optional faceup-file) + "Verify that FILE is fontified as FACEUP-FILE for major mode MODE. + +If FACEUP-FILE is omitted, FILE.faceup is used." + (unless faceup-file + (setq faceup-file (concat file ".faceup"))) + (let ((faceup (with-temp-buffer + (insert-file-contents faceup-file) + (buffer-substring-no-properties (point-min) (point-max))))) + (with-temp-buffer + (insert-file-contents file) + (faceup-test-font-lock-buffer mode faceup)))) + +(faceup-defexplainer faceup-test-font-lock-file) + + +;; ------------------------------ +;; Get current file directory. Test cases can use this to locate test +;; files. +;; + +(defun faceup-this-file-directory () + "The directory of the file where the call to this function is located in. +Intended to be called when a file is loaded." + (expand-file-name + (if load-file-name + ;; File is being loaded. + (file-name-directory load-file-name) + ;; File is being evaluated using, for example, `eval-buffer'. + default-directory))) + + +;; ---------------------------------------------------------------------- +;; The end +;; + +(provide 'faceup) + +;;; faceup.el ends here diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 9d1e43b0fe8..9fc7e4a797d 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1997, 1999, 2001-2019 Free Software Foundation, Inc. ;; Author: Jens Petersen <petersen@kurims.kyoto-u.ac.jp> -;; Maintainer: petersen@kurims.kyoto-u.ac.jp ;; Keywords: emacs-lisp, functions, variables ;; Created: 97/07/25 @@ -368,28 +367,30 @@ The search is done in the source for library LIBRARY." (concat "\\\\?" (regexp-quote (symbol-name symbol)))))) (case-fold-search)) - (with-syntax-table emacs-lisp-mode-syntax-table - (goto-char (point-min)) - (if (if (functionp regexp) - (funcall regexp symbol) - (or (re-search-forward regexp nil t) - ;; `regexp' matches definitions using known forms like - ;; `defun', or `defvar'. But some functions/variables - ;; are defined using special macros (or functions), so - ;; if `regexp' can't find the definition, we look for - ;; something of the form "(SOMETHING <symbol> ...)". - ;; This fails to distinguish function definitions from - ;; variable declarations (or even uses thereof), but is - ;; a good pragmatic fallback. - (re-search-forward - (concat "^([^ ]+" find-function-space-re "['(]?" - (regexp-quote (symbol-name symbol)) - "\\_>") - nil t))) - (progn - (beginning-of-line) - (cons (current-buffer) (point))) - (cons (current-buffer) nil)))))))) + (save-restriction + (widen) + (with-syntax-table emacs-lisp-mode-syntax-table + (goto-char (point-min)) + (if (if (functionp regexp) + (funcall regexp symbol) + (or (re-search-forward regexp nil t) + ;; `regexp' matches definitions using known forms like + ;; `defun', or `defvar'. But some functions/variables + ;; are defined using special macros (or functions), so + ;; if `regexp' can't find the definition, we look for + ;; something of the form "(SOMETHING <symbol> ...)". + ;; This fails to distinguish function definitions from + ;; variable declarations (or even uses thereof), but is + ;; a good pragmatic fallback. + (re-search-forward + (concat "^([^ ]+" find-function-space-re "['(]?" + (regexp-quote (symbol-name symbol)) + "\\_>") + nil t))) + (progn + (beginning-of-line) + (cons (current-buffer) (point))) + (cons (current-buffer) nil))))))))) (defun find-function-library (function &optional lisp-only verbose) "Return the pair (ORIG-FUNCTION . LIBRARY) for FUNCTION. @@ -464,6 +465,7 @@ If TYPE is nil, defaults using `function-called-at-point', otherwise uses `variable-at-point'." (let* ((symb1 (cond ((null type) (function-called-at-point)) ((eq type 'defvar) (variable-at-point)) + ((eq type 'defface) (face-at-point t)) (t (variable-at-point t)))) (symb (unless (eq symb1 0) symb1)) (predicate (cdr (assq type '((nil . fboundp) diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el index 54c8afe62b4..48ffaaab367 100644 --- a/lisp/emacs-lisp/float-sup.el +++ b/lisp/emacs-lisp/float-sup.el @@ -28,8 +28,9 @@ ;; Provide an easy hook to tell if we are running with floats or not. ;; Define pi and e via math-lib calls (much less prone to killer typos). (defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).") -(defconst pi float-pi - "Obsolete since Emacs-23.3. Use `float-pi' instead.") +(with-suppressed-warnings ((lexical pi)) + (defconst pi float-pi + "Obsolete since Emacs-23.3. Use `float-pi' instead.")) (internal-make-var-non-special 'pi) (defconst float-e (exp 1) "The value of e (2.7182818...).") diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index 0f4149eacd5..caf5fed154b 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -213,8 +213,8 @@ don't yield.") ;; Process `and'. - (`(and) ; (and) -> t - (cps--transform-1 t next-state)) + ('(and) ; (and) -> t + (cps--transform-1 t next-state)) (`(and ,condition) ; (and CONDITION) -> CONDITION (cps--transform-1 condition next-state)) (`(and ,condition . ,rest) @@ -246,8 +246,8 @@ don't yield.") ;; Process `cond': transform into `if' or `or' depending on the ;; precise kind of the condition we're looking at. - (`(cond) ; (cond) -> nil - (cps--transform-1 nil next-state)) + ('(cond) ; (cond) -> nil + (cps--transform-1 nil next-state)) (`(cond (,condition) . ,rest) (cps--transform-1 `(or ,condition (cond ,@rest)) next-state)) @@ -281,14 +281,14 @@ don't yield.") ;; Process `progn' and `inline': they are identical except for the ;; name, which has some significance to the byte compiler. - (`(inline) (cps--transform-1 nil next-state)) + ('(inline) (cps--transform-1 nil next-state)) (`(inline ,form) (cps--transform-1 form next-state)) (`(inline ,form . ,rest) (cps--transform-1 form (cps--transform-1 `(inline ,@rest) next-state))) - (`(progn) (cps--transform-1 nil next-state)) + ('(progn) (cps--transform-1 nil next-state)) (`(progn ,form) (cps--transform-1 form next-state)) (`(progn ,form . ,rest) (cps--transform-1 form @@ -345,7 +345,7 @@ don't yield.") ;; Process `or'. - (`(or) (cps--transform-1 nil next-state)) + ('(or) (cps--transform-1 nil next-state)) (`(or ,condition) (cps--transform-1 condition next-state)) (`(or ,condition . ,rest) (cps--transform-1 @@ -374,13 +374,6 @@ don't yield.") `(setf ,cps--value-symbol ,temp-var-symbol ,cps--state-symbol ,next-state)))))))) - ;; Process `prog2'. - - (`(prog2 ,form1 ,form2 . ,body) - (cps--transform-1 - `(progn ,form1 (prog1 ,form2 ,@body)) - next-state)) - ;; Process `unwind-protect': If we're inside an unwind-protect, we ;; have a block of code UNWINDFORMS which we would like to run ;; whenever control flows away from the main piece of code, @@ -567,8 +560,11 @@ modified copy." (unless ,normal-exit-symbol ,@unwind-forms)))))) -(put 'iter-end-of-sequence 'error-conditions '(iter-end-of-sequence)) -(put 'iter-end-of-sequence 'error-message "iteration terminated") +(define-error 'iter-end-of-sequence "Iteration terminated" + ;; FIXME: This was not defined originally as an `error' condition, so + ;; we reproduce this by passing itself as the parent, which avoids the + ;; default `error' parent. Maybe it *should* be in the `error' category? + 'iter-end-of-sequence) (defun cps--make-close-iterator-form (terminal-state) (if cps--cleanup-table-symbol @@ -643,11 +639,11 @@ modified copy." ,(cps--make-close-iterator-form terminal-state))))) (t (error "unknown iterator operation %S" op)))))) ,(when finalizer-symbol - `(funcall iterator - :stash-finalizer - (make-finalizer - (lambda () - (iter-close iterator))))) + '(funcall iterator + :stash-finalizer + (make-finalizer + (lambda () + (iter-close iterator))))) iterator)))) (defun iter-yield (value) @@ -700,6 +696,14 @@ of values. Callers can retrieve each value using `iter-next'." `(lambda ,arglist ,(cps-generate-evaluator body))) +(defmacro iter-make (&rest body) + "Return a new iterator." + (declare (debug t)) + (cps-generate-evaluator body)) + +(defconst iter-empty (lambda (_op _val) (signal 'iter-end-of-sequence nil)) + "Trivial iterator that always signals the end of sequence.") + (defun iter-next (iterator &optional yield-result) "Extract a value from an iterator. YIELD-RESULT becomes the return value of `iter-yield' in the diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el index 4ef9ab694bb..e4ed745b25d 100644 --- a/lisp/emacs-lisp/generic.el +++ b/lisp/emacs-lisp/generic.el @@ -2,7 +2,7 @@ ;; ;; Copyright (C) 1997, 1999, 2001-2019 Free Software Foundation, Inc. ;; -;; Author: Peter Breton <pbreton@cs.umb.edu> +;; Author: Peter Breton <pbreton@cs.umb.edu> ;; Created: Fri Sep 27 1996 ;; Keywords: generic, comment, font-lock ;; Package: emacs @@ -96,8 +96,6 @@ ;; Internal Variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-obsolete-variable-alias 'generic-font-lock-defaults - 'generic-font-lock-keywords "22.1") (defvar generic-font-lock-keywords nil "Keywords for `font-lock-defaults' in a generic mode.") (make-variable-buffer-local 'generic-font-lock-keywords) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index deeb833e1f8..3ab69436088 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -214,9 +214,11 @@ The first arg in ARGLIST (the one that receives VAL) receives an expression which can do arbitrary things, whereas the other arguments are all guaranteed to be pure and copyable. Example use: (gv-define-setter aref (v a i) \\=`(aset ,a ,i ,v))" - (declare (indent 2) (debug (&define name sexp body))) + (declare (indent 2) (debug (&define name sexp def-body))) `(gv-define-expander ,name (lambda (do &rest args) + (declare-function + gv--defsetter "gv" (name setter do args &optional vars)) (gv--defsetter ',name (lambda ,arglist ,@body) do args)))) ;;;###autoload @@ -303,11 +305,14 @@ The return value is the last VAL in the list. (lambda (do before index place) (gv-letplace (getter setter) place (funcall do `(edebug-after ,before ,index ,getter) - setter)))) + (lambda (store) + `(progn (edebug-after ,before ,index ,getter) + ,(funcall setter store))))))) ;;; The common generalized variables. (gv-define-simple-setter aref aset) +(gv-define-simple-setter char-table-range set-char-table-range) (gv-define-simple-setter car setcar) (gv-define-simple-setter cdr setcdr) ;; FIXME: add compiler-macros for `cXXr' instead! @@ -387,18 +392,20 @@ The return value is the last VAL in the list. ,(funcall setter `(cons (setq ,p (cons ,k ,v)) ,getter))))) - (cond - ((null remove) set-exp) - ((or (eql v default) - (and (eq (car-safe v) 'quote) - (eq (car-safe default) 'quote) - (eql (cadr v) (cadr default)))) - `(if ,p ,(funcall setter `(delq ,p ,getter)))) - (t - `(cond - ((not (eql ,default ,v)) ,set-exp) - (,p ,(funcall setter - `(delq ,p ,getter))))))))))))))) + `(progn + ,(cond + ((null remove) set-exp) + ((or (eql v default) + (and (eq (car-safe v) 'quote) + (eq (car-safe default) 'quote) + (eql (cadr v) (cadr default)))) + `(if ,p ,(funcall setter `(delq ,p ,getter)))) + (t + `(cond + ((not (eql ,default ,v)) ,set-exp) + (,p ,(funcall setter + `(delq ,p ,getter)))))) + ,v)))))))))) ;;; Some occasionally handy extensions. diff --git a/lisp/emacs-lisp/inline.el b/lisp/emacs-lisp/inline.el index 1bccf2e0576..39f8e9b5947 100644 --- a/lisp/emacs-lisp/inline.el +++ b/lisp/emacs-lisp/inline.el @@ -71,7 +71,7 @@ (defmacro inline-quote (_exp) "Similar to backquote, but quotes code and only accepts , and not ,@." - (declare (debug t)) + (declare (debug backquote-form)) (error "inline-quote can only be used within define-inline")) (defmacro inline-const-p (_exp) @@ -259,7 +259,7 @@ See Info node `(elisp)Defining Functions' for more details." `(error ,@args)) (defun inline--warning (&rest _args) - `(throw 'inline--just-use + '(throw 'inline--just-use ;; FIXME: This would inf-loop by calling us right back when ;; macroexpand-all recurses to expand inline--form. ;; (macroexp--warn-and-return (format ,@args) diff --git a/lisp/emacs-lisp/let-alist.el b/lisp/emacs-lisp/let-alist.el index dc54342eab6..8831965bafd 100644 --- a/lisp/emacs-lisp/let-alist.el +++ b/lisp/emacs-lisp/let-alist.el @@ -4,7 +4,7 @@ ;; Author: Artur Malabarba <emacs@endlessparentheses.com> ;; Package-Requires: ((emacs "24.1")) -;; Version: 1.0.5 +;; Version: 1.0.6 ;; Keywords: extensions lisp ;; Prefix: let-alist ;; Separator: - @@ -75,6 +75,8 @@ symbol, and each cdr is the same symbol without the `.'." ;; Return the cons cell inside a list, so it can be appended ;; with other results in the clause below. (list (cons data (intern (replace-match "" nil nil name))))))) + ((vectorp data) + (apply #'nconc (mapcar #'let-alist--deep-dot-search data))) ((not (consp data)) nil) ((eq (car data) 'let-alist) ;; For nested ‘let-alist’ forms, ignore symbols appearing in the diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index 6cad17a4a1b..91c76158a31 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -1,4 +1,4 @@ -;;; lisp-mnt.el --- utility functions for Emacs Lisp maintainers +;;; lisp-mnt.el --- utility functions for Emacs Lisp maintainers -*- lexical-binding:t -*- ;; Copyright (C) 1992, 1994, 1997, 2000-2019 Free Software Foundation, ;; Inc. @@ -137,34 +137,28 @@ in your Lisp package: The @(#) construct is used by unix what(1) and then $identifier: doc string $ is used by GNU ident(1)" - :type 'regexp - :group 'lisp-mnt) + :type 'regexp) (defcustom lm-copyright-prefix "^\\(;+[ \t]\\)+Copyright (C) " "Prefix that is ignored before the dates in a copyright. Leading comment characters and whitespace should be in regexp group 1." - :type 'regexp - :group 'lisp-mnt) + :type 'regexp) (defcustom lm-comment-column 16 "Column used for placing formatted output." - :type 'integer - :group 'lisp-mnt) + :type 'integer) (defcustom lm-any-header ".*" "Regexp which matches start of any section." - :type 'regexp - :group 'lisp-mnt) + :type 'regexp) (defcustom lm-commentary-header "Commentary\\|Documentation" "Regexp which matches start of documentation section." - :type 'regexp - :group 'lisp-mnt) + :type 'regexp) (defcustom lm-history-header "Change ?Log\\|History" "Regexp which matches the start of code log section." - :type 'regexp - :group 'lisp-mnt) + :type 'regexp) ;;; Functions: @@ -236,26 +230,26 @@ a section." (while (forward-comment 1)) (point)))))))) -(defsubst lm-code-start () +(defun lm-code-start () "Return the buffer location of the `Code' start marker." (lm-section-start "Code")) (defalias 'lm-code-mark 'lm-code-start) -(defsubst lm-commentary-start () +(defun lm-commentary-start () "Return the buffer location of the `Commentary' start marker." (lm-section-start lm-commentary-header)) (defalias 'lm-commentary-mark 'lm-commentary-start) -(defsubst lm-commentary-end () +(defun lm-commentary-end () "Return the buffer location of the `Commentary' section end." (lm-section-end lm-commentary-header)) -(defsubst lm-history-start () +(defun lm-history-start () "Return the buffer location of the `History' start marker." (lm-section-start lm-history-header)) (defalias 'lm-history-mark 'lm-history-start) -(defsubst lm-copyright-mark () +(defun lm-copyright-mark () "Return the buffer location of the `Copyright' line." (save-excursion (let ((case-fold-search t)) @@ -385,7 +379,7 @@ Each element of the list is a cons; the car is the full name, the cdr is an email address." (lm-with-file file (let ((authorlist (lm-header-multiline "author"))) - (mapcar 'lm-crack-address authorlist)))) + (mapcar #'lm-crack-address authorlist)))) (defun lm-maintainer (&optional file) "Return the maintainer of file FILE, or current buffer if FILE is nil. @@ -453,7 +447,7 @@ each line." (lm-with-file file (let ((keywords (lm-header-multiline "keywords"))) (and keywords - (mapconcat 'downcase keywords " "))))) + (mapconcat #'downcase keywords " "))))) (defun lm-keywords-list (&optional file) "Return list of keywords given in file FILE." @@ -507,7 +501,7 @@ absent, return nil." "Insert, at column COL, list of STRINGS." (if (> (current-column) col) (insert "\n")) (move-to-column col t) - (apply 'insert strings)) + (apply #'insert strings)) (defun lm-verify (&optional file showok verbose non-fsf-ok) "Check that the current buffer (or FILE if given) is in proper format. diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 74bf0c87c53..fa6dc98d04c 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -461,11 +461,6 @@ This will generate compile-time constants from BINDINGS." (throw 'found t))))))) (1 'font-lock-regexp-grouping-backslash prepend) (3 'font-lock-regexp-grouping-construct prepend)) - ;; This is too general -- rms. - ;; A user complained that he has functions whose names start with `do' - ;; and that they get the wrong color. - ;; ;; CL `with-' and `do-' constructs - ;;("(\\(\\(do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) (lisp--match-hidden-arg (0 '(face font-lock-warning-face help-echo "Hidden behind deeper element; move to another line?"))) @@ -491,6 +486,11 @@ This will generate compile-time constants from BINDINGS." (,(concat "[`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)" lisp-mode-symbol-regexp "\\)['’]") (1 font-lock-constant-face prepend)) + ;; Uninterned symbols, e.g., (defpackage #:my-package ...) + ;; must come before keywords below to have effect + (,(concat "\\(#:\\)\\(" lisp-mode-symbol-regexp "\\)") + (1 font-lock-comment-delimiter-face) + (2 font-lock-doc-face)) ;; Constant values. (,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>") (0 font-lock-builtin-face)) @@ -500,8 +500,10 @@ This will generate compile-time constants from BINDINGS." ;; This is too general -- rms. ;; A user complained that he has functions whose names start with `do' ;; and that they get the wrong color. - ;; ;; CL `with-' and `do-' constructs - ;;("(\\(\\(do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) + ;; That user has violated the http://www.cliki.net/Naming+conventions: + ;; CL (but not EL!) `with-' (context) and `do-' (iteration) + (,(concat "(\\(\\(do-\\|with-\\)" lisp-mode-symbol-regexp "\\)") + (1 font-lock-keyword-face)) (lisp--match-hidden-arg (0 '(face font-lock-warning-face help-echo "Hidden behind deeper element; move to another line?"))) @@ -515,6 +517,16 @@ This will generate compile-time constants from BINDINGS." (defvar lisp-cl-font-lock-keywords lisp-cl-font-lock-keywords-1 "Default expressions to highlight in Lisp modes.") +;; Support backtrace mode. +(defconst lisp-el-font-lock-keywords-for-backtraces lisp-el-font-lock-keywords + "Default highlighting from Emacs Lisp mod used in Backtrace mode.") +(defconst lisp-el-font-lock-keywords-for-backtraces-1 lisp-el-font-lock-keywords-1 + "Subdued highlighting from Emacs Lisp mode used in Backtrace mode.") +(defconst lisp-el-font-lock-keywords-for-backtraces-2 + (remove (assoc 'lisp--match-hidden-arg lisp-el-font-lock-keywords-2) + lisp-el-font-lock-keywords-2) + "Gaudy highlighting from Emacs Lisp mode used in Backtrace mode.") + (defun lisp-string-in-doc-position-p (listbeg startpos) "Return true if a doc string may occur at STARTPOS inside a list. LISTBEG is the position of the start of the innermost list @@ -871,9 +883,7 @@ by more than one line to cross a string literal." (interactive) (let ((pos (- (point-max) (point))) (indent (progn (beginning-of-line) - (or indent (calculate-lisp-indent (lisp-ppss))))) - (shift-amt nil) - (beg (progn (beginning-of-line) (point)))) + (or indent (calculate-lisp-indent (lisp-ppss)))))) (skip-chars-forward " \t") (if (or (null indent) (looking-at "\\s<\\s<\\s<")) ;; Don't alter indentation of a ;;; comment line @@ -885,11 +895,7 @@ by more than one line to cross a string literal." ;; as comment lines, not as code. (progn (indent-for-comment) (forward-char -1)) (if (listp indent) (setq indent (car indent))) - (setq shift-amt (- indent (current-column))) - (if (zerop shift-amt) - nil - (delete-region beg (point)) - (indent-to indent))) + (indent-line-to indent)) ;; If initial point was within line's indentation, ;; position after the indentation. Else stay at same point in text. (if (> (- (point-max) pos) (point)) @@ -1177,7 +1183,6 @@ Lisp function does not specify a special indentation." (put 'autoload 'lisp-indent-function 'defun) ;Elisp (put 'progn 'lisp-indent-function 0) (put 'prog1 'lisp-indent-function 1) -(put 'prog2 'lisp-indent-function 2) (put 'save-excursion 'lisp-indent-function 0) ;Elisp (put 'save-restriction 'lisp-indent-function 0) ;Elisp (put 'save-current-buffer 'lisp-indent-function 0) ;Elisp diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 0fe18b6e94c..ab0e853e9a4 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -339,12 +339,18 @@ is called as a function to find the defun's beginning." ((or defun-prompt-regexp open-paren-in-column-0-is-defun-start) (and (< arg 0) (not (eobp)) (forward-char 1)) - (and (re-search-backward (if defun-prompt-regexp - (concat (if open-paren-in-column-0-is-defun-start - "^\\s(\\|" "") - "\\(?:" defun-prompt-regexp "\\)\\s(") - "^\\s(") - nil 'move arg) + (and (let (found) + (while + (and (setq found + (re-search-backward + (if defun-prompt-regexp + (concat (if open-paren-in-column-0-is-defun-start + "^\\s(\\|" "") + "\\(?:" defun-prompt-regexp "\\)\\s(") + "^\\s(") + nil 'move arg)) + (nth 8 (syntax-ppss)))) + found) (progn (goto-char (1- (match-end 0))) t))) @@ -364,8 +370,9 @@ is called as a function to find the defun's beginning." (arg-+ve (> arg 0))) (save-restriction (widen) - (let ((ppss (let (syntax-begin-function) - (syntax-ppss))) + (let ((ppss (with-suppressed-warnings ((obsolete syntax-begin-function)) + (let (syntax-begin-function) + (syntax-ppss)))) ;; position of least enclosing paren, or nil. encl-pos) ;; Back out of any comment/string, so that encl-pos will always @@ -639,7 +646,7 @@ Interactively, the behavior depends on `narrow-to-defun-include-comments'." (re-search-backward "^\n" (- (point) 1) t) (narrow-to-region beg end)))) -(defvar insert-pair-alist +(defcustom insert-pair-alist '((?\( ?\)) (?\[ ?\]) (?\{ ?\}) (?\< ?\>) (?\" ?\") (?\' ?\') (?\` ?\')) "Alist of paired characters inserted by `insert-pair'. Each element looks like (OPEN-CHAR CLOSE-CHAR) or (COMMAND-CHAR @@ -649,7 +656,16 @@ or without modifiers, are inserted by `insert-pair'. If COMMAND-CHAR is specified, it is a character that triggers the insertion of the open/close pair, and COMMAND-CHAR itself isn't -inserted.") +inserted." + :type '(repeat (choice (list :tag "Pair" + (character :tag "Open") + (character :tag "Close")) + (list :tag "Triple" + (character :tag "Command") + (character :tag "Open") + (character :tag "Close")))) + :group 'lisp + :version "27.1") (defun insert-pair (&optional arg open close) "Enclose following ARG sexps in a pair of OPEN and CLOSE characters. @@ -717,11 +733,13 @@ This command assumes point is not in a string or comment." (interactive "P") (insert-pair arg ?\( ?\))) -(defun delete-pair () - "Delete a pair of characters enclosing the sexp that follows point." - (interactive) - (save-excursion (forward-sexp 1) (delete-char -1)) - (delete-char 1)) +(defun delete-pair (&optional arg) + "Delete a pair of characters enclosing ARG sexps following point. +A negative ARG deletes a pair of characters around preceding ARG sexps." + (interactive "p") + (unless arg (setq arg 1)) + (save-excursion (forward-sexp arg) (delete-char (if (> arg 0) -1 1))) + (delete-char (if (> arg 0) 1 -1))) (defun raise-sexp (&optional arg) "Raise ARG sexps higher up the tree." diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index eabd5041978..9af75320ec0 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -94,7 +94,7 @@ each clause." clause))) (defun macroexp--compiler-macro (handler form) - (condition-case err + (condition-case-unless-debug err (apply handler form (cdr form)) (error (message "Compiler-macro error for %S: %S" (car form) err) @@ -222,15 +222,15 @@ Assumes the caller has bound `macroexpand-all-environment'." (cddr form)) (cdr form)) form)) - (`(,(or `defvar `defconst) . ,_) (macroexp--all-forms form 2)) + (`(,(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) dontcare)) + (`(,(or 'function 'quote) . ,_) form) + (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) dontcare)) (macroexp--cons fun (macroexp--cons (macroexp--all-clauses bindings 1) (macroexp--all-forms body) @@ -249,14 +249,14 @@ Assumes the caller has bound `macroexpand-all-environment'." ;; here, so that any code that cares about the difference will ;; see the same transformation. ;; First arg is a function: - (`(,(and fun (or `funcall `apply `mapcar `mapatoms `mapconcat `mapc)) + (`(,(and fun (or 'funcall 'apply 'mapcar 'mapatoms 'mapconcat 'mapc)) ',(and f `(lambda . ,_)) . ,args) (macroexp--warn-and-return (format "%s quoted with ' rather than with #'" (list 'lambda (nth 1 f) '...)) (macroexp--expand-all `(,fun ,f . ,args)))) ;; Second arg is a function: - (`(,(and fun (or `sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args) + (`(,(and fun (or 'sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args) (macroexp--warn-and-return (format "%s quoted with ' rather than with #'" (list 'lambda (nth 1 f) '...)) @@ -406,7 +406,7 @@ cases where EXP is a constant." "Bind each binding in BINDINGS as `macroexp-let2' does." (declare (indent 2) (debug (sexp (&rest (sexp form)) body))) (pcase-exhaustive bindings - (`nil (macroexp-progn body)) + ('nil (macroexp-progn body)) (`((,var ,exp) . ,tl) `(macroexp-let2 ,test ,var ,exp (macroexp-let2* ,test ,tl ,@body))))) diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index 6bd209538bf..a688330b74a 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -192,34 +192,30 @@ Returns the number of actions taken." (funcall actor elt) (setq actions (1+ actions)))))) ((eq def 'help) - (with-output-to-temp-buffer "*Help*" + (with-help-window (help-buffer) (princ - (let ((object (if help (nth 0 help) "object")) - (objects (if help (nth 1 help) "objects")) - (action (if help (nth 2 help) "act on"))) + (let ((object (or (nth 0 help) "object")) + (objects (or (nth 1 help) "objects")) + (action (or (nth 2 help) "act on"))) (concat - (format-message "\ + (format-message + "\ Type SPC or `y' to %s the current %s; DEL or `n' to skip the current %s; -RET or `q' to give up on the %s (skip all remaining %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 action objects action - objects) - (mapconcat (function - (lambda (elt) - (format "%s to %s" - (single-key-description - (nth 0 elt)) - (nth 2 elt)))) + action object object objects action objects) + (mapconcat (lambda (elt) + (format "%s to %s;\n" + (single-key-description + (nth 0 elt)) + (nth 2 elt))) action-alist - ";\n") - (if action-alist ";\n") - (format "or . (period) to %s \ -the current %s and exit." - action object)))) - (with-current-buffer standard-output - (help-mode))) + "") + (format + "or . (period) to %s the current %s and exit." + action object))))) (funcall try-again)) ((and (symbolp def) (commandp def)) diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index 47de28f8f9e..54e802edf4f 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -4,7 +4,8 @@ ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Keywords: convenience, map, hash-table, alist, array -;; Version: 1.2 +;; Version: 2.0 +;; Package-Requires: ((emacs "25")) ;; Package: map ;; Maintainer: emacs-devel@gnu.org @@ -92,17 +93,21 @@ Returns the result of evaluating the form associated with MAP-VAR's type." `(cond ((listp ,map-var) ,(plist-get args :list)) ((hash-table-p ,map-var) ,(plist-get args :hash-table)) ((arrayp ,map-var) ,(plist-get args :array)) - (t (error "Unsupported map: %s" ,map-var))))) + (t (error "Unsupported map type `%S': %S" + (type-of ,map-var) ,map-var))))) -(defun map-elt (map key &optional default testfn) +(define-error 'map-not-inplace "Cannot modify map in-place") + +(defsubst map--plist-p (list) + (and (consp list) (not (listp (car list))))) + +(cl-defgeneric map-elt (map key &optional default testfn) "Lookup KEY in MAP and return its associated value. If KEY is not found, return DEFAULT which defaults to nil. -If MAP is a list, `eql' is used to lookup KEY. Optional argument -TESTFN, if non-nil, means use its function definition instead of -`eql'. +TESTFN is deprecated. Its default depends on the MAP argument. -MAP can be a list, hash-table or array." +In the base definition, MAP can be an alist, hash-table, or array." (declare (gv-expander (lambda (do) @@ -110,17 +115,23 @@ MAP can be a list, hash-table or array." (macroexp-let2* nil ;; Eval them once and for all in the right order. ((key key) (default default) (testfn testfn)) - `(if (listp ,mgetter) - ;; Special case the alist case, since it can't be handled by the - ;; map--put function. - ,(gv-get `(alist-get ,key (gv-synthetic-place - ,mgetter ,msetter) - ,default nil ,testfn) - do) - ,(funcall do `(map-elt ,mgetter ,key ,default) - (lambda (v) `(map--put ,mgetter ,key ,v))))))))) + (funcall do `(map-elt ,mgetter ,key ,default) + (lambda (v) + `(condition-case nil + ;; Silence warnings about the hidden 4th arg. + (with-no-warnings (map-put! ,mgetter ,key ,v ,testfn)) + (map-not-inplace + ,(funcall msetter + `(map-insert ,mgetter ,key ,v)))))))))) + ;; `testfn' is deprecated. + (advertised-calling-convention (map key &optional default) "27.1")) (map--dispatch map - :list (alist-get key map default nil testfn) + :list (if (map--plist-p map) + (let ((res (plist-get map key))) + (if (and default (null res) (not (plist-member map key))) + default + res)) + (alist-get key map default nil testfn)) :hash-table (gethash key map default) :array (if (and (>= key 0) (< key (seq-length map))) (seq-elt map key) @@ -133,16 +144,34 @@ with VALUE. When MAP is a list, test equality with TESTFN if non-nil, otherwise use `eql'. MAP can be a list, hash-table or array." + (declare (obsolete "use map-put! or (setf (map-elt ...) ...) instead" "27.1")) `(setf (map-elt ,map ,key nil ,testfn) ,value)) -(defun map-delete (map key) - "Delete KEY from MAP and return MAP. -No error is signaled if KEY is not a key of MAP. If MAP is an -array, store nil at the index KEY. - -MAP can be a list, hash-table or array." +(defun map--plist-delete (map key) + (let ((tail map) last) + (while (consp tail) + (cond + ((not (equal key (car tail))) + (setq last tail) + (setq tail (cddr last))) + (last + (setq tail (cddr tail)) + (setf (cddr last) tail)) + (t + (cl-assert (eq tail map)) + (setq map (cddr map)) + (setq tail map)))) + map)) + +(cl-defgeneric map-delete (map key) + "Delete KEY in-place from MAP and return MAP. +No error is signaled if KEY is not a key of MAP. +If MAP is an array, store nil at the index KEY." (map--dispatch map - :list (setf (alist-get key map nil t) nil) + ;; FIXME: Signal map-not-inplace i.s.o returning a different list? + :list (if (map--plist-p map) + (setq map (map--plist-delete map key)) + (setf (alist-get key map nil t) nil)) :hash-table (remhash key map) :array (and (>= key 0) (<= key (seq-length map)) @@ -160,120 +189,133 @@ Map can be a nested map composed of alists, hash-tables and arrays." map) default)) -(defun map-keys (map) +(cl-defgeneric map-keys (map) "Return the list of keys in MAP. - -MAP can be a list, hash-table or array." +The default implementation delegates to `map-apply'." (map-apply (lambda (key _) key) map)) -(defun map-values (map) +(cl-defgeneric map-values (map) "Return the list of values in MAP. - -MAP can be a list, hash-table or array." +The default implementation delegates to `map-apply'." (map-apply (lambda (_ value) value) map)) -(defun map-pairs (map) +(cl-defgeneric map-pairs (map) "Return the elements of MAP as key/value association lists. - -MAP can be a list, hash-table or array." +The default implementation delegates to `map-apply'." (map-apply #'cons map)) -(defun map-length (map) - "Return the length of MAP. - -MAP can be a list, hash-table or array." - (length (map-keys map))) - -(defun map-copy (map) - "Return a copy of MAP. - -MAP can be a list, hash-table or array." +(cl-defgeneric map-length (map) + ;; FIXME: Should we rename this to `map-size'? + "Return the number of elements in the map. +The default implementation counts `map-keys'." + (cond + ((hash-table-p map) (hash-table-count map)) + ((listp map) + ;; FIXME: What about repeated/shadowed keys? + (if (map--plist-p map) (/ (length map) 2) (length map))) + ((arrayp map) (length map)) + (t (length (map-keys map))))) + +(cl-defgeneric map-copy (map) + "Return a copy of MAP." + ;; FIXME: Clarify how deep is the copy! (map--dispatch map - :list (seq-copy map) + :list (seq-copy map) ;FIXME: Probably not deep enough for alists! :hash-table (copy-hash-table map) :array (seq-copy map))) -(defun map-apply (function map) +(cl-defgeneric map-apply (function map) "Apply FUNCTION to each element of MAP and return the result as a list. FUNCTION is called with two arguments, the key and the value. +The default implementation delegates to `map-do'." + (let ((res '())) + (map-do (lambda (k v) (push (funcall function k v) res)) map) + (nreverse res))) -MAP can be a list, hash-table or array." - (funcall (map--dispatch map - :list #'map--apply-alist - :hash-table #'map--apply-hash-table - :array #'map--apply-array) - function - map)) - -(defun map-do (function map) +(cl-defgeneric map-do (function map) "Apply FUNCTION to each element of MAP and return nil. -FUNCTION is called with two arguments, the key and the value." - (funcall (map--dispatch map - :list #'map--do-alist - :hash-table #'maphash - :array #'map--do-array) - function - map)) - -(defun map-keys-apply (function map) - "Return the result of applying FUNCTION to each key of MAP. +FUNCTION is called with two arguments, the key and the value.") -MAP can be a list, hash-table or array." +;; FIXME: I wish there was a way to avoid this η-redex! +(cl-defmethod map-do (function (map hash-table)) (maphash function map)) + +(cl-defgeneric map-keys-apply (function map) + "Return the result of applying FUNCTION to each key of MAP. +The default implementation delegates to `map-apply'." (map-apply (lambda (key _) (funcall function key)) map)) -(defun map-values-apply (function map) +(cl-defgeneric map-values-apply (function map) "Return the result of applying FUNCTION to each value of MAP. - -MAP can be a list, hash-table or array." +The default implementation delegates to `map-apply'." (map-apply (lambda (_ val) (funcall function val)) map)) -(defun map-filter (pred map) +(cl-defgeneric map-filter (pred map) "Return an alist of key/val pairs for which (PRED key val) is non-nil in MAP. - -MAP can be a list, hash-table or array." +The default implementation delegates to `map-apply'." (delq nil (map-apply (lambda (key val) (if (funcall pred key val) (cons key val) nil)) map))) -(defun map-remove (pred map) +(cl-defgeneric map-remove (pred map) "Return an alist of the key/val pairs for which (PRED key val) is nil in MAP. - -MAP can be a list, hash-table or array." +The default implementation delegates to `map-filter'." (map-filter (lambda (key val) (not (funcall pred key val))) map)) -(defun mapp (map) - "Return non-nil if MAP is a map (list, hash-table or array)." +(cl-defgeneric mapp (map) + "Return non-nil if MAP is a map (alist, hash-table, array, ...)." (or (listp map) (hash-table-p map) (arrayp map))) -(defun map-empty-p (map) +(cl-defgeneric map-empty-p (map) "Return non-nil if MAP is empty. +The default implementation delegates to `map-length'." + (zerop (map-length map))) + +(cl-defmethod map-empty-p ((map list)) + (null map)) + +(cl-defgeneric map-contains-key (map key &optional testfn) + ;; FIXME: The test function to use generally depends on the map object, + ;; so specifying `testfn' here is problematic: e.g. for hash-tables + ;; we shouldn't use `gethash' unless `testfn' is the same as the map's own + ;; test function! + "Return non-nil If and only if MAP contains KEY. +TESTFN is deprecated. Its default depends on MAP. +The default implementation delegates to `map-do'." + (unless testfn (setq testfn #'equal)) + (catch 'map--catch + (map-do (lambda (k _v) + (if (funcall testfn key k) (throw 'map--catch t))) + map) + nil)) -MAP can be a list, hash-table or array." - (map--dispatch map - :list (null map) - :array (seq-empty-p map) - :hash-table (zerop (hash-table-count map)))) - -(defun map-contains-key (map key &optional testfn) - "If MAP contain KEY return KEY, nil otherwise. -Equality is defined by TESTFN if non-nil or by `equal' if nil. - -MAP can be a list, hash-table or array." - (seq-contains (map-keys map) key testfn)) - -(defun map-some (pred map) - "Return a non-nil if (PRED key val) is non-nil for any key/value pair in MAP. - -MAP can be a list, hash-table or array." +(cl-defmethod map-contains-key ((map list) key &optional testfn) + (let ((v '(nil))) + (not (eq v (alist-get key map v nil (or testfn #'equal)))))) + +(cl-defmethod map-contains-key ((map array) key &optional _testfn) + (and (integerp key) + (>= key 0) + (< key (length map)))) + +(cl-defmethod map-contains-key ((map hash-table) key &optional _testfn) + (let ((v '(nil))) + (not (eq v (gethash key map v))))) + +(cl-defgeneric map-some (pred map) + "Return the first non-nil (PRED key val) in MAP. +The default implementation delegates to `map-apply'." + ;; FIXME: Not sure if there's much benefit to defining it as defgeneric, + ;; since as defined, I can't think of a map-type where we could provide an + ;; algorithmically more efficient algorithm than the default. (catch 'map--break (map-apply (lambda (key value) (let ((result (funcall pred key value))) @@ -282,10 +324,12 @@ MAP can be a list, hash-table or array." map) nil)) -(defun map-every-p (pred map) +(cl-defgeneric map-every-p (pred map) "Return non-nil if (PRED key val) is non-nil for all elements of the map MAP. - -MAP can be a list, hash-table or array." +The default implementation delegates to `map-apply'." + ;; FIXME: Not sure if there's much benefit to defining it as defgeneric, + ;; since as defined, I can't think of a map-type where we could provide an + ;; algorithmically more efficient algorithm than the default. (catch 'map--break (map-apply (lambda (key value) (or (funcall pred key value) @@ -294,9 +338,7 @@ MAP can be a list, hash-table or array." t)) (defun map-merge (type &rest maps) - "Merge into a map of type TYPE all the key/value pairs in MAPS. - -MAP can be a list, hash-table or array." + "Merge into a map of type TYPE all the key/value pairs in MAPS." (let ((result (map-into (pop maps) type))) (while maps ;; FIXME: When `type' is `list', we get an O(N^2) behavior. @@ -310,7 +352,7 @@ MAP can be a list, hash-table or array." (defun map-merge-with (type function &rest maps) "Merge into a map of type TYPE all the key/value pairs in MAPS. -When two maps contain the same key, call FUNCTION on the two +When two maps contain the same key (`eql'), call FUNCTION on the two values and use the value returned by it. MAP can be a list, hash-table or array." (let ((result (map-into (pop maps) type)) @@ -318,49 +360,80 @@ MAP can be a list, hash-table or array." (while maps (map-apply (lambda (key value) (cl-callf (lambda (old) - (if (eq old not-found) + (if (eql old not-found) value (funcall function old value))) (map-elt result key not-found))) (pop maps))) result)) -(defun map-into (map type) - "Convert the map MAP into a map of type TYPE. - -TYPE can be one of the following symbols: list or hash-table. -MAP can be a list, hash-table or array." - (pcase type - (`list (map-pairs map)) - (`hash-table (map--into-hash-table map)) - (_ (error "Not a map type name: %S" type)))) - -(defun map--put (map key v) +(cl-defgeneric map-into (map type) + "Convert the map MAP into a map of type TYPE.") +;; FIXME: I wish there was a way to avoid this η-redex! +(cl-defmethod map-into (map (_type (eql list))) (map-pairs map)) +(cl-defmethod map-into (map (_type (eql alist))) (map-pairs map)) +(cl-defmethod map-into (map (_type (eql plist))) + (let ((plist '())) + (map-do (lambda (k v) (setq plist `(,k ,v ,@plist))) map) + plist)) + +(cl-defgeneric map-put! (map key value &optional testfn) + "Associate KEY with VALUE in MAP. +If KEY is already present in MAP, replace the associated value +with VALUE. +This operates by modifying MAP in place. +If it cannot do that, it signals the `map-not-inplace' error. +If you want to insert an element without modifying MAP, use `map-insert'." + ;; `testfn' only exists for backward compatibility with `map-put'! + (declare (advertised-calling-convention (map key value) "27.1")) (map--dispatch map - :list (let ((p (assoc key map))) - (if p (setcdr p v) - (error "No place to change the mapping for %S" key))) - :hash-table (puthash key v map) - :array (aset map key v))) - -(defun map--apply-alist (function map) - "Private function used to apply FUNCTION over MAP, MAP being an alist." - (seq-map (lambda (pair) - (funcall function - (car pair) - (cdr pair))) - map)) - -(defun map--apply-hash-table (function map) - "Private function used to apply FUNCTION over MAP, MAP being a hash-table." + :list + (if (map--plist-p map) + (plist-put map key value) + (let ((oldmap map)) + (setf (alist-get key map key nil (or testfn #'equal)) value) + (unless (eq oldmap map) + (signal 'map-not-inplace (list oldmap))))) + :hash-table (puthash key value map) + ;; FIXME: If `key' is too large, should we signal `map-not-inplace' + ;; and let `map-insert' grow the array? + :array (aset map key value))) + +(define-error 'map-inplace "Can only modify map in place") + +(cl-defgeneric map-insert (map key value) + "Return a new map like MAP except that it associates KEY with VALUE. +This does not modify MAP. +If you want to insert an element in place, use `map-put!'." + (if (listp map) + (if (map--plist-p map) + `(,key ,value ,@map) + (cons (cons key value) map)) + ;; FIXME: Should we signal an error or use copy+put! ? + (signal 'map-inplace (list map)))) + +;; There shouldn't be old source code referring to `map--put', yet we do +;; need to keep it for backward compatibility with .elc files where the +;; expansion of `setf' may call this function. +(define-obsolete-function-alias 'map--put #'map-put! "27.1") + +(cl-defmethod map-apply (function (map list)) + (if (map--plist-p map) + (cl-call-next-method) + (seq-map (lambda (pair) + (funcall function + (car pair) + (cdr pair))) + map))) + +(cl-defmethod map-apply (function (map hash-table)) (let (result) (maphash (lambda (key value) (push (funcall function key value) result)) map) (nreverse result))) -(defun map--apply-array (function map) - "Private function used to apply FUNCTION over MAP, MAP being an array." +(cl-defmethod map-apply (function (map array)) (let ((index 0)) (seq-map (lambda (elt) (prog1 @@ -368,22 +441,27 @@ MAP can be a list, hash-table or array." (setq index (1+ index)))) map))) -(defun map--do-alist (function alist) +(cl-defmethod map-do (function (map list)) "Private function used to iterate over ALIST using FUNCTION." - (seq-do (lambda (pair) - (funcall function - (car pair) - (cdr pair))) - alist)) - -(defun map--do-array (function array) + (if (map--plist-p map) + (while map + (funcall function (pop map) (pop map))) + (seq-do (lambda (pair) + (funcall function + (car pair) + (cdr pair))) + map))) + +(cl-defmethod map-do (function (array array)) "Private function used to iterate over ARRAY using FUNCTION." (seq-do-indexed (lambda (elt index) (funcall function index elt)) array)) -(defun map--into-hash-table (map) +(cl-defmethod map-into (map (_type (eql hash-table))) "Convert MAP into a hash-table." + ;; FIXME: Just knowing we want a hash-table is insufficient, since that + ;; doesn't tell us the test function to use with it! (let ((ht (make-hash-table :size (map-length map) :test 'equal))) (map-apply (lambda (key value) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 9e058f3c60e..b7c2dab0980 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -4,7 +4,6 @@ ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: extensions, lisp, tools -;; Package: emacs ;; 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 @@ -36,18 +35,23 @@ ;;; Code: +;; 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! +(push (purecopy '(nadvice 1 0)) package--builtin-versions) + ;;;; 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\"\207" 4) + (: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!\"\207" 5) - (:filter-return "\301\300\302\"!\207" 5)) + (:filter-args "\300\302\301\003!\"\207" 5) + (:filter-return "\301\300\302\003\"!\207" 5)) "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. @@ -83,8 +87,9 @@ Each element has the form (WHERE BYTECODE STACK) where: "Build the raw docstring for FUNCTION, presumably advised." (let* ((flist (indirect-function function)) (docfun nil) + (macrop (eq 'macro (car-safe flist))) (docstring nil)) - (if (eq 'macro (car-safe flist)) (setq flist (cdr flist))) + (if macrop (setq flist (cdr flist))) (while (advice--p flist) (let ((doc (aref flist 4)) (where (advice--where flist))) @@ -96,10 +101,11 @@ Each element has the form (WHERE BYTECODE STACK) where: (setq docstring (concat docstring - (propertize (format "%s advice: " where) - 'face 'warning) + (format "This %s has %s advice: " + (if macrop "macro" "function") + where) (let ((fun (advice--car flist))) - (if (symbolp fun) (format-message "`%S'" fun) + (if (symbolp fun) (format-message "`%S'." fun) (let* ((name (cdr (assq 'name (advice--props flist)))) (doc (documentation fun t)) (usage (help-split-fundoc doc function))) @@ -241,6 +247,8 @@ different, but `function-equal' will hopefully ignore those differences.") (if (local-variable-p var) (symbol-value var) (setq advice--buffer-local-function-sample ;; This function acts like the t special value in buffer-local hooks. + ;; FIXME: Provide an `advice-bottom' function that's like + ;; `advice-cd*r' but also follows through this proxy. (lambda (&rest args) (apply (default-value var) args))))) (eval-and-compile diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el index 9e63dce6d7b..e26b6b99c17 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el @@ -204,8 +204,8 @@ if it exists." (split-version (package-desc-version pkg-desc)) (commentary (pcase file-type - (`single (lm-commentary)) - (`tar nil))) ;; FIXME: Get it from the README file. + ('single (lm-commentary)) + ('tar nil))) ;; FIXME: Get it from the README file. (extras (package-desc-extras pkg-desc)) (pkg-version (package-version-join split-version)) (pkg-buffer (current-buffer))) @@ -285,6 +285,7 @@ package (a \".el\" file)." (let ((pkg-desc (package-buffer-info))) (package-upload-buffer-internal pkg-desc "el"))))) +;;;###autoload (defun package-upload-file (file) "Upload the Emacs Lisp package FILE to the package archive. Interactively, prompt for FILE. The package is considered a diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index ab02134bbd8..e7e0bd11247 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -101,7 +101,7 @@ ;; Michael Olson <mwolson@member.fsf.org> ;; Sebastian Tennant <sebyte@smolny.plus.com> ;; Stefan Monnier <monnier@iro.umontreal.ca> -;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Phil Hagelberg <phil@hagelb.org> ;;; ToDo: @@ -143,14 +143,15 @@ ;;; Code: +(require 'cl-lib) (eval-when-compile (require 'subr-x)) -(eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'epg)) ;For setf accessors. (require 'seq) (require 'tabulated-list) (require 'macroexp) (require 'url-handlers) +(require 'browse-url) (defgroup package nil "Manager for Emacs Lisp packages." @@ -161,29 +162,34 @@ ;;; Customization options ;;;###autoload (defcustom package-enable-at-startup t - "Whether to activate installed packages when Emacs starts. -If non-nil, packages are activated after reading the init file -and before `after-init-hook'. Activation is not done if -`user-init-file' is nil (e.g. Emacs was started with \"-q\"). + "Whether to make installed packages available when Emacs starts. +If non-nil, packages are made available before reading the init +file (but after reading the early init file). This means that if +you wish to set this variable, you must do so in the early init +file. Regardless of the value of this variable, packages are not +made available if `user-init-file' is nil (e.g. Emacs was started +with \"-q\"). Even if the value is nil, you can type \\[package-initialize] to -activate the package system at any time." +make installed packages available at any time, or you can +call (package-initialize) in your init-file." :type 'boolean :version "24.1") (defcustom package-load-list '(all) - "List of packages for `package-initialize' to load. + "List of packages for `package-initialize' to make available. Each element in this list should be a list (NAME VERSION), or the -symbol `all'. The symbol `all' says to load the latest installed -versions of all packages not specified by other elements. +symbol `all'. The symbol `all' says to make available the latest +installed versions of all packages not specified by other +elements. For an element (NAME VERSION), NAME is a package name (a symbol). VERSION should be t, a string, or nil. -If VERSION is t, the most recent version is activated. -If VERSION is a string, only that version is ever loaded. +If VERSION is t, the most recent version is made available. +If VERSION is a string, only that version is ever made available. Any other version, even if newer, is silently ignored. Hence, the package is \"held\" at that version. -If VERSION is nil, the package is not loaded (it is \"disabled\")." +If VERSION is nil, the package is not made available (it is \"disabled\")." :type '(repeat (choice (const all) (list :tag "Specific package" (symbol :tag "Package name") @@ -247,7 +253,9 @@ number from the archive with the highest priority is selected. When higher versions are available from archives with lower priorities, the user has to select those manually. -Archives not in this list have the priority 0. +Archives not in this list have the priority 0, as have packages +that are already installed. If you use negative priorities for +the archives, they will not be upgraded automatically. See also `package-menu-hide-low-priority'." :type '(alist :key-type (string :tag "Archive name") @@ -324,21 +332,37 @@ default directory." :risky t :version "26.1") -(defcustom package-check-signature - (if (and (require 'epg-config) - (epg-find-configuration 'OpenPGP)) - 'allow-unsigned) +(defcustom package-check-signature 'allow-unsigned "Non-nil means to check package signatures when installing. -The value `allow-unsigned' means to still install a package even if -it is unsigned. +More specifically the value can be: +- nil: package signatures are ignored. +- `allow-unsigned': install a package even if it is unsigned, but + if it is signed, we have the key for it, and OpenGPG is + installed, verify the signature. +- t: accept a package only if it comes with at least one verified signature. +- `all': same as t, except when the package has several signatures, + in which case we verify all the signatures. This also applies to the \"archive-contents\" file that lists the contents of the archive." :type '(choice (const nil :tag "Never") (const allow-unsigned :tag "Allow unsigned") - (const t :tag "Check always")) + (const t :tag "Check always") + (const all :tag "Check all signatures")) :risky t - :version "24.4") + :version "27.1") + +(defun package-check-signature () + "Check whether we have a usable OpenPGP configuration. +If true, and `package-check-signature' is `allow-unsigned', +return `allow-unsigned', otherwise return the value of +`package-check-signature'." + (if (eq package-check-signature 'allow-unsigned) + (progn + (require 'epg-config) + (and (epg-find-configuration 'OpenPGP) + 'allow-unsigned)) + package-check-signature)) (defcustom package-unsigned-archives nil "List of archives where we do not check for package signatures." @@ -482,7 +506,7 @@ This is, approximately, the inverse of `version-to-list'. str-list)))) (if (equal "." (car str-list)) (pop str-list)) - (apply 'concat (nreverse str-list))))) + (apply #'concat (nreverse str-list))))) (defun package-desc-full-name (pkg-desc) (format "%s-%s" @@ -491,9 +515,9 @@ This is, approximately, the inverse of `version-to-list'. (defun package-desc-suffix (pkg-desc) (pcase (package-desc-kind pkg-desc) - (`single ".el") - (`tar ".tar") - (`dir "") + ('single ".el") + ('tar ".tar") + ('dir "") (kind (error "Unknown package kind: %s" kind)))) (defun package-desc--keywords (pkg-desc) @@ -604,6 +628,12 @@ updates `package-alist'." (when (file-directory-p pkg-dir) (package-load-descriptor pkg-dir)))))))) +(defun package--alist () + "Return `package-alist', after computing it if needed." + (or package-alist + (progn (package-load-all-descriptors) + package-alist))) + (defun define-package (_name-string _version-string &optional _docstring _requirements &rest _extra-properties) @@ -676,13 +706,17 @@ PKG-DESC is a `package-desc' object." (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))))) + (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 @@ -718,7 +752,10 @@ correspond to previously loaded files (those returned by (message "Unable to activate package `%s'.\nRequired package `%s-%s' is unavailable" name (car req) (package-version-join (cadr req))) (throw 'exit nil)))) - (package--load-files-for-activation pkg-desc reload) + (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)) ;; Add info node. (when (file-exists-p (expand-file-name "dir" pkg-dir)) ;; FIXME: not the friendliest, but simple. @@ -738,7 +775,8 @@ DIR, sorted by most recently loaded last." (let* ((history (delq nil (mapcar (lambda (x) (let ((f (car x))) - (and f (file-name-sans-extension f)))) + (and (stringp f) + (file-name-sans-extension f)))) load-history))) (dir (file-truename dir)) ;; List all files that have already been loaded. @@ -825,7 +863,7 @@ untar into a directory named DIR; otherwise, signal an error." (tar-untar-buffer)) (defun package--alist-to-plist-args (alist) - (mapcar 'macroexp-quote + (mapcar #'macroexp-quote (apply #'nconc (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist)))) (defun package-unpack (pkg-desc) @@ -834,7 +872,7 @@ untar into a directory named DIR; otherwise, signal an error." (dirname (package-desc-full-name pkg-desc)) (pkg-dir (expand-file-name dirname package-user-dir))) (pcase (package-desc-kind pkg-desc) - (`dir + ('dir (make-directory pkg-dir t) (let ((file-list (directory-files @@ -848,12 +886,12 @@ untar into a directory named DIR; otherwise, signal an error." ;; things simple by ensuring we're one of them. (setf (package-desc-kind pkg-desc) (if (> (length file-list) 1) 'tar 'single)))) - (`tar + ('tar (make-directory package-user-dir t) ;; FIXME: should we delete PKG-DIR if it exists? (let* ((default-directory (file-name-as-directory package-user-dir))) (package-untar-buffer dirname))) - (`single + ('single (let ((el-file (expand-file-name (format "%s.el" name) pkg-dir))) (make-directory pkg-dir t) (package--write-file-no-coding el-file))) @@ -886,7 +924,9 @@ untar into a directory named DIR; otherwise, signal an error." (print-length nil)) (write-region (concat - ";;; -*- no-byte-compile: t -*-\n" + ";;; Generated package description from " + (replace-regexp-in-string "-pkg\\.el\\'" ".el" pkg-file) + " -*- no-byte-compile: t -*-\n" (prin1-to-string (nconc (list 'define-package @@ -961,17 +1001,12 @@ This assumes that `pkg-desc' has already been activated with (defun package-read-from-string (str) "Read a Lisp expression from STR. Signal an error if the entire string was not used." - (let* ((read-data (read-from-string str)) - (more-left - (condition-case nil - ;; The call to `ignore' suppresses a compiler warning. - (progn (ignore (read-from-string - (substring str (cdr read-data)))) - t) - (end-of-file nil)))) - (if more-left - (error "Can't read whole string") - (car read-data)))) + (pcase-let ((`(,expr . ,offset) (read-from-string str))) + (condition-case () + ;; The call to `ignore' suppresses a compiler warning. + (progn (ignore (read-from-string str offset)) + (error "Can't read whole string")) + (end-of-file expr)))) (defun package--prepare-dependencies (deps) "Turn DEPS into an acceptable list of dependencies. @@ -994,6 +1029,7 @@ is wrapped around any parts requiring it." (declare-function lm-header "lisp-mnt" (header)) (declare-function lm-homepage "lisp-mnt" (&optional file)) +(declare-function lm-keywords-list "lisp-mnt" (&optional file)) (declare-function lm-maintainer "lisp-mnt" (&optional file)) (declare-function lm-authors "lisp-mnt" (&optional file)) @@ -1009,6 +1045,8 @@ boundaries." (let ((file-name (match-string-no-properties 1)) (desc (match-string-no-properties 2)) (start (line-beginning-position))) + ;; The terminating comment format could be extended to accept a + ;; generic string that is not in English. (unless (search-forward (concat ";;; " file-name ".el ends here")) (error "Package lacks a terminating comment")) ;; Try to include a trailing newline. @@ -1022,6 +1060,7 @@ boundaries." (pkg-version (or (package-strip-rcs-id (lm-header "package-version")) (package-strip-rcs-id (lm-header "version")))) + (keywords (lm-keywords-list)) (homepage (lm-homepage))) (unless pkg-version (error @@ -1033,6 +1072,7 @@ boundaries." (package-read-from-string requires-str))) :kind 'single :url homepage + :keywords keywords :maintainer (lm-maintainer) :authors (lm-authors))))) @@ -1170,45 +1210,66 @@ errors signaled by ERROR-FORM or by BODY). (declare (indent defun) (debug t)) (while (keywordp (car body)) (setq body (cdr (cdr body)))) - (macroexp-let2* nil ((url-1 url) - (noerror-1 noerror)) - (let ((url-sym (make-symbol "url")) - (b-sym (make-symbol "b-sym"))) - `(cl-macrolet ((unless-error (body-2 &rest before-body) - (let ((err (make-symbol "err"))) - `(with-temp-buffer - (when (condition-case ,err - (progn ,@before-body t) - ,(list 'error ',error-form - (list 'unless ',noerror-1 - `(signal (car ,err) (cdr ,err))))) - ,@body-2))))) - (if (string-match-p "\\`https?:" ,url-1) - (let ((,url-sym (concat ,url-1 ,file))) - (if ,async - (unless-error nil - (url-retrieve ,url-sym - (lambda (status) - (let ((,b-sym (current-buffer))) - (require 'url-handlers) - (unless-error ,body - (when-let* ((er (plist-get status :error))) - (error "Error retrieving: %s %S" ,url-sym er)) - (with-current-buffer ,b-sym - (goto-char (point-min)) - (unless (search-forward-regexp "^\r?\n\r?" nil 'noerror) - (error "Error retrieving: %s %S" ,url-sym "incomprehensible buffer"))) - (url-insert-buffer-contents ,b-sym ,url-sym) - (kill-buffer ,b-sym) - (goto-char (point-min))))) - nil - 'silent)) - (unless-error ,body (url-insert-file-contents ,url-sym)))) - (unless-error ,body - (let ((url (expand-file-name ,file ,url-1))) - (unless (file-name-absolute-p url) - (error "Location %s is not a url nor an absolute file name" url)) - (insert-file-contents url)))))))) + `(package--with-response-buffer-1 ,url (lambda () ,@body) + :file ,file + :async ,async + :error-function (lambda () ,error-form) + :noerror ,noerror)) + +(defmacro package--unless-error (body &rest before-body) + (declare (debug t) (indent 1)) + (let ((err (make-symbol "err"))) + `(with-temp-buffer + (set-buffer-multibyte nil) + (when (condition-case ,err + (progn ,@before-body t) + (error (funcall error-function) + (unless noerror + (signal (car ,err) (cdr ,err))))) + (funcall ,body))))) + +(cl-defun package--with-response-buffer-1 (url body &key async file error-function noerror &allow-other-keys) + (if (string-match-p "\\`https?:" url) + (let ((url (concat url file))) + (if async + (package--unless-error #'ignore + (url-retrieve + url + (lambda (status) + (let ((b (current-buffer))) + (require 'url-handlers) + (package--unless-error body + (when-let* ((er (plist-get status :error))) + (error "Error retrieving: %s %S" url er)) + (with-current-buffer b + (goto-char (point-min)) + (unless (search-forward-regexp "^\r?\n\r?" nil t) + (error "Error retrieving: %s %S" + url "incomprehensible buffer"))) + (url-insert b) + (kill-buffer b) + (goto-char (point-min))))) + nil + 'silent)) + (package--unless-error body + ;; Copy&pasted from url-insert-file-contents, + ;; except it calls `url-insert' because we want the contents + ;; literally (but there's no url-insert-file-contents-literally). + (let ((buffer (url-retrieve-synchronously url))) + (unless buffer (signal 'file-error (list url "No Data"))) + (when (fboundp 'url-http--insert-file-helper) + ;; XXX: This is HTTP/S specific and should be moved + ;; to url-http instead. See bug#17549. + (url-http--insert-file-helper buffer url)) + (url-insert buffer) + (kill-buffer buffer) + (goto-char (point-min)))))) + (package--unless-error body + (let ((url (expand-file-name file url))) + (unless (file-name-absolute-p url) + (error "Location %s is not a url nor an absolute file name" + url)) + (insert-file-contents-literally url))))) (define-error 'bad-signature "Failed to verify signature") @@ -1229,29 +1290,20 @@ errors." (dolist (sig (epg-context-result-for context 'verify)) (if (eq (epg-signature-status sig) 'good) (push sig good-signatures) - ;; If package-check-signature is allow-unsigned, don't + ;; If `package-check-signature' is allow-unsigned, don't ;; signal error when we can't verify signature because of ;; missing public key. Other errors are still treated as ;; fatal (bug#17625). - (unless (and (eq package-check-signature 'allow-unsigned) + (unless (and (eq (package-check-signature) 'allow-unsigned) (eq (epg-signature-status sig) 'no-pubkey)) (setq had-fatal-error t)))) - (when (or (null good-signatures) had-fatal-error) + (when (or (null good-signatures) + (and (eq (package-check-signature) 'all) + had-fatal-error)) (package--display-verify-error context sig-file) (signal 'bad-signature (list sig-file))) good-signatures))) -(defun package--buffer-string () - (let ((string (buffer-string))) - (when (and buffer-file-coding-system - (> (length string) 0)) - (put-text-property 0 1 'package--cs buffer-file-coding-system string)) - string)) - -(defun package--cs (string) - (and (> (length string) 0) - (get-text-property 0 'package--cs string))) - (defun package--check-signature (location file &optional string async callback unwind) "Check signature of the current buffer. Download the signature file from LOCATION by appending \".sig\" @@ -1271,16 +1323,13 @@ Otherwise, an error is signaled. UNWIND, if provided, is a function to be called after everything else, even if an error is signaled." - (let* ((sig-file (concat file ".sig")) - (string (or string (package--buffer-string))) - (cs (package--cs string))) - ;; Re-encode the downloaded file with the coding-system with which - ;; it was decoded, so we (hopefully) get the exact same bytes back. - (when cs (setq string (encode-coding-string string cs))) + (let ((sig-file (concat file ".sig")) + (string (or string (buffer-string)))) (package--with-response-buffer location :file sig-file :async async :noerror t ;; Connection error is assumed to mean "no sig-file". - :error-form (let ((allow-unsigned (eq package-check-signature 'allow-unsigned))) + :error-form (let ((allow-unsigned + (eq (package-check-signature) 'allow-unsigned))) (when (and callback allow-unsigned) (funcall callback nil)) (when unwind (funcall unwind)) @@ -1289,8 +1338,9 @@ else, even if an error is signaled." ;; OTOH, an error here means "bad signature", which we never ;; suppress. (Bug#22089) (unwind-protect - (let ((sig (package--check-signature-content (buffer-substring (point) (point-max)) - string sig-file))) + (let ((sig (package--check-signature-content + (buffer-substring (point) (point-max)) + string sig-file))) (when callback (funcall callback sig)) sig) (when unwind (funcall unwind)))))) @@ -1451,45 +1501,59 @@ If successful, set `package-archive-contents'." ;; available on disk. (defvar package--initialized nil) -(defvar package--init-file-ensured nil - "Whether we know the init file has package-initialize.") - ;;;###autoload (defun package-initialize (&optional no-activate) "Load Emacs Lisp packages, and activate them. The variable `package-load-list' controls which packages to load. If optional arg NO-ACTIVATE is non-nil, don't activate packages. -If `user-init-file' does not mention `(package-initialize)', add -it to the file. If called as part of loading `user-init-file', set `package-enable-at-startup' to nil, to prevent accidentally loading packages twice. + It is not necessary to adjust `load-path' or `require' the individual packages after calling `package-initialize' -- this is -taken care of by `package-initialize'." +taken care of by `package-initialize'. + +If `package-initialize' is called twice during Emacs startup, +signal a warning, since this is a bad idea except in highly +advanced use cases. To suppress the warning, remove the +superfluous call to `package-initialize' from your init-file. If +you have code which must run before `package-initialize', put +that code in the early init-file." (interactive) + (when (and package--initialized (not after-init-time)) + (lwarn '(package reinitialization) :warning + "Unnecessary call to `package-initialize' in init file")) (setq package-alist nil) - (if after-init-time - (package--ensure-init-file) - ;; If `package-initialize' is before we finished loading the init - ;; file, it's obvious we don't need to ensure-init. - (setq package--init-file-ensured t - ;; And likely we don't need to run it again after init. - package-enable-at-startup nil)) + (setq package-enable-at-startup nil) (package-load-all-descriptors) (package-read-all-archive-contents) - (unless no-activate - (dolist (elt package-alist) - (condition-case err - (package-activate (car elt)) - ;; Don't let failure of activation of a package arbitrarily stop - ;; activation of further packages. - (error (message "%s" (error-message-string err)))))) (setq package--initialized t) + (unless no-activate + (package-activate-all)) ;; This uses `package--mapc' so it must be called after ;; `package--initialized' is t. (package--build-compatibility-table)) +(defvar package-quickstart-file) + +;;;###autoload +(defun package-activate-all () + "Activate all installed packages. +The variable `package-load-list' controls which packages to load." + (setq package-enable-at-startup nil) + (if (file-readable-p package-quickstart-file) + ;; Skip load-source-file-function which would slow us down by a factor + ;; 2 (this assumes we were careful to save this file so it doesn't need + ;; any decoding). + (let ((load-source-file-function nil)) + (load package-quickstart-file nil 'nomessage)) + (dolist (elt (package--alist)) + (condition-case err + (package-activate (car elt)) + ;; Don't let failure of activation of a package arbitrarily stop + ;; activation of further packages. + (error (message "%s" (error-message-string err))))))) ;;;; Populating `package-archive-contents' from archives ;; This subsection populates the variables listed above from the @@ -1544,25 +1608,27 @@ similar to an entry in `package-alist'. Save the cached copy to :error-form (package--update-downloads-in-progress archive) (let* ((location (cdr archive)) (name (car archive)) - (content (package--buffer-string)) - (dir (expand-file-name (format "archives/%s" name) package-user-dir)) + (content (buffer-string)) + (dir (expand-file-name (concat "archives/" name) package-user-dir)) (local-file (expand-file-name file dir))) (when (listp (read content)) (make-directory dir t) - (if (or (not package-check-signature) + (if (or (not (package-check-signature)) (member name package-unsigned-archives)) ;; If we don't care about the signature, save the file and ;; we're done. - (progn (let ((coding-system-for-write - (or (package--cs content) 'utf-8))) - (write-region content nil local-file nil 'silent)) - (package--update-downloads-in-progress archive)) + (progn + (cl-assert (not enable-multibyte-characters)) + (let ((coding-system-for-write 'binary)) + (write-region content nil local-file nil 'silent)) + (package--update-downloads-in-progress archive)) ;; If we care, check it (perhaps async) and *then* write the file. (package--check-signature location file content async ;; This function will be called after signature checking. (lambda (&optional good-sigs) - (let ((coding-system-for-write (or (package--cs content) 'utf-8))) + (cl-assert (not enable-multibyte-characters)) + (let ((coding-system-for-write 'binary)) (write-region content nil local-file nil 'silent)) ;; Write out good signatures into archive-contents.signed file. (when good-sigs @@ -1598,8 +1664,8 @@ downloads in the background." (make-directory package-user-dir t)) (let ((default-keyring (expand-file-name "package-keyring.gpg" data-directory)) - (inhibit-message async)) - (when (and package-check-signature (file-exists-p default-keyring)) + (inhibit-message (or inhibit-message async))) + (when (and (package-check-signature) (file-exists-p default-keyring)) (condition-case-unless-debug error (package-import-keyring default-keyring) (error (message "Cannot import default keyring: %S" (cdr error)))))) @@ -1846,7 +1912,7 @@ if all the in-between dependencies are also in PACKAGE-LIST." (file (concat (package-desc-full-name pkg-desc) (package-desc-suffix pkg-desc)))) (package--with-response-buffer location :file file - (if (or (not package-check-signature) + (if (or (not (package-check-signature)) (member (package-desc-archive pkg-desc) package-unsigned-archives)) ;; If we don't care about the signature, unpack and we're @@ -1854,15 +1920,16 @@ if all the in-between dependencies are also in PACKAGE-LIST." (let ((save-silently t)) (package-unpack pkg-desc)) ;; If we care, check it and *then* write the file. - (let ((content (package--buffer-string))) + (let ((content (buffer-string))) (package--check-signature location file content nil ;; This function will be called after signature checking. (lambda (&optional good-sigs) ;; Signature checked, unpack now. - (with-temp-buffer + (with-temp-buffer ;FIXME: Just use the previous current-buffer. + (set-buffer-multibyte nil) + (cl-assert (not (multibyte-string-p content))) (insert content) - (setq buffer-file-coding-system (package--cs content)) (let ((save-silently t)) (package-unpack pkg-desc))) ;; Here the package has been installed successfully, mark it as @@ -1878,7 +1945,8 @@ if all the in-between dependencies are also in PACKAGE-LIST." ;; Update the old pkg-desc which will be shown on the description buffer. (setf (package-desc-signed pkg-desc) t) ;; Update the new (activated) pkg-desc as well. - (when-let* ((pkg-descs (cdr (assq (package-desc-name pkg-desc) package-alist)))) + (when-let* ((pkg-descs (cdr (assq (package-desc-name pkg-desc) + package-alist)))) (setf (package-desc-signed (car pkg-descs)) t)))))))))) (defun package-installed-p (package &optional min-version) @@ -1887,18 +1955,25 @@ 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." - (unless package--initialized (error "package.el is not yet initialized!")) - (if (package-desc-p package) - (let ((dir (package-desc-dir package))) + (cond + ((package-desc-p package) + (let ((dir (package-desc-dir package))) (and (stringp dir) - (file-exists-p dir))) + (file-exists-p dir)))) + ((and (not package--initialized) + (null min-version) + package-activated-list) + ;; We used the quickstart: make it possible to use package-installed-p + ;; even before package is fully initialized. + (memq package package-activated-list)) + (t (or - (let ((pkg-descs (cdr (assq package package-alist)))) + (let ((pkg-descs (cdr (assq package (package--alist))))) (and pkg-descs (version-list-<= min-version (package-desc-version (car pkg-descs))))) ;; Also check built-in packages. - (package-built-in-p package min-version)))) + (package-built-in-p package min-version))))) (defun package-download-transaction (packages) "Download and install all the packages in PACKAGES. @@ -1908,64 +1983,6 @@ PACKAGES are satisfied, i.e. that PACKAGES is computed using `package-compute-transaction'." (mapc #'package-install-from-archive packages)) -(defun package--ensure-init-file () - "Ensure that the user's init file has `package-initialize'. -`package-initialize' doesn't have to be called, as long as it is -present somewhere in the file, even as a comment. If it is not, -add a call to it along with some explanatory comments." - ;; Don't mess with the init-file from "emacs -Q". - (when (and (stringp user-init-file) - (not package--init-file-ensured) - (file-readable-p user-init-file) - (file-writable-p user-init-file)) - (let* ((buffer (find-buffer-visiting user-init-file)) - buffer-name - (contains-init - (if buffer - (with-current-buffer buffer - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (re-search-forward "(package-initialize\\_>" nil 'noerror)))) - ;; Don't visit the file if we don't have to. - (with-temp-buffer - (insert-file-contents user-init-file) - (goto-char (point-min)) - (re-search-forward "(package-initialize\\_>" nil 'noerror))))) - (unless contains-init - (with-current-buffer (or buffer - (let ((delay-mode-hooks t) - (find-file-visit-truename t)) - (find-file-noselect user-init-file))) - (when buffer - (setq buffer-name (buffer-file-name)) - (set-visited-file-name (file-chase-links user-init-file))) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (and (looking-at-p "[[:blank:]]*\\(;\\|$\\)") - (not (eobp))) - (forward-line 1)) - (insert - "\n" - ";; Added by Package.el. This must come before configurations of\n" - ";; installed packages. Don't delete this line. If you don't want it,\n" - ";; just comment it out by adding a semicolon to the start of the line.\n" - ";; You may delete these explanatory comments.\n" - "(package-initialize)\n") - (unless (looking-at-p "$") - (insert "\n")) - (let ((file-precious-flag t)) - (save-buffer)) - (if buffer - (progn - (set-visited-file-name buffer-name) - (set-buffer-modified-p nil)) - (kill-buffer (current-buffer))))))))) - (setq package--init-file-ensured t)) - ;;;###autoload (defun package-install (pkg &optional dont-select) "Install the package PKG. @@ -2007,7 +2024,9 @@ to install it but still mark it as selected." (package-compute-transaction (list pkg) (package-desc-reqs pkg))) (package-compute-transaction () (list (list pkg)))))) - (package-download-transaction transaction) + (progn + (package-download-transaction transaction) + (package--quickstart-maybe-refresh)) (message "`%s' is already installed" name)))) (defun package-strip-rcs-id (str) @@ -2091,12 +2110,12 @@ If some packages are not installed propose to install them." (cond (available (when (y-or-n-p - (format "%s packages will be installed:\n%s, proceed?" + (format "Packages to install: %d (%s), proceed? " (length available) - (mapconcat #'symbol-name available ", "))) + (mapconcat #'symbol-name available " "))) (mapc (lambda (p) (package-install p 'dont-select)) available))) ((> difference 0) - (message "%s packages are not available (the rest already installed), maybe you need to `M-x package-refresh-contents'" + (message "Packages that are not available: %d (the rest is already installed), maybe you need to `M-x package-refresh-contents'" difference)) (t (message "All your packages are already installed")))))) @@ -2122,16 +2141,12 @@ If NOSAVE is non-nil, the package is not removed from `package-selected-packages'." (interactive (progn - ;; Initialize the package system to get the list of package - ;; symbols for completion. - (unless package--initialized - (package-initialize t)) (let* ((package-table (mapcar (lambda (p) (cons (package-desc-full-name p) p)) (delq nil (mapcar (lambda (p) (unless (package-built-in-p p) p)) - (apply #'append (mapcar #'cdr package-alist)))))) + (apply #'append (mapcar #'cdr (package--alist))))))) (package-name (completing-read "Delete package: " (mapcar #'car package-table) nil t))) @@ -2166,6 +2181,9 @@ If NOSAVE is non-nil, the package is not removed from (add-hook 'post-command-hook #'package-menu--post-refresh) (delete-directory dir t) ;; Remove NAME-VERSION.signed and NAME-readme.txt files. + ;; + ;; NAME-readme.txt files are no longer created, but they + ;; may be left around from an earlier install. (dolist (suffix '(".signed" "readme.txt")) (let* ((version (package-version-join (package-desc-version pkg-desc))) (file (concat (if (string= suffix ".signed") @@ -2179,7 +2197,9 @@ If NOSAVE is non-nil, the package is not removed from (delete pkg-desc pkgs) (unless (cdr pkgs) (setq package-alist (delq pkgs package-alist)))) - (message "Package `%s' deleted." (package-desc-full-name pkg-desc)))))) + (package--quickstart-maybe-refresh) + (message "Package `%s' deleted." + (package-desc-full-name pkg-desc)))))) ;;;###autoload (defun package-reinstall (pkg) @@ -2213,9 +2233,9 @@ will be deleted." (let ((removable (package--removable-packages))) (if removable (when (y-or-n-p - (format "%s packages will be deleted:\n%s, proceed? " + (format "Packages to delete: %d (%s), proceed? " (length removable) - (mapconcat #'symbol-name removable ", "))) + (mapconcat #'symbol-name removable " "))) (mapc (lambda (p) (package-delete (cadr (assq p package-alist)) t)) removable)) @@ -2234,12 +2254,12 @@ will be deleted." ;; Load the package list if necessary (but don't activate them). (unless package--initialized (package-initialize t)) - (let ((packages (append (mapcar 'car package-alist) - (mapcar 'car package-archive-contents) - (mapcar 'car package--builtins)))) + (let ((packages (append (mapcar #'car package-alist) + (mapcar #'car package-archive-contents) + (mapcar #'car package--builtins)))) (unless (memq guess packages) (setq guess nil)) - (setq packages (mapcar 'symbol-name packages)) + (setq packages (mapcar #'symbol-name packages)) (let ((val (completing-read (if guess (format "Describe package (default %s): " @@ -2247,7 +2267,7 @@ will be deleted." "Describe package: ") packages nil t nil nil (when guess (symbol-name guess))))) - (list (intern val)))))) + (list (and (> (length val) 0) (intern val))))))) (if (not (or (package-desc-p package) (and package (symbolp package)))) (message "No package specified") (help-setup-xref (list #'describe-package package) @@ -2274,6 +2294,45 @@ Otherwise no newline is inserted." (declare-function lm-commentary "lisp-mnt" (&optional file)) +(defun package--get-description (desc) + "Return a string containing the long description of the package DESC. +The description is read from the installed package files." + ;; Installed packages have nil for kind, so we look for README + ;; first, then fall back to the Commentary header. + + ;; We don’t include README.md here, because that is often the home + ;; page on a site like github, and not suitable as the package long + ;; description. + (let ((files '("README-elpa" "README-elpa.md" "README" "README.rst" "README.org")) + file + (srcdir (package-desc-dir desc)) + result) + (while (and files + (not result)) + (setq file (pop files)) + (when (file-readable-p (expand-file-name file srcdir)) + ;; Found a README. + (with-temp-buffer + (insert-file-contents (expand-file-name file srcdir)) + (setq result (buffer-string))))) + + (or + result + + ;; Look for Commentary header. + (let ((mainsrcfile (expand-file-name (format "%s.el" (package-desc-name desc)) + srcdir))) + (when (file-readable-p mainsrcfile) + (with-temp-buffer + (insert (or (lm-commentary mainsrcfile) "")) + (goto-char (point-min)) + (when (re-search-forward "^;;; Commentary:\n" nil t) + (replace-match "")) + (while (re-search-forward "^\\(;+ ?\\)" nil t) + (replace-match "")) + (buffer-string)))) + ))) + (defun describe-package-1 (pkg) (require 'lisp-mnt) (let* ((desc (or @@ -2302,12 +2361,10 @@ Otherwise no newline is inserted." (setq status "available obsolete")) (when incompatible-reason (setq status "incompatible")) - (prin1 name) - (princ " is ") - (princ (if (memq (aref status 0) '(?a ?e ?i ?o ?u)) "an " "a ")) - (princ status) - (princ " package.\n\n") + (princ (format "Package %S is %s.\n\n" name status)) + ;; TODO: Remove the string decorations and reformat the strings + ;; for future l10n. (package--print-help-section "Status") (cond (built-in (insert (propertize (capitalize status) @@ -2448,39 +2505,47 @@ Otherwise no newline is inserted." (insert "\n") - (if built-in - ;; For built-in packages, insert the commentary. - (let ((fn (locate-file (format "%s.el" name) load-path - load-file-rep-suffixes)) - (opoint (point))) - (insert (or (lm-commentary fn) "")) - (save-excursion - (goto-char opoint) - (when (re-search-forward "^;;; Commentary:\n" nil t) - (replace-match "")) - (while (re-search-forward "^\\(;+ ?\\)" nil t) - (replace-match "")))) - (let* ((basename (format "%s-readme.txt" name)) - (readme (expand-file-name basename package-user-dir)) - readme-string) - ;; For elpa packages, try downloading the commentary. If that - ;; fails, try an existing readme file in `package-user-dir'. - (cond ((and (package-desc-archive desc) - (package--with-response-buffer (package-archive-base desc) - :file basename :noerror t - (save-excursion - (goto-char (point-max)) - (unless (bolp) - (insert ?\n))) - (write-region nil nil - (expand-file-name readme package-user-dir) - nil 'silent) - (setq readme-string (buffer-string)) - t)) - (insert readme-string)) - ((file-readable-p readme) - (insert-file-contents readme) - (goto-char (point-max)))))))) + (let ((start-of-description (point))) + (if built-in + ;; For built-in packages, get the description from the + ;; Commentary header. + (let ((fn (locate-file (format "%s.el" name) load-path + load-file-rep-suffixes)) + (opoint (point))) + (insert (or (lm-commentary fn) "")) + (save-excursion + (goto-char opoint) + (when (re-search-forward "^;;; Commentary:\n" nil t) + (replace-match "")) + (while (re-search-forward "^\\(;+ ?\\)" nil t) + (replace-match "")))) + + (if (package-installed-p desc) + ;; For installed packages, get the description from the + ;; installed files. + (insert (package--get-description desc)) + + ;; For non-built-in, non-installed packages, get description from + ;; the archive. + (let* ((basename (format "%s-readme.txt" name)) + readme-string) + + (package--with-response-buffer (package-archive-base desc) + :file basename :noerror t + (save-excursion + (goto-char (point-max)) + (unless (bolp) + (insert ?\n))) + (cl-assert (not enable-multibyte-characters)) + (setq readme-string + ;; The readme.txt files are defined to contain utf-8 text. + (decode-coding-region (point-min) (point-max) 'utf-8 t)) + t) + (insert (or readme-string + "This package does not provide a description."))))) + ;; Make URLs in the description into links. + (goto-char start-of-description) + (browse-url-add-buttons)))) (defun package-install-button-action (button) (let ((pkg-desc (button-get button 'package-desc))) @@ -2509,7 +2574,7 @@ Otherwise no newline is inserted." :background "light grey" :foreground "black") 'link))) - (apply 'insert-text-button button-text 'face button-face 'follow-link t + (apply #'insert-text-button button-text 'face button-face 'follow-link t props))) @@ -2537,7 +2602,7 @@ Otherwise no newline is inserted." (easy-menu-define package-menu-mode-menu package-menu-mode-map "Menu for `package-menu-mode'." - `("Package" + '("Package" ["Describe Package" package-menu-describe-package :help "Display information about this package"] ["Help" package-menu-quick-help :help "Show short key binding help for package-menu-mode"] "--" @@ -2590,8 +2655,12 @@ Letters do not insert themselves; instead, they are commands. ("Description" 0 nil)]) (setq tabulated-list-padding 2) (setq tabulated-list-sort-key (cons "Status" nil)) - (add-hook 'tabulated-list-revert-hook 'package-menu--refresh nil t) - (tabulated-list-init-header)) + (add-hook 'tabulated-list-revert-hook #'package-menu--refresh nil t) + (tabulated-list-init-header) + (setf imenu-prev-index-position-function + #'package--imenu-prev-index-position-function) + (setf imenu-extract-index-name-function + #'package--imenu-extract-index-name-function)) (defmacro package--push (pkg-desc status listname) "Convenience macro for `package-menu--generate'. @@ -2689,9 +2758,9 @@ Installed obsolete packages are always displayed.") (user-error "The current buffer is not a Package Menu")) (setq package-menu--hide-packages (not package-menu--hide-packages)) - (message "%s packages" (if package-menu--hide-packages - "Hiding obsolete or unwanted" - "Displaying all")) + (if package-menu--hide-packages + (message "Hiding obsolete or unwanted packages") + (message "Displaying all packages")) (revert-buffer nil 'no-confirm)) (defun package--remove-hidden (pkg-list) @@ -2717,12 +2786,11 @@ to their archives." ((not package-menu-hide-low-priority) pkg-list) ((eq package-menu-hide-low-priority 'archive) - (let* ((max-priority most-negative-fixnum) - (out)) + (let (max-priority out) (while pkg-list (let ((p (pop pkg-list))) (let ((priority (package-desc-priority p))) - (if (< priority max-priority) + (if (and max-priority (< priority max-priority)) (setq pkg-list nil) (push p out) (setq max-priority priority))))) @@ -2862,7 +2930,7 @@ shown." (package-menu--refresh packages keywords) (setf (car (aref tabulated-list-format 0)) (if keywords - (let ((filters (mapconcat 'identity keywords ","))) + (let ((filters (mapconcat #'identity keywords ","))) (concat "Package[" filters "]")) "Package")) (if keywords @@ -2955,17 +3023,17 @@ PKG is a `package-desc' object. Return (PKG-DESC [NAME VERSION STATUS DOC])." (let* ((status (package-desc-status pkg)) (face (pcase status - (`"built-in" 'package-status-built-in) - (`"external" 'package-status-external) - (`"available" 'package-status-available) - (`"avail-obso" 'package-status-avail-obso) - (`"new" 'package-status-new) - (`"held" 'package-status-held) - (`"disabled" 'package-status-disabled) - (`"installed" 'package-status-installed) - (`"dependency" 'package-status-dependency) - (`"unsigned" 'package-status-unsigned) - (`"incompat" 'package-status-incompat) + ("built-in" 'package-status-built-in) + ("external" 'package-status-external) + ("available" 'package-status-available) + ("avail-obso" 'package-status-avail-obso) + ("new" 'package-status-new) + ("held" 'package-status-held) + ("disabled" 'package-status-disabled) + ("installed" 'package-status-installed) + ("dependency" 'package-status-dependency) + ("unsigned" 'package-status-unsigned) + ("incompat" 'package-status-incompat) (_ 'font-lock-warning-face)))) ; obsolete. (list pkg `[(,(symbol-name (package-desc-name pkg)) @@ -3015,11 +3083,11 @@ If optional arg BUTTON is non-nil, describe its associated package." (let ((hidden (cl-remove-if-not (lambda (e) (string-match re (symbol-name (car e)))) package-archive-contents))) - (message (substitute-command-keys - (concat "Hiding %s packages, type `\\[package-menu-toggle-hiding]'" - " to toggle or `\\[customize-variable] RET package-hidden-regexps'" - " to customize it")) - (length hidden))))) + (message "Packages to hide: %d. Type `%s' to toggle or `%s' to customize" + (length hidden) + (substitute-command-keys "\\[package-menu-toggle-hidding]") + (substitute-command-keys "\\[customize-variable] RET package-hidden-regexps"))))) + (defun package-menu-describe-package (&optional button) "Describe the current package. @@ -3154,7 +3222,7 @@ Implementation of `package-menu-mark-upgrades'." (setq package-menu--mark-upgrades-pending nil) (let ((upgrades (package-menu--find-upgrades))) (if (null upgrades) - (message "No packages to upgrade.") + (message "No packages to upgrade") (widen) (save-excursion (goto-char (point-min)) @@ -3167,9 +3235,9 @@ Implementation of `package-menu-mark-upgrades'." (package-menu-mark-install)) (t (package-menu-mark-delete)))))) - (message "%d package%s marked for upgrading." - (length upgrades) - (if (= (length upgrades) 1) "" "s"))))) + (message "Packages marked for upgrading: %d" + (length upgrades))))) + (defun package-menu-mark-upgrades () "Mark all upgradable packages in the Package Menu. @@ -3192,17 +3260,12 @@ immediately." 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')." - (cond - ;; None - ((not packages) "") - ;; More than 1 - ((cdr packages) - (format "these %d packages (%s)" - (length packages) - (mapconcat #'package-desc-full-name packages ", "))) - ;; Exactly 1 - (t (format-message "package `%s'" - (package-desc-full-name (car packages)))))) + ;; The case where `package' is empty is handled in + ;; `package-menu--prompt-transaction-p' below. + (format "%d (%s)" + (length packages) + (mapconcat #'package-desc-full-name packages " "))) + (defun package-menu--prompt-transaction-p (delete install upgrade) "Prompt the user about DELETE, INSTALL, and UPGRADE. @@ -3210,16 +3273,14 @@ DELETE, INSTALL, and UPGRADE are lists of `package-desc' objects. Either may be nil, but not all." (y-or-n-p (concat - (when delete "Delete ") - (package-menu--list-to-prompt delete) - (when (and delete install) - (if upgrade "; " "; and ")) - (when install "Install ") - (package-menu--list-to-prompt install) - (when (and upgrade (or install delete)) "; and ") - (when upgrade "Upgrade ") - (package-menu--list-to-prompt upgrade) - "? "))) + (when 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))) + (when upgrade + (format "Packages to upgrade: %s. " (package-menu--list-to-prompt upgrade))) + "Proceed? "))) + (defun package-menu--partition-transaction (install delete) "Return an alist describing an INSTALL DELETE transaction. @@ -3255,7 +3316,7 @@ objects removed." (redisplay 'force) (dolist (elt (package--sort-by-dependence delete-list)) (condition-case-unless-debug err - (let ((inhibit-message package-menu-async)) + (let ((inhibit-message (or inhibit-message package-menu-async))) (package-delete elt nil 'nosave)) (error (message "Error trying to delete `%s': %S" (package-desc-full-name elt) @@ -3303,25 +3364,24 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (when (or noquery (package-menu--prompt-transaction-p .delete .install .upgrade)) (let ((message-template - (concat "Package menu: Operation %s [" - (when .delete (format "Delet__ %s" (length .delete))) - (when (and .delete .install) "; ") - (when .install (format "Install__ %s" (length .install))) - (when (and .upgrade (or .install .delete)) "; ") - (when .upgrade (format "Upgrad__ %s" (length .upgrade))) + (concat "[ " + (when .delete + (format "Delete %d " (length .delete))) + (when .install + (format "Install %d " (length .install))) + (when .upgrade + (format "Upgrade %d " (length .upgrade))) "]"))) - (message (replace-regexp-in-string "__" "ing" message-template) "started") + (message "Operation %s started" message-template) ;; Packages being upgraded are not marked as selected. (package--update-selected-packages .install .delete) (package-menu--perform-transaction install-list delete-list) (when package-selected-packages (if-let* ((removable (package--removable-packages))) - (message "Package menu: Operation finished. %d packages %s" - (length removable) - (substitute-command-keys - "are no longer needed, type `\\[package-autoremove]' to remove them")) - (message (replace-regexp-in-string "__" "ed" message-template) - "finished")))))))) + (message "Operation finished. Packages that are no longer needed: %d. Type `%s' to remove them" + (length removable) + (substitute-command-keys "\\[package-autoremove]")) + (message "Operation %s finished" message-template)))))))) (defun package-menu--version-predicate (A B) (let ((vA (or (aref (cadr A) 1) '(0))) @@ -3388,11 +3448,10 @@ Store this list in `package-menu--new-package-list'." (defun package-menu--find-and-notify-upgrades () "Notify the user of upgradable packages." (when-let* ((upgrades (package-menu--find-upgrades))) - (message "%d package%s can be upgraded; type `%s' to mark %s for upgrading." - (length upgrades) - (if (= (length upgrades) 1) "" "s") - (substitute-command-keys "\\[package-menu-mark-upgrades]") - (if (= (length upgrades) 1) "it" "them")))) + (message "Packages that can be upgraded: %d; type `%s' to mark for upgrading." + (length upgrades) + (substitute-command-keys "\\[package-menu-mark-upgrades]")))) + (defun package-menu--post-refresh () "If there's a *Packages* buffer, revert it and check for new packages and upgrades. @@ -3488,10 +3547,16 @@ shown." (defun package-menu-filter (keyword) "Filter the *Packages* buffer. Show only those items that relate to the specified KEYWORD. + KEYWORD can be a string or a list of strings. If it is a list, a package will be displayed if it matches any of the keywords. Interactively, it is a list of strings separated by commas. +KEYWORD can also be used to filter by status or archive name by +using keywords like \"arc:gnu\" and \"status:available\". +Statuses available include \"incompat\", \"available\", +\"built-in\" and \"installed\". + To restore the full package list, type `q'." (interactive (list (completing-read-multiple @@ -3507,6 +3572,149 @@ The list is displayed in a buffer named `*Packages*'." (interactive) (list-packages t)) +;;;###autoload +(defun package-get-version () + "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)." + ;; 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)) + ;; Hack alert! + (let ((file + (or (if (boundp 'byte-compile-current-file) byte-compile-current-file) + load-file-name + buffer-file-name))) + (cond + ((null file) nil) + ;; Packages are normally installed into directories named "<pkg>-<vers>", + ;; so get the version number from there. + ((string-match "/[^/]+-\\([0-9]\\(?:[0-9.]\\|pre\\|beta\\|alpha\\|snapshot\\)+\\)/[^/]+\\'" file) + (match-string 1 file)) + ;; For packages run straight from the an elpa.git clone, there's no + ;; "-<vers>" in the directory name, so we have to fetch the version + ;; the hard way. + (t + (let* ((pkgdir (file-name-directory file)) + (pkgname (file-name-nondirectory (directory-file-name pkgdir))) + (mainfile (expand-file-name (concat pkgname ".el") pkgdir))) + (when (file-readable-p mainfile) + (require 'lisp-mnt) + (with-temp-buffer + (insert-file-contents mainfile) + (or (lm-header "package-version") + (lm-header "version"))))))))) + +;;;; Quickstart: precompute activation actions for faster start up. + +;; Activating packages via `package-initialize' is costly: for N installed +;; packages, it needs to read all N <pkg>-pkg.el files first to decide +;; which packages to activate, and then again N <pkg>-autoloads.el files. +;; To speed this up, we precompute a mega-autoloads file which is the +;; concatenation of all those <pkg>-autoloads.el, so we can activate +;; all packages by loading this one file (and hence without initializing +;; package.el). + +;; Other than speeding things up, this also offers a bootstrap feature: +;; it lets us activate packages according to `package-load-list' and +;; `package-user-dir' even before those vars are set. + +(defcustom package-quickstart nil + "Precompute activation actions to speed up startup. +This requires the use of `package-quickstart-refresh' every time the +activations need to be changed, such as when `package-load-list' is modified." + :type 'boolean + :version "27.1") + +(defcustom package-quickstart-file + (locate-user-emacs-file "package-quickstart.el") + "Location of the file used to speed up activation of packages at startup." + :type 'file + :version "27.1") + +(defun package--quickstart-maybe-refresh () + (if package-quickstart + ;; FIXME: Delay refresh in case we're installing/deleting + ;; several packages! + (package-quickstart-refresh) + (delete-file package-quickstart-file))) + +(defun package-quickstart-refresh () + "(Re)Generate the `package-quickstart-file'." + (interactive) + (package-initialize 'no-activate) + (require 'info) + (let ((package--quickstart-pkgs ()) + ;; Pretend we haven't activated anything yet! + (package-activated-list ()) + ;; Make sure we can load this file without load-source-file-function. + (coding-system-for-write 'emacs-internal) + (Info-directory-list '(""))) + (dolist (elt package-alist) + (condition-case err + (package-activate (car elt)) + ;; Don't let failure of activation of a package arbitrarily stop + ;; activation of further packages. + (error (message "%s" (error-message-string err))))) + (setq package--quickstart-pkgs (nreverse package--quickstart-pkgs)) + (with-temp-file package-quickstart-file + (emacs-lisp-mode) ;For `syntax-ppss'. + (insert ";;; Quickstart file to activate all packages at startup -*- lexical-binding:t -*-\n") + (insert ";; ¡¡ This file is autogenerated by `package-quickstart-refresh', DO NOT EDIT !!\n\n") + (dolist (pkg package--quickstart-pkgs) + (let* ((file + ;; Prefer uncompiled files (and don't accept .so files). + (let ((load-suffixes '(".el" ".elc"))) + (locate-library (package--autoloads-file-name pkg)))) + (pfile (prin1-to-string file))) + (insert "(let ((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)) + (replace-match (if (match-end 1) "" pfile) t t))) + (unless (bolp) (insert "\n")) + (insert ")\n"))) + (pp `(setq package-activated-list + (append ',(mapcar #'package-desc-name package--quickstart-pkgs) + package-activated-list)) + (current-buffer)) + (let ((info-dirs (butlast Info-directory-list))) + (when info-dirs + (pp `(progn (require 'info) + (info-initialize) + (setq Info-directory-list + (append ',info-dirs Info-directory-list))) + (current-buffer)))) + ;; Use `\s' instead of a space character, so this code chunk is not + ;; mistaken for an actual file-local section of package.el. + (insert " +;; Local\sVariables: +;; version-control: never +;;\sno-byte-compile: t +;; no-update-autoloads: t +;; End: +")))) + +(defun package--imenu-prev-index-position-function () + "Move point to previous line in package-menu buffer. +This function is used as a value for +`imenu-prev-index-position-function'." + (unless (bobp) + (forward-line -1))) + +(defun package--imenu-extract-index-name-function () + "Return imenu name for line at point. +This function is used as a value for +`imenu-extract-index-name-function'. Point should be at the +beginning of the line." + (let ((package-desc (tabulated-list-get-id))) + (format "%s (%s): %s" + (package-desc-name package-desc) + (package-version-join (package-desc-version package-desc)) + (package-desc-summary package-desc)))) + (provide 'package) ;;; package.el ends here diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 7859860c560..ae2cf8eb02f 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -63,6 +63,7 @@ ;; FIXME: Now that macroexpansion is also performed when loading an interpreted ;; file, this is not a real problem any more. (defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq)) +;; (defconst pcase--memoize (make-hash-table :test 'eq)) ;; (defconst pcase--memoize-1 (make-hash-table :test 'eq)) ;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal)) @@ -175,7 +176,9 @@ Emacs Lisp manual for more information and examples." ;; FIXME: Obviously, this will collide with nadvice's use of ;; function-documentation if we happen to advise `pcase'. +;;;###autoload (put 'pcase 'function-documentation '(pcase--make-docstring)) +;;;###autoload (defun pcase--make-docstring () (let* ((main (documentation (symbol-function 'pcase) 'raw)) (ud (help-split-fundoc main 'pcase))) @@ -782,25 +785,26 @@ Otherwise, it defers to REST which is a list of branches of the form ((eq 'or (caar matches)) (let* ((alts (cdar matches)) (var (if (eq (caar alts) 'match) (cadr (car alts)))) - (simples '()) (others '()) (memq-ok t)) + (simples '()) (others '()) (mem-fun 'memq)) (when var (dolist (alt alts) (if (and (eq (car alt) 'match) (eq var (cadr alt)) (let ((upat (cddr alt))) (eq (car-safe upat) 'quote))) (let ((val (cadr (cddr alt)))) - (unless (or (integerp val) (symbolp val)) - (setq memq-ok nil)) - (push (cadr (cddr alt)) simples)) + (cond ((integerp val) + (when (eq mem-fun 'memq) + (setq mem-fun 'memql))) + ((not (symbolp val)) + (setq mem-fun 'member))) + (push val simples)) (push alt others)))) (cond ((null alts) (error "Please avoid it") (pcase--u rest)) - ;; Yes, we can use `memq' (or `member')! + ;; Yes, we can use `memql' (or `member')! ((> (length simples) 1) (pcase--u1 (cons `(match ,var - . (pred (pcase--flip - ,(if memq-ok #'memq #'member) - ',simples))) + . (pred (pcase--flip ,mem-fun ',simples))) (cdr matches)) code vars (if (null others) rest @@ -887,7 +891,8 @@ Otherwise, it defers to REST which is a list of branches of the form (else-rest (cdr splitrest))) (pcase--if (cond ((null val) `(null ,sym)) - ((or (integerp val) (symbolp val)) + ((integerp val) `(eql ,sym ,val)) + ((symbolp val) (if (pcase--self-quoting-p val) `(eq ,sym ,val) `(eq ,sym ',val))) @@ -936,7 +941,7 @@ QPAT can take the following forms: ,PAT matches if the `pcase' pattern PAT matches. SYMBOL matches if EXPVAL is `equal' to SYMBOL. KEYWORD likewise for KEYWORD. - INTEGER likewise for INTEGER. + NUMBER likewise for NUMBER. STRING likewise for STRING. The list or vector QPAT is a template. The predicate formed @@ -966,7 +971,10 @@ The predicate is the logical-AND of: `(and (pred consp) (app car ,(list '\` (car qpat))) (app cdr ,(list '\` (cdr qpat))))) - ((or (stringp qpat) (integerp qpat) (symbolp qpat)) `',qpat) + ((or (stringp qpat) (numberp qpat) (symbolp qpat)) `',qpat) + ;; In all other cases just raise an error so we can't break + ;; backward compatibility when adding \` support for other + ;; compounded values that are not `consp' (t (error "Unknown QPAT: %S" qpat)))) (provide 'pcase) diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el index 519087ca3e7..dd65e1a0b4e 100644 --- a/lisp/emacs-lisp/radix-tree.el +++ b/lisp/emacs-lisp/radix-tree.el @@ -74,7 +74,7 @@ (cmp (compare-strings prefix nil nil key i ni))) (if (eq t cmp) (pcase (radix-tree--remove ptree key ni) - (`nil rtree) + ('nil rtree) (`((,pprefix . ,pptree)) `((,(concat prefix pprefix) . ,pptree) . ,rtree)) (nptree `((,prefix . ,nptree) . ,rtree))) @@ -196,8 +196,8 @@ If not found, return nil." (eval-and-compile (pcase-defmacro radix-tree-leaf (vpat) - "Build a `pcase' pattern that matches radix-tree leaf EXPVAL. -VPAT is a `pcase' pattern to extract the value." + "Pattern which matches a radix-tree leaf. +The pattern VPAT is matched against the leaf's carried value." ;; FIXME: We'd like to use a negative pattern (not consp), but pcase ;; doesn't support it. Using `atom' works but generates sub-optimal code. `(or `(t . ,,vpat) (and (pred atom) ,vpat)))) @@ -237,6 +237,8 @@ PREFIX is only used internally." (radix-tree-iter-mappings tree (lambda (_k _v) (setq i (1+ i)))) i)) +(declare-function map-apply "map" (function map)) + (defun radix-tree-from-map (map) ;; Aka (cl-defmethod map-into (map (type (eql radix-tree)))) ...) (require 'map) diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index f5b1dd89b4b..961d26a7212 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -240,6 +240,7 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (define-key menu-map [rq] '(menu-item "Quit" reb-quit :help "Quit the RE Builder mode")) + (define-key menu-map [div1] '(menu-item "--")) (define-key menu-map [rt] '(menu-item "Case sensitive" reb-toggle-case :button (:toggle . (with-current-buffer @@ -252,6 +253,7 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (define-key menu-map [rs] '(menu-item "Change syntax..." reb-change-syntax :help "Change the syntax used by the RE Builder")) + (define-key menu-map [div2] '(menu-item "--")) (define-key menu-map [re] '(menu-item "Enter subexpression mode" reb-enter-subexp-mode :help "Enter the subexpression mode in the RE Builder")) @@ -264,6 +266,7 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (define-key menu-map [rp] '(menu-item "Go to previous match" reb-prev-match :help "Go to previous match in the RE Builder target window")) + (define-key menu-map [div3] '(menu-item "--")) (define-key menu-map [rc] '(menu-item "Copy current RE" reb-copy :help "Copy current RE into the kill ring for later insertion")) @@ -339,6 +342,7 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (cond ((reb-lisp-syntax-p) (reb-lisp-mode)) (t (reb-mode))) + (reb-restart-font-lock) (reb-do-update)) (defun reb-mode-buffer-p () @@ -371,6 +375,7 @@ matching parts of the target buffer will be highlighted." (setq reb-window-config (current-window-configuration)) (split-window (selected-window) (- (window-height) 4))))) (switch-to-buffer (get-buffer-create reb-buffer)) + (font-lock-mode 1) (reb-initialize-buffer))) (defun reb-change-target-buffer (buf) @@ -447,8 +452,10 @@ matching parts of the target buffer will be highlighted." (reb-update-regexp) (let ((re (with-output-to-string (print (reb-target-binding reb-regexp))))) - (kill-new (substring re 1 (1- (length re)))) - (message "Regexp copied to kill-ring"))) + (setq re (substring re 1 (1- (length re)))) + (setq re (replace-regexp-in-string "\n" "\\n" re nil t)) + (kill-new re) + (message "Copied regexp `%s' to kill-ring" re))) ;; The subexpression mode is not electric because the number of ;; matches should be seen rather than a prompt. @@ -483,6 +490,8 @@ If the optional PAUSE is non-nil then pause at the end in any case." (use-local-map reb-mode-map) (reb-do-update)) +(defvar reb-change-syntax-hist nil) + (defun reb-change-syntax (&optional syntax) "Change the syntax used by the RE Builder. Optional argument SYNTAX must be specified if called non-interactively." @@ -491,7 +500,8 @@ Optional argument SYNTAX must be specified if called non-interactively." (completing-read (format "Select syntax (default %s): " reb-re-syntax) '(read string sregex rx) - nil t nil nil (symbol-name reb-re-syntax))))) + nil t nil nil (symbol-name reb-re-syntax) + 'reb-change-syntax-hist)))) (if (memq syntax '(read string sregex rx)) (let ((buffer (get-buffer reb-buffer))) @@ -653,8 +663,14 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions." (subexps (reb-count-subexps re)) (matches 0) (submatches 0) - firstmatch) + firstmatch + here + firstmatch-after-here) (with-current-buffer reb-target-buffer + (setq here + (if reb-target-window + (with-selected-window reb-target-window (window-point)) + (point))) (reb-delete-overlays) (goto-char (point-min)) (while (and (not (eobp)) @@ -689,6 +705,9 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions." ;; `reb-match-1' must exist. 'reb-match-1)))) (unless firstmatch (setq firstmatch (match-data))) + (unless firstmatch-after-here + (when (> (point) here) + (setq firstmatch-after-here (match-data)))) (setq reb-overlays (cons overlay reb-overlays) submatches (1+ submatches)) (overlay-put overlay 'face face) @@ -703,7 +722,7 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions." (= reb-auto-match-limit count)) " (limit reached)" ""))) (when firstmatch - (store-match-data firstmatch) + (store-match-data (or firstmatch-after-here firstmatch)) (reb-show-subexp (or subexp 0))))) ;; The End @@ -718,6 +737,124 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions." ;; continue standard unloading nil) +(defun reb-fontify-string-re (bound) + (catch 'found + ;; The following loop is needed to continue searching after matches + ;; that do not occur in strings. The associated regexp matches one + ;; of `\\\\' `\\(' `\\(?:' `\\|' `\\)'. `\\\\' has been included to + ;; avoid highlighting, for example, `\\(' in `\\\\('. + (when (memq reb-re-syntax '(read string)) + (while (re-search-forward + (if (eq reb-re-syntax 'read) + ;; Copied from font-lock.el + "\\(\\\\\\\\\\)\\(?:\\(\\\\\\\\\\)\\|\\((\\(?:\\?[0-9]*:\\)?\\|[|)]\\)\\)" + "\\(\\\\\\)\\(?:\\(\\\\\\)\\|\\((\\(?:\\?[0-9]*:\\)?\\|[|)]\\)\\)") + bound t) + (unless (match-beginning 2) + (let ((face (get-text-property (1- (point)) 'face))) + (when (or (and (listp face) + (memq 'font-lock-string-face face)) + (eq 'font-lock-string-face face) + t) + (throw 'found t)))))))) + +(defface reb-regexp-grouping-backslash + '((t :inherit font-lock-keyword-face :weight bold :underline t)) + "Font Lock mode face for backslashes in Lisp regexp grouping constructs." + :group 're-builder) + +(defface reb-regexp-grouping-construct + '((t :inherit font-lock-keyword-face :weight bold :underline t)) + "Font Lock mode face used to highlight grouping constructs in Lisp regexps." + :group 're-builder) + +(defconst reb-string-font-lock-keywords + (eval-when-compile + '(((reb-fontify-string-re + (1 'reb-regexp-grouping-backslash prepend) + (3 'reb-regexp-grouping-construct prepend)) + (reb-mark-non-matching-parenthesis)) + nil))) + +(defsubst reb-while (limit counter where) + (let ((count (symbol-value counter))) + (if (= count limit) + (progn + (message "Reached (while limit=%s, where=%s)" limit where) + nil) + (set counter (1+ count))))) + +(defun reb-mark-non-matching-parenthesis (bound) + ;; We have a small string, check the whole of it, but wait until + ;; everything else is fontified. + (when (>= bound (point-max)) + (let (left-pars + faces-here) + (goto-char (point-min)) + (while (and (reb-while 100 'n-reb "mark-par") + (not (eobp))) + (skip-chars-forward "^()") + (unless (eobp) + (setq faces-here (get-text-property (point) 'face)) + ;; It is already fontified, use that info: + (when (or (eq 'reb-regexp-grouping-construct faces-here) + (and (listp faces-here) + (memq 'reb-regexp-grouping-construct faces-here))) + (cond ((eq (char-after) ?\() + (setq left-pars (cons (point) left-pars))) + ((eq (char-after) ?\)) + (if left-pars + (setq left-pars (cdr left-pars)) + (put-text-property (point) (1+ (point)) + 'face 'font-lock-warning-face))) + (t (message "markpar: char-after=%s" + (char-to-string (char-after)))))) + (forward-char))) + (dolist (lp left-pars) + (put-text-property lp (1+ lp) + 'face 'font-lock-warning-face))))) + +(require 'rx) +(defconst reb-rx-font-lock-keywords + (let ((constituents (mapcar (lambda (rec) + (symbol-name (car rec))) + rx-constituents)) + (syntax (mapcar (lambda (rec) (symbol-name (car rec))) rx-syntax)) + (categories (mapcar (lambda (rec) + (symbol-name (car rec))) + rx-categories))) + `( + (,(concat "(" (regexp-opt (list "rx-to-string") t) "[[:space:]]") + (1 font-lock-function-name-face)) + (,(concat "(" (regexp-opt (list "rx") t) "[[:space:]]") + (1 font-lock-preprocessor-face)) + (,(concat "(category[[:space:]]+" (regexp-opt categories t) ")") + (1 font-lock-variable-name-face)) + (,(concat "(syntax[[:space:]]+" (regexp-opt syntax t) ")") + (1 font-lock-type-face)) + (,(concat "(" (regexp-opt constituents t)) + (1 font-lock-keyword-face)) + ))) + +(defun reb-restart-font-lock () + "Restart `font-lock-mode' to fit current regexp format." + (message "reb-restart-font-lock re-re-syntax=%s" reb-re-syntax) + (with-current-buffer (get-buffer reb-buffer) + (let ((font-lock-is-on font-lock-mode)) + (font-lock-mode -1) + (kill-local-variable 'font-lock-set-defaults) + ;;(set (make-local-variable 'reb-re-syntax) 'string) + ;;(set (make-local-variable 'reb-re-syntax) 'rx) + (setq font-lock-defaults + (cond + ((memq reb-re-syntax '(read string)) + reb-string-font-lock-keywords) + ((eq reb-re-syntax 'rx) + '(reb-rx-font-lock-keywords + nil)) + (t nil))) + (when font-lock-is-on (font-lock-mode 1))))) + (provide 're-builder) ;;; re-builder.el ends here diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index 63786c1508c..ab52003cdf7 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -84,11 +84,14 @@ ;;; Code: ;;;###autoload -(defun regexp-opt (strings &optional paren) +(defun regexp-opt (strings &optional paren keep-order) "Return a regexp to match a string in the list STRINGS. -Each string should be unique in STRINGS and should not contain -any regexps, quoted or not. Optional PAREN specifies how the -returned regexp is surrounded by grouping constructs. +Each member of STRINGS is treated as a fixed string, not as a regexp. +Optional PAREN specifies how the returned regexp is surrounded by +grouping constructs. + +If STRINGS is the empty list, the return value is a regexp that +never matches anything. The optional argument PAREN can be any of the following: @@ -111,8 +114,14 @@ nil necessary to ensure that a postfix operator appended to it will apply to the whole expression. -The resulting regexp is equivalent to but usually more efficient -than that of a simplified version: +The optional argument KEEP-ORDER, if nil or omitted, allows the +returned regexp to match the strings in any order. If non-nil, +the match is guaranteed to be performed in the order given, as if +the strings were made into a regexp by joining them with the +`\\|' operator. + +Up to reordering, the resulting regexp is equivalent to but +usually more efficient than that of a simplified version: (defun simplified-regexp-opt (strings &optional paren) (let ((parens @@ -131,9 +140,34 @@ than that of a simplified version: (completion-ignore-case nil) (completion-regexp-list nil) (open (cond ((stringp paren) paren) (paren "\\("))) - (sorted-strings (delete-dups - (sort (copy-sequence strings) 'string-lessp))) - (re (regexp-opt-group sorted-strings (or open t) (not open)))) + (re + (cond + ;; No strings: return an unmatchable regexp. + ((null strings) + (concat (or open "\\(?:") regexp-unmatchable "\\)")) + + ;; The algorithm will generate a pattern that matches + ;; longer strings in the list before shorter. If the + ;; list order matters, then no string must come after a + ;; proper prefix of that string. To check this, verify + ;; that a straight or-pattern matches each string + ;; entirely. + ((and keep-order + (let* ((case-fold-search nil) + (alts (mapconcat #'regexp-quote strings "\\|"))) + (and (let ((s strings)) + (while (and s + (string-match alts (car s)) + (= (match-end 0) (length (car s)))) + (setq s (cdr s))) + ;; If we exited early, we found evidence that + ;; regexp-opt-group cannot be used. + s) + (concat (or open "\\(?:") alts "\\)"))))) + (t + (regexp-opt-group + (delete-dups (sort (copy-sequence strings) 'string-lessp)) + (or open t) (not open)))))) (cond ((eq paren 'words) (concat "\\<" re "\\>")) ((eq paren 'symbols) @@ -258,7 +292,9 @@ Merges keywords to avoid backtracking in Emacs's regexp matcher." (defun regexp-opt-charset (chars) "Return a regexp to match a character in CHARS. -CHARS should be a list of characters." +CHARS should be a list of characters. +If CHARS is the empty list, the return value is a regexp that +never matches anything." ;; The basic idea is to find character ranges. Also we take care in the ;; position of character set meta characters in the character set regexp. ;; @@ -305,13 +341,16 @@ CHARS should be a list of characters." (while (>= end start) (setq charset (format "%s%c" charset start)) (setq start (1+ start))))) - ;; - ;; Make sure a caret is not first and a dash is first or last. - (if (and (string-equal charset "") (string-equal bracket "")) - (if (string-equal dash "") - "\\^" ; [^] is not a valid regexp - (concat "[" dash caret "]")) - (concat "[" bracket charset caret dash "]")))) + + ;; Make sure that ] is first, ^ is not first, - is first or last. + (let ((all (concat bracket charset caret dash))) + (pcase (length all) + (0 regexp-unmatchable) + (1 (regexp-quote all)) + (_ (if (string-equal all "^-") + "[-^]" + (concat "[" all "]"))))))) + (provide 'regexp-opt) diff --git a/lisp/emacs-lisp/regi.el b/lisp/emacs-lisp/regi.el index f8268ed27b3..c2e1c44dcfc 100644 --- a/lisp/emacs-lisp/regi.el +++ b/lisp/emacs-lisp/regi.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1993, 2001-2019 Free Software Foundation, Inc. ;; Author: 1993 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com> -;; Maintainer: bwarsaw@cen.com ;; Created: 24-Feb-1993 ;; Version: 1.8 ;; Last Modified: 1993/06/01 21:33:00 diff --git a/lisp/emacs-lisp/ring.el b/lisp/emacs-lisp/ring.el index cfbe4eb9ef8..c7d0268a77f 100644 --- a/lisp/emacs-lisp/ring.el +++ b/lisp/emacs-lisp/ring.el @@ -189,17 +189,28 @@ Raise error if ITEM is not in the RING." (defun ring-extend (ring x) "Increase the size of RING by X." (when (and (integerp x) (> x 0)) - (let* ((hd (car ring)) - (length (ring-length ring)) - (size (ring-size ring)) - (old-vec (cddr ring)) - (new-vec (make-vector (+ size x) nil))) - (setcdr ring (cons length new-vec)) - ;; If the ring is wrapped, the existing elements must be written - ;; out in the right order. - (dotimes (j length) - (aset new-vec j (aref old-vec (mod (+ hd j) size)))) - (setcar ring 0)))) + (ring-resize ring (+ x (ring-size ring))))) + +(defun ring-resize (ring size) + "Set the size of RING to SIZE. +If the new size is smaller, then the oldest items in the ring are +discarded." + (when (integerp size) + (let ((length (ring-length ring)) + (new-vec (make-vector size nil))) + (if (= length 0) + (setcdr ring (cons 0 new-vec)) + (let* ((hd (car ring)) + (old-size (ring-size ring)) + (old-vec (cddr ring)) + (copy-length (min size length)) + (copy-hd (mod (+ hd (- length copy-length)) length))) + (setcdr ring (cons copy-length new-vec)) + ;; If the ring is wrapped, the existing elements must be written + ;; out in the right order. + (dotimes (j copy-length) + (aset new-vec j (aref old-vec (mod (+ copy-hd j) old-size)))) + (setcar ring 0)))))) (defun ring-insert+extend (ring item &optional grow-p) "Like `ring-insert', but if GROW-P is non-nil, then enlarge ring. diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el index 5411f2ba77b..47f3b8dc9cf 100644 --- a/lisp/emacs-lisp/rmc.el +++ b/lisp/emacs-lisp/rmc.el @@ -116,15 +116,10 @@ Usage example: (cons (capitalize (cadr elem)) (car elem))) choices))) - (condition-case err + (condition-case nil (let ((cursor-in-echo-area t)) - (read-char)) - (error (when (equal (cadr err) "Non-character input-event") - ;; Use up the non-character input-event. - ;; Otherwise we'll just keep reading it - ;; again and again (Bug#32257). - (read-event)) - nil)))) + (read-event)) + (error nil)))) (setq answer (lookup-key query-replace-map (vector tchar) t)) (setq tchar (cond diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index a16c5da053a..249529e54e3 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -1,4 +1,4 @@ -;;; rx.el --- sexp notation for regular expressions +;;; rx.el --- sexp notation for regular expressions -*- lexical-binding: t -*- ;; Copyright (C) 2001-2019 Free Software Foundation, Inc. @@ -47,57 +47,58 @@ ;; Rx translates a sexp notation for regular expressions into the ;; usual string notation. The translation can be done at compile-time -;; by using the `rx' macro. It can be done at run-time by calling -;; function `rx-to-string'. See the documentation of `rx' for a -;; complete description of the sexp notation. +;; by using the `rx' macro. The `regexp' and `literal' forms accept +;; non-constant expressions, in which case `rx' will translate to a +;; `concat' expression. Translation can be done fully at run time by +;; calling function `rx-to-string'. See the documentation of `rx' for +;; a complete description of the sexp notation. ;; ;; Some examples of string regexps and their sexp counterparts: ;; ;; "^[a-z]*" -;; (rx (and line-start (0+ (in "a-z")))) +;; (rx line-start (0+ (in "a-z"))) ;; ;; "\n[^ \t]" -;; (rx (and "\n" (not (any " \t")))) +;; (rx ?\n (not (in " \t"))) ;; ;; "\\*\\*\\* EOOH \\*\\*\\*\n" ;; (rx "*** EOOH ***\n") ;; ;; "\\<\\(catch\\|finally\\)\\>[^_]" -;; (rx (and word-start (submatch (or "catch" "finally")) word-end -;; (not (any ?_)))) +;; (rx word-start (submatch (or "catch" "finally")) word-end +;; (not (in ?_))) ;; -;; "[ \t\n]*:\\([^:]+\\|$\\)" -;; (rx (and (zero-or-more (in " \t\n")) ":" -;; (submatch (or line-end (one-or-more (not (any ?:))))))) +;; "[ \t\n]*:\\($\\|[^:]+\\)" +;; (rx (* (in " \t\n")) ":" +;; (submatch (or line-end (+ (not (in ?:)))))) ;; -;; "^content-transfer-encoding:\\(\n?[\t ]\\)*quoted-printable\\(\n?[\t ]\\)*" -;; (rx (and line-start -;; "content-transfer-encoding:" -;; (+ (? ?\n)) (any " \t") -;; "quoted-printable" -;; (+ (? ?\n)) (any " \t")) +;; "^content-transfer-encoding:\\(?:\n?[\t ]\\)*quoted-printable\\(?:\n?[\t ]\\)*" +;; (rx line-start +;; "content-transfer-encoding:" +;; (* (? ?\n) (in " \t")) +;; "quoted-printable" +;; (* (? ?\n) (in " \t"))) ;; ;; (concat "^\\(?:" something-else "\\)") -;; (rx (and line-start (eval something-else))), statically or -;; (rx-to-string '(and line-start ,something-else)), dynamically. +;; (rx line-start (regexp something-else)) ;; ;; (regexp-opt '(STRING1 STRING2 ...)) ;; (rx (or STRING1 STRING2 ...)), or in other words, `or' automatically ;; calls `regexp-opt' as needed. ;; ;; "^;;\\s-*\n\\|^\n" -;; (rx (or (and line-start ";;" (0+ space) ?\n) -;; (and line-start ?\n))) +;; (rx (or (seq line-start ";;" (0+ space) ?\n) +;; (seq line-start ?\n))) ;; ;; "\\$[I]d: [^ ]+ \\([^ ]+\\) " -;; (rx (and "$Id: " -;; (1+ (not (in " "))) -;; " " -;; (submatch (1+ (not (in " ")))) -;; " ")) +;; (rx "$Id: " +;; (1+ (not (in " "))) +;; " " +;; (submatch (1+ (not (in " ")))) +;; " ") ;; ;; "\\\\\\\\\\[\\w+" -;; (rx (and ?\\ ?\\ ?\[ (1+ word))) +;; (rx "\\\\[" (1+ word)) ;; ;; etc. @@ -106,14 +107,17 @@ ;;; Code: +(require 'cl-lib) +(require 'cl-extra) + ;; FIXME: support macros. (defvar rx-constituents ;Not `const' because some modes extend it. - '((and . (rx-and 1 nil)) + '((and . (rx-and 0 nil)) (seq . and) ; SRE (: . and) ; SRE (sequence . and) ; sregex - (or . (rx-or 1 nil)) + (or . (rx-or 0 nil)) (| . or) ; SRE (not-newline . ".") (nonl . not-newline) ; SRE @@ -173,6 +177,7 @@ (not-syntax . (rx-not-syntax 1 1)) ; sregex (category . (rx-category 1 1 rx-check-category)) (eval . (rx-eval 1 1)) + (literal . (rx-literal 1 1 stringp)) (regexp . (rx-regexp 1 1 stringp)) (regex . regexp) ; sregex (digit . "[[:digit:]]") @@ -244,7 +249,9 @@ regular expressions.") (defconst rx-categories - '((consonant . ?0) + '((space-for-indent . ?\s) + (base . ?.) + (consonant . ?0) (base-vowel . ?1) (upper-diacritical-mark . ?2) (lower-diacritical-mark . ?3) @@ -263,7 +270,9 @@ regular expressions.") (japanese-hiragana-two-byte . ?H) (indian-two-byte . ?I) (japanese-katakana-two-byte . ?K) + (strong-left-to-right . ?L) (korean-hangul-two-byte . ?N) + (strong-right-to-left . ?R) (cyrillic-two-byte . ?Y) (combining-diacritic . ?^) (ascii . ?a) @@ -295,6 +304,10 @@ regular expression strings.") "Non-nil means produce greedy regular expressions for `zero-or-one', `zero-or-more', and `one-or-more'. Dynamically bound.") +(defvar rx--compile-to-lisp nil + "Nil means return a regexp as a string. +Non-nil means we may return a lisp form which produces a +string (used for `rx' macro).") (defun rx-info (op head) "Return parsing/code generation info for OP. @@ -337,7 +350,7 @@ a standalone symbol." (> nargs max-args)) (error "rx form `%s' accepts at most %d args" (car form) max-args)) - (when (not (null type-pred)) + (when type-pred (dolist (sub-form (cdr form)) (unless (funcall type-pred sub-form) (error "rx form `%s' requires args satisfying `%s'" @@ -353,8 +366,9 @@ is non-nil." ;; for concatenation ((eq group ':) (if (rx-atomic-p - (if (string-match - "\\(?:[?*+]\\??\\|\\\\{[0-9]*,?[0-9]*\\\\}\\)\\'" regexp) + (if (and (stringp regexp) + (string-match + "\\(?:[?*+]\\??\\|\\\\{[0-9]*,?[0-9]*\\\\}\\)\\'" regexp)) (substring regexp 0 (match-beginning 0)) regexp)) (setq group nil))) @@ -363,9 +377,10 @@ is non-nil." ;; do anyway ((eq group t)) ((rx-atomic-p regexp t) (setq group nil))) - (if group - (concat "\\(?:" regexp "\\)") - regexp)) + (cond ((and group (stringp regexp)) + (concat "\\(?:" regexp "\\)")) + (group `("\\(?:" ,@regexp "\\)")) + (t regexp))) (defvar rx-parent) @@ -377,7 +392,7 @@ is non-nil." FORM is of the form `(and FORM1 ...)'." (rx-check form) (rx-group-if - (mapconcat (lambda (x) (rx-form x ':)) (cdr form) nil) + (rx--subforms (cdr form) ':) (and (memq rx-parent '(* t)) rx-parent))) @@ -385,9 +400,11 @@ FORM is of the form `(and FORM1 ...)'." "Parse and produce code from FORM, which is `(or FORM1 ...)'." (rx-check form) (rx-group-if - (if (memq nil (mapcar 'stringp (cdr form))) - (mapconcat (lambda (x) (rx-form x '|)) (cdr form) "\\|") - (regexp-opt (cdr form))) + (cond + ((null (cdr form)) regexp-unmatchable) + ((cl-every #'stringp (cdr form)) + (regexp-opt (cdr form) nil t)) + (t (rx--subforms (cdr form) '| "\\|"))) (and (memq rx-parent '(: * t)) rx-parent))) @@ -423,6 +440,13 @@ Only both edges of each range is checked." ;; set L list of all ranges (mapc (lambda (e) (cond ((stringp e) (push e str)) ((numberp e) (push (cons e e) l)) + ;; Ranges between ASCII and raw bytes are split, + ;; to prevent accidental inclusion of Unicode + ;; characters later on. + ((and (<= (car e) #x7f) + (>= (cdr e) #x3fff80)) + (push (cons (car e) #x7f) l) + (push (cons #x3fff80 (cdr e)) l)) (t (push e l)))) args) ;; condense overlapped ranges in L @@ -447,28 +471,38 @@ Only both edges of each range is checked." (defun rx-check-any-string (str) - "Check string argument STR for Rx `any'." - (let ((i 0) - c1 c2 l) - (if (= 0 (length str)) - (error "String arg for Rx `any' must not be empty")) - (while (string-match ".-." str i) - ;; string before range: convert it to characters - (if (< i (match-beginning 0)) - (setq l (nconc - l - (append (substring str i (match-beginning 0)) nil)))) - ;; range - (setq i (match-end 0) - c1 (aref str (match-beginning 0)) - c2 (aref str (1- i))) - (cond - ((< c1 c2) (setq l (nconc l (list (cons c1 c2))))) - ((= c1 c2) (setq l (nconc l (list c1)))))) - ;; rest? - (if (< i (length str)) - (setq l (nconc l (append (substring str i) nil)))) - l)) + "Turn the `any' argument string STR into a list of characters. +The original order is not preserved. Ranges, \"A-Z\", become pairs, (?A . ?Z)." + (let ((decode-char + ;; Make sure raw bytes are decoded as such, to avoid confusion with + ;; U+0080..U+00FF. + (if (multibyte-string-p str) + #'identity + (lambda (c) (if (<= #x80 c #xff) + (+ c #x3fff00) + c)))) + (len (length str)) + (i 0) + (ret nil)) + (if (= 0 len) + (error "String arg for Rx `any' must not be empty")) + (while (< i len) + (cond ((and (< i (- len 2)) + (= (aref str (+ i 1)) ?-)) + ;; Range. + (let ((start (funcall decode-char (aref str i))) + (end (funcall decode-char (aref str (+ i 2))))) + (cond ((< start end) (push (cons start end) ret)) + ((= start end) (push start ret)) + (t + (error "Rx character range `%c-%c' is reversed" + start end))) + (setq i (+ i 3)))) + (t + ;; Single character. + (push (funcall decode-char (aref str i)) ret) + (setq i (+ i 1))))) + ret)) (defun rx-check-any (arg) @@ -483,7 +517,10 @@ Only both edges of each range is checked." (null (string-match "\\`\\[\\[:[-a-z]+:\\]\\]\\'" translation))) (error "Invalid char class `%s' in Rx `any'" arg)) (list (substring translation 1 -1)))) ; strip outer brackets - ((and (integerp (car-safe arg)) (integerp (cdr-safe arg))) + ((and (characterp (car-safe arg)) (characterp (cdr-safe arg))) + (unless (<= (car arg) (cdr arg)) + (error "Rx character range `%c-%c' is reversed" + (car arg) (cdr arg))) (list arg)) ((stringp arg) (rx-check-any-string arg)) ((error @@ -589,7 +626,7 @@ ARG is optional." (rx-check form) (let ((result (rx-form (cadr form) '!)) case-fold-search) - (cond ((string-match "\\`\\[^" result) + (cond ((string-match "\\`\\[\\^" result) (cond ((equal result "[^]") "[^^]") ((and (= (length result) 4) (null (eq rx-parent '!))) @@ -640,7 +677,10 @@ If SKIP is non-nil, allow that number of items after the head, i.e. (unless (and (integerp (nth 1 form)) (> (nth 1 form) 0)) (error "rx `=' requires positive integer first arg")) - (format "%s\\{%d\\}" (rx-form (nth 2 form) '*) (nth 1 form))) + (let ((subform (rx-form (nth 2 form) '*))) + (if (stringp subform) + (format "%s\\{%d\\}" subform (nth 1 form)) + `(,@subform ,(format "\\{%d\\}" (nth 1 form)))))) (defun rx->= (form) @@ -650,7 +690,10 @@ If SKIP is non-nil, allow that number of items after the head, i.e. (unless (and (integerp (nth 1 form)) (> (nth 1 form) 0)) (error "rx `>=' requires positive integer first arg")) - (format "%s\\{%d,\\}" (rx-form (nth 2 form) '*) (nth 1 form))) + (let ((subform (rx-form (nth 2 form) '*))) + (if (stringp subform) + (format "%s\\{%d,\\}" subform (nth 1 form)) + `(,@subform ,(format "\\{%d,\\}" (nth 1 form)))))) (defun rx-** (form) @@ -671,7 +714,10 @@ FORM is either `(repeat N FORM1)' or `(repeat N M FORMS...)'." (unless (and (integerp (nth 1 form)) (> (nth 1 form) 0)) (error "rx `repeat' requires positive integer first arg")) - (format "%s\\{%d\\}" (rx-form (nth 2 form) '*) (nth 1 form))) + (let ((subform (rx-form (nth 2 form) '*))) + (if (stringp subform) + (format "%s\\{%d\\}" subform (nth 1 form)) + `(,@subform ,(format "\\{%d\\}" (nth 1 form)))))) ((or (not (integerp (nth 2 form))) (< (nth 2 form) 0) (not (integerp (nth 1 form))) @@ -679,30 +725,28 @@ FORM is either `(repeat N FORM1)' or `(repeat N M FORMS...)'." (< (nth 2 form) (nth 1 form))) (error "rx `repeat' range error")) (t - (format "%s\\{%d,%d\\}" (rx-form (nth 3 form) '*) - (nth 1 form) (nth 2 form))))) + (let ((subform (rx-form (nth 3 form) '*))) + (if (stringp subform) + (format "%s\\{%d,%d\\}" subform (nth 1 form) (nth 2 form)) + `(,@subform ,(format "\\{%d,%d\\}" (nth 1 form) (nth 2 form)))))))) (defun rx-submatch (form) "Parse and produce code from FORM, which is `(submatch ...)'." - (concat "\\(" - (if (= 2 (length form)) - ;; Only one sub-form. - (rx-form (cadr form)) - ;; Several sub-forms implicitly concatenated. - (mapconcat (lambda (re) (rx-form re ':)) (cdr form) nil)) - "\\)")) + (let ((subforms (rx--subforms (cdr form) ':))) + (if (stringp subforms) + (concat "\\(" subforms "\\)") + `("\\(" ,@subforms "\\)")))) (defun rx-submatch-n (form) "Parse and produce code from FORM, which is `(submatch-n N ...)'." - (let ((n (nth 1 form))) - (concat "\\(?" (number-to-string n) ":" - (if (= 3 (length form)) - ;; Only one sub-form. - (rx-form (nth 2 form)) - ;; Several sub-forms implicitly concatenated. - (mapconcat (lambda (re) (rx-form re ':)) (cddr form) nil)) - "\\)"))) + (let ((n (nth 1 form)) + (subforms (rx--subforms (cddr form) ':))) + (unless (and (integerp n) (> n 0)) + (error "rx `submatch-n' argument must be positive")) + (if (stringp subforms) + (concat "\\(?" (number-to-string n) ":" subforms "\\)") + `("\\(?" ,(number-to-string n) ":" ,@subforms "\\)")))) (defun rx-backref (form) "Parse and produce code from FORM, which is `(backref N)'." @@ -724,15 +768,18 @@ If OP is anything else, produce a greedy regexp if `rx-greedy-flag' is non-nil." (rx-check form) (setq form (rx-trans-forms form)) - (let ((suffix (cond ((memq (car form) '(* + ?\s)) "") - ((memq (car form) '(*? +? ??)) "?") + (let ((suffix (cond ((memq (car form) '(* + \? ?\s)) "") + ((memq (car form) '(*? +? \?? ??)) "?") (rx-greedy-flag "") (t "?"))) (op (cond ((memq (car form) '(* *? 0+ zero-or-more)) "*") ((memq (car form) '(+ +? 1+ one-or-more)) "+") - (t "?")))) + (t "?"))) + (subform (rx-form (cadr form) '*))) (rx-group-if - (concat (rx-form (cadr form) '*) op suffix) + (if (stringp subform) + (concat subform op suffix) + `(,@subform ,(concat op suffix))) (and (memq rx-parent '(t *)) rx-parent)))) @@ -760,15 +807,18 @@ regexps that are atomic but end in operators, such as be detected without much effort. A guarantee of no false negatives would require a theoretic specification of the set of all atomic regexps." - (let ((l (length r))) - (cond - ((<= l 1)) - ((= l 2) (= (aref r 0) ?\\)) - ((= l 3) (string-match "\\`\\(?:\\\\[cCsS_]\\|\\[[^^]\\]\\)" r)) - ((null lax) + (if (and rx--compile-to-lisp + (not (stringp r))) + nil ;; Runtime value, we must assume non-atomic. + (let ((l (length r))) (cond - ((string-match "\\`\\[^?\]?\\(?:\\[:[a-z]+:]\\|[^]]\\)*\\]\\'" r)) - ((string-match "\\`\\\\(\\(?:[^\\]\\|\\\\[^)]\\)*\\\\)\\'" r))))))) + ((<= l 1)) + ((= l 2) (= (aref r 0) ?\\)) + ((= l 3) (string-match "\\`\\(?:\\\\[cCsS_]\\|\\[[^^]\\]\\)" r)) + ((null lax) + (cond + ((string-match "\\`\\[\\^?]?\\(?:\\[:[a-z]+:]\\|[^]]\\)*]\\'" r)) + ((string-match "\\`\\\\(\\(?:[^\\]\\|\\\\[^)]\\)*\\\\)\\'" r)))))))) (defun rx-syntax (form) @@ -824,360 +874,197 @@ If FORM is `(minimal-match FORM1)', non-greedy versions of `*', (defun rx-regexp (form) "Parse and produce code from FORM, which is `(regexp STRING)'." - (rx-check form) - (rx-group-if (cadr form) rx-parent)) - - -(defun rx-form (form &optional rx-parent) + (cond ((stringp (cadr form)) + (rx-group-if (cadr form) rx-parent)) + (rx--compile-to-lisp + ;; Always group non-string forms, since we can't be sure they + ;; are atomic. + (rx-group-if (cdr form) t)) + (t (rx-check form)))) + +(defun rx-literal (form) + "Parse and produce code from FORM, which is `(literal STRING-EXP)'." + (cond ((stringp (cadr form)) + ;; This is allowed, but makes little sense, you could just + ;; use STRING directly. + (rx-group-if (regexp-quote (cadr form)) rx-parent)) + (rx--compile-to-lisp + (rx-group-if `((regexp-quote ,(cadr form))) rx-parent)) + (t (rx-check form)))) + +(defun rx-form (form &optional parent) "Parse and produce code for regular expression FORM. FORM is a regular expression in sexp form. -RX-PARENT shows which type of expression calls and controls putting of +PARENT shows which type of expression calls and controls putting of shy groups around the result and some more in other functions." - (cond - ((stringp form) - (rx-group-if (regexp-quote form) - (if (and (eq rx-parent '*) (< 1 (length form))) - rx-parent))) - ((integerp form) - (regexp-quote (char-to-string form))) - ((symbolp form) - (let ((info (rx-info form nil))) - (cond ((stringp info) - info) - ((null info) - (error "Unknown rx form `%s'" form)) - (t - (funcall (nth 0 info) form))))) - ((consp form) - (let ((info (rx-info (car form) 'head))) - (unless (consp info) - (error "Unknown rx form `%s'" (car form))) - (funcall (nth 0 info) form))) - (t - (error "rx syntax error at `%s'" form)))) + (let ((rx-parent parent)) + (cond + ((stringp form) + (rx-group-if (regexp-quote form) + (if (and (eq parent '*) (< 1 (length form))) + parent))) + ((integerp form) + (regexp-quote (char-to-string form))) + ((symbolp form) + (let ((info (rx-info form nil))) + (cond ((stringp info) + info) + ((null info) + (error "Unknown rx form `%s'" form)) + (t + (funcall (nth 0 info) form))))) + ((consp form) + (let ((info (rx-info (car form) 'head))) + (unless (consp info) + (error "Unknown rx form `%s'" (car form))) + (funcall (nth 0 info) form))) + (t + (error "rx syntax error at `%s'" form))))) + +(defun rx--subforms (subforms &optional parent separator) + "Produce code for regular expressions SUBFORMS. +SUBFORMS is a list of regular expression sexps. +PARENT controls grouping, as in `rx-form'. +Insert SEPARATOR between the code from each of SUBFORMS." + (if (null (cdr subforms)) + ;; Zero or one forms, no need for grouping. + (and subforms (rx-form (car subforms))) + (let ((listify (lambda (x) + (if (listp x) (copy-sequence x) + (list x))))) + (setq subforms (mapcar (lambda (x) (rx-form x parent)) subforms)) + (cond ((or (not rx--compile-to-lisp) + (cl-every #'stringp subforms)) + (mapconcat #'identity subforms separator)) + (separator + (nconc (funcall listify (car subforms)) + (mapcan (lambda (x) + (cons separator (funcall listify x))) + (cdr subforms)))) + (t (mapcan listify subforms)))))) ;;;###autoload (defun rx-to-string (form &optional no-group) "Parse and produce code for regular expression FORM. FORM is a regular expression in sexp form. -NO-GROUP non-nil means don't put shy groups around the result." +NO-GROUP non-nil means don't put shy groups around the result. + +In contrast to the `rx' macro, subforms `literal' and `regexp' +will not accept non-string arguments, i.e., (literal STRING) +becomes just a more verbose version of STRING." (rx-group-if (rx-form form) (null no-group))) ;;;###autoload (defmacro rx (&rest regexps) "Translate regular expressions REGEXPS in sexp form to a regexp string. -REGEXPS is a non-empty sequence of forms of the sort listed below. - -Note that `rx' is a Lisp macro; when used in a Lisp program being -compiled, the translation is performed by the compiler. -See `rx-to-string' for how to do such a translation at run-time. - -The following are valid subforms of regular expressions in sexp -notation. - -STRING - matches string STRING literally. - -CHAR - matches character CHAR literally. - -`not-newline', `nonl' - matches any character except a newline. - -`anything' - matches any character - -`(any SET ...)' -`(in SET ...)' -`(char SET ...)' - matches any character in SET .... SET may be a character or string. - Ranges of characters can be specified as `A-Z' in strings. - Ranges may also be specified as conses like `(?A . ?Z)'. - - SET may also be the name of a character class: `digit', - `control', `hex-digit', `blank', `graph', `print', `alnum', - `alpha', `ascii', `nonascii', `lower', `punct', `space', `upper', - `word', or one of their synonyms. - -`(not (any SET ...))' - matches any character not in SET ... - -`line-start', `bol' - matches the empty string, but only at the beginning of a line - in the text being matched - -`line-end', `eol' - is similar to `line-start' but matches only at the end of a line - -`string-start', `bos', `bot' - matches the empty string, but only at the beginning of the - string being matched against. - -`string-end', `eos', `eot' - matches the empty string, but only at the end of the - string being matched against. - -`buffer-start' - matches the empty string, but only at the beginning of the - buffer being matched against. Actually equivalent to `string-start'. - -`buffer-end' - matches the empty string, but only at the end of the - buffer being matched against. Actually equivalent to `string-end'. - -`point' - matches the empty string, but only at point. - -`word-start', `bow' - matches the empty string, but only at the beginning of a word. - -`word-end', `eow' - matches the empty string, but only at the end of a word. - -`word-boundary' - matches the empty string, but only at the beginning or end of a - word. - -`(not word-boundary)' -`not-word-boundary' - matches the empty string, but not at the beginning or end of a - word. - -`symbol-start' - matches the empty string, but only at the beginning of a symbol. - -`symbol-end' - matches the empty string, but only at the end of a symbol. - -`digit', `numeric', `num' - matches 0 through 9. - -`control', `cntrl' - matches ASCII control characters. - -`hex-digit', `hex', `xdigit' - matches 0 through 9, a through f and A through F. - -`blank' - matches horizontal whitespace, as defined by Annex C of the - Unicode Technical Standard #18. In particular, it matches - spaces, tabs, and other characters whose Unicode - `general-category' property indicates they are spacing - separators. - -`graphic', `graph' - matches graphic characters--everything except whitespace, ASCII - and non-ASCII control characters, surrogates, and codepoints - unassigned by Unicode. - -`printing', `print' - matches whitespace and graphic characters. - -`alphanumeric', `alnum' - matches alphabetic characters and digits. For multibyte characters, - it matches characters whose Unicode `general-category' property - indicates they are alphabetic or decimal number characters. - -`letter', `alphabetic', `alpha' - matches alphabetic characters. For multibyte characters, - it matches characters whose Unicode `general-category' property - indicates they are alphabetic characters. - -`ascii' - matches ASCII (unibyte) characters. - -`nonascii' - matches non-ASCII (multibyte) characters. - -`lower', `lower-case' - matches anything lower-case, as determined by the current case - table. If `case-fold-search' is non-nil, this also matches any - upper-case letter. - -`upper', `upper-case' - matches anything upper-case, as determined by the current case - table. If `case-fold-search' is non-nil, this also matches any - lower-case letter. - -`punctuation', `punct' - matches punctuation. (But at present, for multibyte characters, - it matches anything that has non-word syntax.) - -`space', `whitespace', `white' - matches anything that has whitespace syntax. - -`word', `wordchar' - matches anything that has word syntax. - -`not-wordchar' - matches anything that has non-word syntax. - -`(syntax SYNTAX)' - matches a character with syntax SYNTAX. SYNTAX must be one - of the following symbols, or a symbol corresponding to the syntax - character, e.g. `\\.' for `\\s.'. - - `whitespace' (\\s- in string notation) - `punctuation' (\\s.) - `word' (\\sw) - `symbol' (\\s_) - `open-parenthesis' (\\s() - `close-parenthesis' (\\s)) - `expression-prefix' (\\s') - `string-quote' (\\s\") - `paired-delimiter' (\\s$) - `escape' (\\s\\) - `character-quote' (\\s/) - `comment-start' (\\s<) - `comment-end' (\\s>) - `string-delimiter' (\\s|) - `comment-delimiter' (\\s!) - -`(not (syntax SYNTAX))' - matches a character that doesn't have syntax SYNTAX. - -`(category CATEGORY)' - matches a character with category CATEGORY. CATEGORY must be - either a character to use for C, or one of the following symbols. - - `consonant' (\\c0 in string notation) - `base-vowel' (\\c1) - `upper-diacritical-mark' (\\c2) - `lower-diacritical-mark' (\\c3) - `tone-mark' (\\c4) - `symbol' (\\c5) - `digit' (\\c6) - `vowel-modifying-diacritical-mark' (\\c7) - `vowel-sign' (\\c8) - `semivowel-lower' (\\c9) - `not-at-end-of-line' (\\c<) - `not-at-beginning-of-line' (\\c>) - `alpha-numeric-two-byte' (\\cA) - `chinese-two-byte' (\\cC) - `greek-two-byte' (\\cG) - `japanese-hiragana-two-byte' (\\cH) - `indian-two-byte' (\\cI) - `japanese-katakana-two-byte' (\\cK) - `korean-hangul-two-byte' (\\cN) - `cyrillic-two-byte' (\\cY) - `combining-diacritic' (\\c^) - `ascii' (\\ca) - `arabic' (\\cb) - `chinese' (\\cc) - `ethiopic' (\\ce) - `greek' (\\cg) - `korean' (\\ch) - `indian' (\\ci) - `japanese' (\\cj) - `japanese-katakana' (\\ck) - `latin' (\\cl) - `lao' (\\co) - `tibetan' (\\cq) - `japanese-roman' (\\cr) - `thai' (\\ct) - `vietnamese' (\\cv) - `hebrew' (\\cw) - `cyrillic' (\\cy) - `can-break' (\\c|) - -`(not (category CATEGORY))' - matches a character that doesn't have category CATEGORY. - -`(and SEXP1 SEXP2 ...)' -`(: SEXP1 SEXP2 ...)' -`(seq SEXP1 SEXP2 ...)' -`(sequence SEXP1 SEXP2 ...)' - matches what SEXP1 matches, followed by what SEXP2 matches, etc. - -`(submatch SEXP1 SEXP2 ...)' -`(group SEXP1 SEXP2 ...)' - like `and', but makes the match accessible with `match-end', - `match-beginning', and `match-string'. - -`(submatch-n N SEXP1 SEXP2 ...)' -`(group-n N SEXP1 SEXP2 ...)' - like `group', but make it an explicitly-numbered group with - group number N. - -`(or SEXP1 SEXP2 ...)' -`(| SEXP1 SEXP2 ...)' - matches anything that matches SEXP1 or SEXP2, etc. If all - args are strings, use `regexp-opt' to optimize the resulting - regular expression. - -`(minimal-match SEXP)' - produce a non-greedy regexp for SEXP. Normally, regexps matching - zero or more occurrences of something are \"greedy\" in that they - match as much as they can, as long as the overall regexp can - still match. A non-greedy regexp matches as little as possible. - -`(maximal-match SEXP)' - produce a greedy regexp for SEXP. This is the default. - -Below, `SEXP ...' represents a sequence of regexp forms, treated as if -enclosed in `(and ...)'. - -`(zero-or-more SEXP ...)' -`(0+ SEXP ...)' - matches zero or more occurrences of what SEXP ... matches. - -`(* SEXP ...)' - like `zero-or-more', but always produces a greedy regexp, independent - of `rx-greedy-flag'. - -`(*? SEXP ...)' - like `zero-or-more', but always produces a non-greedy regexp, - independent of `rx-greedy-flag'. - -`(one-or-more SEXP ...)' -`(1+ SEXP ...)' - matches one or more occurrences of SEXP ... - -`(+ SEXP ...)' - like `one-or-more', but always produces a greedy regexp. - -`(+? SEXP ...)' - like `one-or-more', but always produces a non-greedy regexp. - -`(zero-or-one SEXP ...)' -`(optional SEXP ...)' -`(opt SEXP ...)' - matches zero or one occurrences of A. - -`(? SEXP ...)' - like `zero-or-one', but always produces a greedy regexp. - -`(?? SEXP ...)' - like `zero-or-one', but always produces a non-greedy regexp. - -`(repeat N SEXP)' -`(= N SEXP ...)' - matches N occurrences. - -`(>= N SEXP ...)' - matches N or more occurrences. - -`(repeat N M SEXP)' -`(** N M SEXP ...)' - matches N to M occurrences. - -`(backref N)' - matches what was matched previously by submatch N. - -`(eval FORM)' - evaluate FORM and insert result. If result is a string, - `regexp-quote' it. - -`(regexp REGEXP)' - include REGEXP in string notation in the result." - (cond ((null regexps) - (error "No regexp")) - ((cdr regexps) - (rx-to-string `(and ,@regexps) t)) - (t - (rx-to-string (car regexps) t)))) +Each argument is one of the forms below; RX is a subform, and RX... stands +for one or more RXs. For details, see Info node `(elisp) Rx Notation'. +See `rx-to-string' for the corresponding function. + +STRING Match a literal string. +CHAR Match a literal character. + +(seq RX...) Match the RXs in sequence. Alias: :, sequence, and. +(or RX...) Match one of the RXs. Alias: |. + +(zero-or-more RX...) Match RXs zero or more times. Alias: 0+. +(one-or-more RX...) Match RXs one or more times. Alias: 1+. +(zero-or-one RX...) Match RXs or the empty string. Alias: opt, optional. +(* RX...) Match RXs zero or more times; greedy. +(+ RX...) Match RXs one or more times; greedy. +(? RX...) Match RXs or the empty string; greedy. +(*? RX...) Match RXs zero or more times; non-greedy. +(+? RX...) Match RXs one or more times; non-greedy. +(?? RX...) Match RXs or the empty string; non-greedy. +(= N RX...) Match RXs exactly N times. +(>= N RX...) Match RXs N or more times. +(** N M RX...) Match RXs N to M times. Alias: repeat. +(minimal-match RX) Match RX, with zero-or-more, one-or-more, zero-or-one + and aliases using non-greedy matching. +(maximal-match RX) Match RX, with zero-or-more, one-or-more, zero-or-one + and aliases using greedy matching, which is the default. + +(any SET...) Match a character from one of the SETs. Each SET is a + character, a string, a range as string \"A-Z\" or cons + (?A . ?Z), or a character class (see below). Alias: in, char. +(not CHARSPEC) Match one character not matched by CHARSPEC. CHARSPEC + can be (any ...), (syntax ...), (category ...), + or a character class. +not-newline Match any character except a newline. Alias: nonl. +anything Match any character. + +CHARCLASS Match a character from a character class. One of: + alpha, alphabetic, letter Alphabetic characters (defined by Unicode). + alnum, alphanumeric Alphabetic or decimal digit chars (Unicode). + digit numeric, num 0-9. + xdigit, hex-digit, hex 0-9, A-F, a-f. + cntrl, control ASCII codes 0-31. + blank Horizontal whitespace (Unicode). + space, whitespace, white Chars with whitespace syntax. + lower, lower-case Lower-case chars, from current case table. + upper, upper-case Upper-case chars, from current case table. + graph, graphic Graphic characters (Unicode). + print, printing Whitespace or graphic (Unicode). + punct, punctuation Not control, space, letter or digit (ASCII); + not word syntax (non-ASCII). + word, wordchar Characters with word syntax. + ascii ASCII characters (codes 0-127). + nonascii Non-ASCII characters (but not raw bytes). + +(syntax SYNTAX) Match a character with syntax SYNTAX, being one of: + whitespace, punctuation, word, symbol, open-parenthesis, + close-parenthesis, expression-prefix, string-quote, + paired-delimiter, escape, character-quote, comment-start, + comment-end, string-delimiter, comment-delimiter + +(category CAT) Match a character in category CAT, being one of: + space-for-indent, base, consonant, base-vowel, + upper-diacritical-mark, lower-diacritical-mark, tone-mark, symbol, + digit, vowel-modifying-diacritical-mark, vowel-sign, + semivowel-lower, not-at-end-of-line, not-at-beginning-of-line, + alpha-numeric-two-byte, chinese-two-byte, greek-two-byte, + japanese-hiragana-two-byte, indian-two-byte, + japanese-katakana-two-byte, strong-left-to-right, + korean-hangul-two-byte, strong-right-to-left, cyrillic-two-byte, + combining-diacritic, ascii, arabic, chinese, ethiopic, greek, + korean, indian, japanese, japanese-katakana, latin, lao, + tibetan, japanese-roman, thai, vietnamese, hebrew, cyrillic, + can-break + +Zero-width assertions: these all match the empty string in specific places. + line-start At the beginning of a line. Alias: bol. + line-end At the end of a line. Alias: eol. + string-start At the start of the string or buffer. + Alias: buffer-start, bos, bot. + string-end At the end of the string or buffer. + Alias: buffer-end, eos, eot. + point At point. + word-start At the beginning of a word. + word-end At the end of a word. + word-boundary At the beginning or end of a word. + not-word-boundary Not at the beginning or end of a word. + symbol-start At the beginning of a symbol. + symbol-end At the end of a symbol. + +(group RX...) Match RXs and define a capture group. Alias: submatch. +(group-n N RX...) Match RXs and define capture group N. Alias: submatch-n. +(backref N) Match the text that capture group N matched. + +(literal EXPR) Match the literal string from evaluating EXPR at run time. +(regexp EXPR) Match the string regexp from evaluating EXPR at run time. +(eval EXPR) Match the rx sexp from evaluating EXPR at compile time." + (let* ((rx--compile-to-lisp t) + (re (cond ((null regexps) + (error "No regexp")) + ((cdr regexps) + (rx-to-string `(and ,@regexps) t)) + (t + (rx-to-string (car regexps) t))))) + (if (stringp re) + re + `(concat ,@re)))) (pcase-defmacro rx (&rest regexps) @@ -1239,14 +1126,6 @@ string as argument to `match-string'." for var in vars collect `(app (match-string ,i) ,var))))) -;; ;; sregex.el replacement - -;; ;;;###autoload (provide 'sregex) -;; ;;;###autoload (autoload 'sregex "rx") -;; (defalias 'sregex 'rx-to-string) -;; ;;;###autoload (autoload 'sregexq "rx" nil nil 'macro) -;; (defalias 'sregexq 'rx) - (provide 'rx) ;;; rx.el ends here diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 5f3d224e1f8..3413cd1513c 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -4,7 +4,7 @@ ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Keywords: sequences -;; Version: 2.20 +;; Version: 2.21 ;; Package: seq ;; Maintainer: emacs-devel@gnu.org @@ -110,6 +110,14 @@ name to be bound to the rest of SEQUENCE." "Return the number of elements of SEQUENCE." (length sequence)) +(defun seq-first (sequence) + "Return the first element of SEQUENCE." + (seq-elt sequence 0)) + +(defun seq-rest (sequence) + "Return a sequence of the elements of SEQUENCE except the first one." + (seq-drop sequence 1)) + (cl-defgeneric seq-do (function sequence) "Apply FUNCTION to each element of SEQUENCE, presumably for side effects. Return SEQUENCE." @@ -348,6 +356,7 @@ found or not." count)) (cl-defgeneric seq-contains (sequence elt &optional testfn) + (declare (obsolete seq-contains-p "27.1")) "Return the first element in SEQUENCE that is equal to ELT. Equality is defined by TESTFN if non-nil or by `equal' if nil." (seq-some (lambda (e) @@ -355,11 +364,20 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." 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))) + nil)) + (cl-defgeneric seq-set-equal-p (sequence1 sequence2 &optional testfn) "Return non-nil if SEQUENCE1 and SEQUENCE2 contain the same elements, regardless of order. Equality is defined by TESTFN if non-nil or by `equal' if nil." - (and (seq-every-p (lambda (item1) (seq-contains sequence2 item1 testfn)) sequence1) - (seq-every-p (lambda (item2) (seq-contains sequence1 item2 testfn)) sequence2))) + (and (seq-every-p (lambda (item1) (seq-contains-p sequence2 item1 testfn)) sequence1) + (seq-every-p (lambda (item2) (seq-contains-p sequence1 item2 testfn)) sequence2))) (cl-defgeneric seq-position (sequence elt &optional testfn) "Return the index of the first element in SEQUENCE that is equal to ELT. @@ -377,7 +395,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." TESTFN is used to compare elements, or `equal' if TESTFN is nil." (let ((result '())) (seq-doseq (elt sequence) - (unless (seq-contains result elt testfn) + (unless (seq-contains-p result elt testfn) (setq result (cons elt result)))) (nreverse result))) @@ -402,7 +420,7 @@ negative integer or 0, nil is returned." "Return a list of the elements that appear in both SEQUENCE1 and SEQUENCE2. Equality is defined by TESTFN if non-nil or by `equal' if nil." (seq-reduce (lambda (acc elt) - (if (seq-contains sequence2 elt testfn) + (if (seq-contains-p sequence2 elt testfn) (cons elt acc) acc)) (seq-reverse sequence1) @@ -412,9 +430,9 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." "Return a list of the elements that appear in SEQUENCE1 but not in SEQUENCE2. Equality is defined by TESTFN if non-nil or by `equal' if nil." (seq-reduce (lambda (acc elt) - (if (not (seq-contains sequence2 elt testfn)) - (cons elt acc) - acc)) + (if (seq-contains-p sequence2 elt testfn) + acc + (cons elt acc))) (seq-reverse sequence1) '())) diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index 636a90d0d27..85adbe3dd12 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -78,7 +78,7 @@ See the documentation for `list-load-path-shadows' for further information." shadows ; List of shadowings, to be returned. files ; File names ever seen, with dirs. dir ; The dir being currently scanned. - dir-case-insensitive ; `file-name-case-insentive-p' for dir. + dir-case-insensitive ; `file-name-case-insensitive-p' of dir. curr-files ; This dir's Emacs Lisp files. orig-dir ; Where the file was first seen. files-seen-this-dir ; Files seen so far in this dir. @@ -161,8 +161,8 @@ See the documentation for `list-load-path-shadows' for further information." (or (equal (file-truename f1) (file-truename f2)) ;; As a quick test, avoiding spawning a process, compare file ;; sizes. - (and (= (nth 7 (file-attributes f1)) - (nth 7 (file-attributes f2))) + (and (= (file-attribute-size (file-attributes f1)) + (file-attribute-size (file-attributes f2))) (eq 0 (call-process "cmp" nil nil nil "-s" f1 f2)))))))) (defvar load-path-shadows-font-lock-keywords diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index d0c6cac79fa..f2163b243ee 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -533,9 +533,9 @@ PREC2 is a table as returned by `smie-precs->prec2' or (setq y (cons nil (cons nil nil))) (push (cons (cdr k) y) table)) (pcase v - (`= (push (cons x y) eqs)) - (`< (push (cons x y) csts)) - (`> (push (cons y x) csts)) + ('= (push (cons x y) eqs)) + ('< (push (cons x y) csts)) + ('> (push (cons y x) csts)) (_ (error "SMIE error: prec2 has %S↦%S which ∉ {<,+,>}" k v)))))) prec2) @@ -612,8 +612,8 @@ PREC2 is a table as returned by `smie-precs->prec2' or (dolist (x (gethash :smie-open/close-alist prec2)) (let* ((token (car x)) (cons (pcase (cdr x) - (`closer (cddr (assoc token table))) - (`opener (cdr (assoc token table)))))) + ('closer (cddr (assoc token table))) + ('opener (cdr (assoc token table)))))) ;; `cons' can be nil for openers/closers which only contain ;; "atomic" elements. (when cons @@ -1446,9 +1446,9 @@ in order to figure out the indentation of some other (further down) point." (and (smie-indent--bolp) (save-excursion (comment-normalize-vars) - (re-search-forward (concat comment-start-skip + (re-search-forward (concat "\\(?:" comment-start-skip "\\)" "fixindent" - comment-end-skip) + "\\(?:" comment-end-skip "\\)") ;; 1+ to account for the \n comment termination. (1+ (line-end-position)) t)) (current-column))) @@ -1648,11 +1648,33 @@ should not be computed on the basis of the following token." (let ((ppss (syntax-ppss))) (save-excursion (forward-line -1) - (if (<= (point) (nth 8 ppss)) - (progn (goto-char (1+ (nth 8 ppss))) (current-column)) - (skip-chars-forward " \t") - (if (looking-at (regexp-quote continue)) - (current-column)))))))) + (let ((start (nth 8 ppss))) + (if (<= (point) start) + (progn + (goto-char start) + (if (not (and comment-start-skip + (looking-at comment-start-skip))) + (forward-char 1) + (goto-char (match-end 0)) + (skip-chars-backward " \t") + ;; Try to align the first char of the comment-continue + ;; with the second char of the comment-start or the + ;; first char if the comment-start is made of + ;; a single char. E.g. + ;; + ;; /* foo + ;; * bar */ + ;; + ;; but + ;; + ;; { foo + ;; | bar } + (goto-char (if (eq (point) (1+ start)) + start (1+ start)))) + (current-column)) + (skip-chars-forward " \t") + (if (looking-at (regexp-quote continue)) + (current-column))))))))) (defun smie-indent-comment-close () (and (boundp 'comment-end-skip) @@ -1856,9 +1878,9 @@ KEYWORDS are additional arguments, which can use the following keywords: (let ((k (pop keywords)) (v (pop keywords))) (pcase k - (`:forward-token + (:forward-token (set (make-local-variable 'smie-forward-token-function) v)) - (`:backward-token + (:backward-token (set (make-local-variable 'smie-backward-token-function) v)) (_ (message "smie-setup: ignoring unknown keyword %s" k))))) (let ((ca (cdr (assq :smie-closer-alist grammar)))) diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 15c9a824d39..f76409c4de8 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -152,14 +152,15 @@ are non-nil, then the result is non-nil." (let (res) (if varlist `(let* ,(setq varlist (internal--build-bindings varlist)) - (if ,(setq res (caar (last varlist))) - ,@(or body `(,res)))) + (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, stopping if a binding value is nil. -If all are non-nil return the value of THEN, otherwise the last form in 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 @@ -208,7 +209,7 @@ The variable list SPEC is the same as in `if-let'." (defsubst string-join (strings &optional separator) "Join all STRINGS using SEPARATOR." - (mapconcat 'identity strings separator)) + (mapconcat #'identity strings separator)) (define-obsolete-function-alias 'string-reverse 'reverse "25.1") @@ -216,17 +217,17 @@ The variable list SPEC is the same as in `if-let'." "Trim STRING of leading string matching REGEXP. REGEXP defaults to \"[ \\t\\n\\r]+\"." - (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+")"\\)") string) - (replace-match "" t t string) + (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string) + (substring string (match-end 0)) string)) (defsubst string-trim-right (string &optional regexp) "Trim STRING of trailing string matching REGEXP. REGEXP defaults to \"[ \\t\\n\\r]+\"." - (if (string-match (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'") string) - (replace-match "" t t string) - string)) + (let ((i (string-match-p (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'") + string))) + (if i (substring string 0 i) string))) (defsubst string-trim (string &optional trim-left trim-right) "Trim STRING of leading and trailing strings matching TRIM-LEFT and TRIM-RIGHT. @@ -250,6 +251,35 @@ TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"." (substring string 0 (- (length string) (length suffix))) string)) +(defun replace-region-contents (beg end replace-fn + &optional max-secs max-costs) + "Replace the region between BEG and END using REPLACE-FN. +REPLACE-FN runs on the current buffer narrowed to the region. It +should return either a string or a buffer replacing the region. + +The replacement is performed using `replace-buffer-contents' +which also describes the MAX-SECS and MAX-COSTS arguments and the +return value. + +Note: If the replacement is a string, it'll be placed in a +temporary buffer so that `replace-buffer-contents' can operate on +it. Therefore, if you already have the replacement in a buffer, +it makes no sense to convert it to a string using +`buffer-substring' or similar." + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char (point-min)) + (let ((repl (funcall replace-fn))) + (if (bufferp repl) + (replace-buffer-contents repl max-secs max-costs) + (let ((source-buffer (current-buffer))) + (with-temp-buffer + (insert repl) + (let ((tmp-buffer (current-buffer))) + (set-buffer source-buffer) + (replace-buffer-contents tmp-buffer max-secs max-costs))))))))) + (provide 'subr-x) ;;; subr-x.el ends here diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index f27596f77c7..6464e2a52db 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -176,7 +176,7 @@ Note: back-references in REGEXPs do not work." (re (mapconcat (lambda (rule) - (let* ((orig-re (eval (car rule))) + (let* ((orig-re (eval (car rule) t)) (re orig-re)) (when (and (assq 0 rule) (cdr rules)) ;; If there's more than 1 rule, and the rule want to apply @@ -190,7 +190,7 @@ Note: back-references in REGEXPs do not work." (cond ((assq 0 rule) (if (zerop offset) t `(match-beginning ,offset))) - ((null (cddr rule)) + ((and (cdr rule) (null (cddr rule))) `(match-beginning ,(+ offset (car (cadr rule))))) (t `(or ,@(mapcar @@ -283,10 +283,13 @@ END) suitable for `syntax-propertize-function'." ;; In case it was eval'd/compiled. (setq keywords font-lock-syntactic-keywords))))) +(defvar-local syntax-ppss-table nil + "Syntax-table to use during `syntax-ppss', if any.") + (defun syntax-propertize (pos) "Ensure that syntax-table properties are set until POS (a buffer point)." (when (< syntax-propertize--done pos) - (if (null syntax-propertize-function) + (if (memq syntax-propertize-function '(nil ignore)) (setq syntax-propertize--done (max (point-max) pos)) ;; (message "Needs to syntax-propertize from %s to %s" ;; syntax-propertize--done pos) @@ -298,50 +301,51 @@ END) suitable for `syntax-propertize-function'." ;; between syntax-ppss and syntax-propertize, we also have to make ;; sure the flush function is installed here (bug#29767). (add-hook 'before-change-functions - #'syntax-ppss-flush-cache t t)) + #'syntax-ppss-flush-cache 99 t)) (save-excursion (with-silent-modifications - (make-local-variable 'syntax-propertize--done) ;Just in case! - (let* ((start (max (min syntax-propertize--done (point-max)) - (point-min))) - (end (max pos - (min (point-max) - (+ start syntax-propertize-chunk-size)))) - (funs syntax-propertize-extend-region-functions)) - (while funs - (let ((new (funcall (pop funs) start end)) - ;; Avoid recursion! - (syntax-propertize--done most-positive-fixnum)) - (if (or (null new) - (and (>= (car new) start) (<= (cdr new) end))) - nil - (setq start (car new)) - (setq end (cdr new)) - ;; If there's been a change, we should go through the - ;; list again since this new position may - ;; warrant a different answer from one of the funs we've - ;; already seen. - (unless (eq funs - (cdr syntax-propertize-extend-region-functions)) - (setq funs syntax-propertize-extend-region-functions))))) - ;; Flush ppss cache between the original value of `start' and that - ;; set above by syntax-propertize-extend-region-functions. - (syntax-ppss-flush-cache start) - ;; Move the limit before calling the function, so the function - ;; can use syntax-ppss. - (setq syntax-propertize--done end) - ;; (message "syntax-propertizing from %s to %s" start end) - (remove-text-properties start end - '(syntax-table nil syntax-multiline nil)) - ;; Avoid recursion! - (let ((syntax-propertize--done most-positive-fixnum)) - (funcall syntax-propertize-function start end)))))))) + (with-syntax-table (or syntax-ppss-table (syntax-table)) + (make-local-variable 'syntax-propertize--done) ;Just in case! + (let* ((start (max (min syntax-propertize--done (point-max)) + (point-min))) + (end (max pos + (min (point-max) + (+ start syntax-propertize-chunk-size)))) + (funs syntax-propertize-extend-region-functions)) + (while funs + (let ((new (funcall (pop funs) start end)) + ;; Avoid recursion! + (syntax-propertize--done most-positive-fixnum)) + (if (or (null new) + (and (>= (car new) start) (<= (cdr new) end))) + nil + (setq start (car new)) + (setq end (cdr new)) + ;; If there's been a change, we should go through the + ;; list again since this new position may + ;; warrant a different answer from one of the funs we've + ;; already seen. + (unless (eq funs + (cdr syntax-propertize-extend-region-functions)) + (setq funs syntax-propertize-extend-region-functions))))) + ;; Flush ppss cache between the original value of `start' and that + ;; set above by syntax-propertize-extend-region-functions. + (syntax-ppss-flush-cache start) + ;; Move the limit before calling the function, so the function + ;; can use syntax-ppss. + (setq syntax-propertize--done end) + ;; (message "syntax-propertizing from %s to %s" start end) + (remove-text-properties start end + '(syntax-table nil syntax-multiline nil)) + ;; Avoid recursion! + (let ((syntax-propertize--done most-positive-fixnum)) + (funcall syntax-propertize-function start end))))))))) ;;; Link syntax-propertize with syntax.c. (defvar syntax-propertize-chunks ;; We're not sure how far we'll go. In my tests, using chunks of 2000 - ;; brings to overhead to something negligible. Passing ‘charpos’ directly + ;; brings the overhead to something negligible. Passing ‘charpos’ directly ;; also works (basically works line-by-line) but results in an overhead which ;; I thought was a bit too high (like around 50%). 2000) @@ -367,6 +371,10 @@ itself at the outermost level), return nil." (nth 8 ppss))) (defsubst syntax-ppss-context (ppss) + "Say whether PPSS is a string, a comment, or something else. +If PPSS is a string, the symbol `string' is returned. If it's a +comment, the symbol `comment' is returned. If it's something +else, nil is returned." (cond ((nth 3 ppss) 'string) ((nth 4 ppss) 'comment) @@ -404,7 +412,8 @@ These are valid when the buffer has no restriction.") (defvar-local syntax-ppss-narrow-start nil "Start position of the narrowing for `syntax-ppss-narrow'.") -(defalias 'syntax-ppss-after-change-function 'syntax-ppss-flush-cache) +(define-obsolete-function-alias 'syntax-ppss-after-change-function + #'syntax-ppss-flush-cache "27.1") (defun syntax-ppss-flush-cache (beg &rest ignored) "Flush the cache of `syntax-ppss' starting at position BEG." ;; Set syntax-propertize to refontify anything past beg. @@ -429,22 +438,25 @@ These are valid when the buffer has no restriction.") ;; Unregister if there's no cache left. Sadly this doesn't work ;; because `before-change-functions' is temporarily bound to nil here. ;; (unless cache - ;; (remove-hook 'before-change-functions 'syntax-ppss-flush-cache t)) + ;; (remove-hook 'before-change-functions #'syntax-ppss-flush-cache t)) (setcar cell last) (setcdr cell cache))) )) +;;; FIXME: Explain this variable. Currently only its last (5th) slot is used. +;;; Perhaps the other slots should be removed? (defvar syntax-ppss-stats - [(0 . 0.0) (0 . 0.0) (0 . 0.0) (0 . 0.0) (0 . 0.0) (1 . 2500.0)]) + [(0 . 0) (0 . 0) (0 . 0) (0 . 0) (0 . 0) (2 . 2500)]) (defun syntax-ppss-stats () (mapcar (lambda (x) (condition-case nil - (cons (car x) (truncate (/ (cdr x) (car x)))) + (cons (car x) (/ (cdr x) (car x))) (error nil))) syntax-ppss-stats)) - -(defvar-local syntax-ppss-table nil - "Syntax-table to use during `syntax-ppss', if any.") +(defun syntax-ppss--update-stats (i old new) + (let ((pair (aref syntax-ppss-stats i))) + (cl-incf (car pair)) + (cl-incf (cdr pair) (- new old)))) (defun syntax-ppss--data () (if (eq (point-min) 1) @@ -486,11 +498,10 @@ running the hook." (if (and old-pos (< (- pos old-pos) ;; The time to use syntax-begin-function and ;; find PPSS is assumed to be about 2 * distance. - (* 2 (/ (cdr (aref syntax-ppss-stats 5)) - (1+ (car (aref syntax-ppss-stats 5))))))) + (let ((pair (aref syntax-ppss-stats 5))) + (/ (* 2 (cdr pair)) (car pair))))) (progn - (cl-incf (car (aref syntax-ppss-stats 0))) - (cl-incf (cdr (aref syntax-ppss-stats 0)) (- pos old-pos)) + (syntax-ppss--update-stats 0 old-pos pos) (parse-partial-sexp old-pos pos nil nil old-ppss)) (cond @@ -506,8 +517,7 @@ running the hook." (setq pt-min (or (syntax-ppss-toplevel-pos old-ppss) (nth 2 old-ppss))) (<= pt-min pos) (< (- pos pt-min) syntax-ppss-max-span)) - (cl-incf (car (aref syntax-ppss-stats 1))) - (cl-incf (cdr (aref syntax-ppss-stats 1)) (- pos pt-min)) + (syntax-ppss--update-stats 1 pt-min pos) (setq ppss (parse-partial-sexp pt-min pos))) ;; The OLD-* data can't be used. Consult the cache. (t @@ -529,14 +539,19 @@ running the hook." ;; Setup the before-change function if necessary. (unless (or ppss-cache ppss-last) + ;; Note: combine-change-calls-1 needs to be kept in sync + ;; with this! (add-hook 'before-change-functions - 'syntax-ppss-flush-cache t t)) + #'syntax-ppss-flush-cache + ;; We should be either the very last function on + ;; before-change-functions or the very first on + ;; after-change-functions. + 99 t)) ;; Use the best of OLD-POS and CACHE. (if (or (not old-pos) (< old-pos pt-min)) (setq pt-best pt-min ppss-best ppss) - (cl-incf (car (aref syntax-ppss-stats 4))) - (cl-incf (cdr (aref syntax-ppss-stats 4)) (- pos old-pos)) + (syntax-ppss--update-stats 4 old-pos pos) (setq pt-best old-pos ppss-best old-ppss)) ;; Use the `syntax-begin-function' if available. @@ -556,21 +571,18 @@ running the hook." (not (memq (get-text-property (point) 'face) '(font-lock-string-face font-lock-doc-face font-lock-comment-face)))) - (cl-incf (car (aref syntax-ppss-stats 5))) - (cl-incf (cdr (aref syntax-ppss-stats 5)) (- pos (point))) + (syntax-ppss--update-stats 5 (point) pos) (setq pt-best (point) ppss-best nil)) (cond ;; Quick case when we found a nearby pos. ((< (- pos pt-best) syntax-ppss-max-span) - (cl-incf (car (aref syntax-ppss-stats 2))) - (cl-incf (cdr (aref syntax-ppss-stats 2)) (- pos pt-best)) + (syntax-ppss--update-stats 2 pt-best pos) (setq ppss (parse-partial-sexp pt-best pos nil nil ppss-best))) ;; Slow case: compute the state from some known position and ;; populate the cache so we won't need to do it again soon. (t - (cl-incf (car (aref syntax-ppss-stats 3))) - (cl-incf (cdr (aref syntax-ppss-stats 3)) (- pos pt-min)) + (syntax-ppss--update-stats 3 pt-min pos) ;; If `pt-min' is too far, add a few intermediate entries. (while (> (- pos pt-min) (* 2 syntax-ppss-max-span)) diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 6fdca2cd083..63ae1f8c072 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -36,6 +36,48 @@ ;;; Code: +(defgroup tabulated-list nil + "Tabulated-list customization group." + :group 'convenience + :group 'display) + +(defcustom tabulated-list-gui-sort-indicator-asc ?▼ + "Indicator for columns sorted in ascending order, for GUI frames. +See `tabulated-list-tty-sort-indicator-asc' for the indicator used on +text-mode frames." + :group 'tabulated-list + :type 'character + :version "27.1") + +(defcustom tabulated-list-gui-sort-indicator-desc ?▲ + "Indicator for columns sorted in descending order, for GUI frames. +See `tabulated-list-tty-sort-indicator-desc' for the indicator used on +text-mode frames." + :group 'tabulated-list + :type 'character + :version "27.1") + +(defcustom tabulated-list-tty-sort-indicator-asc ?v + "Indicator for columns sorted in ascending order, for text-mode frames. +See `tabulated-list-gui-sort-indicator-asc' for the indicator used on GUI +frames." + :group 'tabulated-list + :type 'character + :version "27.1") + +(defcustom tabulated-list-tty-sort-indicator-desc ?^ + "Indicator for columns sorted in ascending order, for text-mode frames. +See `tabulated-list-gui-sort-indicator-asc' for the indicator used on GUI +frames." + :group 'tabulated-list + :type 'character + :version "27.1") + +(defface tabulated-list-fake-header + '((t :overline t :underline t :weight bold)) + "Face used on fake header lines." + :version "27.1") + ;; The reason `tabulated-list-format' and other variables are ;; permanent-local is to make it convenient to switch to a different ;; major mode, switch back, and have the original Tabulated List data @@ -151,11 +193,15 @@ If ADVANCE is non-nil, move forward by one line afterwards." (forward-line))) (defvar tabulated-list-mode-map - (let ((map (copy-keymap special-mode-map))) - (set-keymap-parent map button-buffer-map) + (let ((map (make-sparse-keymap))) + (set-keymap-parent map (make-composed-keymap + button-buffer-map + special-mode-map)) (define-key map "n" 'next-line) (define-key map "p" 'previous-line) (define-key map "S" 'tabulated-list-sort) + (define-key map "}" 'tabulated-list-widen-current-column) + (define-key map "{" 'tabulated-list-narrow-current-column) (define-key map [follow-link] 'mouse-face) (define-key map [mouse-2] 'mouse-select-window) map) @@ -172,14 +218,20 @@ If ADVANCE is non-nil, move forward by one line afterwards." map) "Local keymap for `tabulated-list-mode' sort buttons.") -(defvar tabulated-list-glyphless-char-display +(defun tabulated-list-make-glyphless-char-display-table () + "Make the `glyphless-char-display' table used for text-mode frames. +This table is used for displaying the sorting indicators, see +variables `tabulated-list-tty-sort-indicator-asc' and +`tabulated-list-tty-sort-indicator-desc' for more information." (let ((table (make-char-table 'glyphless-char-display nil))) (set-char-table-parent table glyphless-char-display) - ;; Some text terminals can't display the Unicode arrows; be safe. - (aset table 9650 (cons nil "^")) - (aset table 9660 (cons nil "v")) - table) - "The `glyphless-char-display' table in Tabulated List buffers.") + (aset table + tabulated-list-gui-sort-indicator-desc + (cons nil (char-to-string tabulated-list-tty-sort-indicator-desc))) + (aset table + tabulated-list-gui-sort-indicator-asc + (cons nil (char-to-string tabulated-list-tty-sort-indicator-asc))) + table)) (defvar tabulated-list--header-string nil "Holds the header if `tabulated-list-use-header-line' is nil. @@ -229,8 +281,11 @@ Populated by `tabulated-list-init-header'.") (concat label (cond ((> (+ 2 (length label)) width) "") - ((cdr tabulated-list-sort-key) " ▲") - (t " ▼"))) + ((cdr tabulated-list-sort-key) + (format " %c" + tabulated-list-gui-sort-indicator-desc)) + (t (format " %c" + tabulated-list-gui-sort-indicator-asc)))) 'face 'bold 'tabulated-list-column-name label button-props)) @@ -258,7 +313,6 @@ Populated by `tabulated-list-init-header'.") (setq cols (apply 'concat (nreverse cols))) (if tabulated-list-use-header-line (setq header-line-format cols) - (setq header-line-format nil) (setq-local tabulated-list--header-string cols)))) (defun tabulated-list-print-fake-header () @@ -272,7 +326,8 @@ Do nothing if `tabulated-list--header-string' is nil." (move-overlay tabulated-list--header-overlay (point-min) (point)) (setq-local tabulated-list--header-overlay (make-overlay (point-min) (point)))) - (overlay-put tabulated-list--header-overlay 'face 'underline)))) + (overlay-put tabulated-list--header-overlay + 'face 'tabulated-list-fake-header)))) (defsubst tabulated-list-header-overlay-p (&optional pos) "Return non-nil if there is a fake header. @@ -597,6 +652,39 @@ With a numeric prefix argument N, sort the Nth column." (tabulated-list-init-header) (tabulated-list-print t))) +(defun tabulated-list-widen-current-column (&optional n) + "Widen the current tabulated-list column by N chars. +Interactively, N is the prefix numeric argument, and defaults to +1." + (interactive "p") + (let ((start (current-column)) + (nb-cols (length tabulated-list-format)) + (col-nb 0) + (total-width 0) + (found nil) + 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)))))) + (setq col-nb (1+ col-nb)) + (setq found t) + (setf (cadr (aref tabulated-list-format col-nb)) + (max 1 (+ col-width n))) + (tabulated-list-print t) + (tabulated-list-init-header))))) + +(defun tabulated-list-narrow-current-column (&optional n) + "Narrow the current tabulated list column by N chars. +Interactively, N is the prefix numeric argument, and defaults to +1." + (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 @@ -653,7 +741,8 @@ as the ewoc pretty-printer." (setq-local truncate-lines t) (setq-local buffer-undo-list t) (setq-local revert-buffer-function #'tabulated-list-revert) - (setq-local glyphless-char-display tabulated-list-glyphless-char-display) + (setq-local glyphless-char-display + (tabulated-list-make-glyphless-char-display-table)) ;; 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) diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el index 675598fd228..d34d30ff0f9 100644 --- a/lisp/emacs-lisp/tcover-ses.el +++ b/lisp/emacs-lisp/tcover-ses.el @@ -2,8 +2,7 @@ ;; Copyright (C) 2002-2019 Free Software Foundation, Inc. -;; Author: Jonathan Yavner <jyavner@engineer.com> -;; Maintainer: Jonathan Yavner <jyavner@engineer.com> +;; Author: Jonathan Yavner <jyavner@member.fsf.org> ;; Keywords: spreadsheet lisp utility ;; Package: testcover @@ -39,464 +38,464 @@ ;;;Here are some macros that exercise SES. Set `pause' to t if you want the ;;;macros to pause after each step. (let* ((pause nil) - (x (if pause "q" "")) - (y "ses-test.ses\r<")) + (x (if pause "\^Xq" "")) + (y "\^X\^Fses-test.ses\r\^[<")) ;;Fiddle with the existing spreadsheet (fset 'ses-exercise-example - (concat "" data-directory "ses-example.ses\r<" - x "10" - x "" - x "" - x "pses-center\r" - x "p\r" - x "\t\t" - x "\r A9 B9\r" - x "" - x "\r2\r" - x "" + (concat "\^X\^F" data-directory "ses-example.ses\r\^[<" + x "\^U10\^N" + x "\^K" + x "\^_" + x "\^P\^P\^Fpses-center\r" + x "\^Fp\r" + x "\^U\^P\t\t" + x "\r\^B A9 B9\r" + x "\^U\^N\^B\^B\^B" + x "\r\^A\^K2\r" + x "\^N\^N\^F" x "50\r" - x "4" - x "" - x "" - x "(+ o\0" - x "-1o \r" - x "" + x "\^U4\^_" + x "\^C\^[\^L" + x "\^_" + x "(+ \^Xo\^N\^N\^F\0\^F\^F" + x "\^U-1\^Xo\^C\^R \^C\^S\r\^B" + x "\^_" x)) ;;Create a new spreadsheet (fset 'ses-exercise-new (concat y - x "\"%.8g\"\r" + x "\^C\^P\"%.8g\"\r" x "2\r" - x "" - x "" - x "2" + x "\^O" + x "\^P" + x "\^U2\^O" x "\"Header\r" - x "(sqrt 1\r" - x "pses-center\r" + x "(sqrt 1\r\^B" + x "pses-center\r\^F" x "\t" - x "(+ A2 A3\r" - x "(* B2 A3\r" - x "2" - x "\rB3\r" - x "" + x "\^P(+ A2 A3\r" + x "\^F(* B2 A3\r" + x "\^U2\^C\^[\^H" + x "\r\^?\^?\^?B3\r" + x "\^X\^S" x)) ;;Basic cell display (fset 'ses-exercise-display - (concat y ":(revert-buffer t t)\r" - x "" - x "\"Very long\r" + (concat y "\^[:(revert-buffer t t)\r" + x "\^E" + x "\"Very long\r\^B" x "w3\r" x "w3\r" - x "(/ 1 0\r" - x "234567\r" - x "5w" - x "\t1\r" - x "" - x "234567\r" - x "\t" - x "" - x "345678\r" - x "3w" - x "\0>" - x "" - x "" - x "" - x "" - x "" - x "" - x "" - x "1\r" - x "" - x "" - x "\"1234567-1234567-1234567\r" - x "123\r" - x "2" - x "\"1234567-1234567-1234567\r" - x "123\r" - x "w8\r" - x "\"1234567\r" - x "w5\r" + x "(/ 1 0\r\^B" + x "234567\r\^B" + x "\^U5w" + x "\t1\r\^B" + x "\^B\^C\^C" + x "\^F234567\r\^B" + x "\t\^D\^B" + x "\^B\^C\^C" + x "345678\r\^B" + x "\^U3w" + x "\0\^[>" + x "\^C\^C" + x "\^X\^X" + x "\^E" + x "\^X\^X\^A" + x "\^E" + x "\^F\^E" + x "\^C\^C" + x "1\r\^B" + x "\^C\^C\^F" + x "\^E" + x "\^B\^B\^B\"1234567-1234567-1234567\r\^B" + x "123\r\^B" + x "\^U2\^O" + x "\^N\"1234567-1234567-1234567\r\^B" + x "123\r\^B" + x "\^F\^Fw8\r" + x "\^B\^B\"1234567\r" + x "\^N\^Bw5\r" x)) ;;Cell formulas (fset 'ses-exercise-formulas - (concat y ":(revert-buffer t t)\r" + (concat y "\^[:(revert-buffer t t)\r" x "\t\t" x "\t" - x "(* B1 B2 D1\r" - x "(* B2 B3\r" - x "(apply '+ (ses-range B1 B3)\r" - x "(apply 'ses+ (ses-range B1 B3)\r" - x "(apply 'ses+ (ses-range A2 A3)\r" - x "(mapconcat'number-to-string(ses-range B2 B4) \"-\"\r" - x "(apply 'concat (reverse (ses-range A3 D3))\r" - x "(* (+ A2 A3) (ses+ B2 B3)\r" - x "" - x "2" - x "5\t" - x "(apply 'ses+ (ses-range E1 E2)\r" - x "(apply 'ses+ (ses-range A5 B5)\r" - x "(apply 'ses+ (ses-range E1 F1)\r" - x "(apply 'ses+ (ses-range D1 E1)\r" + x "(* B1 B2 D1\r\^B" + x "(* B2 B3\r\^B" + x "\^N(apply '+ (ses-range B1 B3)\r\^B" + x "(apply 'ses+ (ses-range B1 B3)\r\^B" + x "\^N(apply 'ses+ (ses-range A2 A3)\r\^B" + x "\^N(mapconcat'number-to-string(ses-range B2 B4) \"-\"\r\^B" + x "\^B(apply 'concat (reverse (ses-range A3 D3))\r\^B" + x "\^B(* (+ A2 A3) (ses+ B2 B3)\r\^B" + x "\^N" + x "\^U2\^O" + x "\^U5\t" + x "\^P(apply 'ses+ (ses-range E1 E2)\r\^B" + x "\^P(apply 'ses+ (ses-range A5 B5)\r\^B" + x "\^P(apply 'ses+ (ses-range E1 F1)\r\^B" + x "\^P(apply 'ses+ (ses-range D1 E1)\r\^B" x "\t" - x "(ses-average (ses-range A2 A5)\r" - x "(apply 'ses+ (ses-range A5 A6)\r" - x "k" - x "" - x "" - x "2" - x "3" - x "o" - x "2o" - x "3k" - x "(ses-average (ses-range B3 E3)\r" - x "k" - x "12345678\r" + x "(ses-average (ses-range A2 A5)\r\^B" + x "\^N(apply 'ses+ (ses-range A5 A6)\r\^B" + x "\^B\^B\^[k" + x "\^N\^N\^K" + x "\^P\^P\^P\^O" + x "\^N\^U2\^O" + x "\^P\^U3\^K" + x "\^B\^B\^B\^[o" + x "\^F\^U2\^[o" + x "\^B\^U3\^[k" + x "\^F(ses-average (ses-range B3 E3)\r\^B" + x "\^B\^[k" + x "\^N\^P12345678\r\^B" x)) ;;Recalculating and reconstructing (fset 'ses-exercise-recalc - (concat y ":(revert-buffer t t)\r" - x "" + (concat y "\^[:(revert-buffer t t)\r" + x "\^C\^[\^L" x "\t\t" - x "" - x "(/ 1 0\r" - x "" + x "\^C\^C" + x "(/ 1 0\r\^B" + x "\^C\^C" x "\n" - x "" - x "\"%.6g\"\r" - x "" - x ">nw" - x "\0>xdelete-region\r" - x "" - x "8" - x "\0>xdelete-region\r" - x "" - x "" - x "k" - x "" - x "\"Very long\r" - x "" - x "\r\r" - x "" - x "o" - x "" - x "\"Very long2\r" - x "o" - x "" - x "\rC3\r" - x "\rC2\r" - x "\0" - x "\rC4\r" - x "\rC2\r" - x "\0" - x "" - x "xses-mode\r" - x "<" - x "2k" + x "\^C\^C" + x "\^C\^P\"%.6g\"\r" + x "\^C\^[\^L" + x "\^[>\^Xnw\^F\^F\^F" + x "\0\^[>\^[xdelete-region\r" + x "\^C\^[\^L" + x "\^U8\^N" + x "\0\^[>\^[xdelete-region\r" + x "\^C\^[\^L" + x "\^C\^N" + x "\^N\^K\^B\^[k" + x "\^C\^L" + x "\^B\"Very long\r" + x "\^P\^C\^T" + x "\^B\r\r" + x "\^N\^C\^T" + x "\^F\^[o" + x "\^F\^C\^T" + x "\^B\^B\"Very long2\r" + x "\^B\^[o\^F" + x "\^C\^T" + x "\r\^?\^?\^?C3\r" + x "\^N\r\^?\^?\^?C2\r" + x "\^P\0\^N\^F\^C\^C" + x "\r\^?\^?C4\r" + x "\^N\^N\r\^?\^?\^?C2\r" + x "\^F\0\^B\^P\^P" + x "\^C\^C" + x "\^[xses-mode\r" + x "\^[<\^O" + x "\^U2\^[k" x)) ;;Header line (fset 'ses-exercise-header-row - (concat y ":(revert-buffer t t)\r" - x "<" - x ">" - x "6<" - x ">" - x "7<" - x ">" - x "8<" - x "2<" - x ">" - x "3w" - x "10<" - x ">" - x "2" + (concat y "\^[:(revert-buffer t t)\r" + x "\^X<" + x "\^X>" + x "\^U6\^X<" + x "\^X>" + x "\^U7\^X<" + x "\^X>" + x "\^U8\^X<" + x "\^U2\^X<" + x "\^X>" + x "\^F\^U3w\^B" + x "\^U10\^X<" + x "\^X>" + x "\^U2\^K" x)) ;;Detecting unsafe formulas and printers (fset 'ses-exercise-unsafe - (concat y ":(revert-buffer t t)\r" + (concat y "\^[:(revert-buffer t t)\r" x "p(lambda (x) (delete-file x))\rn" x "p(lambda (x) (delete-file \"ses-nothing\"))\ry" - x "\0n" - x "(delete-file \"x\"\rn" - x "(delete-file \"ses-nothing\"\ry" - x "\0n" - x "(open-network-stream \"x\" nil \"localhost\" \"smtp\"\ry" - x "\0n" + x "\0\^F\^W\^Yn" + x "\^N(delete-file \"x\"\rn" + x "(delete-file \"ses-nothing\"\ry\^B" + x "\0\^F\^W\^Yn" + x "(open-network-stream \"x\" nil \"localhost\" \"smtp\"\ry\^B" + x "\0\^F\^W\^Yn" x)) ;;Inserting and deleting rows (fset 'ses-exercise-rows - (concat y ":(revert-buffer t t)\r" - x "" - x "\"%s=\"\r" - x "20" - x "p\"%s+\"\r" - x "" - x "123456789\r" - x "\021" - x "" - x "" - x "(not B25\r" - x "k" + (concat y "\^[:(revert-buffer t t)\r" + x "\^N\^F" + x "\^C\^P\"%s=\"\r" + x "\^U20\^O" + x "\^[p\"%s+\"\r" + x "\^N\^O" + x "123456789\r\^B" + x "\0\^U21\^N\^F" + x "\^C\^C" + x "\^[\^L" + x "\^P\^P(not B25\r\^B" + x "\^N\^[k" x "jA3\r" - x "19" - x "" - x "100" ;Make this approx your CPU speed in MHz + x "\^U19\^K" + x "\^P\^F\^K" + x "\^U100\^O" ;Make this approx your CPU speed in MHz x)) ;;Inserting and deleting columns (fset 'ses-exercise-columns - (concat y ":(revert-buffer t t)\r" - x "\"%s@\"\r" - x "o" - x "" - x "o" - x "" - x "k" + (concat y "\^[:(revert-buffer t t)\r" + x "\^C\^P\"%s@\"\r" + x "\^[o" + x "\^O" + x "\^[o" + x "\^K" + x "\^[k" x "w8\r" - x "p\"%.7s*\"\r" - x "o" - x "" - x "2o" - x "3k" - x "\"%.6g\"\r" - x "26o" - x "\026\t" - x "26o" - x "0\r" - x "26\t" - x "400" - x "50k" - x "\0D" + x "\^[p\"%.7s*\"\r" + x "\^[o" + x "\^F" + x "\^U2\^[o" + x "\^U3\^[k" + x "\^C\^P\"%.6g\"\r" + x "\^U26\^[o" + x "\0\^U26\t" + x "\^U26\^[o" + x "\^C\^[\^H0\r" + x "\^U26\t" + x "\^U400\^B" + x "\^U50\^[k" + x "\0\^N\^N\^F\^F\^C\^[\^SD" x)) (fset 'ses-exercise-editing - (concat y ":(revert-buffer t t)\r" - x "1\r" - x "('x\r" - x "" - x "" + (concat y "\^[:(revert-buffer t t)\r" + x "\^N\^N\^N1\r\^B" + x "\^F(\^B'\^Fx\r\^B" + x "\^B\^P\^P\^P\^O" + x "\^_" x "\r\r" x "w9\r" - x "\r.5\r" - x "\r 10\r" + x "\^N\r\^B.5\r" + x "\^N\^F\r\^B 10\r" x "w12\r" - x "\r'\r" - x "\r\r" + x "\r\^A'\r" + x "\r\^A\^D\r" x "jA4\r" - x "(+ A2 100\r" - x "3\r" + x "(+ A2 100\r\^B" + x "\^P\^P3\r\^B" x "jB1\r" - x "(not A1\r" - x "\"Very long\r" - x "" - x "h" - x "H" - x "" - x ">\t" - x "" - x "" - x "2" - x "" - x "o" - x "h" - x "\0" - x "\"Also very long\r" - x "H" - x "\0'\r" - x "'Trial\r" - x "'qwerty\r" - x "(concat o<\0" - x "-1o\r" - x "(apply '+ o<\0-1o\r" - x "2" - x "-2" - x "-2" - x "2" - x "" - x "H" - x "\0" - x "\"Another long one\r" - x "H" - x "" - x "<" - x "" - x ">" - x "\0" + x "(not A1\r\^B" + x "\^B\"Very long\r\^B" + x "\^C\^C" + x "\^[h" + x "\^[H" + x "\^C\^C" + x "\^[>\t" + x "\^P\^P\^D" + x "\^P\^D" + x "\^F\^F\^U2\^?" + x "\^P\^?" + x "\^[o" + x "\^[h" + x "\0\^O\^F" + x "\"Also very long\r\^B" + x "\^N\^F\^[H" + x "\0'\r\^B" + x "'Trial\r\^B" + x "\^N\^B'qwerty\r\^B" + x "\^F(concat \^Xo\^[<\0\^N\^N" + x "\^U-1\^Xo\^C\^R\r\^B" + x "(apply '+ \^Xo\^[<\0\^N\^F\^U-1\^Xo\^C\^S\r\^B" + x "\^P\^U2\^?" + x "\^U-2\^?" + x "\^U-2\^D" + x "\^U2\^D" + x "\^B\^P\^P\^K" + x "\^N\^F\^[H" + x "\^B\^P\0\^O" + x "\"Another long one\r\^B" + x "\^N\^N\^F\^[H" + x "\^A\^P\^E" + x "\^C\^C\^[<" + x "\^N\^E" + x "\^[>\^P\^O" + x "\0\^E\^F\^E" x)) ;;Sorting of columns (fset 'ses-exercise-sort-column - (concat y ":(revert-buffer t t)\r" + (concat y "\^[:(revert-buffer t t)\r" x "\"Very long\r" - x "99\r" - x "o13\r" + x "\^F99\r" + x "\^F\^[o13\r" x "(+ A3 B3\r" x "7\r8\r(* A4 B4\r" - x "\0A\r" - x "\0B\r" - x "\0C\r" - x "o" - x "\0C\r" + x "\0\^P\^P\^P\^C\^[\^SA\r" + x "\^N\0\^P\^P\^P\^C\^[\^SB\r" + x "\^P\^P\^F\0\^N\^N\^F\^F\^C\^[\^SC\r" + x "\^F\^[o\^P\^O" + x "\^B\0\^N\^N\^N\^U\^C\^[\^SC\r" x)) ;;Simple cell printers (fset 'ses-exercise-cell-printers - (concat y ":(revert-buffer t t)\r" - x "\"4\t76\r" - x "\"4\n7\r" + (concat y "\^[:(revert-buffer t t)\r" + x "\^F\"4\^Q\t76\r\^B" + x "\"4\^Q\n7\r\^B" x "p\"{%S}\"\r" x "p(\"[%s]\")\r" x "p(\"<%s>\")\r" - x "\0" + x "\^B\0\^F\^F" x "p\r" x "pnil\r" x "pses-dashfill\r" - x "48\r" + x "48\r\^B" x "\t" - x "\0p\r" - x "p\r" + x "\^B\0\^Fp\r" + x "\^Fp\r" x "pses-dashfill\r" - x "\0pnil\r" - x "5\r" + x "\^B\0\^F\^Fpnil\r" + x "5\r\^B" x "pses-center\r" - x "\"%s\"\r" + x "\^C\^P\"%s\"\r" x "w8\r" - x "p\r" - x "p\"%.7g@\"\r" - x "\r" - x "\"%.6g#\"\r" - x "\"%.6g.\"\r" - x "\"%.6g.\"\r" - x "pidentity\r" - x "6\r" - x "\"UPCASE\r" - x "pdowncase\r" - x "(* 3 4\r" - x "p(lambda (x) '(\"Hi\"))\r" - x "p(lambda (x) '(\"Bye\"))\r" + x "\^[p\r" + x "\^[p\"%.7g@\"\r" + x "\^C\^P\r" + x "\^C\^P\"%.6g#\"\r" + x "\^C\^P\"%.6g.\"\r" + x "\^C\^P\"%.6g.\"\r" + x "\^[pidentity\r" + x "6\r\^B" + x "\^N\"UPCASE\r\^B" + x "\^[pdowncase\r" + x "(* 3 4\r\^B" + x "p(lambda\^Q (x)\^Q '(\"Hi\"))\r" + x "p(lambda\^Q (x)\^Q '(\"Bye\"))\r" x)) ;;Spanning cell printers (fset 'ses-exercise-spanning-printers - (concat y ":(revert-buffer t t)\r" - x "p\"%.6g*\"\r" + (concat y "\^[:(revert-buffer t t)\r" + x "\^[p\"%.6g*\"\r" x "pses-dashfill-span\r" - x "5\r" + x "5\r\^B" x "pses-tildefill-span\r" - x "\"4\r" - x "p\"$%s\"\r" - x "p(\"$%s\")\r" - x "8\r" - x "p(\"!%s!\")\r" - x "\t\"12345678\r" + x "\"4\r\^B" + x "\^[p\"$%s\"\r" + x "\^[p(\"$%s\")\r" + x "8\r\^B" + x "\^[p(\"!%s!\")\r" + x "\t\"12345678\r\^B" x "pses-dashfill-span\r" - x "\"23456789\r" + x "\"23456789\r\^B" x "\t" - x "(not t\r" - x "w6\r" - x "\"5\r" - x "o" - x "k" - x "k" + x "(not t\r\^B" + x "\^Bw6\r" + x "\"5\r\^B" + x "\^N\^F\^[o" + x "\^[k" + x "\^[k" x "\t" - x "" - x "o" - x "2k" - x "k" + x "\^B\^P\^C\^C" + x "\^[o" + x "\^N\^U2\^[k" + x "\^B\^B\^[k" x)) ;;Cut/copy/paste - within same buffer (fset 'ses-exercise-paste-1buf - (concat y ":(revert-buffer t t)\r" - x "\0w" - x "" - x "o" - x "\"middle\r" - x "\0" - x "w" - x "\0" - x "w" - x "" - x "" - x "2y" - x "y" - x "y" - x ">" - x "y" - x ">y" - x "<" + (concat y "\^[:(revert-buffer t t)\r" + x "\^N\0\^F\^[w" + x "\^C\^C\^P\^F\^Y" + x "\^N\^[o" + x "\"middle\r\^B" + x "\0\^F\^N\^F" + x "\^[w" + x "\^P\0\^F" + x "\^[w" + x "\^C\^C\^F\^N" + x "\^Y" + x "\^U2\^Yy" + x "\^F\^U\^Yy" + x "\^P\^P\^F\^U\^Yy" + x "\^[>" + x "\^Yy" + x "\^[>\^Yy" + x "\^[<" x "p\"<%s>\"\r" - x "pses-dashfill\r" - x "\0" - x "" - x "" - x "y" - x "\r\0w" - x "\r" - x "3(+ G2 H1\r" - x "\0w" - x ">" - x "" - x "8(ses-average (ses-range G2 H2)\r" - x "\0k" - x "7" - x "" - x "(ses-average (ses-range E7 E9)\r" - x "\0" - x "" - x "(ses-average (ses-range E7 F7)\r" - x "\0k" - x "" - x "(ses-average (ses-range D6 E6)\r" - x "\0k" - x "" - x "2" - x "\"Line A\r" + x "\^Fpses-dashfill\r" + x "\^B\0\^F\^F\^F\^N\^N\^N" + x "\^W" + x "\^_" + x "\^U\^Yy" + x "\r\0\^B\^B\^B\^[w" + x "\r\^F\^Y" + x "\^U3\^P(+ G2 H1\r" + x "\0\^B\^[w" + x "\^C\^C\^[>\^B" + x "\^Y" + x "\^B\^U8\^P(ses-average (ses-range G2 H2)\r\^B" + x "\0\^F\^W\^[k" + x "\^U7\^N" + x "\^Y" + x "\^P\^B(ses-average (ses-range E7 E9)\r\^B" + x "\0\^F\^W\^K" + x "\^N\^Y" + x "\^B\^B\^P(ses-average (ses-range E7 F7)\r\^B" + x "\0\^F\^W\^[k" + x "\^F\^Y" + x "\^B\^B\^P(ses-average (ses-range D6 E6)\r\^B" + x "\0\^F\^W\^[k" + x "\^F\^Y" + x "\^A\^U2\^O" + x "\"Line A\r\^B" x "pses-tildefill-span\r" - x "\"Subline A(1)\r" + x "\^N\^F\"Subline A(1)\r\^B" x "pses-dashfill-span\r" - x "\0w" - x "" - x "" - x "\0w" - x "" + x "\^B\^P\0\^N\^N\^N\^[w\^C\^C" + x "\^A\^P\^P\^P\^P\^P\^P" + x "\^Y" + x "\0\^N\^F\^F\^[w\^C\^C" + x "\^F\^Y" x)) ;;Cut/copy/paste - between two buffers (fset 'ses-exercise-paste-2buf - (concat y ":(revert-buffer t t)\r" - x "o\"middle\r\0" - x "" - x "4bses-test.txt\r" - x " " - x "\"xxx\0" - x "wo" - x "" - x "" - x "o\"\0" - x "wo" - x "o123.45\0" - x "o" - x "o1 \0" - x "o" - x ">y" - x "o symb\0" - x "oy2y" - x "o1\t\0" - x "o" - x "w9\np\"<%s>\"\n" - x "o\n2\t\"3\nxxx\t5\n\0" - x "oy" + (concat y "\^[:(revert-buffer t t)\r" + x "\^F\^N\^[o\"middle\r\^B\0\^F\^N\^F" + x "\^W" + x "\^X4bses-test.txt\r" + x " \^A\^Y" + x "\^E\"xxx\0\^B\^B\^B\^B" + x "\^[w\^Xo" + x "\^_" + x "\^Y" + x "\^Xo\^E\"\0\^B\^B\^B\^B\^B" + x "\^[w\^Xo\^Y" + x "\^Xo123.45\0\^B\^B\^B\^B\^B\^B" + x "\^W\^Xo\^Y" + x "\^Xo1 \^B\^B\0\^F\^F\^F\^F\^F\^F\^F" + x "\^W\^Xo\^Y" + x "\^[>\^Yy" + x "\^F\^Xo symb\0\^B\^B\^B\^B" + x "\^W\^Xo\^U\^Y\^[y\^U2\^[y" + x "\^Xo1\t\0\^B\^B" + x "\^W\^Xo\^B\^Y" + x "w9\n\^[p\"<%s>\"\n" + x "\^Xo\n2\t\"3\nxxx\t5\n\0\^P\^P" + x "\^W\^Xo\^Yy" x)) ;;Export text, import it back (fset 'ses-exercise-import-export - (concat y ":(revert-buffer t t)\r" - x "\0xt" - x "4bses-test.txt\r" - x "\n-1o" - x "xTo-1o" - x "'crunch\r" - x "pses-center-span\r" - x "\0xT" - x "o\n-1o" - x "\0y" - x "\0xt" - x "\0y" - x "12345678\r" - x "'bunch\r" - x "\0xtxT" + (concat y "\^[:(revert-buffer t t)\r" + x "\^N\^N\^F\0\^Fxt" + x "\^X4bses-test.txt\r" + x "\n\^Y\^U-1\^Xo" + x "xT\^Xo\^Y\^U-1\^Xo" + x "\^C\^C\^F'crunch\r\^B" + x "\^P\^P\^Ppses-center-span\r" + x "\0\^N\^N\^N\^NxT" + x "\^Xo\n\^Y\^U-1\^Xo" + x "\0\^Yy" + x "\^F\0\^B\^P\^Pxt" + x "\^N\^N\0\^U\^Yy" + x "12345678\r\^B" + x "\^F\^F'bunch\r" + x "\0\^P\^PxtxT" x))) (defun ses-exercise-macros () @@ -565,10 +564,10 @@ spreadsheet files with invalid formatting." (let ((curcell '(A1 . A2))) (ses-check-curcell 'end)) (let ((curcell '(A1 . A2))) (ses-sort-column "B")) (let ((curcell '(C1 . D2))) (ses-sort-column "B")) - (execute-kbd-macro "jB10\n2") + (execute-kbd-macro "jB10\n\^U2\^D") (execute-kbd-macro [?j ?B ?9 ?\n ?\C-@ ?\C-f ?\C-f cut]) - (progn (kill-new "x") (execute-kbd-macro ">n")) - (execute-kbd-macro "\0w"))) + (progn (kill-new "x") (execute-kbd-macro "\^[>\^Yn")) + (execute-kbd-macro "\^B\0\^[w"))) (condition-case nil (progn (eval x) @@ -589,7 +588,7 @@ spreadsheet files with invalid formatting." (defun ses-exercise-invalid-spreadsheets () "Execute code paths that detect invalid spreadsheet files." ;;Detect invalid spreadsheets - (let ((p&d "\n\n\n(ses-cell A1 nil nil nil nil)\n\n") + (let ((p&d "\n\n\^L\n(ses-cell A1 nil nil nil nil)\n\n") (cw "(ses-column-widths [7])\n") (cp "(ses-column-printers [ses-center])\n") (dp "(ses-default-printer \"%.7g\")\n") @@ -603,12 +602,12 @@ spreadsheet files with invalid formatting." "(1 2 x)" "(1 2 -1)" "(3 1 1)" - "\n\n(2 1 1)" - "\n\n\n(ses-cell)(2 1 1)" - "\n\n\n(x)\n(2 1 1)" - "\n\n\n\n(ses-cell A2)\n(2 2 2)" - "\n\n\n\n(ses-cell B1)\n(2 2 2)" - "\n\n\n(ses-cell A1 nil nil nil nil)\n(2 1 1)" + "\n\n\^L(2 1 1)" + "\n\n\^L\n(ses-cell)(2 1 1)" + "\n\n\^L\n(x)\n(2 1 1)" + "\n\n\n\^L\n(ses-cell A2)\n(2 2 2)" + "\n\n\n\^L\n(ses-cell B1)\n(2 2 2)" + "\n\n\^L\n(ses-cell A1 nil nil nil nil)\n(2 1 1)" (concat p&d "(x)\n(x)\n(x)\n(x)\n" p11) (concat p&d "(ses-column-widths)(x)\n(x)\n(x)\n" p11) (concat p&d cw "(x)\n(x)\n(x)\n(2 1 1)") @@ -671,7 +670,7 @@ spreadsheet files with invalid formatting." (ses-exercise-invalid-spreadsheets) ;;Upgrade of old-style spreadsheet (with-temp-buffer - (insert " \n\n\n(ses-cell A1 nil nil nil nil)\n\n(ses-column-widths [7])\n(ses-column-printers [nil])\n(ses-default-printer \"%.7g\")\n\n( ;Global parameters (these are read first)\n 1 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n") + (insert " \n\n\^L\n(ses-cell A1 nil nil nil nil)\n\n(ses-column-widths [7])\n(ses-column-printers [nil])\n(ses-default-printer \"%.7g\")\n\n( ;Global parameters (these are read first)\n 1 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n") (ses-load)) ;;ses-vector-delete is always called from buffer-undo-list with the same ;;symbol as argument. We'll give it a different one here. diff --git a/lisp/emacs-lisp/tcover-unsafep.el b/lisp/emacs-lisp/tcover-unsafep.el index 571f53c7957..fc6b6cb74dd 100644 --- a/lisp/emacs-lisp/tcover-unsafep.el +++ b/lisp/emacs-lisp/tcover-unsafep.el @@ -2,8 +2,7 @@ ;; Copyright (C) 2002-2019 Free Software Foundation, Inc. -;; Author: Jonathan Yavner <jyavner@engineer.com> -;; Maintainer: Jonathan Yavner <jyavner@engineer.com> +;; Author: Jonathan Yavner <jyavner@member.fsf.org> ;; Keywords: safety lisp utility ;; Package: testcover diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index 3ede465fcc5..20851805f5c 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2002-2019 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@member.fsf.org> -;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org> ;; Keywords: lisp utility ;; This file is part of GNU Emacs. @@ -33,7 +32,9 @@ ;; that has a splotch. ;; * Basic algorithm: use `edebug' to mark up the function text with -;; instrumentation callbacks, then replace edebug's callbacks with ours. +;; instrumentation callbacks, walk the instrumented code looking for +;; forms which don't return or always return the same value, then use +;; Edebug's before and after hooks to replace its code coverage with ours. ;; * To show good coverage, we want to see two values for every form, except ;; functions that always return the same value and `defconst' variables ;; need show only one value for good coverage. To avoid the brown @@ -47,11 +48,10 @@ ;; function being called is capable of returning in other cases. ;; Problems: -;; * To detect different values, we store the form's result in a vector and -;; compare the next result using `equal'. We don't copy the form's -;; result, so if caller alters it (`setcar', etc.) we'll think the next -;; call has the same value! Also, equal thinks two strings are the same -;; if they differ only in properties. +;; * `equal', which is used to compare the results of repeatedly executing +;; a form, has a couple of shortcomings. It considers strings to be the same +;; if they only differ in properties, and it raises an error when asked to +;; compare circular lists. ;; * Because we have only a "1value" class and no "always nil" class, we have ;; to treat as potentially 1-valued any `and' whose last term is 1-valued, ;; in case the last term is always nil. Example: @@ -62,6 +62,7 @@ ;; error if these "potentially" 1-valued forms actually return differing ;; values. +(eval-when-compile (require 'cl-lib)) (require 'edebug) (provide 'testcover) @@ -89,16 +90,14 @@ these. This list is quite incomplete!" buffer-disable-undo buffer-enable-undo current-global-map deactivate-mark delete-backward-char delete-char delete-region ding forward-char function* insert insert-and-inherit kill-all-local-variables - kill-line kill-paragraph kill-region kill-sexp lambda + kill-line kill-paragraph kill-region kill-sexp minibuffer-complete-and-exit narrow-to-region next-line push-mark put-text-property run-hooks set-match-data signal substitute-key-definition suppress-keymap undo use-local-map while widen yank) - "Functions that always return the same value. No brown splotch is shown -for these. This list is quite incomplete! Notes: Nobody ever changes the -current global map. The macro `lambda' is self-evaluating, hence always -returns the same value (the function it defines may return varying values -when called)." + "Functions that always return the same value, according to `equal'. +No brown splotch is shown for these. This list is quite +incomplete! Notes: Nobody ever changes the current global map." :group 'testcover :type '(repeat symbol)) @@ -111,7 +110,7 @@ them as having returned nil just before calling them." (defcustom testcover-compose-functions '(+ - * / = append length list make-keymap make-sparse-keymap - mapcar message propertize replace-regexp-in-string + message propertize replace-regexp-in-string run-with-idle-timer set-buffer-modified-p) "Functions that are 1-valued if all their args are either constants or calls to one of the `testcover-1value-functions', so if that's true then no @@ -186,19 +185,18 @@ call to one of the `testcover-1value-functions'." ;;;###autoload (defun testcover-start (filename &optional byte-compile) - "Uses edebug to instrument all macros and functions in FILENAME, then -changes the instrumentation from edebug to testcover--much faster, no -problems with type-ahead or post-command-hook, etc. If BYTE-COMPILE is -non-nil, byte-compiles each function after instrumenting." + "Use Edebug to instrument for coverage all macros and functions in FILENAME. +If BYTE-COMPILE is non-nil, byte compile each function after instrumenting." (interactive "fStart covering file: ") - (let ((buf (find-file filename)) - (load-read-function load-read-function)) - (add-function :around load-read-function - #'testcover--read) - (setq edebug-form-data nil - testcover-module-constants nil - testcover-module-1value-functions nil) - (eval-buffer buf)) + (let ((buf (find-file filename))) + (setq edebug-form-data nil + testcover-module-constants nil + testcover-module-1value-functions nil + testcover-module-potentially-1value-functions nil) + (let ((edebug-all-defs t) + (edebug-after-instrumentation-function #'testcover-after-instrumentation) + (edebug-new-definition-function #'testcover-init-definition)) + (eval-buffer buf))) (when byte-compile (dolist (x (reverse edebug-form-data)) (when (fboundp (car x)) @@ -209,229 +207,10 @@ non-nil, byte-compiles each function after instrumenting." (defun testcover-this-defun () "Start coverage on function under point." (interactive) - (let ((x (let ((edebug-all-defs t)) - (symbol-function (eval-defun nil))))) - (testcover-reinstrument x) - x)) - -(defun testcover--read (orig &optional stream) - "Read a form using edebug, changing edebug callbacks to testcover callbacks." - (or stream (setq stream standard-input)) - (if (eq stream (current-buffer)) - (let ((x (let ((edebug-all-defs t)) - (edebug-read-and-maybe-wrap-form)))) - (testcover-reinstrument x) - x) - (funcall (or orig #'read) stream))) - -(defun testcover-reinstrument (form) - "Reinstruments FORM to use testcover instead of edebug. This -function modifies the list that FORM points to. Result is nil if -FORM should return multiple values, t if should always return same -value, `maybe' if either is acceptable." - (let ((fun (car-safe form)) - id val) - (cond - ((not fun) ;Atom - (when (or (not (symbolp form)) - (memq form testcover-constants) - (memq form testcover-module-constants)) - t)) - ((consp fun) ;Embedded list - (testcover-reinstrument fun) - (testcover-reinstrument-list (cdr form)) - nil) - ((or (memq fun testcover-1value-functions) - (memq fun testcover-module-1value-functions)) - ;;Should always return same value - (testcover-reinstrument-list (cdr form)) - t) - ((or (memq fun testcover-potentially-1value-functions) - (memq fun testcover-module-potentially-1value-functions)) - ;;Might always return same value - (testcover-reinstrument-list (cdr form)) - 'maybe) - ((memq fun testcover-progn-functions) - ;;1-valued if last argument is - (testcover-reinstrument-list (cdr form))) - ((memq fun testcover-prog1-functions) - ;;1-valued if first argument is - (testcover-reinstrument-list (cddr form)) - (testcover-reinstrument (cadr form))) - ((memq fun testcover-compose-functions) - ;;1-valued if all arguments are. Potentially 1-valued if all - ;;arguments are either definitely or potentially. - (testcover-reinstrument-compose (cdr form) 'testcover-reinstrument)) - ((eq fun 'edebug-enter) - ;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS)) - ;; => (testcover-enter 'SYM #'(lambda nil FORMS)) - (setcar form 'testcover-enter) - (setcdr (nthcdr 1 form) (nthcdr 3 form)) - (let ((testcover-vector (get (cadr (cadr form)) 'edebug-coverage))) - (testcover-reinstrument-list (nthcdr 2 (cadr (nth 2 form)))))) - ((eq fun 'edebug-after) - ;;(edebug-after (edebug-before XXX) YYY FORM) - ;; => (testcover-after YYY FORM), mark XXX as ok-coverage - (unless (eq (cadr form) 0) - (aset testcover-vector (cadr (cadr form)) 'ok-coverage)) - (setq id (nth 2 form)) - (setcdr form (nthcdr 2 form)) - (setq val (testcover-reinstrument (nth 2 form))) - (setcar form (if (eq val t) - 'testcover-1value - 'testcover-after)) - (when val - ;;1-valued or potentially 1-valued - (aset testcover-vector id '1value)) - (cond - ((memq (car-safe (nth 2 form)) testcover-noreturn-functions) - ;;This function won't return, so set the value in advance - ;;(edebug-after (edebug-before XXX) YYY FORM) - ;; => (progn (edebug-after YYY nil) FORM) - (setcar (cdr form) `(,(car form) ,id nil)) - (setcar form 'progn) - (aset testcover-vector id '1value) - (setq val t)) - ((eq (car-safe (nth 2 form)) '1value) - ;;This function is always supposed to return the same value - (setq val t) - (aset testcover-vector id '1value) - (setcar form 'testcover-1value))) - val) - ((eq fun 'defun) - (setq val (testcover-reinstrument-list (nthcdr 3 form))) - (when (eq val t) - (push (cadr form) testcover-module-1value-functions)) - (when (eq val 'maybe) - (push (cadr form) testcover-module-potentially-1value-functions))) - ((memq fun '(defconst defcustom)) - ;;Define this symbol as 1-valued - (push (cadr form) testcover-module-constants) - (testcover-reinstrument-list (cddr form))) - ((memq fun '(dotimes dolist)) - ;;Always returns third value from SPEC - (testcover-reinstrument-list (cddr form)) - (setq val (testcover-reinstrument-list (cadr form))) - (if (nth 2 (cadr form)) - val - ;;No third value, always returns nil - t)) - ((memq fun '(let let*)) - ;;Special parsing for second argument - (mapc 'testcover-reinstrument-list (cadr form)) - (testcover-reinstrument-list (cddr form))) - ((eq fun 'if) - ;;Potentially 1-valued if both THEN and ELSE clauses are - (testcover-reinstrument (cadr form)) - (let ((then (testcover-reinstrument (nth 2 form))) - (else (testcover-reinstrument-list (nthcdr 3 form)))) - (and then else 'maybe))) - ((eq fun 'cond) - ;;Potentially 1-valued if all clauses are - (when (testcover-reinstrument-compose (cdr form) - 'testcover-reinstrument-list) - 'maybe)) - ((eq fun 'condition-case) - ;;Potentially 1-valued if BODYFORM is and all HANDLERS are - (let ((body (testcover-reinstrument (nth 2 form))) - (errs (testcover-reinstrument-compose - (mapcar #'cdr (nthcdr 3 form)) - 'testcover-reinstrument-list))) - (and body errs 'maybe))) - ((eq fun 'quote) - ;;Don't reinstrument what's inside! - ;;This doesn't apply within a backquote - t) - ((eq fun '\`) - ;;Quotes are not special within backquotes - (let ((testcover-1value-functions - (cons 'quote testcover-1value-functions))) - (testcover-reinstrument (cadr form)))) - ((eq fun '\,) - ;;In commas inside backquotes, quotes are special again - (let ((testcover-1value-functions - (remq 'quote testcover-1value-functions))) - (testcover-reinstrument (cadr form)))) - ((eq fun '1value) - ;;Hack - pretend the arg is 1-valued here - (cond - ((symbolp (cadr form)) - ;;A pseudoconstant variable - t) - ((and (eq (car (cadr form)) 'edebug-after) - (symbolp (nth 3 (cadr form)))) - ;;Reference to pseudoconstant - (aset testcover-vector (nth 2 (cadr form)) '1value) - (setcar (cdr form) `(testcover-1value ,(nth 2 (cadr form)) - ,(nth 3 (cadr form)))) - t) - (t - (setq id (car (if (eq (car (cadr form)) 'edebug-after) - (nth 3 (cadr form)) - (cadr form)))) - (let ((testcover-1value-functions - (cons id testcover-1value-functions))) - (testcover-reinstrument (cadr form)))))) - ((eq fun 'noreturn) - ;;Hack - pretend the arg has no return - (cond - ((symbolp (cadr form)) - ;;A pseudoconstant variable - 'maybe) - ((and (eq (car (cadr form)) 'edebug-after) - (symbolp (nth 3 (cadr form)))) - ;;Reference to pseudoconstant - (aset testcover-vector (nth 2 (cadr form)) '1value) - (setcar (cdr form) `(progn (testcover-after ,(nth 2 (cadr form)) nil) - ,(nth 3 (cadr form)))) - 'maybe) - (t - (setq id (car (if (eq (car (cadr form)) 'edebug-after) - (nth 3 (cadr form)) - (cadr form)))) - (let ((testcover-noreturn-functions - (cons id testcover-noreturn-functions))) - (testcover-reinstrument (cadr form)))))) - ((and (eq fun 'apply) - (eq (car-safe (cadr form)) 'quote) - (symbolp (cadr (cadr form)))) - ;;Apply of a constant symbol. Process as 1value or noreturn - ;;depending on symbol. - (setq fun (cons (cadr (cadr form)) (cddr form)) - val (testcover-reinstrument fun)) - (setcdr (cdr form) (cdr fun)) - val) - (t ;Some other function or weird thing - (testcover-reinstrument-list (cdr form)) - nil)))) - -(defun testcover-reinstrument-list (list) - "Reinstruments each form in LIST to use testcover instead of edebug. -This function modifies the forms in LIST. Result is `testcover-reinstrument's -value for the last form in LIST. If the LIST is empty, its evaluation will -always be nil, so we return t for 1-valued." - (let ((result t)) - (while (consp list) - (setq result (testcover-reinstrument (pop list)))) - result)) - -(defun testcover-reinstrument-compose (list fun) - "For a compositional function, the result is 1-valued if all -arguments are, potentially 1-valued if all arguments are either -definitely or potentially 1-valued, and multi-valued otherwise. -FUN should be `testcover-reinstrument' for compositional functions, - `testcover-reinstrument-list' for clauses in a `cond'." - (let ((result t)) - (mapc #'(lambda (x) - (setq x (funcall fun x)) - (cond - ((eq result t) - (setq result x)) - ((eq result 'maybe) - (when (not x) - (setq result nil))))) - list) - result)) + (let ((edebug-all-defs t) + (edebug-after-instrumentation-function #'testcover-after-instrumentation) + (edebug-new-definition-function #'testcover-init-definition)) + (eval-defun nil))) (defun testcover-end (filename) "Turn off instrumentation of all macros and functions in FILENAME." @@ -444,48 +223,108 @@ FUN should be `testcover-reinstrument' for compositional functions, ;;; Accumulate coverage data ;;;========================================================================= -(defun testcover-enter (testcover-sym testcover-fun) - "Internal function for coverage testing. Invokes TESTCOVER-FUN while -binding `testcover-vector' to the code-coverage vector for TESTCOVER-SYM -\(the name of the current function)." - (let ((testcover-vector (get testcover-sym 'edebug-coverage))) - (funcall testcover-fun))) - -(defun testcover-after (idx val) - "Internal function for coverage testing. Returns VAL after installing it in -`testcover-vector' at offset IDX." - (declare (gv-expander (lambda (do) - (gv-letplace (getter setter) val - (funcall do getter - (lambda (store) - `(progn (testcover-after ,idx ,getter) - ,(funcall setter store)))))))) - (cond - ((eq (aref testcover-vector idx) 'unknown) - (aset testcover-vector idx val)) - ((not (condition-case () - (equal (aref testcover-vector idx) val) - ;; TODO: Actually check circular lists for equality. - (circular-list nil))) - (aset testcover-vector idx 'ok-coverage))) - val) - -(defun testcover-1value (idx val) - "Internal function for coverage testing. Returns VAL after installing it in -`testcover-vector' at offset IDX. Error if FORM does not always return the -same value during coverage testing." - (cond - ((eq (aref testcover-vector idx) '1value) - (aset testcover-vector idx (cons '1value val))) - ((not (and (eq (car-safe (aref testcover-vector idx)) '1value) - (condition-case () - (equal (cdr (aref testcover-vector idx)) val) - ;; TODO: Actually check circular lists for equality. - (circular-list nil)))) - (error "Value of form marked with `1value' does vary: %s" val))) - val) - - +(defun testcover-after-instrumentation (form) + "Analyze FORM for code coverage." + (testcover-analyze-coverage form) + form) + +(defun testcover-init-definition (sym) + "Mark SYM as under test coverage." + (message "Testcover: %s" sym) + (put sym 'edebug-behavior 'testcover)) + +(defun testcover-enter (func _args body) + "Begin execution of a function under coverage testing. +Bind `testcover-vector' to the code-coverage vector for FUNC and +return the result of evaluating BODY." + (let ((testcover-vector (get func 'edebug-coverage))) + (funcall body))) + +(defun testcover-before (before-index) + "Update code coverage before a form is evaluated. +BEFORE-INDEX is the form's index into the code-coverage vector." + (let ((before-entry (aref testcover-vector before-index))) + (when (eq (car-safe before-entry) 'noreturn) + (let* ((after-index (cdr before-entry))) + (aset testcover-vector after-index 'edebug-ok-coverage))))) + +(defun testcover-after (_before-index after-index value) + "Update code coverage with the result of a form's evaluation. +AFTER-INDEX is the form's index into the code-coverage +vector. Return VALUE." + (let ((old-result (aref testcover-vector after-index))) + (cond + ((eq 'edebug-unknown old-result) + (aset testcover-vector after-index (testcover--copy-object value))) + ((eq 'maybe old-result) + (aset testcover-vector after-index 'edebug-ok-coverage)) + ((eq '1value old-result) + (aset testcover-vector after-index + (cons old-result (testcover--copy-object value)))) + ((and (eq (car-safe old-result) '1value) + (not (condition-case () + (equal (cdr old-result) value) + (circular-list t)))) + (error "Value of form expected to be constant does vary, from %s to %s" + old-result value)) + ;; Test if a different result. + ((not (condition-case () + (equal value old-result) + (circular-list nil))) + (aset testcover-vector after-index 'edebug-ok-coverage)))) + value) + +;; Add these behaviors to Edebug. +(unless (assoc 'testcover edebug-behavior-alist) + (push '(testcover testcover-enter testcover-before testcover-after) + edebug-behavior-alist)) + +(defun testcover--copy-object (obj) + "Make a copy of OBJ. +If OBJ is a cons cell, copy both its car and its cdr. +Contrast to `copy-tree' which does the same but fails on circular +structures, and `copy-sequence', which copies only along the +cdrs. Copy vectors as well as conses." + (let ((ht (make-hash-table :test 'eq))) + (testcover--copy-object1 obj t ht))) + +(defun testcover--copy-object1 (obj vecp hash-table) + "Make a copy of OBJ, using a HASH-TABLE of objects already copied. +If OBJ is a cons cell, this recursively copies its car and +iteratively copies its cdr. When VECP is non-nil, copy +vectors as well as conses." + (if (and (atom obj) (or (not vecp) (not (vectorp obj)))) + obj + (let ((copy (gethash obj hash-table nil))) + (unless copy + (cond + ((consp obj) + (let* ((rest obj) current) + (setq copy (cons nil nil) + current copy) + (while + (progn + (puthash rest current hash-table) + (setf (car current) + (testcover--copy-object1 (car rest) vecp hash-table)) + (setq rest (cdr rest)) + (cond + ((atom rest) + (setf (cdr current) + (testcover--copy-object1 rest vecp hash-table)) + nil) + ((gethash rest hash-table nil) + (setf (cdr current) (gethash rest hash-table nil)) + nil) + (t (setq current + (setf (cdr current) (cons nil nil))))))))) + (t ; (and vecp (vectorp obj)) is true due to test in if above. + (setq copy (copy-sequence obj)) + (puthash obj copy hash-table) + (dotimes (i (length copy)) + (aset copy i + (testcover--copy-object1 (aref copy i) vecp hash-table)))))) + copy))) ;;;========================================================================= ;;; Display the coverage data as color splotches on your code. @@ -517,12 +356,13 @@ eliminated by adding more test cases." (while (> len 0) (setq len (1- len) data (aref coverage len)) - (when (and (not (eq data 'ok-coverage)) - (not (eq (car-safe data) '1value)) - (setq j (+ def-mark (aref points len)))) + (when (and (not (eq data 'edebug-ok-coverage)) + (not (memq (car-safe data) + '(1value maybe noreturn))) + (setq j (+ def-mark (aref points len)))) (setq ov (make-overlay (1- j) j)) (overlay-put ov 'face - (if (memq data '(unknown 1value)) + (if (memq data '(edebug-unknown maybe 1value)) 'testcover-nohits 'testcover-1value)))) (set-buffer-modified-p changed)))) @@ -553,4 +393,286 @@ coverage tests. This function creates many overlays." (goto-char (next-overlay-change (point))) (end-of-line)) + +;;; Coverage Analysis + +;; The top level function for initializing code coverage is +;; `testcover-analyze-coverage', which recursively walks the form it is +;; passed, which should have already been instrumented by +;; edebug-read-and-maybe-wrap-form, and initializes the associated +;; code coverage vectors, which should have already been created by +;; `edebug-clear-coverage'. +;; +;; The purpose of the analysis is to identify forms which can only +;; ever return a single value. These forms can be considered to have +;; adequate code coverage even if only executed once. In addition, +;; forms which will never return, such as error signals, can be +;; identified and treated correctly. +;; +;; The code coverage vector entries for the beginnings of forms will +;; be changed to `edebug-ok-coverage.', except for the beginnings of forms +;; which should never return, which will be changed to +;; (noreturn . AFTER-INDEX) so that testcover-before can set the entry +;; for the end of the form just before it is executed. +;; +;; Entries for the ends of forms may be changed to `1value' if +;; analysis determines the form will only ever return a single value, +;; or `maybe' if the form could potentially only ever return a single +;; value. +;; +;; An example of a potentially 1-valued form is an `and' whose last +;; term is 1-valued, in case the last term is always nil. Example: +;; +;; (and (< (point) 1000) (forward-char 10)) +;; +;; This form always returns nil. Similarly, `or', `if', and `cond' +;; are treated as potentially 1-valued if all clauses are, in case +;; those values are always nil. Unlike truly 1-valued functions, it +;; is not an error if these "potentially" 1-valued forms actually +;; return differing values. + +(defun testcover-analyze-coverage (form) + "Analyze FORM and initialize coverage vectors for definitions found within. +Return 1value, maybe or nil depending on if the form is determined +to return only a single value, potentially return only a single value, +or return multiple values." + (pcase form + (`(edebug-enter ',sym ,_ (function (lambda nil . ,body))) + (let ((testcover-vector (get sym 'edebug-coverage))) + (testcover-analyze-coverage-progn body))) + + (`(edebug-after ,(and before-form + (or `(edebug-before ,before-id) before-id)) + ,after-id ,wrapped-form) + (testcover-analyze-coverage-edebug-after + form before-form before-id after-id wrapped-form)) + + (`(defconst ,sym . ,args) + (push sym testcover-module-constants) + (testcover-analyze-coverage-progn args) + '1value) + + (`(defun ,name ,_ . ,doc-and-body) + (let ((val (testcover-analyze-coverage-progn doc-and-body))) + (cl-case val + ((1value) (push name testcover-module-1value-functions)) + ((maybe) (push name testcover-module-potentially-1value-functions))) + nil)) + + (`(quote . ,_) + ;; A quoted form is 1value. Edebug could have instrumented + ;; something inside the form if an Edebug spec contained a quote. + ;; It's also possible that the quoted form is a circular object. + ;; To avoid infinite recursion, don't examine quoted objects. + ;; This will cause the coverage marks on an instrumented quoted + ;; form to look odd. See bug#25316. + '1value) + + (`(\` ,bq-form) + (testcover-analyze-coverage-backquote-form bq-form)) + + ((or 't 'nil (pred keywordp)) + '1value) + + ((pred vectorp) + (testcover-analyze-coverage-compose (append form nil) + #'testcover-analyze-coverage)) + + ((pred symbolp) + nil) + + ((pred atom) + '1value) + + (_ + ;; Whatever we have here, it's not wrapped, so treat it as a list of forms. + (testcover-analyze-coverage-compose form #'testcover-analyze-coverage)))) + +(defun testcover-analyze-coverage-progn (forms) + "Analyze FORMS, which should be a list of forms, for code coverage. +Analyze all the forms in FORMS and return 1value, maybe or nil +depending on the analysis of the last one. Find the coverage +vectors referenced by `edebug-enter' forms nested within FORMS and +update them with the results of the analysis." + (let ((result '1value)) + (while (consp forms) + (setq result (testcover-analyze-coverage (pop forms)))) + result)) + +(defun testcover-analyze-coverage-edebug-after (_form before-form before-id + after-id wrapped-form + &optional wrapper) + "Analyze a _FORM wrapped by `edebug-after' for code coverage. +_FORM should be either: + (edebug-after (edebug-before BEFORE-ID) AFTER-ID WRAPPED-FORM) +or: + (edebug-after 0 AFTER-ID WRAPPED-FORM) + +where BEFORE-FORM is bound to either (edebug-before BEFORE-ID) or +0. WRAPPER may be 1value or noreturn, and if so it forces the +form to be treated accordingly." + (let (val) + (unless (eql before-form 0) + (aset testcover-vector before-id 'edebug-ok-coverage)) + + (setq val (testcover-analyze-coverage-wrapped-form wrapped-form)) + (when (or (eq wrapper '1value) val) + ;; The form is 1-valued or potentially 1-valued. + (aset testcover-vector after-id (or val '1value))) + + (cond + ((or (eq wrapper 'noreturn) + (memq (car-safe wrapped-form) testcover-noreturn-functions)) + ;; This function won't return, so indicate to testcover-before that + ;; it should record coverage. + (aset testcover-vector before-id (cons 'noreturn after-id)) + (aset testcover-vector after-id '1value) + (setq val '1value)) + + ((eq (car-safe wrapped-form) '1value) + ;; This function is always supposed to return the same value. + (setq val '1value) + (aset testcover-vector after-id '1value))) + val)) + +(defun testcover-analyze-coverage-wrapped-form (form) + "Analyze a FORM for code coverage which was wrapped by `edebug-after'. +FORM is treated as if it will be evaluated." + (pcase form + ((pred keywordp) + '1value) + ((pred symbolp) + (when (or (memq form testcover-constants) + (memq form testcover-module-constants)) + '1value)) + ((pred atom) + '1value) + (`(\` ,bq-form) + (testcover-analyze-coverage-backquote-form bq-form)) + (`(defconst ,sym ,val . ,_) + (push sym testcover-module-constants) + (testcover-analyze-coverage val) + '1value) + (`(,(or 'dotimes 'dolist) (,_ ,expr . ,result) . ,body) + ;; These always return RESULT if provided. + (testcover-analyze-coverage expr) + (testcover-analyze-coverage-progn body) + (let ((val (testcover-analyze-coverage-progn result))) + ;; If the third value is not present, the loop always returns nil. + (if result val '1value))) + (`(,(or 'let 'let*) ,bindings . ,body) + (testcover-analyze-coverage-progn bindings) + (testcover-analyze-coverage-progn body)) + (`(if ,test ,then-form . ,else-body) + ;; `if' is potentially 1-valued if both THEN and ELSE clauses are. + (testcover-analyze-coverage test) + (let ((then (testcover-analyze-coverage then-form)) + (else (testcover-analyze-coverage else-body))) + (and then else 'maybe))) + (`(cond . ,clauses) + ;; `cond' is potentially 1-valued if all clauses are. + (when (testcover-analyze-coverage-compose clauses #'testcover-analyze-coverage-progn) + 'maybe)) + (`(condition-case ,_ ,body-form . ,handlers) + ;; `condition-case' is potentially 1-valued if BODY-FORM is and all + ;; HANDLERS are. + (let ((body (testcover-analyze-coverage body-form)) + (errs (testcover-analyze-coverage-compose + (mapcar #'cdr handlers) + #'testcover-analyze-coverage-progn))) + (and body errs 'maybe))) + (`(apply (quote ,(and func (pred symbolp))) . ,args) + ;; Process application of a constant symbol as 1value or noreturn + ;; depending on the symbol. + (let ((temp-form (cons func args))) + (testcover-analyze-coverage-wrapped-form temp-form))) + (`(,(and func (or '1value 'noreturn)) ,inner-form) + ;; 1value and noreturn change how the edebug-after they wrap is handled. + (let ((val (if (eq func '1value) '1value 'maybe))) + (pcase inner-form + (`(edebug-after ,(and before-form + (or `(edebug-before ,before-id) before-id)) + ,after-id ,wrapped-form) + (testcover-analyze-coverage-edebug-after inner-form before-form + before-id after-id + wrapped-form func)) + (_ (testcover-analyze-coverage inner-form))) + val)) + (`(,func . ,args) + (testcover-analyze-coverage-wrapped-application func args)))) + +(defun testcover-analyze-coverage-wrapped-application (func args) + "Analyze the application of FUNC to ARGS for code coverage." + (cond + ((eq func 'quote) '1value) + ((or (memq func testcover-1value-functions) + (memq func testcover-module-1value-functions)) + ;; The function should always return the same value. + (testcover-analyze-coverage-progn args) + '1value) + ((or (memq func testcover-potentially-1value-functions) + (memq func testcover-module-potentially-1value-functions)) + ;; The function might always return the same value. + (testcover-analyze-coverage-progn args) + 'maybe) + ((memq func testcover-progn-functions) + ;; The function is 1-valued if the last argument is. + (testcover-analyze-coverage-progn args)) + ((memq func testcover-prog1-functions) + ;; The function is 1-valued if first argument is. + (testcover-analyze-coverage-progn (cdr args)) + (testcover-analyze-coverage (car args))) + ((memq func testcover-compose-functions) + ;; The function is 1-valued if all arguments are, and potentially + ;; 1-valued if all arguments are either definitely or potentially. + (testcover-analyze-coverage-compose args #'testcover-analyze-coverage)) + (t (testcover-analyze-coverage-progn args) + nil))) + +(defun testcover-coverage-combine (result val) + "Combine RESULT with VAL and return the new result. +If either argument is nil, return nil, otherwise if either +argument is maybe, return maybe. Return 1value only if both arguments +are 1value." + (cl-case val + (1value result) + (maybe (and result 'maybe)) + (nil nil))) + +(defun testcover-analyze-coverage-compose (forms func) + "Analyze a list of FORMS for code coverage using FUNC. +The list is 1valued if all of its constituent elements are also 1valued." + (let ((result '1value)) + (while (consp forms) + (setq result (testcover-coverage-combine result (funcall func (car forms)))) + (setq forms (cdr forms))) + (when forms + (setq result (testcover-coverage-combine result (funcall func forms)))) + result)) + +(defun testcover-analyze-coverage-backquote (bq-list) + "Analyze BQ-LIST, the body of a backquoted list, for code coverage." + (let ((result '1value)) + (while (consp bq-list) + (let ((form (car bq-list)) + val) + (if (memq form (list '\, '\,@)) + ;; Correctly handle `(foo bar . ,(baz). + (progn + (setq val (testcover-analyze-coverage (cdr bq-list))) + (setq bq-list nil)) + (setq val (testcover-analyze-coverage-backquote-form form)) + (setq bq-list (cdr bq-list))) + (setq result (testcover-coverage-combine result val)))) + result)) + +(defun testcover-analyze-coverage-backquote-form (form) + "Analyze a single FORM from a backquoted list for code coverage." + (cond + ((vectorp form) (testcover-analyze-coverage-backquote (append form nil))) + ((atom form) '1value) + ((memq (car form) (list '\, '\,@)) + (testcover-analyze-coverage (cadr form))) + (t (testcover-analyze-coverage-backquote form)))) + ;; testcover.el ends here. diff --git a/lisp/emacs-lisp/text-property-search.el b/lisp/emacs-lisp/text-property-search.el new file mode 100644 index 00000000000..41ca07057e0 --- /dev/null +++ b/lisp/emacs-lisp/text-property-search.el @@ -0,0 +1,206 @@ +;;; text-property-search.el --- search for text properties -*- lexical-binding:t -*- + +;; Copyright (C) 2018-2019 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Keywords: convenience + +;; 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)) + +(cl-defstruct (prop-match) + beginning end value) + +(defun text-property-search-forward (property &optional value predicate + not-immediate) + "Search for the next region that has text property PROPERTY set to VALUE. +If not found, the return value is nil. If found, point will be +placed at the end of the region and an object describing the +match is returned. + +PREDICATE is called with two values. The first is the VALUE +parameter. The second is the value of PROPERTY. This predicate +should return non-nil if there is a match. + +Some convenience values for PREDICATE can also be used. `t' +means the same as `equal'. `nil' means almost the same as \"not +equal\", but will also end the match if the value of PROPERTY +changes. See the manual for extensive examples. + +If `not-immediate', if the match is under point, it will not be +returned, but instead the next instance is returned, if any. + +The return value (if a match is made) is a `prop-match' +structure. The accessors available are +`prop-match-beginning'/`prop-match-end' (the region in the buffer +that's matching), and `prop-match-value' (the value of PROPERTY +at the start of the region)." + (interactive + (list + (let ((string (completing-read "Search for property: " obarray))) + (when (> (length string) 0) + (intern string obarray))))) + (cond + ;; No matches at the end of the buffer. + ((eobp) + nil) + ;; We're standing in the property we're looking for, so find the + ;; end. + ((and (text-property--match-p value (get-text-property (point) property) + predicate) + (not not-immediate)) + (text-property--find-end-forward (point) property value predicate)) + (t + (let ((origin (point)) + (ended nil) + pos) + ;; Fix the next candidate. + (while (not ended) + (setq pos (next-single-property-change (point) property)) + (if (not pos) + (progn + (goto-char origin) + (setq ended t)) + (goto-char pos) + (if (text-property--match-p value (get-text-property (point) property) + predicate) + (setq ended + (text-property--find-end-forward + (point) property value predicate)) + ;; Skip past this section of non-matches. + (setq pos (next-single-property-change (point) property)) + (unless pos + (goto-char origin) + (setq ended t))))) + (and (not (eq ended t)) + ended))))) + +(defun text-property--find-end-forward (start property value predicate) + (let (end) + (if (and value + (null predicate)) + ;; This is the normal case: We're looking for areas where the + ;; values aren't, so we aren't interested in sub-areas where the + ;; property has different values, all non-matching value. + (let ((ended nil)) + (while (not ended) + (setq end (next-single-property-change (point) property)) + (if (not end) + (progn + (goto-char (point-max)) + (setq end (point) + ended t)) + (goto-char end) + (unless (text-property--match-p + value (get-text-property (point) property) predicate) + (setq ended t))))) + ;; End this at the first place the property changes value. + (setq end (next-single-property-change (point) property nil (point-max))) + (goto-char end)) + (make-prop-match :beginning start + :end end + :value (get-text-property start property)))) + + +(defun text-property-search-backward (property &optional value predicate + not-immediate) + "Search for the previous region that has text property PROPERTY set to VALUE. +See `text-property-search-forward' for further documentation." + (interactive + (list + (let ((string (completing-read "Search for property: " obarray))) + (when (> (length string) 0) + (intern string obarray))))) + (cond + ;; We're at the start of the buffer; no previous matches. + ((bobp) + nil) + ;; We're standing in the property we're looking for, so find the + ;; end. + ((and (text-property--match-p + value (get-text-property (1- (point)) property) + predicate) + (not not-immediate)) + (text-property--find-end-backward (1- (point)) property value predicate)) + (t + (let ((origin (point)) + (ended nil) + pos) + (forward-char -1) + ;; Fix the next candidate. + (while (not ended) + (setq pos (previous-single-property-change (point) property)) + (if (not pos) + (progn + (goto-char origin) + (setq ended t)) + (goto-char (1- pos)) + (if (text-property--match-p value (get-text-property (point) property) + predicate) + (setq ended + (text-property--find-end-backward + (point) property value predicate)) + ;; Skip past this section of non-matches. + (setq pos (previous-single-property-change (point) property)) + (unless pos + (goto-char origin) + (setq ended t))))) + (and (not (eq ended t)) + ended))))) + +(defun text-property--find-end-backward (start property value predicate) + (let (end) + (if (and value + (null predicate)) + ;; This is the normal case: We're looking for areas where the + ;; values aren't, so we aren't interested in sub-areas where the + ;; property has different values, all non-matching value. + (let ((ended nil)) + (while (not ended) + (setq end (previous-single-property-change (point) property)) + (if (not end) + (progn + (goto-char (point-min)) + (setq end (point) + ended t)) + (goto-char (1- end)) + (unless (text-property--match-p + value (get-text-property (point) property) predicate) + (goto-char end) + (setq ended t))))) + ;; End this at the first place the property changes value. + (setq end (previous-single-property-change + (point) property nil (point-min))) + (goto-char end)) + (make-prop-match :beginning end + :end (1+ start) + :value (get-text-property end property)))) + +(defun text-property--match-p (value prop-value predicate) + (cond + ((eq predicate t) + (setq predicate #'equal)) + ((eq predicate nil) + (setq predicate (lambda (val p-val) + (not (equal val p-val)))))) + (funcall predicate value prop-value)) + +(provide 'text-property-search) diff --git a/lisp/emacs-lisp/thunk.el b/lisp/emacs-lisp/thunk.el index 7a3b17999ca..8d28570dc2a 100644 --- a/lisp/emacs-lisp/thunk.el +++ b/lisp/emacs-lisp/thunk.el @@ -29,9 +29,9 @@ ;; Thunk provides functions and macros to delay the evaluation of ;; forms. ;; -;; Use `thunk-delay' to delay the evaluation of a form, and -;; `thunk-force' to evaluate it. The result of the evaluation is -;; cached, and only happens once. +;; Use `thunk-delay' to delay the evaluation of a form (requires +;; lexical-binding), and `thunk-force' to evaluate it. The result of +;; the evaluation is cached, and only happens once. ;; ;; Here is an example of a form which evaluation is delayed: ;; @@ -41,22 +41,28 @@ ;; following: ;; ;; (thunk-force delayed) +;; +;; This file also defines macros `thunk-let' and `thunk-let*' that are +;; analogous to `let' and `let*' but provide lazy evaluation of +;; bindings by using thunks implicitly (i.e. in the expansion). ;;; Code: +(require 'cl-lib) + (defmacro thunk-delay (&rest body) "Delay the evaluation of BODY." (declare (debug t)) - (let ((forced (make-symbol "forced")) - (val (make-symbol "val"))) - `(let (,forced ,val) - (lambda (&optional check) - (if check - ,forced - (unless ,forced - (setf ,val (progn ,@body)) - (setf ,forced t)) - ,val))))) + (cl-assert lexical-binding) + `(let (forced + (val (lambda () ,@body))) + (lambda (&optional check) + (if check + forced + (unless forced + (setf val (funcall val)) + (setf forced t)) + val)))) (defun thunk-force (delayed) "Force the evaluation of DELAYED. @@ -68,5 +74,60 @@ with the same DELAYED argument." "Return non-nil if DELAYED has been evaluated." (funcall delayed t)) +(defmacro thunk-let (bindings &rest body) + "Like `let' but create lazy bindings. + +BINDINGS is a list of elements of the form (SYMBOL EXPRESSION). +Any binding EXPRESSION is not evaluated before the variable +SYMBOL is used for the first time when evaluating the BODY. + +It is not allowed to set `thunk-let' or `thunk-let*' bound +variables. + +Using `thunk-let' and `thunk-let*' requires `lexical-binding'." + (declare (indent 1) (debug let)) + (cl-callf2 mapcar + (lambda (binding) + (pcase binding + (`(,(pred symbolp) ,_) binding) + (_ (signal 'error (cons "Bad binding in thunk-let" + (list binding)))))) + bindings) + (cl-callf2 mapcar + (pcase-lambda (`(,var ,binding)) + (list (make-symbol (concat (symbol-name var) "-thunk")) + var binding)) + bindings) + `(let ,(mapcar + (pcase-lambda (`(,thunk-var ,_var ,binding)) + `(,thunk-var (thunk-delay ,binding))) + bindings) + (cl-symbol-macrolet + ,(mapcar (pcase-lambda (`(,thunk-var ,var ,_binding)) + `(,var (thunk-force ,thunk-var))) + bindings) + ,@body))) + +(defmacro thunk-let* (bindings &rest body) + "Like `let*' but create lazy bindings. + +BINDINGS is a list of elements of the form (SYMBOL EXPRESSION). +Any binding EXPRESSION is not evaluated before the variable +SYMBOL is used for the first time when evaluating the BODY. + +It is not allowed to set `thunk-let' or `thunk-let*' bound +variables. + +Using `thunk-let' and `thunk-let*' requires `lexical-binding'." + (declare (indent 1) (debug let)) + (cl-reduce + (lambda (expr binding) `(thunk-let (,binding) ,expr)) + (nreverse bindings) + :initial-value (macroexp-progn body))) + +;; (defalias 'lazy-let #'thunk-let) +;; (defalias 'lazy-let* #'thunk-let*) + + (provide 'thunk) ;;; thunk.el ends here diff --git a/lisp/emacs-lisp/timer-list.el b/lisp/emacs-lisp/timer-list.el index c9b2fae7d91..adfc2250223 100644 --- a/lisp/emacs-lisp/timer-list.el +++ b/lisp/emacs-lisp/timer-list.el @@ -1,4 +1,4 @@ -;;; timer-list.el --- list active timers in a buffer +;;; timer-list.el --- list active timers in a buffer -*- lexical-binding:t -*- ;; Copyright (C) 2016-2019 Free Software Foundation, Inc. @@ -24,6 +24,9 @@ ;;; Code: +(defvar cl-print-compiled) +(defvar cl-print-compiled-button) + ;;;###autoload (defun list-timers (&optional _ignore-auto _nonconfirm) "List all timers in a buffer." @@ -37,16 +40,14 @@ ;; Idle. (if (aref timer 7) "*" " ") ;; Next time. - (let ((time (float-time (list (aref timer 1) - (aref timer 2) - (aref timer 3))))) + (let ((time (list (aref timer 1) + (aref timer 2) + (aref timer 3)))) (format "%.2f" - (if (aref timer 7) - time - (- (float-time (list (aref timer 1) - (aref timer 2) - (aref timer 3))) - (float-time))))) + (float-time + (if (aref timer 7) + time + (time-subtract time nil))))) ;; Repeat. (let ((repeat (aref timer 4))) (cond @@ -58,7 +59,8 @@ (format "%s" repeat)))) ;; Function. (let ((cl-print-compiled 'static) - (cl-print-compiled-button nil)) + (cl-print-compiled-button nil) + (print-escape-newlines t)) (cl-prin1-to-string (aref timer 5))))) (put-text-property (line-beginning-position) (1+ (line-beginning-position)) @@ -87,8 +89,9 @@ (setq-local revert-buffer-function #'list-timers) (setq buffer-read-only t) (setq header-line-format - (format "%4s %10s %8s %s" - "Idle" "Next" "Repeat" "Function"))) + (concat (propertize " " 'display '(space :align-to 0)) + (format "%4s %10s %8s %s" + "Idle" "Next" "Repeat" "Function")))) (defun timer-list-cancel () "Cancel the timer on the line under point." diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 29abc35916e..400f00a85b5 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -57,17 +57,11 @@ (defun timer--time-setter (timer time) (timer--check timer) - (setf (timer--high-seconds timer) (pop time)) - (let ((low time) (usecs 0) (psecs 0)) - (when (consp time) - (setq low (pop time)) - (when time - (setq usecs (pop time)) - (when time - (setq psecs (car time))))) - (setf (timer--low-seconds timer) low) - (setf (timer--usecs timer) usecs) - (setf (timer--psecs timer) psecs) + (let ((lt (encode-time time 'list))) + (setf (timer--high-seconds timer) (nth 0 lt)) + (setf (timer--low-seconds timer) (nth 1 lt)) + (setf (timer--usecs timer) (nth 2 lt)) + (setf (timer--psecs timer) (nth 3 lt)) time)) ;; Pseudo field `time'. @@ -80,7 +74,7 @@ (defun timer-set-time (timer time &optional delta) "Set the trigger time of TIMER to TIME. -TIME must be in the internal format returned by, e.g., `current-time'. +TIME must be a Lisp time value. If optional third argument DELTA is a positive number, make the timer fire repeatedly that many seconds apart." (setf (timer--time timer) time) @@ -94,7 +88,7 @@ SECS may be an integer, floating point number, or the internal time format returned by, e.g., `current-idle-time'. If optional third argument REPEAT is non-nil, make the timer fire each time Emacs is idle for that many seconds." - (setf (timer--time timer) (if (consp secs) secs (seconds-to-time secs))) + (setf (timer--time timer) secs) (setf (timer--repeat-delay timer) repeat) timer) @@ -102,24 +96,20 @@ fire each time Emacs is idle for that many seconds." "Yield the next value after TIME that is an integral multiple of SECS. More precisely, the next value, after TIME, that is an integral multiple of SECS seconds since the epoch. SECS may be a fraction." - (let* ((trillion 1e12) - (time-sec (+ (nth 1 time) - (* 65536.0 (nth 0 time)))) - (delta-sec (mod (- time-sec) secs)) - (next-sec (+ time-sec (ffloor delta-sec))) - (next-sec-psec (ffloor (* trillion (mod delta-sec 1)))) - (sub-time-psec (+ (or (nth 3 time) 0) - (* 1e6 (nth 2 time)))) - (psec-diff (- sub-time-psec next-sec-psec))) - (if (and (<= next-sec time-sec) (< 0 psec-diff)) - (setq next-sec-psec (+ sub-time-psec - (mod (- psec-diff) (* trillion secs))))) - (setq next-sec (+ next-sec (floor next-sec-psec trillion))) - (setq next-sec-psec (mod next-sec-psec trillion)) - (list (floor next-sec 65536) - (floor (mod next-sec 65536)) - (floor next-sec-psec 1000000) - (floor (mod next-sec-psec 1000000))))) + (let* ((ticks-hz (if (and (consp time) (integerp (car time)) + (integerp (cdr time)) (< 0 (cdr time))) + time + (encode-time time 1000000000000))) + (ticks (car ticks-hz)) + (hz (cdr ticks-hz)) + trunc-s-ticks) + (while (let ((s-ticks (* secs hz))) + (setq trunc-s-ticks (truncate s-ticks)) + (/= s-ticks trunc-s-ticks)) + (setq ticks (ash ticks 1)) + (setq hz (ash hz 1))) + (let ((more-ticks (+ ticks trunc-s-ticks))) + (encode-time (cons (- more-ticks (% more-ticks trunc-s-ticks)) hz))))) (defun timer-relative-time (time secs &optional usecs psecs) "Advance TIME by SECS seconds and optionally USECS microseconds @@ -141,20 +131,6 @@ omitted, they are treated as zero." (setf (timer--time timer) (timer-relative-time (timer--time timer) secs usecs psecs))) -(defun timer-set-time-with-usecs (timer time usecs &optional delta) - "Set the trigger time of TIMER to TIME plus USECS. -TIME must be in the internal format returned by, e.g., `current-time'. -The microsecond count from TIME is ignored, and USECS is used instead. -If optional fourth argument DELTA is a positive number, make the timer -fire repeatedly that many seconds apart." - (declare (obsolete "use `timer-set-time' and `timer-inc-time' instead." - "22.1")) - (setf (timer--time timer) time) - (setf (timer--usecs timer) usecs) - (setf (timer--psecs timer) 0) - (setf (timer--repeat-delay timer) (and (numberp delta) (> delta 0) delta)) - timer) - (defun timer-set-function (timer function &optional args) "Make TIMER call FUNCTION with optional ARGS when triggering." (timer--check timer) @@ -273,8 +249,8 @@ how many will really happen." (defun timer-until (timer time) "Calculate number of seconds from when TIMER will run, until TIME. TIMER is a timer, and stands for the time when its next repeat is scheduled. -TIME is a time-list." - (- (float-time time) (float-time (timer--time timer)))) +TIME is a Lisp time value." + (float-time (time-subtract time (timer--time timer)))) (defun timer-event-handler (timer) "Call the handler for the timer TIMER. @@ -305,7 +281,7 @@ This function is called, by name, directly by the C code." ;; perhaps because Emacs was suspended for a long time, ;; limit how many times things get repeated. (if (and (numberp timer-max-repeats) - (< 0 (timer-until timer nil))) + (time-less-p (timer--time timer) nil)) (let ((repeats (/ (timer-until timer nil) (timer--repeat-delay timer)))) (if (> repeats timer-max-repeats) @@ -399,8 +375,11 @@ This function returns a timer object which you can use in (now (decode-time))) (if (>= hhmm 0) (setq time - (encode-time 0 (% hhmm 100) (/ hhmm 100) (nth 3 now) - (nth 4 now) (nth 5 now) (nth 8 now))))))) + (encode-time 0 (% hhmm 100) (/ hhmm 100) + (decoded-time-day now) + (decoded-time-month now) + (decoded-time-year now) + (decoded-time-zone now))))))) (or (consp time) (error "Invalid time format")) diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el index 36d1fe3cfd2..e374cbec55d 100644 --- a/lisp/emacs-lisp/unsafep.el +++ b/lisp/emacs-lisp/unsafep.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2002-2019 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@member.fsf.org> -;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org> ;; Keywords: safety lisp utility ;; This file is part of GNU Emacs. @@ -92,11 +91,6 @@ in the parse.") (put 'unsafep-vars 'risky-local-variable t) -;;Side-effect-free functions from subr.el -(dolist (x '(assoc-default assoc-ignore-case butlast last match-string - match-string-no-properties member-ignore-case remove remq)) - (put x 'side-effect-free t)) - ;;Other safe functions (dolist (x '(;;Special forms and catch if or prog1 prog2 progn while unwind-protect diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 8e5ae6be365..1207353ba30 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -68,6 +68,7 @@ Each element looks like (ALIAS . LEVEL) and defines ALIAS as equivalent to LEVEL. LEVEL must be defined in `warning-levels'; it may not itself be an alias.") +(defvaralias 'display-warning-minimum-level 'warning-minimum-level) (defcustom warning-minimum-level :warning "Minimum severity level for displaying the warning buffer. If a warning's severity level is lower than this, @@ -77,8 +78,8 @@ is not immediately displayed. See also `warning-minimum-log-level'." :type '(choice (const :emergency) (const :error) (const :warning) (const :debug)) :version "22.1") -(defvaralias 'display-warning-minimum-level 'warning-minimum-level) +(defvaralias 'log-warning-minimum-level 'warning-minimum-log-level) (defcustom warning-minimum-log-level :warning "Minimum severity level for logging a warning. If a warning severity level is lower than this, @@ -89,7 +90,6 @@ because warnings not logged aren't displayed either." :type '(choice (const :emergency) (const :error) (const :warning) (const :debug)) :version "22.1") -(defvaralias 'log-warning-minimum-level 'warning-minimum-log-level) (defcustom warning-suppress-log-types nil "List of warning types that should not be logged. @@ -153,6 +153,11 @@ also call that function before the next warning.") (defvar warning-fill-prefix nil "Non-nil means fill each warning text using this string as `fill-prefix'.") +;; I don't see why it can't just use the buffer-local fill-column, +;; but at least this is better than hard-coding 78. +(defvar warning-fill-column 78 + "Value to use for `fill-column' when filling warnings.") + ;; The autoload cookie is so that programs can bind this variable ;; safely, testing the existing value, before they call one of the ;; warnings functions. @@ -222,8 +227,9 @@ has to create the buffer, it disables undo in the buffer. See the `warnings' custom group for user customization features. -See also `warning-series', `warning-prefix-function' and -`warning-fill-prefix' for additional programming features." +See also `warning-series', `warning-prefix-function', +`warning-fill-prefix', and `warning-fill-column' for additional +programming features." (if (not (or after-init-time noninteractive (daemonp))) ;; Ensure warnings that happen early in the startup sequence ;; are visible when startup completes (bug#20792). @@ -241,11 +247,15 @@ See also `warning-series', `warning-prefix-function' and (old (get-buffer buffer-name)) (buffer (or old (get-buffer-create buffer-name))) (level-info (assq level warning-levels)) + ;; `newline' may be unbound during bootstrap. + (newline (if (fboundp 'newline) #'newline + (lambda () (insert "\n")))) start end) (with-current-buffer buffer ;; If we created the buffer, disable undo. (unless old - (special-mode) + (when (fboundp 'special-mode) ; Undefined during bootstrap. + (special-mode)) (setq buffer-read-only t) (setq buffer-undo-list t)) (goto-char (point-max)) @@ -256,7 +266,7 @@ See also `warning-series', `warning-prefix-function' and (funcall warning-series))))) (let ((inhibit-read-only t)) (unless (bolp) - (newline)) + (funcall newline)) (setq start (point)) (if warning-prefix-function (setq level-info (funcall warning-prefix-function @@ -264,10 +274,10 @@ See also `warning-series', `warning-prefix-function' and (insert (format (nth 1 level-info) (format warning-type-format typename)) message) - (newline) + (funcall newline) (when (and warning-fill-prefix (not (string-match "\n" message))) (let ((fill-prefix warning-fill-prefix) - (fill-column 78)) + (fill-column warning-fill-column)) (fill-region start (point)))) (setq end (point))) (when (and (markerp warning-series) diff --git a/lisp/emacs-lock.el b/lisp/emacs-lock.el index 47ab615d976..0cded29193a 100644 --- a/lisp/emacs-lock.el +++ b/lisp/emacs-lock.el @@ -88,6 +88,9 @@ The functions get one argument, the first locked buffer found." :group 'emacs-lock :version "24.3") +(define-obsolete-variable-alias 'emacs-lock-from-exiting + 'emacs-lock-mode "24.1") + (defvar-local emacs-lock-mode nil "If non-nil, the current buffer is locked. It can be one of the following values: @@ -185,16 +188,11 @@ Return a value appropriate for `kill-buffer-query-functions' (which see)." ;; anything else (turn off) mode)))) -(define-obsolete-variable-alias 'emacs-lock-from-exiting - 'emacs-lock-mode "24.1") - ;;;###autoload (define-minor-mode emacs-lock-mode "Toggle Emacs Lock mode in the current buffer. If called with a plain prefix argument, ask for the locking mode -to be used. With any other prefix ARG, turn mode on if ARG is -positive, off otherwise. If called from Lisp, enable the mode if -ARG is omitted or nil. +to be used. Initially, if the user does not pass an explicit locking mode, it defaults to `emacs-lock-default-locking-mode' (which see); diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el index 4dd292fbdb9..46258cbbd81 100644 --- a/lisp/emulation/cua-base.el +++ b/lisp/emulation/cua-base.el @@ -39,7 +39,7 @@ ;; C-v -> paste ;; ;; The tricky part is the handling of the C-x and C-c keys which -;; are normally used as prefix keys for most of emacs' built-in +;; are normally used as prefix keys for most of Emacs' built-in ;; commands. With CUA they still do!!! ;; ;; Only when the region is currently active (and highlighted since @@ -69,7 +69,7 @@ ;; [C-space] to start the region and use unshifted movement keys to extend ;; it. To cancel the region, use [C-space] or [C-g]. -;; If you prefer to use the standard emacs cut, copy, paste, and undo +;; If you prefer to use the standard Emacs cut, copy, paste, and undo ;; bindings, customize cua-enable-cua-keys to nil. @@ -138,7 +138,7 @@ ;; cua-mode's superior rectangle support uses a true visual ;; representation of the selected rectangle, i.e. it highlights the ;; actual part of the buffer that is currently selected as part of the -;; rectangle. Unlike emacs' traditional rectangle commands, the +;; rectangle. Unlike Emacs' traditional rectangle commands, the ;; selected rectangle always as straight left and right edges, even ;; when those are in the middle of a TAB character or beyond the end ;; of the current line. And it does this without actually modifying @@ -427,7 +427,7 @@ and after the region marked by the rectangle to search." (defcustom cua-rectangle-modifier-key 'meta "Modifier key used for rectangle commands bindings. -On non-window systems, always use the meta modifier. +On non-window systems, use `cua-rectangle-terminal-modifier-key'. Must be set prior to enabling CUA." :type '(choice (const :tag "Meta key" meta) (const :tag "Alt key" alt) @@ -435,6 +435,16 @@ Must be set prior to enabling CUA." (const :tag "Super key" super)) :group 'cua) +(defcustom cua-rectangle-terminal-modifier-key 'meta + "Modifier key used for rectangle commands bindings in terminals. +Must be set prior to enabling CUA." + :type '(choice (const :tag "Meta key" meta) + (const :tag "Alt key" alt) + (const :tag "Hyper key" hyper) + (const :tag "Super key" super)) + :group 'cua + :version "27.1") + (defcustom cua-enable-rectangle-auto-help t "If non-nil, automatically show help for region, rectangle and global mark." :type 'boolean @@ -711,7 +721,8 @@ a cons (TYPE . COLOR), then both properties are affected." ;; C-x binding after the first C-x C-x was rewritten to just C-x). (prefix-command-preserve-state) ;; Push the key back on the event queue - (setq unread-command-events (cons key unread-command-events)))) + (setq unread-command-events (cons (cons 'no-record key) + unread-command-events)))) (defun cua--prefix-override-handler () "Start timer waiting for prefix key to be followed by another key. @@ -853,8 +864,6 @@ With numeric prefix arg, copy to register 0-9 instead." (if (fboundp 'cua--cancel-rectangle) (cua--cancel-rectangle))) -(declare-function x-clipboard-yank "../term/x-win" ()) - (put 'cua-paste 'delete-selection 'yank) (defun cua-paste (arg) "Paste last cut or copied region or rectangle. @@ -885,10 +894,8 @@ If global mark is active, copy from register or one character." ((consp regtxt) (cua--insert-rectangle regtxt)) ((stringp regtxt) (insert-for-yank regtxt)) (t (message "Unknown data in register %c" cua--register)))) - ((eq this-original-command 'clipboard-yank) - (clipboard-yank)) - ((eq this-original-command 'x-clipboard-yank) - (x-clipboard-yank)) + ((memq this-original-command '(clipboard-yank x-clipboard-yank)) + (funcall this-original-command)) (t (yank arg))))))) @@ -1052,7 +1059,6 @@ If ARG is the atom `-', scroll downward by nearly full screen." (scroll-up arg) (end-of-buffer (goto-char (point-max))))))) -(put 'cua-scroll-up 'CUA 'move) (put 'cua-scroll-up 'isearch-scroll t) (defun cua-scroll-down (&optional arg) @@ -1073,7 +1079,6 @@ If ARG is the atom `-', scroll upward by nearly full screen." (scroll-down arg) (beginning-of-buffer (goto-char (point-min))))))) -(put 'cua-scroll-down 'CUA 'move) (put 'cua-scroll-down 'isearch-scroll t) ;;; Cursor indications @@ -1243,10 +1248,9 @@ If ARG is the atom `-', scroll upward by nearly full screen." (defun cua--init-keymaps () ;; Cache actual rectangle modifier key. (setq cua--rectangle-modifier-key - (if (and cua-rectangle-modifier-key - (memq window-system '(x))) - cua-rectangle-modifier-key - 'meta)) + (if (eq (framep (selected-frame)) t) + cua-rectangle-terminal-modifier-key + cua-rectangle-modifier-key)) ;; C-return always toggles rectangle mark (define-key cua-global-keymap cua-rectangle-mark-key 'cua-set-rectangle-mark) (unless (eq cua--rectangle-modifier-key 'meta) @@ -1323,9 +1327,6 @@ If ARG is the atom `-', scroll upward by nearly full screen." ;;;###autoload (define-minor-mode cua-mode "Toggle Common User Access style editing (CUA mode). -With a prefix argument ARG, enable CUA mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. 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 diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el index 706634a5017..1a19cc2910e 100644 --- a/lisp/emulation/cua-rect.el +++ b/lisp/emulation/cua-rect.el @@ -1127,7 +1127,7 @@ The length of STRING need not be the same as the rectangle width." (cua--rectangle-operation 'keep nil t 1 nil (lambda (_s e _l _r) (cond - ((re-search-forward "0x\\([0-9a-fA-F]+\\)" e t) + ((re-search-forward "0x\\([[:xdigit:]]+\\)" e t) (let* ((txt (cua--filter-buffer-noprops (match-beginning 1) (match-end 1))) (n (string-to-number txt 16)) (fmt (format "0x%%0%dx" (length txt)))) diff --git a/lisp/emulation/edt-lk201.el b/lisp/emulation/edt-lk201.el index 797de504fd0..9ccb40dfe51 100644 --- a/lisp/emulation/edt-lk201.el +++ b/lisp/emulation/edt-lk201.el @@ -4,7 +4,6 @@ ;; Foundation, Inc. ;; Author: Kevin Gallagher <kevin.gal@verizon.net> -;; Maintainer: Kevin Gallagher <kevin.gal@verizon.net> ;; Keywords: emulations ;; Package: edt diff --git a/lisp/emulation/edt-mapper.el b/lisp/emulation/edt-mapper.el index b8e28f5a759..4aad72caf3c 100644 --- a/lisp/emulation/edt-mapper.el +++ b/lisp/emulation/edt-mapper.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1994-1995, 2000-2019 Free Software Foundation, Inc. ;; Author: Kevin Gallagher <kevin.gal@verizon.net> -;; Maintainer: Kevin Gallagher <kevin.gal@verizon.net> ;; Keywords: emulations ;; Package: edt diff --git a/lisp/emulation/edt-pc.el b/lisp/emulation/edt-pc.el index 3fe33ca13de..484f84eb155 100644 --- a/lisp/emulation/edt-pc.el +++ b/lisp/emulation/edt-pc.el @@ -4,7 +4,6 @@ ;; Inc. ;; Author: Kevin Gallagher <kevin.gal@verizon.net> -;; Maintainer: Kevin Gallagher <kevin.gal@verizon.net> ;; Keywords: emulations ;; Package: edt diff --git a/lisp/emulation/edt-vt100.el b/lisp/emulation/edt-vt100.el index f3d2518a49c..40c74c9d74f 100644 --- a/lisp/emulation/edt-vt100.el +++ b/lisp/emulation/edt-vt100.el @@ -4,7 +4,6 @@ ;; Foundation, Inc. ;; Author: Kevin Gallagher <kevin.gal@verizon.net> -;; Maintainer: Kevin Gallagher <kevin.gal@verizon.net> ;; Keywords: emulations ;; Package: edt diff --git a/lisp/emulation/edt.el b/lisp/emulation/edt.el index d1fe0b81077..dcc327dbd4d 100644 --- a/lisp/emulation/edt.el +++ b/lisp/emulation/edt.el @@ -4,7 +4,6 @@ ;; Inc. ;; Author: Kevin Gallagher <kevin.gal@verizon.net> -;; Maintainer: Kevin Gallagher <kevin.gal@verizon.net> ;; Keywords: emulations ;; This file is part of GNU Emacs. diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el index 39db89bc29f..bdb205ce7c8 100644 --- a/lisp/emulation/viper-cmd.el +++ b/lisp/emulation/viper-cmd.el @@ -45,8 +45,6 @@ (defvar undo-beg-posn) (defvar undo-end-posn) -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest _)))) ;; end pacifier @@ -131,9 +129,6 @@ ;; define viper-vi-command-p (viper-test-com-defun viper-vi-command) -;; Where viper saves mark. This mark is resurrected by m^ -(defvar viper-saved-mark nil) - ;; Contains user settings for vars affected by viper-set-expert-level function. ;; Not a user option. (defvar viper-saved-user-settings nil) @@ -169,7 +164,7 @@ viper-insert-point (>= (point) viper-insert-point)) (setq viper-last-posn-while-in-insert-state (point-marker))) - (or (viper-overlay-p viper-replace-overlay) + (or (overlayp viper-replace-overlay) (progn (viper-set-replace-overlay (point-min) (point-min)) (viper-hide-replace-overlay))) @@ -298,12 +293,6 @@ ;; desirable that viper-pre-command-sentinel is the last hook and ;; viper-post-command-sentinel is the first hook. - (when (featurep 'xemacs) - (make-local-hook 'viper-after-change-functions) - (make-local-hook 'viper-before-change-functions) - (make-local-hook 'viper-post-command-hooks) - (make-local-hook 'viper-pre-command-hooks)) - (remove-hook 'post-command-hook 'viper-post-command-sentinel) (add-hook 'post-command-hook 'viper-post-command-sentinel) (remove-hook 'pre-command-hook 'viper-pre-command-sentinel) @@ -614,7 +603,7 @@ (if (and viper-first-time (not (viper-is-in-minibuffer))) (viper-mode) (if overwrite-mode (overwrite-mode -1)) - (or (viper-overlay-p viper-replace-overlay) + (or (overlayp viper-replace-overlay) (viper-set-replace-overlay (point-min) (point-min))) (viper-hide-replace-overlay) ;; Expand abbrevs iff the previous character has word syntax. @@ -650,7 +639,7 @@ (interactive) (viper-change-state 'insert-state) - (or (viper-overlay-p viper-replace-overlay) + (or (overlayp viper-replace-overlay) (viper-set-replace-overlay (point-min) (point-min))) (viper-hide-replace-overlay) @@ -697,7 +686,7 @@ (defun viper-change-state-to-emacs (&rest _) "Change Viper state to Emacs." (interactive) - (or (viper-overlay-p viper-replace-overlay) + (or (overlayp viper-replace-overlay) (viper-set-replace-overlay (point-min) (point-min))) (viper-hide-replace-overlay) @@ -753,7 +742,7 @@ Vi's prefix argument will be used. Otherwise, the prefix argument passed to (unwind-protect (progn (setq com - (key-binding (setq key (viper-read-key-sequence nil)))) + (key-binding (setq key (read-key-sequence nil)))) ;; In case of binding indirection--chase definitions. ;; Have to do it here because we execute this command under ;; different keymaps, so command-execute may not do the @@ -769,21 +758,14 @@ Vi's prefix argument will be used. Otherwise, the prefix argument passed to ;; this-command, last-command-char, last-command-event (setq this-command com) - (if (featurep 'xemacs) - ;; XEmacs represents key sequences as vectors - (setq last-command-event - (viper-copy-event (viper-seq-last-elt key)) - last-command-char (event-to-character last-command-event)) - ;; Emacs represents them as sequences (str or vec) - (setq last-command-event - (viper-copy-event (viper-seq-last-elt key)))) + ;; Emacs represents key sequences as sequences (str or vec) + (setq last-command-event (viper-seq-last-elt key)) (if (commandp com) ;; pretend that current state is the state we escaped to (let ((viper-current-state state)) (setq prefix-arg (or prefix-arg arg)) - (command-execute com))) - ) + (command-execute com)))) (quit (ding)) (error (beep 1)))) ;; set state in the new buffer @@ -831,30 +813,7 @@ Vi's prefix argument will be used. Otherwise, the prefix argument passed to (insert quail-current-str)) (setq ch (or ch (aref quail-current-str - (1- (length quail-current-str))))) - )) - ((and viper-special-input-method - (featurep 'xemacs) - (fboundp 'quail-start-translation)) - ;; same as above but for XEmacs, which doesn't have - ;; quail-input-method - (let (unread-command-events) - (setq ch (read-char-exclusive)) - ;; replace ^M with the newline - (if (eq ch ?\C-m) (setq ch ?\n)) - ;; Make sure ^V and ^Q work as quotation chars - (if (memq ch '(?\C-v ?\C-q)) - (setq ch (read-char-exclusive))) - (viper-set-unread-command-events ch) - (quail-start-translation nil) - - (if (and ch (string= quail-current-str "")) - (insert ch) - (insert quail-current-str)) - (setq ch (or ch - (aref quail-current-str - (1- (length quail-current-str))))) - )) + (1- (length quail-current-str))))))) ((and (boundp 'iso-accents-mode) iso-accents-mode) (setq ch (aref (read-key-sequence nil) 0)) ;; replace ^M with the newline @@ -864,25 +823,14 @@ Vi's prefix argument will be used. Otherwise, the prefix argument passed to (setq ch (aref (read-key-sequence nil) 0))) (insert ch)) (t - ;;(setq ch (read-char-exclusive)) (setq ch (aref (read-key-sequence nil) 0)) - (if (featurep 'xemacs) - (setq ch (event-to-character ch))) ;; replace ^M with the newline (if (eq ch ?\C-m) (setq ch ?\n)) ;; Make sure ^V and ^Q work as quotation chars (if (memq ch '(?\C-v ?\C-q)) - (progn - ;;(setq ch (read-char-exclusive)) - (setq ch (aref (read-key-sequence nil) 0)) - (if (featurep 'xemacs) - (setq ch (event-to-character ch)))) - ) - (insert ch)) - ) - (setq last-command-event - (viper-copy-event (if (featurep 'xemacs) - (character-to-event ch) ch))) + (setq ch (aref (read-key-sequence nil) 0))) + (insert ch))) + (setq last-command-event ch) ) ; let (error nil) ) ; condition-case @@ -992,7 +940,7 @@ as a Meta key and any number of multiple escapes are allowed." (interactive) (if (and (< viper-expert-level 2) (equal viper-toggle-key "\C-z")) (if (viper-window-display-p) - (viper-iconify) + (iconify-or-deiconify-frame) (suspend-emacs)) (viper-change-state-to-emacs))) @@ -1067,20 +1015,20 @@ as a Meta key and any number of multiple escapes are allowed." (let ((viper-intermediate-command 'viper-digit-argument) value func) ;; read while number - (while (and (viper-characterp event-char) + (while (and (characterp event-char) (>= event-char ?0) (<= event-char ?9)) (setq value (+ (* (if (integerp value) value 0) 10) (- event-char ?0))) - (setq event-char (viper-read-event-convert-to-char))) + (setq event-char (read-event))) (setq prefix-arg value) (if com (setq prefix-arg (cons prefix-arg com))) (while (eq event-char ?U) (viper-describe-arg prefix-arg) - (setq event-char (viper-read-event-convert-to-char))) + (setq event-char (read-event))) (if (or com (and (not (eq viper-current-state 'vi-state)) ;; make sure it is a Vi command - (viper-characterp event-char) + (characterp event-char) (viper-vi-command-p event-char) )) ;; If appears to be one of the vi commands, @@ -1101,10 +1049,7 @@ as a Meta key and any number of multiple escapes are allowed." ((eq event-char 'delete) (setq event-char ?\C-?)) ((eq event-char 'backspace) (setq event-char ?\C-h)) ((eq event-char 'space) (setq event-char ?\ ))) - (setq last-command-event - (if (featurep 'xemacs) - (character-to-event (or com event-char)) - (or com event-char))) + (setq last-command-event (or com event-char)) (setq func (viper-exec-form-in-vi `(key-binding (char-to-string ,event-char)))) (funcall func prefix-arg) @@ -1129,7 +1074,7 @@ as a Meta key and any number of multiple escapes are allowed." ;; it is an error. (progn ;; new com is (CHAR . OLDCOM) - (if (viper-memq-char char '(?# ?\")) (error "Viper bell")) + (if (viper-memq-char 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 @@ -1148,7 +1093,7 @@ as a Meta key and any number of multiple escapes are allowed." (let ((reg (read-char))) (if (viper-valid-register reg) (setq viper-use-register reg) - (error "Viper bell")) + (user-error viper-ViperBell)) (setq char (read-char)))) (t (setq com char) @@ -1170,7 +1115,7 @@ as a Meta key and any number of multiple escapes are allowed." (viper-regsuffix-command-p char) (viper= char ?!) ; bang command (viper= char ?g) ; the gg command (like G0) - (error "Viper bell")) + (user-error viper-ViperBell)) (setq cmd-to-exec-at-end (viper-exec-form-in-vi `(key-binding (char-to-string ,char))))) @@ -1204,13 +1149,11 @@ as a Meta key and any number of multiple escapes are allowed." ((equal com '(?= . ?=)) (viper-line (cons value ?=))) ;; gg acts as G0 ((equal (car com) ?g) (viper-goto-line 0)) - (t (error "Viper bell"))))) + (t (user-error viper-ViperBell))))) (if cmd-to-exec-at-end (progn - (setq last-command-event - (viper-copy-event - (if (featurep 'xemacs) (character-to-event char) char))) + (setq last-command-event char) (condition-case err (funcall cmd-to-exec-at-end cmd-info) (error @@ -1232,7 +1175,6 @@ as a Meta key and any number of multiple escapes are allowed." (defun viper-digit-argument (arg) "Begin numeric argument for the next command." (interactive "P") - (viper-leave-region-active) (viper-prefix-arg-value (viper-last-command-char) (if (consp arg) (cdr arg) nil))) @@ -1253,7 +1195,7 @@ as a Meta key and any number of multiple escapes are allowed." (t (error viper-InvalidCommandArgument)))) (quit (setq viper-use-register nil) (signal 'quit nil))) - (viper-deactivate-mark))) + (deactivate-mark))) ;; repeat last destructive command @@ -1437,7 +1379,7 @@ as a Meta key and any number of multiple escapes are allowed." (if (> lines-saved viper-change-notification-threshold) (unless (viper-is-in-minibuffer) (message "Saved %d lines" lines-saved))))) - (viper-deactivate-mark) + (deactivate-mark) (goto-char viper-com-point)) (defun viper-exec-bang (_m-com com) @@ -1579,7 +1521,7 @@ If the prefix argument ARG is non-nil, it is used instead of `val'." ;; executed by `.' is already on the ring. (if (eq last-command 'viper-display-current-destructive-command) (viper-push-onto-ring viper-d-com 'viper-command-ring)) - (viper-deactivate-mark) + (deactivate-mark) )) (defun viper-repeat-from-history () @@ -1737,18 +1679,9 @@ invokes the command before that, etc." (message " `.' runs `%s'%s" (viper-array-to-string keys) (viper-abbreviate-string - (if (featurep 'xemacs) - (replace-in-string ; xemacs - (cond ((characterp text) (char-to-string text)) - ((stringp text) text) - (t "")) - "\n" "^J") - text ; emacs - ) - max-text-len + text max-text-len (format-message " inserting `") (format-message "'") - " .......")) - )) + " .......")))) ;; don't change viper-d-com if it was viper-repeat command invoked with `.' @@ -2058,15 +1991,10 @@ To turn this feature off, set this variable to nil." (setq cmd (key-binding (setq key (read-key-sequence nil)))) (cond ((eq cmd 'self-insert-command) - (if (featurep 'xemacs) - (insert (events-to-keys key)) ; xemacs - (insert key) ; emacs - )) + (insert key)) ((memq cmd '(exit-minibuffer viper-exit-minibuffer)) nil) - (t (command-execute cmd))) - ))) - )))) + (t (command-execute cmd)))))))))) (defun viper-minibuffer-trim-tail () @@ -2454,7 +2382,7 @@ These keys are ESC, RET, and LineFeed." (if (eq this-command 'viper-intercept-ESC-key) (setq com 'viper-exit-insert-state) (viper-set-unread-command-events last-input-event) - (setq com (key-binding (viper-read-key-sequence nil)))) + (setq com (key-binding (read-key-sequence nil)))) (condition-case conds (command-execute com) @@ -2602,7 +2530,6 @@ These keys are ESC, RET, and LineFeed." "Move point right ARG characters (left if ARG negative). On reaching end of line, stop and signal error." (interactive "P") - (viper-leave-region-active) (let ((val (viper-p-val arg)) (com (viper-getcom arg))) (if com (viper-move-marker-locally 'viper-com-point (point))) @@ -2614,9 +2541,9 @@ On reaching end of line, stop and signal error." ;; the forward motion before the 'viper-execute-com', but, of ;; course, 'dl' doesn't work on an empty line, so we have to ;; catch that condition before 'viper-execute-com' - (if (and (eolp) (bolp)) (error "Viper bell") (forward-char val)) + (if (and (eolp) (bolp)) (user-error viper-ViperBell) (forward-char val)) (if com (viper-execute-com 'viper-forward-char val com)) - (if (eolp) (progn (backward-char 1) (error "Viper bell")))) + (if (eolp) (progn (backward-char 1) (user-error viper-ViperBell)))) (forward-char val) (if com (viper-execute-com 'viper-forward-char val com))))) @@ -2625,13 +2552,12 @@ On reaching end of line, stop and signal error." "Move point left ARG characters (right if ARG negative). On reaching beginning of line, stop and signal error." (interactive "P") - (viper-leave-region-active) (let ((val (viper-p-val arg)) (com (viper-getcom arg))) (if com (viper-move-marker-locally 'viper-com-point (point))) (if viper-ex-style-motion (progn - (if (bolp) (error "Viper bell") (backward-char val)) + (if (bolp) (user-error viper-ViperBell) (backward-char val)) (if com (viper-execute-com 'viper-backward-char val com))) (backward-char val) (if com (viper-execute-com 'viper-backward-char val com))))) @@ -2758,7 +2684,6 @@ On reaching beginning of line, stop and signal error." (defun viper-forward-word (arg) "Forward word." (interactive "P") - (viper-leave-region-active) (let ((val (viper-p-val arg)) (com (viper-getcom arg))) (if com (viper-move-marker-locally 'viper-com-point (point))) @@ -2779,7 +2704,6 @@ On reaching beginning of line, stop and signal error." (defun viper-forward-Word (arg) "Forward word delimited by white characters." (interactive "P") - (viper-leave-region-active) (let ((val (viper-p-val arg)) (com (viper-getcom arg))) (if com (viper-move-marker-locally 'viper-com-point (point))) @@ -2822,7 +2746,6 @@ On reaching beginning of line, stop and signal error." (defun viper-end-of-word (arg &optional _careful) "Move point to end of current word." (interactive "P") - (viper-leave-region-active) (let ((val (viper-p-val arg)) (com (viper-getcom arg))) (if com (viper-move-marker-locally 'viper-com-point (point))) @@ -2835,7 +2758,6 @@ On reaching beginning of line, stop and signal error." (defun viper-end-of-Word (arg) "Forward to end of word delimited by white character." (interactive "P") - (viper-leave-region-active) (let ((val (viper-p-val arg)) (com (viper-getcom arg))) (if com (viper-move-marker-locally 'viper-com-point (point))) @@ -2870,7 +2792,6 @@ On reaching beginning of line, stop and signal error." (defun viper-backward-word (arg) "Backward word." (interactive "P") - (viper-leave-region-active) (let ((val (viper-p-val arg)) (com (viper-getcom arg))) (if com @@ -2885,7 +2806,6 @@ On reaching beginning of line, stop and signal error." (defun viper-backward-Word (arg) "Backward word delimited by white character." (interactive "P") - (viper-leave-region-active) (let ((val (viper-p-val arg)) (com (viper-getcom arg))) (if com @@ -2906,7 +2826,6 @@ On reaching beginning of line, stop and signal error." (defun viper-beginning-of-line (arg) "Go to beginning of line." (interactive "P") - (viper-leave-region-active) (let ((val (viper-p-val arg)) (com (viper-getcom arg))) (if com (viper-move-marker-locally 'viper-com-point (point))) @@ -2916,7 +2835,6 @@ On reaching beginning of line, stop and signal error." (defun viper-bol-and-skip-white (arg) "Beginning of line at first non-white character." (interactive "P") - (viper-leave-region-active) (let ((val (viper-p-val arg)) (com (viper-getcom arg))) (if com (viper-move-marker-locally 'viper-com-point (point))) @@ -2926,7 +2844,6 @@ On reaching beginning of line, stop and signal error." (defun viper-goto-eol (arg) "Go to end of line." (interactive "P") - (viper-leave-region-active) (let ((val (viper-p-val arg)) (com (viper-getcom arg))) (if com (viper-move-marker-locally 'viper-com-point (point))) @@ -2943,7 +2860,6 @@ On reaching beginning of line, stop and signal error." (defun viper-goto-col (arg) "Go to ARG's column." (interactive "P") - (viper-leave-region-active) (let ((val (viper-p-val arg)) (com (viper-getcom arg)) line-len) @@ -2958,14 +2874,13 @@ On reaching beginning of line, stop and signal error." (if com (viper-execute-com 'viper-goto-col val com)) (save-excursion (end-of-line) - (if (> val (current-column)) (error "Viper bell"))) + (if (> val (current-column)) (user-error viper-ViperBell))) )) (defun viper-next-line (arg) "Go to next line." (interactive "P") - (viper-leave-region-active) (let ((val (viper-p-val arg)) (com (viper-getCom arg))) (if com (viper-move-marker-locally 'viper-com-point (point))) @@ -3000,7 +2915,6 @@ If point is on a widget or a button, simulate clicking on that widget/button." (if (and (fboundp 'button-at) (fboundp 'push-button) (button-at (point))) (push-button) ;; not a widget or a button - (viper-leave-region-active) (save-excursion (end-of-line) (if (eobp) (error "Last line in buffer"))) @@ -3015,7 +2929,6 @@ If point is on a widget or a button, simulate clicking on that widget/button." (defun viper-previous-line (arg) "Go to previous line." (interactive "P") - (viper-leave-region-active) (let ((val (viper-p-val arg)) (com (viper-getCom arg))) (if com (viper-move-marker-locally 'viper-com-point (point))) @@ -3033,7 +2946,6 @@ If point is on a widget or a button, simulate clicking on that widget/button." (defun viper-previous-line-at-bol (arg) "Previous line at beginning of line." (interactive "P") - (viper-leave-region-active) (save-excursion (beginning-of-line) (if (bobp) (error "First line in buffer"))) @@ -3068,7 +2980,7 @@ If point is on a widget or a button, simulate clicking on that widget/button." (let ((val (viper-P-val arg)) (com (viper-getCom arg))) (viper-move-marker-locally 'viper-com-point (point)) - (viper-deactivate-mark) + (deactivate-mark) (push-mark nil t) (if (null val) (goto-char (point-max)) @@ -3089,7 +3001,7 @@ If point is on a widget or a button, simulate clicking on that widget/button." ;; If FORWARD then search is forward, otherwise backward. OFFSET is used to ;; adjust point after search. (defun viper-find-char (arg char forward offset) - (or (char-or-string-p char) (error "Viper bell")) + (or (char-or-string-p char) (user-error viper-ViperBell)) (let ((arg (if forward arg (- arg))) (cmd (if (eq viper-intermediate-command 'viper-repeat) (nth 5 viper-d-com) @@ -3251,7 +3163,7 @@ controlled by the sign of prefix numeric value." (interactive "P") (let ((val (viper-p-val arg)) (com (viper-getcom arg))) - (viper-deactivate-mark) + (deactivate-mark) (if com (viper-move-marker-locally 'viper-com-point (point))) (viper-find-char val viper-f-char viper-f-forward viper-f-offset) (if com @@ -3264,7 +3176,7 @@ controlled by the sign of prefix numeric value." (interactive "P") (let ((val (viper-p-val arg)) (com (viper-getcom arg))) - (viper-deactivate-mark) + (deactivate-mark) (if com (viper-move-marker-locally 'viper-com-point (point))) (viper-find-char val viper-f-char (not viper-f-forward) viper-f-offset) (if com @@ -3280,7 +3192,6 @@ controlled by the sign of prefix numeric value." (interactive "P") (let ((val (viper-p-val arg)) (com (viper-getCom arg))) - (viper-leave-region-active) (if com (viper-move-marker-locally 'viper-com-point (point))) (push-mark nil t) (move-to-window-line (1- val)) @@ -3300,7 +3211,6 @@ controlled by the sign of prefix numeric value." (interactive "P") (let ((val (viper-p-val arg)) (com (viper-getCom arg))) - (viper-leave-region-active) (if com (viper-move-marker-locally 'viper-com-point (point))) (push-mark nil t) (move-to-window-line (+ (/ (1- (window-height)) 2) (1- val))) @@ -3320,7 +3230,6 @@ controlled by the sign of prefix numeric value." (interactive "P") (let ((val (viper-p-val arg)) (com (viper-getCom arg))) - (viper-leave-region-active) (if com (viper-move-marker-locally 'viper-com-point (point))) (push-mark nil t) (move-to-window-line (- val)) @@ -3356,9 +3265,7 @@ controlled by the sign of prefix numeric value." ;; (which is called from viper-search-forward/backward/next). If the value of ;; viper-search-scroll-threshold is negative - don't scroll. (defun viper-adjust-window () - (let ((win-height (if (featurep 'xemacs) - (window-displayed-height) - (1- (window-height)))) ; adjust for mode line + (let ((win-height (1- (window-height))) ; adjust for mode line (pt (point)) at-top-p at-bottom-p min-scroll direction) @@ -3388,7 +3295,6 @@ controlled by the sign of prefix numeric value." (defun viper-paren-match (arg) "Go to the matching parenthesis." (interactive "P") - (viper-leave-region-active) (let ((com (viper-getcom arg)) (parse-sexp-ignore-comments viper-parse-sexp-ignore-comments) anchor-point) @@ -3429,7 +3335,7 @@ controlled by the sign of prefix numeric value." (if com (viper-move-marker-locally 'viper-com-point (point))) (backward-sexp 1) (if com (viper-execute-com 'viper-paren-match nil com))) - (t (error "Viper bell")))))) + (t (user-error viper-ViperBell)))))) (defun viper-toggle-parse-sexp-ignore-comments () (interactive) @@ -3676,9 +3582,7 @@ If MODE is set, set the macros only in that major mode." "///" 'vi-state [2 (meta x) v i p e r - t o g g l e - s e a r c h - s t y l e return] scope) - (if (if (featurep 'xemacs) - (interactive-p) - (called-interactively-p 'interactive)) + (if (called-interactively-p 'interactive) (message "// and /// now toggle case-sensitivity and regexp search"))) (viper-unrecord-kbd-macro "//" 'vi-state) @@ -3701,9 +3605,7 @@ With a prefix argument, unsets the macro." "%%%" 'vi-state [(meta x) v i p e r - t o g g l e - p a r s e - s e x p - i g n o r e - c o m m e n t s return] 't) - (if (if (featurep 'xemacs) - (interactive-p) - (called-interactively-p 'interactive)) + (if (called-interactively-p 'interactive) (message "%%%%%% now toggles whether comments should be parsed for matching parentheses"))) (viper-unrecord-kbd-macro "%%%" 'vi-state)))) @@ -3732,9 +3634,7 @@ the macros are set in the current major mode. "///" 'emacs-state [2 (meta x) v i p e r - t o g g l e - s e a r c h - s t y l e return] (or arg-majormode major-mode)) - (if (if (featurep 'xemacs) - (interactive-p) - (called-interactively-p 'interactive)) + (if (called-interactively-p 'interactive) (message "// and /// now toggle case-sensitivity and regexp search."))) (viper-unrecord-kbd-macro "//" 'emacs-state) @@ -3801,7 +3701,7 @@ Null string will repeat previous search." (offset (not no-offset)) (case-fold-search viper-case-fold-search) (start-point (or init-point (point)))) - (viper-deactivate-mark) + (deactivate-mark) (if forward (condition-case nil (progn @@ -3910,7 +3810,7 @@ Null string will repeat previous search." ;; ?g acts as a default value for viper-buffer-search-char (setq viper-buffer-search-char ?g))) (define-key viper-vi-basic-map - (cond ((viper-characterp viper-buffer-search-char) + (cond ((characterp viper-buffer-search-char) (char-to-string viper-buffer-search-char)) (t (error "viper-buffer-search-char: wrong value type, %S" viper-buffer-search-char))) @@ -4006,7 +3906,7 @@ Null string will repeat previous search." (let ((reg viper-use-register)) (setq viper-use-register nil) (error viper-EmptyRegister reg)) - (error "Viper bell"))) + (user-error viper-ViperBell))) (setq viper-use-register nil) (if (viper-end-with-a-newline-p text) (progn @@ -4016,7 +3916,7 @@ Null string will repeat previous search." (forward-line 1)) (beginning-of-line)) (if (not (eolp)) (viper-forward-char-carefully))) - (set-marker (viper-mark-marker) (point) (current-buffer)) + (set-marker (mark-marker) (point) (current-buffer)) (viper-set-destructive-command (list 'viper-put-back val nil viper-use-register nil nil)) (setq sv-point (point)) @@ -4036,7 +3936,7 @@ Null string will repeat previous search." (exchange-point-and-mark) (if (bolp) (back-to-indentation))) - (viper-deactivate-mark)) + (deactivate-mark)) (defun viper-Put-back (arg) "Put back at point/above line." @@ -4056,12 +3956,12 @@ Null string will repeat previous search." (let ((reg viper-use-register)) (setq viper-use-register nil) (error viper-EmptyRegister reg)) - (error "Viper bell"))) + (user-error viper-ViperBell))) (setq viper-use-register nil) (if (viper-end-with-a-newline-p text) (beginning-of-line)) (viper-set-destructive-command (list 'viper-Put-back val nil viper-use-register nil nil)) - (set-marker (viper-mark-marker) (point) (current-buffer)) + (set-marker (mark-marker) (point) (current-buffer)) (setq sv-point (point)) (viper-loop val (viper-yank text)) (setq chars-inserted (abs (- (point) sv-point)) @@ -4079,7 +3979,7 @@ Null string will repeat previous search." (exchange-point-and-mark) (if (bolp) (back-to-indentation))) - (viper-deactivate-mark)) + (deactivate-mark)) ;; Copy region to kill-ring. @@ -4101,7 +4001,7 @@ Null string will repeat previous search." (> val (viper-chars-in-region (point) (viper-line-pos 'end)))) (setq val (viper-chars-in-region (point) (viper-line-pos 'end)))) (if (and viper-ex-style-motion (eolp)) - (if (bolp) (error "Viper bell") (setq val 0))) ; not bol---simply back 1 ch + (if (bolp) (user-error viper-ViperBell) (setq val 0))) ; not bol---simply back 1 ch (save-excursion (viper-forward-char-carefully val) (setq end-del-pos (point))) @@ -4364,14 +4264,14 @@ and regexp replace." (interactive) (let ((char (read-char))) (cond ((and (<= ?a char) (<= char ?z)) - (point-to-register (viper-int-to-char (1+ (- char ?a))))) + (point-to-register (1+ (- char ?a)))) ((viper= char ?<) (viper-mark-beginning-of-buffer)) ((viper= char ?>) (viper-mark-end-of-buffer)) ((viper= char ?.) (viper-set-mark-if-necessary)) ((viper= char ?,) (viper-cycle-through-mark-ring)) ((viper= char ?^) (push-mark viper-saved-mark t t)) ((viper= char ?D) (mark-defun)) - (t (error "Viper bell")) + (t (user-error viper-ViperBell)) ))) ;; Algorithm: If first invocation of this command save mark on ring, goto @@ -4400,15 +4300,15 @@ One can use \\=`\\=` and \\='\\=' to temporarily jump 1 step back." (if (eq last-command 'viper-cycle-through-mark-ring) () ;; save current mark if the first iteration - (setq mark-ring (delete (viper-mark-marker) mark-ring)) + (setq mark-ring (delete (mark-marker) mark-ring)) (if (mark t) (push-mark (mark t) t)) ) (pop-mark) (set-mark-command 1) ;; don't duplicate mark on the ring - (setq mark-ring (delete (viper-mark-marker) mark-ring)) + (setq mark-ring (delete (mark-marker) mark-ring)) (push-mark sv-pt t) - (viper-deactivate-mark) + (deactivate-mark) (setq this-command 'viper-cycle-through-mark-ring) )) @@ -4434,7 +4334,7 @@ One can use \\=`\\=` and \\='\\=' to temporarily jump 1 step back." (backward-char 1))) (cond ((viper-valid-register char '(letter)) (let* ((buff (current-buffer)) - (reg (viper-int-to-char (1+ (- char ?a)))) + (reg (1+ (- char ?a))) (text-marker (get-register reg))) ;; If marker points to file that had markers set (and those markers ;; were saved (as e.g., in session.el), then restore those markers @@ -4470,7 +4370,7 @@ One can use \\=`\\=` and \\='\\=' to temporarily jump 1 step back." (switch-to-buffer buff) (goto-char viper-com-point) (viper-change-state-to-vi) - (error "Viper bell"))))) + (user-error viper-ViperBell))))) ((and (not skip-white) (viper= char ?`)) (if com (viper-move-marker-locally 'viper-com-point (point))) (if (and (viper-same-line (point) viper-last-jump) @@ -4597,7 +4497,7 @@ One can use \\=`\\=` and \\='\\=' to temporarily jump 1 step back." ((viper= ?\] reg) (viper-heading-end arg)) ((viper-valid-register reg '(letter)) - (let* ((val (get-register (viper-int-to-char (1+ (- reg ?a))))) + (let* ((val (get-register (1+ (- reg ?a)))) (buf (if (not (markerp val)) (error viper-EmptyTextmarker reg) (marker-buffer val))) @@ -4834,13 +4734,13 @@ Please, specify your level now: ")) (if (and enforce-buffer (not (equal (current-buffer) (marker-buffer val)))) (error (concat viper-EmptyTextmarker " in this buffer") - (viper-int-to-char (1- (+ char ?a))))) + (1- (+ char ?a)))) (pop-to-buffer (marker-buffer val)) (goto-char val)) ((and (consp val) (eq (car val) 'file)) (find-file (cdr val))) (t - (error viper-EmptyTextmarker (viper-int-to-char (1- (+ char ?a)))))))) + (error viper-EmptyTextmarker (1- (+ char ?a))))))) (defun viper-save-kill-buffer () @@ -4874,14 +4774,14 @@ Please, specify your level now: ")) (viper-frame-parameters (if (fboundp 'frame-parameters) (frame-parameters (selected-frame)))) (viper-minibuffer-emacs-face (if (viper-has-face-support-p) - (viper-get-face + (facep viper-minibuffer-emacs-face) 'non-x)) (viper-minibuffer-vi-face (if (viper-has-face-support-p) - (viper-get-face viper-minibuffer-vi-face) + (facep viper-minibuffer-vi-face) 'non-x)) (viper-minibuffer-insert-face (if (viper-has-face-support-p) - (viper-get-face + (facep viper-minibuffer-insert-face) 'non-x)) varlist salutation window-config) diff --git a/lisp/emulation/viper-ex.el b/lisp/emulation/viper-ex.el index 02a912eeb59..26bca686cb3 100644 --- a/lisp/emulation/viper-ex.el +++ b/lisp/emulation/viper-ex.el @@ -427,18 +427,18 @@ reversed." (forward-char 1) (setq ex-token-type 'whole)) ((= char ?+) - (cond ((or (looking-at "+[-+]") (looking-at "+[\n|]")) + (cond ((looking-at "\\+[-+\n|]") (forward-char 1) (insert "1") (backward-char 1) (setq ex-token-type 'plus)) - ((looking-at "+[0-9]") + ((looking-at "\\+[0-9]") (forward-char 1) (setq ex-token-type 'plus)) (t (error viper-BadAddress)))) ((= char ?-) - (cond ((or (looking-at "-[-+]") (looking-at "-[\n|]")) + (cond ((looking-at "-[-+\n|]") (forward-char 1) (insert "1") (backward-char 1) @@ -455,7 +455,7 @@ reversed." (while (and (not (eolp)) cont) ;;(re-search-forward "[^/]*/") (re-search-forward "[^/]*\\(/\\|\n\\)") - (if (not (looking-back "[^\\\\]\\(\\\\\\\\\\)*\\\\/" + (if (not (looking-back "[^\\]\\(\\\\\\\\\\)*\\\\/" (line-beginning-position 0))) (setq cont nil)))) (backward-char 1) @@ -469,7 +469,7 @@ reversed." (while (and (not (eolp)) cont) ;;(re-search-forward "[^\\?]*\\?") (re-search-forward "[^\\?]*\\(\\?\\|\n\\)") - (if (not (looking-back "[^\\\\]\\(\\\\\\\\\\)*\\\\\\?" + (if (not (looking-back "[^\\]\\(\\\\\\\\\\)*\\\\\\?" (line-beginning-position 0))) (setq cont nil)) (backward-char 1) @@ -548,9 +548,13 @@ reversed." (setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) (set-buffer viper-ex-work-buf) (goto-char (point-max))) - (cond ((looking-back quit-regex1) (exit-minibuffer)) - ((looking-back stay-regex) (insert " ")) - ((looking-back quit-regex2) (exit-minibuffer)) + (cond ((looking-back quit-regex1 (line-beginning-position)) + (exit-minibuffer)) + ;; Almost certainly point-min should be line-beginning-position, + ;; but probably the two are identical anyway, and who really cares? + ((looking-back stay-regex (point-min)) (insert " ")) + ((looking-back quit-regex2 (line-beginning-position)) + (exit-minibuffer)) (t (insert " "))))) (declare-function viper-tmp-insert-at-eob "viper-cmd" (msg)) @@ -561,7 +565,7 @@ reversed." (let (save-pos dist compl-list string-to-complete completion-result) (save-excursion - (setq dist (skip-chars-backward "[a-zA-Z!=>&~]") + (setq dist (skip-chars-backward "a-zA-Z!=>&~") save-pos (point))) (if (or (= dist 0) @@ -674,7 +678,7 @@ reversed." (viper-get-ex-token) (cond ((memq ex-token-type '(command end-mark)) (if address (setq ex-addresses (cons address ex-addresses))) - (viper-deactivate-mark) + (deactivate-mark) (let ((cmd (ex-cmd-assoc ex-token ex-token-alist))) (if (null cmd) (error "`%s': %s" ex-token viper-BadExCommand)) @@ -740,7 +744,7 @@ reversed." (error "Global regexp must be inside matching non-alphanumeric chars")) ((= c ??) (error "`?' is not an allowed pattern delimiter here"))) - (if (looking-at "[^\\\\\n]") + (if (looking-at "[^\\\n]") (progn (forward-char 1) (set-mark (point)) @@ -753,7 +757,7 @@ reversed." (error "Missing closing delimiter for global regexp") (goto-char (point-max)))) (if (not (looking-back - (format "[^\\\\]\\(\\\\\\\\\\)*\\\\%c" c) + (format "[^\\]\\(\\\\\\\\\\)*\\\\%c" c) (line-beginning-position 0))) (setq cont nil) ;; we are at an escaped delimiter: unescape it and continue @@ -877,8 +881,7 @@ reversed." (if (null ex-token) (exchange-point-and-mark) (goto-char - (viper-register-to-point - (viper-int-to-char (1+ (- ex-token ?a))) 'enforce-buffer))) + (viper-register-to-point (1+ (- ex-token ?a)) 'enforce-buffer))) (setq address (point-marker))))) address)) @@ -1081,7 +1084,7 @@ reversed." (defun viper-handle-! () (interactive) (if (and (string= - (buffer-string) (viper-abbreviate-file-name default-directory)) + (buffer-string) (abbreviate-file-name default-directory)) (member ex-token '("read" "write"))) (erase-buffer)) (insert "!")) @@ -1170,7 +1173,7 @@ reversed." (princ "\n=============\n") (princ "\nThe numbers can be given as counts to :next. ") (princ "\n\nPress any key to continue...\n\n")) - (viper-read-event)))))) + (read-event)))))) ;; Ex cd command. Default directory of this buffer changes (defun ex-cd () @@ -1236,7 +1239,7 @@ reversed." (read-string "[Hit return to confirm] ") (quit (save-excursion (kill-buffer " *delete text*")) - (error "Viper bell"))) + (user-error viper-ViperBell))) (save-excursion (kill-buffer " *delete text*"))) (if ex-buffer (cond ((viper-valid-register ex-buffer '(Letter)) @@ -1259,7 +1262,7 @@ reversed." (if (not file) (viper-get-ex-file)) (cond ((and (string= ex-file "") buffer-file-name) - (setq ex-file (viper-abbreviate-file-name (buffer-file-name)))) + (setq ex-file (abbreviate-file-name (buffer-file-name)))) ((string= ex-file "") (error viper-NoFileSpecified))) @@ -1476,7 +1479,7 @@ reversed." (error "`%s' requires a following letter" ex-token)))) (save-excursion (goto-char (car ex-addresses)) - (point-to-register (viper-int-to-char (1+ (- char ?a))))))) + (point-to-register (1+ (- char ?a)))))) @@ -1543,7 +1546,7 @@ reversed." (if (not (viper-buffer-live-p buf)) (error "Didn't find buffer %S or file %S" file-or-buffer-name - (viper-abbreviate-file-name + (abbreviate-file-name (expand-file-name file-or-buffer-name)))) (if (equal buf (current-buffer)) @@ -1558,7 +1561,7 @@ reversed." ;; setup buffer (if (setq wind (viper-get-visible-buffer-window buf)) () - (setq wind (get-lru-window (if (featurep 'xemacs) nil 'visible))) + (setq wind (get-lru-window 'visible)) (set-window-buffer wind buf)) (if (viper-window-display-p) @@ -1682,7 +1685,7 @@ reversed." (message ":set <Variable> [= <Value>]") (or batch (sit-for 2)) - (while (string-match "^[ \\t\\n]*$" + (while (string-match "^[ \t\n]*$" (setq str (completing-read ":set " ex-variable-alist))) (message ":set <Variable> [= <Value>]") @@ -1880,17 +1883,15 @@ reversed." (condition-case nil (progn (pop-to-buffer (get-buffer-create "*info*")) - (info (if (featurep 'xemacs) "viper.info" "viper")) + (info "viper") (message "Type `i' to search for a specific topic")) (error (beep 1) (with-output-to-temp-buffer " *viper-info*" (princ (format " The Info file for Viper does not seem to be installed. -This file is part of the standard distribution of %sEmacs. -Please contact your system administrator. " - (if (featurep 'xemacs) "X" "") - )))))) +This file is part of the standard distribution of Emacs. +Please contact your system administrator. ")))))) ;; Ex source command. ;; Loads the file specified as argument or viper-custom-file-name. @@ -2012,8 +2013,10 @@ Please contact your system administrator. " (condition-case conds (progn (if (string= tag "") - (find-tag ex-tag t) - (find-tag-other-window ex-tag)) + ;; If we have an *xref* window, `next-error' will take + ;; us to the next definition. + (next-error) + (xref-find-definitions-other-window ex-tag)) (viper-change-state-to-vi)) (error (viper-change-state-to-vi) @@ -2085,9 +2088,7 @@ Please contact your system administrator. " ;; create temp buffer for the region (setq temp-buf (get-buffer-create " *ex-write*")) (set-buffer temp-buf) - (if (featurep 'xemacs) - (set-visited-file-name ex-file) - (set-visited-file-name ex-file 'noquery)) + (set-visited-file-name ex-file 'noquery) (erase-buffer) (if (and file-exists ex-append) (insert-file-contents ex-file)) @@ -2126,7 +2127,7 @@ Please contact your system administrator. " (defun ex-write-info (exists file-name beg end) (message "`%s'%s %d lines, %d characters" - (viper-abbreviate-file-name file-name) + (abbreviate-file-name file-name) (if exists "" " [New file]") (count-lines beg (min (1+ end) (point-max))) (- end beg))) @@ -2222,9 +2223,9 @@ Type `mak ' (including the space) to run make with no args." lines file info) (setq lines (count-lines (point-min) (viper-line-pos 'end)) file (cond ((buffer-file-name) - (concat (viper-abbreviate-file-name (buffer-file-name)) ":")) + (concat (abbreviate-file-name (buffer-file-name)) ":")) ((buffer-file-name (buffer-base-buffer)) - (concat (viper-abbreviate-file-name (buffer-file-name (buffer-base-buffer))) " (indirect buffer):")) + (concat (abbreviate-file-name (buffer-file-name (buffer-base-buffer))) " (indirect buffer):")) (t (concat (buffer-name) " [Not visiting any file]:"))) info (format "line=%d/%d pos=%d/%d col=%d %s" (if (= pos1 pos2) @@ -2241,7 +2242,7 @@ Type `mak ' (including the space) to run make with no args." (with-output-to-temp-buffer " *viper-info*" (princ (concat "\n" file "\n\n\t" info "\n\n"))) (let ((inhibit-quit t)) - (viper-set-unread-command-events (viper-read-event))) + (viper-set-unread-command-events (read-event))) (kill-buffer " *viper-info*"))) )) diff --git a/lisp/emulation/viper-init.el b/lisp/emulation/viper-init.el index 0ad9a7a373c..5a80804e757 100644 --- a/lisp/emulation/viper-init.el +++ b/lisp/emulation/viper-init.el @@ -268,6 +268,7 @@ that deletes a file.") (defconst viper-BadAddress "Ill-formed address" "") (defconst viper-FirstAddrExceedsSecond "First address exceeds second" "") (defconst viper-NoFileSpecified "No file specified" "") +(defconst viper-ViperBell "Viper bell" "") ;; Is t until viper-mode executes for the very first time. ;; Prevents recursive descend into startup messages. diff --git a/lisp/emulation/viper-keym.el b/lisp/emulation/viper-keym.el index c0b7a5b5c9c..a7de64652fb 100644 --- a/lisp/emulation/viper-keym.el +++ b/lisp/emulation/viper-keym.el @@ -1,4 +1,4 @@ -;;; viper-keym.el --- Viper keymaps +;;; viper-keym.el --- Viper keymaps -*- lexical-binding:t -*- ;; Copyright (C) 1994-1997, 2000-2019 Free Software Foundation, Inc. @@ -32,8 +32,6 @@ (defvar viper-ex-style-editing) (defvar viper-ex-style-motion) -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) ;; end pacifier (require 'viper-util) @@ -84,10 +82,6 @@ major mode in effect." (defvar viper-insert-intercept-map (make-sparse-keymap)) (defvar viper-emacs-intercept-map (make-sparse-keymap)) -;; keymap used to zap all keymaps other than function-key-map, -;; device-function-key-map, etc. -(defvar viper-overriding-map (make-sparse-keymap)) - (viper-deflocalvar viper-vi-local-user-map (make-sparse-keymap) "Keymap for user-defined local bindings. Useful for changing bindings such as ZZ in certain major modes. @@ -648,12 +642,8 @@ Arguments: (major-mode viper-state keymap)" (defun viper-add-keymap (mapsrc mapdst) "Add contents of mapsrc to mapdst. It is assumed that mapsrc is sparse." - (if (featurep 'xemacs) - ;; Emacs 22 has map-keymap. - (map-keymap (lambda (key binding) (define-key mapdst key binding)) - mapsrc) - (mapc (lambda (p) (define-key mapdst (vector (car p)) (cdr p))) - (cdr mapsrc)))) + (mapc (lambda (p) (define-key mapdst (vector (car p)) (cdr p))) + (cdr mapsrc))) (defun viper-modify-keymap (map alist) "Modifies MAP with bindings specified in the ALIST. The alist has the diff --git a/lisp/emulation/viper-macs.el b/lisp/emulation/viper-macs.el index 90d33d5fa7b..3dd6a012ab3 100644 --- a/lisp/emulation/viper-macs.el +++ b/lisp/emulation/viper-macs.el @@ -1,4 +1,4 @@ -;;; viper-macs.el --- functions implementing keyboard macros for Viper +;;; viper-macs.el --- functions implementing keyboard macros for Viper -*- lexical-binding:t -*- ;; Copyright (C) 1994-1997, 2000-2019 Free Software Foundation, Inc. @@ -174,7 +174,7 @@ a key is a symbol, e.g., `a', `\\1', `f2', etc., or a list, e.g., (prin1-to-string (viper-display-macro key-seq)) ""))) (message "%s" message) - (setq event (viper-read-key)) + (setq event (read-key)) ;;(setq event (viper-read-event)) (setq key (if (viper-mouse-event-p event) @@ -251,7 +251,7 @@ a key is a symbol, e.g., `a', `\\1', `f2', etc., or a list, e.g., (viper-display-macro key-seq)) ""))) (message "%s" message) - (setq event (viper-read-key)) + (setq event (read-key)) ;;(setq event (viper-read-event)) (setq key (if (viper-mouse-event-p event) @@ -415,7 +415,7 @@ If SCOPE is nil, the user is asked to specify the scope." t))) (if (y-or-n-p (format "Save this macro in %s? " - (viper-abbreviate-file-name viper-custom-file-name))) + (abbreviate-file-name viper-custom-file-name))) (viper-save-string-in-file (format "\n(viper-record-kbd-macro %S '%S %s '%S)" (viper-display-macro macro-name) @@ -815,12 +815,7 @@ mistakes in macro names to be passed to this function is to use ;; convert strings or arrays of characters to Viper macro form (defun viper-char-array-to-macro (array) - (let ((vec (vconcat array)) - macro) - (if (featurep 'xemacs) - (setq macro (mapcar 'character-to-event vec)) - (setq macro vec)) - (vconcat (mapcar 'viper-event-key macro)))) + (vconcat (mapcar 'viper-event-key (vconcat array)))) ;; For macros bodies and names, goes over MACRO and checks if all members are ;; names of keys (actually, it only checks if they are symbols or lists @@ -867,16 +862,19 @@ mistakes in macro names to be passed to this function is to use ;; A fast keysequence is one that is terminated by a pause longer than ;; viper-fast-keyseq-timeout. (defun viper-read-fast-keysequence (event macro-alist) + ;; FIXME: Do we still need this? Now that the discrimination between the ESC + ;; key and the ESC byte sent as part of terminal escape sequences is performed + ;; in the input-decode-map, I suspect that we don't need this hack any more. (let ((lis (vector event)) next-event) (while (and (viper-fast-keysequence-p) (viper-keyseq-is-a-possible-macro lis macro-alist)) ;; Seems that viper-read-event is more robust here. We need to be able to ;; place these events on unread-command-events list. If we use - ;; viper-read-key then events will be converted to keys, and sometimes + ;; read-key then events will be converted to keys, and sometimes ;; (e.g., (control \[)) those keys differ from the corresponding events. - ;; So, do not use (setq next-event (viper-read-key)) - (setq next-event (viper-read-event)) + ;; So, do not use (setq next-event (read-key)) + (setq next-event (read-event)) (or (viper-mouse-event-p next-event) (setq lis (vconcat lis (vector next-event))))) lis)) diff --git a/lisp/emulation/viper-mous.el b/lisp/emulation/viper-mous.el index e49fc875418..e1f7c1643bd 100644 --- a/lisp/emulation/viper-mous.el +++ b/lisp/emulation/viper-mous.el @@ -280,7 +280,7 @@ See `viper-surrounding-word' for the definition of a word in this case." ;; the next pending event is not a mouse event, we execute the ;; current mouse event (progn - (setq interrupting-event (viper-read-event)) + (setq interrupting-event (read-event)) (viper-mouse-event-p last-input-event))) (progn ; interrupted wait (setq viper-global-prefix-argument arg) @@ -362,7 +362,7 @@ this command." ;; pending event is not a mouse event, we execute the current mouse ;; event (progn - (viper-read-event) + (read-event) (viper-mouse-event-p last-input-event))) (progn ; interrupted wait (setq viper-global-prefix-argument (or viper-global-prefix-argument @@ -380,7 +380,7 @@ this command." viper-global-prefix-argument nil)) (setq arg (or arg 1)) - (viper-deactivate-mark) + (deactivate-mark) (if (or (not (string= click-word viper-s-string)) (not (markerp viper-search-start-marker)) (not (equal (marker-buffer viper-search-start-marker) diff --git a/lisp/emulation/viper-util.el b/lisp/emulation/viper-util.el index 04edc90c88a..1d7bb1580ce 100644 --- a/lisp/emulation/viper-util.el +++ b/lisp/emulation/viper-util.el @@ -1,4 +1,4 @@ -;;; viper-util.el --- Utilities used by viper.el +;;; viper-util.el --- Utilities used by viper.el -*- lexical-binding:t -*- ;; Copyright (C) 1994-1997, 1999-2019 Free Software Foundation, Inc. @@ -28,7 +28,6 @@ ;; Compiler pacifier -(defvar viper-overriding-map) (defvar viper-minibuffer-current-face) (defvar viper-minibuffer-insert-face) (defvar viper-minibuffer-vi-face) @@ -39,47 +38,31 @@ (defvar ex-unix-type-shell-options) (defvar viper-ex-tmp-buf-name) (defvar viper-syntax-preference) -(defvar viper-saved-mark) (require 'ring) -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - ;; end pacifier (require 'viper-init) -(defalias 'viper-overlay-p - (if (featurep 'xemacs) 'extentp 'overlayp)) -(defalias 'viper-make-overlay - (if (featurep 'xemacs) 'make-extent 'make-overlay)) -(defalias 'viper-overlay-live-p - (if (featurep 'xemacs) 'extent-live-p 'overlayp)) -(defalias 'viper-move-overlay - (if (featurep 'xemacs) 'set-extent-endpoints 'move-overlay)) -(defalias 'viper-overlay-start - (if (featurep 'xemacs) 'extent-start-position 'overlay-start)) -(defalias 'viper-overlay-end - (if (featurep 'xemacs) 'extent-end-position 'overlay-end)) -(defalias 'viper-overlay-get - (if (featurep 'xemacs) 'extent-property 'overlay-get)) -(defalias 'viper-overlay-put - (if (featurep 'xemacs) 'set-extent-property 'overlay-put)) -(defalias 'viper-read-event - (if (featurep 'xemacs) 'next-command-event 'read-event)) -(defalias 'viper-characterp - (if (featurep 'xemacs) 'characterp 'integerp)) -(defalias 'viper-int-to-char - (if (featurep 'xemacs) 'int-to-char 'identity)) -(defalias 'viper-get-face - (if (featurep 'xemacs) 'get-face 'facep)) -(defalias 'viper-color-defined-p - (if (featurep 'xemacs) 'valid-color-name-p 'x-color-defined-p)) -(defalias 'viper-iconify - (if (featurep 'xemacs) 'iconify-frame 'iconify-or-deiconify-frame)) +(define-obsolete-function-alias 'viper-overlay-p 'overlayp "27.1") +(define-obsolete-function-alias 'viper-make-overlay 'make-overlay "27.1") +(define-obsolete-function-alias 'viper-overlay-live-p 'overlayp "27.1") +(define-obsolete-function-alias 'viper-move-overlay 'move-overlay "27.1") +(define-obsolete-function-alias 'viper-overlay-start 'overlay-start "27.1") +(define-obsolete-function-alias 'viper-overlay-end 'overlay-end "27.1") +(define-obsolete-function-alias 'viper-overlay-get 'overlay-get "27.1") +(define-obsolete-function-alias 'viper-overlay-put 'overlay-put "27.1") +(define-obsolete-function-alias 'viper-read-event 'read-event "27.1") +(define-obsolete-function-alias 'viper-characterp 'integerp "27.1") +(define-obsolete-function-alias 'viper-int-to-char 'identity "27.1") +(define-obsolete-function-alias 'viper-get-face 'facep "27.1") +(define-obsolete-function-alias 'viper-color-defined-p + 'x-color-defined-p "27.1") +(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) @@ -89,60 +72,50 @@ ;; chars. (defun viper-memq-char (char list) (cond ((and (integerp char) (>= char 0)) - (memq (viper-int-to-char char) list)) + (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)) - (= (viper-int-to-char char-or-int) char)) + (= char-or-int char)) ((eq char-or-int char)))) ;; Like =, but accommodates null and also is t for eq-objects (defun viper= (char char1) (cond ((eq char char1) t) - ((and (viper-characterp char) (viper-characterp char1)) + ((and (characterp char) (characterp char1)) (= char char1)) (t nil))) (defsubst viper-color-display-p () - (if (featurep 'xemacs) (eq (device-class (selected-device)) 'color) - (x-display-color-p))) + (x-display-color-p)) -(defun viper-get-cursor-color (&optional frame) - (if (featurep 'xemacs) - (color-instance-name - (frame-property (or frame (selected-frame)) 'cursor-color)) - (cdr (assoc 'cursor-color (frame-parameters))))) +(defun viper-get-cursor-color (&optional _frame) + (cdr (assoc 'cursor-color (frame-parameters)))) (defmacro viper-frame-value (variable) "Return the value of VARIABLE local to the current frame, if there is one. Otherwise return the normal value." - `(if (featurep 'xemacs) + ;; 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 - ;; 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 - ;; with a value of nil. - (let ((fp (assoc ',variable (frame-parameters)))) - (if fp (cdr fp) - ,variable))))) + ;; Distinguish between no frame parameter and a frame parameter + ;; with a value of nil. + (let ((fp (assoc ',variable (frame-parameters)))) + (if fp (cdr fp) + ,variable)))) ;; cursor colors (defun viper-change-cursor-color (new-color &optional frame) - (if (and (viper-window-display-p) (viper-color-display-p) - (stringp new-color) (viper-color-defined-p new-color) + (if (and (viper-window-display-p) (viper-color-display-p) + (stringp new-color) (x-color-defined-p new-color) (not (string= new-color (viper-get-cursor-color)))) - (if (featurep 'xemacs) - (set-frame-property - (or frame (selected-frame)) - 'cursor-color (make-color-instance new-color)) - (modify-frame-parameters - (or frame (selected-frame)) - (list (cons 'cursor-color new-color)))))) + (modify-frame-parameters + (or frame (selected-frame)) + (list (cons 'cursor-color new-color))))) ;; Note that the colors this function uses might not be those ;; associated with FRAME, if there are frame-local values. @@ -171,7 +144,7 @@ Otherwise return the normal value." (defun viper-save-cursor-color (before-which-mode) (if (and (viper-window-display-p) (viper-color-display-p)) (let ((color (viper-get-cursor-color))) - (if (and (stringp color) (viper-color-defined-p color) + (if (and (stringp color) (x-color-defined-p color) ;; there is something fishy in that the color is not saved if ;; it is the same as frames default cursor color. need to be ;; checked. @@ -221,7 +194,7 @@ Otherwise return the normal value." ;; restore cursor color from replace overlay (defun viper-restore-cursor-color(after-which-mode) - (if (viper-overlay-p viper-replace-overlay) + (if (overlayp viper-replace-overlay) (viper-change-cursor-color (cond ((eq after-which-mode 'after-replace-mode) (viper-get-saved-cursor-color-in-replace-mode)) @@ -260,10 +233,7 @@ Otherwise return the normal value." (defun viper-get-visible-buffer-window (wind) - (if (featurep 'xemacs) - (get-buffer-window wind t) - (get-buffer-window wind 'visible))) - + (get-buffer-window wind 'visible)) ;; Return line position. ;; If pos is 'start then returns position of line start. @@ -635,15 +605,15 @@ Otherwise return the normal value." ;;; Saving settings in custom file -;; Save the current setting of VAR in CUSTOM-FILE. +;; Save the current setting of VAR in FILE. ;; If given, MESSAGE is a message to be displayed after that. ;; This message is erased after 2 secs, if erase-msg is non-nil. -;; Arguments: var message custom-file &optional erase-message -(defun viper-save-setting (var message custom-file &optional erase-msg) +;; Arguments: var message file &optional erase-message +(defun viper-save-setting (var message file &optional erase-msg) (let* ((var-name (symbol-name var)) (var-val (if (boundp var) (eval var))) (regexp (format "^[^;]*%s[ \t\n]*[a-zA-Z---_']*[ \t\n)]" var-name)) - (buf (find-file-noselect (substitute-in-file-name custom-file))) + (buf (find-file-noselect (substitute-in-file-name file))) ) (message "%s" (or message "")) (with-current-buffer buf @@ -665,12 +635,12 @@ Otherwise return the normal value." (message ""))) )) -;; Save STRING in CUSTOM-FILE. If PATTERN is non-nil, remove strings that +;; Save STRING in FILE. If PATTERN is non-nil, remove strings that ;; match this pattern. -(defun viper-save-string-in-file (string custom-file &optional pattern) - (let ((buf (find-file-noselect (substitute-in-file-name custom-file)))) +(defun viper-save-string-in-file (string file &optional pattern) + (let ((buf (find-file-noselect (substitute-in-file-name file)))) (with-current-buffer buf - (let (buffer-read-only) + (let ((inhibit-read-only t)) (goto-char (point-min)) (if pattern (delete-matching-lines pattern)) (goto-char (point-max)) @@ -713,9 +683,7 @@ Otherwise return the normal value." (if (fboundp 'vc-state) (and (not (memq (vc-state file) '(edited needs-merge))) - (not (stringp (vc-state file)))) - ;; XEmacs has no vc-state - (if (featurep 'xemacs) (not (vc-locking-user file)))))) + (not (stringp (vc-state file))))))) ;; checkout if visited file is checked in (defun viper-maybe-checkout (buf) @@ -735,12 +703,12 @@ Otherwise return the normal value." ;;; Overlays (defun viper-put-on-search-overlay (beg end) - (if (viper-overlay-p viper-search-overlay) - (viper-move-overlay viper-search-overlay beg end) - (setq viper-search-overlay (viper-make-overlay beg end (current-buffer))) - (viper-overlay-put + (if (overlayp viper-search-overlay) + (move-overlay viper-search-overlay beg end) + (setq viper-search-overlay (make-overlay beg end (current-buffer))) + (overlay-put viper-search-overlay 'priority viper-search-overlay-priority)) - (viper-overlay-put viper-search-overlay 'face viper-search-face)) + (overlay-put viper-search-overlay 'face viper-search-face)) ;; Search @@ -749,41 +717,41 @@ Otherwise return the normal value." nil (viper-put-on-search-overlay (match-beginning 0) (match-end 0)) (sit-for 2) - (viper-overlay-put viper-search-overlay 'face nil))) + (overlay-put viper-search-overlay 'face nil))) (defun viper-hide-search-overlay () - (if (not (viper-overlay-p viper-search-overlay)) + (if (not (overlayp viper-search-overlay)) (progn (setq viper-search-overlay - (viper-make-overlay (point-min) (point-min) (current-buffer))) - (viper-overlay-put + (make-overlay (point-min) (point-min) (current-buffer))) + (overlay-put viper-search-overlay 'priority viper-search-overlay-priority))) - (viper-overlay-put viper-search-overlay 'face nil)) + (overlay-put viper-search-overlay 'face nil)) ;; Replace state (defsubst viper-move-replace-overlay (beg end) - (viper-move-overlay viper-replace-overlay beg end)) + (move-overlay viper-replace-overlay beg end)) (defun viper-set-replace-overlay (beg end) - (if (viper-overlay-live-p viper-replace-overlay) + (if (overlayp viper-replace-overlay) (viper-move-replace-overlay beg end) - (setq viper-replace-overlay (viper-make-overlay beg end (current-buffer))) + (setq viper-replace-overlay (make-overlay beg end (current-buffer))) ;; never detach - (viper-overlay-put + (overlay-put viper-replace-overlay (if (featurep 'emacs) 'evaporate 'detachable) nil) - (viper-overlay-put + (overlay-put viper-replace-overlay 'priority viper-replace-overlay-priority) ;; If Emacs will start supporting overlay maps, as it currently supports ;; text-property maps, we could do away with viper-replace-minor-mode and ;; just have keymap attached to replace overlay. - ;;(viper-overlay-put + ;;(overlay-put ;; viper-replace-overlay ;; (if (featurep 'xemacs) 'keymap 'local-map) ;; viper-replace-map) ) (if (viper-has-face-support-p) - (viper-overlay-put + (overlay-put viper-replace-overlay 'face viper-replace-overlay-face)) (viper-save-cursor-color 'before-replace-mode) (viper-change-cursor-color @@ -791,27 +759,25 @@ Otherwise return the normal value." (defun viper-set-replace-overlay-glyphs (before-glyph after-glyph) - (or (viper-overlay-live-p viper-replace-overlay) + (or (overlayp viper-replace-overlay) (viper-set-replace-overlay (point-min) (point-min))) (if (or (not (viper-has-face-support-p)) viper-use-replace-region-delimiters) - (let ((before-name (if (featurep 'xemacs) 'begin-glyph 'before-string)) - (after-name (if (featurep 'xemacs) 'end-glyph 'after-string))) - (viper-overlay-put viper-replace-overlay before-name before-glyph) - (viper-overlay-put viper-replace-overlay after-name after-glyph)))) + (overlay-put viper-replace-overlay 'before-string before-glyph) + (overlay-put viper-replace-overlay 'after-string after-glyph))) (defun viper-hide-replace-overlay () (viper-set-replace-overlay-glyphs nil nil) (viper-restore-cursor-color 'after-replace-mode) (viper-restore-cursor-color 'after-insert-mode) (if (viper-has-face-support-p) - (viper-overlay-put viper-replace-overlay 'face nil))) + (overlay-put viper-replace-overlay 'face nil))) (defsubst viper-replace-start () - (viper-overlay-start viper-replace-overlay)) + (overlay-start viper-replace-overlay)) (defsubst viper-replace-end () - (viper-overlay-end viper-replace-overlay)) + (overlay-end viper-replace-overlay)) ;; Minibuffer @@ -819,35 +785,25 @@ Otherwise return the normal value." (defun viper-set-minibuffer-overlay () (viper-check-minibuffer-overlay) (when (viper-has-face-support-p) - (viper-overlay-put + (overlay-put viper-minibuffer-overlay 'face viper-minibuffer-current-face) - (viper-overlay-put + (overlay-put viper-minibuffer-overlay 'priority viper-minibuffer-overlay-priority) ;; never detach - (viper-overlay-put - viper-minibuffer-overlay - (if (featurep 'emacs) 'evaporate 'detachable) - nil) - ;; make viper-minibuffer-overlay open-ended - ;; In emacs, it is made open ended at creation time - (when (featurep 'xemacs) - (viper-overlay-put viper-minibuffer-overlay 'start-open nil) - (viper-overlay-put viper-minibuffer-overlay 'end-open nil)))) + (overlay-put viper-minibuffer-overlay 'evaporate nil))) (defun viper-check-minibuffer-overlay () - (if (viper-overlay-live-p viper-minibuffer-overlay) - (viper-move-overlay + (if (overlayp viper-minibuffer-overlay) + (move-overlay viper-minibuffer-overlay (if (fboundp 'minibuffer-prompt-end) (minibuffer-prompt-end) 1) (1+ (buffer-size))) (setq viper-minibuffer-overlay - (if (featurep 'xemacs) - (viper-make-overlay 1 (1+ (buffer-size)) (current-buffer)) - ;; make overlay open-ended - (viper-make-overlay - (if (fboundp 'minibuffer-prompt-end) (minibuffer-prompt-end) 1) - (1+ (buffer-size)) - (current-buffer) nil 'rear-advance))))) + ;; make overlay open-ended + (make-overlay + (if (fboundp 'minibuffer-prompt-end) (minibuffer-prompt-end) 1) + (1+ (buffer-size)) + (current-buffer) nil 'rear-advance)))) (defsubst viper-is-in-minibuffer () @@ -859,9 +815,7 @@ Otherwise return the normal value." ;;; XEmacs compatibility (defun viper-abbreviate-file-name (file) - (if (featurep 'xemacs) - (abbreviate-file-name file t) ; XEmacs requires addl argument - (abbreviate-file-name file))) + (abbreviate-file-name file)) ;; Sit for VAL milliseconds. XEmacs doesn't support the millisecond arg ;; in sit-for, so this function smooths out the differences. @@ -882,27 +836,25 @@ Otherwise return the normal value." (with-current-buffer buf (and (<= pos (point-max)) (<= (point-min) pos)))))) -(defsubst viper-mark-marker () - (if (featurep 'xemacs) (mark-marker t) - (mark-marker))) +(define-obsolete-function-alias 'viper-mark-marker 'mark-marker "27.1") + +(defvar viper-saved-mark nil + "Where viper saves mark. This mark is resurrected by m^.") ;; like (set-mark-command nil) but doesn't push twice, if (car mark-ring) ;; is the same as (mark t). (defsubst viper-set-mark-if-necessary () - (setq mark-ring (delete (viper-mark-marker) mark-ring)) + (setq mark-ring (delete (mark-marker) mark-ring)) (set-mark-command nil) (setq viper-saved-mark (point))) -;; In transient mark mode (zmacs mode), it is annoying when regions become -;; highlighted due to Viper's pushing marks. So, we deactivate marks, unless -;; the user explicitly wants highlighting, e.g., by hitting '' or `` -(defun viper-deactivate-mark () - (if (featurep 'xemacs) - (zmacs-deactivate-region) - (deactivate-mark))) +;; In transient mark mode, it is annoying when regions become +;; highlighted due to Viper's pushing marks. So, we deactivate marks, +;; unless the user explicitly wants highlighting, e.g., by hitting '' +;; or `` +(define-obsolete-function-alias 'viper-deactivate-mark 'deactivate-mark "27.1") -(defsubst viper-leave-region-active () - (if (featurep 'xemacs) (setq zmacs-region-stays t))) +(define-obsolete-function-alias 'viper-leave-region-active 'ignore "27.1") ;; Check if arg is a valid character for register ;; TYPE is a list that can contain `letter', `Letter', and `digit'. @@ -921,11 +873,7 @@ Otherwise return the normal value." -;; it is suggested that an event must be copied before it is assigned to -;; last-command-event in XEmacs -(defun viper-copy-event (event) - (if (featurep 'xemacs) (copy-event event) - event)) +(define-obsolete-function-alias 'viper-copy-event 'identity "27.1") ;; Uses different timeouts for ESC-sequences and others (defun viper-fast-keysequence-p () @@ -935,57 +883,8 @@ Otherwise return the normal value." viper-fast-keyseq-timeout) t))) -;; like read-event, but in XEmacs also try to convert to char, if possible -(defun viper-read-event-convert-to-char () - (let (event) - (if (featurep 'xemacs) - (progn - (setq event (next-command-event)) - (or (event-to-character event) - event)) - (read-event)))) - -;; Viperized read-key-sequence -(defun viper-read-key-sequence (prompt &optional continue-echo) - (let (inhibit-quit event keyseq) - (setq keyseq (read-key-sequence prompt continue-echo)) - (setq event (if (featurep 'xemacs) - (elt keyseq 0) ; XEmacs returns vector of events - (elt (listify-key-sequence keyseq) 0))) - (if (viper-ESC-event-p event) - (let (unread-command-events) - (if (viper-fast-keysequence-p) - (let ((viper-vi-global-user-minor-mode nil) - (viper-vi-local-user-minor-mode nil) - (viper-vi-intercept-minor-mode nil) - (viper-insert-intercept-minor-mode nil) - (viper-replace-minor-mode nil) ; actually unnecessary - (viper-insert-global-user-minor-mode nil) - (viper-insert-local-user-minor-mode nil)) - ;; Note: set unread-command-events only after testing for fast - ;; keysequence. Otherwise, viper-fast-keysequence-p will be - ;; always t -- whether there is anything after ESC or not - (viper-set-unread-command-events keyseq) - (setq keyseq (read-key-sequence nil))) - (viper-set-unread-command-events keyseq) - (setq keyseq (read-key-sequence nil))))) - keyseq)) - - -;; This function lets function-key-map convert key sequences into logical -;; keys. This does a better job than viper-read-event when it comes to kbd -;; macros, since it enables certain macros to be shared between X and TTY modes -;; by correctly mapping key sequences for Left/Right/... (on an ascii -;; terminal) into logical keys left, right, etc. -(defun viper-read-key () ;; FIXME: Use `read-key'? - (let ((overriding-local-map viper-overriding-map) - (inhibit-quit t) - help-char key) - (use-global-map viper-overriding-map) - (unwind-protect - (setq key (elt (viper-read-key-sequence nil) 0)) - (use-global-map global-map)) - key)) +(define-obsolete-function-alias 'viper-read-event-convert-to-char + 'read-event "27.1") ;; Emacs has a bug in eventp, which causes (eventp nil) to return (nil) @@ -994,64 +893,47 @@ Otherwise return the normal value." (defun viper-event-key (event) (or (and event (eventp event)) (error "viper-event-key: Wrong type argument, eventp, %S" event)) - (when (if (featurep 'xemacs) - (or (key-press-event-p event) (mouse-event-p event)) ; xemacs - t ; emacs - ) - (let ((mod (event-modifiers event)) - basis) - (setq basis - (if (featurep 'xemacs) - ;; XEmacs - (cond ((key-press-event-p event) - (event-key event)) - ((button-event-p event) - (concat "mouse-" (prin1-to-string (event-button event)))) - (t - (error "viper-event-key: Unknown event, %S" event))) - ;; Emacs doesn't handle capital letters correctly, since - ;; \S-a isn't considered the same as A (it behaves as - ;; plain `a' instead). So we take care of this here - (cond ((and (viper-characterp event) (<= ?A event) (<= event ?Z)) - (setq mod nil - event event)) - ;; Emacs has the oddity whereby characters 128+char - ;; represent M-char *if* this appears inside a string. - ;; So, we convert them manually to (meta char). - ((and (viper-characterp event) - (< ?\C-? event) (<= event 255)) - (setq mod '(meta) - event (- event ?\C-? 1))) - ((and (null mod) (eq event 'return)) - (setq event ?\C-m)) - ((and (null mod) (eq event 'space)) - (setq event ?\ )) - ((and (null mod) (eq event 'delete)) - (setq event ?\C-?)) - ((and (null mod) (eq event 'backspace)) - (setq event ?\C-h)) - (t (event-basic-type event))) - ) ; (featurep 'xemacs) - ) - (if (viper-characterp basis) - (setq basis - (if (viper= basis ?\C-?) - (list 'control '\?) ; taking care of an emacs bug - (intern (char-to-string basis))))) - (if mod - (append mod (list basis)) - basis)))) + (let ((mod (event-modifiers event)) + basis) + (setq basis + ;; Emacs doesn't handle capital letters correctly, since + ;; \S-a isn't considered the same as A (it behaves as + ;; plain `a' instead). So we take care of this here + (cond ((and (characterp event) (<= ?A event) (<= event ?Z)) + (setq mod nil + event event)) + ;; Emacs has the oddity whereby characters 128+char + ;; represent M-char *if* this appears inside a string. + ;; So, we convert them manually to (meta char). + ((and (characterp event) + (< ?\C-? event) (<= event 255)) + (setq mod '(meta) + event (- event ?\C-? 1))) + ((and (null mod) (eq event 'return)) + (setq event ?\C-m)) + ((and (null mod) (eq event 'space)) + (setq event ?\ )) + ((and (null mod) (eq event 'delete)) + (setq event ?\C-?)) + ((and (null mod) (eq event 'backspace)) + (setq event ?\C-h)) + (t (event-basic-type event)))) + + (if (characterp basis) + (setq basis + (if (viper= basis ?\C-?) + (list 'control '\?) ; taking care of an emacs bug + (intern (char-to-string basis))))) + (if mod + (append mod (list basis)) + basis))) (defun viper-last-command-char () - (if (featurep 'xemacs) - (event-to-character last-command-event) - last-command-event)) + last-command-event) (defun viper-key-to-emacs-key (key) (let (key-name char-p modifiers mod-char-list base-key base-key-name) - (cond ((featurep 'xemacs) key) - - ((symbolp key) + (cond ((symbolp key) (setq key-name (symbol-name key)) (cond ((= (length key-name) 1) ; character event (string-to-char key-name)) @@ -1093,16 +975,7 @@ Otherwise return the normal value." ;; LIS is assumed to be a list of events of characters -(defun viper-eventify-list-xemacs (lis) - (if (featurep 'xemacs) - (mapcar - (lambda (elt) - (cond ((viper-characterp elt) (character-to-event elt)) - ((eventp elt) elt) - (t (error - "viper-eventify-list-xemacs: can't convert to event, %S" - elt)))) - lis))) +(define-obsolete-function-alias 'viper-eventify-list-xemacs 'ignore "27.1") ;; Smooths out the difference between Emacs's unread-command-events @@ -1132,11 +1005,11 @@ Otherwise return the normal value." (setq unread-command-events (append - (cond ((viper-characterp arg) (list (character-to-event arg))) + (cond ((characterp arg) (list (character-to-event arg))) ((eventp arg) (list arg)) ((stringp arg) (mapcar 'character-to-event arg)) ((vectorp arg) (append arg nil)) ; turn into list - ((listp arg) (viper-eventify-list-xemacs arg)) + ((listp arg) nil) (t (error "viper-set-unread-command-events: Invalid argument, %S" arg))) unread-command-events)))) @@ -1161,7 +1034,7 @@ Otherwise return the normal value." (defun viper-char-array-p (array) - (eval (cons 'and (mapcar 'viper-characterp array)))) + (eval (cons 'and (mapcar 'characterp array)))) ;; Args can be a sequence of events, a string, or a Viper macro. Will try to @@ -1189,12 +1062,7 @@ Otherwise return the normal value." (t (prin1-to-string event-seq))))) (defun viper-key-press-events-to-chars (events) - (mapconcat (if (featurep 'xemacs) - (lambda (elt) (char-to-string (event-to-character elt))) ; xemacs - 'char-to-string ; emacs - ) - events - "")) + (mapconcat #'char-to-string events "")) (defun viper-read-char-exclusive () @@ -1205,7 +1073,7 @@ Otherwise return the normal value." (setq char (read-char)) (error ;; skip event if not char - (viper-read-event)))) + (read-event)))) char)) ;; key is supposed to be in viper's representation, e.g., (control l), a diff --git a/lisp/emulation/viper.el b/lisp/emulation/viper.el index 274c4543e51..521edbe6048 100644 --- a/lisp/emulation/viper.el +++ b/lisp/emulation/viper.el @@ -700,8 +700,6 @@ It also can't undo some Viper settings." (and (fboundp 'add-to-ordered-list) (boundp 'emulation-mode-map-alists)) (viper-delocalize-var 'minor-mode-map-alist)) (viper-delocalize-var 'require-final-newline) - (if (featurep 'xemacs) (viper-delocalize-var 'bar-cursor)) - ;; deactivate all advices done by Viper. (viper--deactivate-advice-list) @@ -787,8 +785,6 @@ It also can't undo some Viper settings." ;; In emacs, we have to advice handle-switch-frame ;; This advice is undone earlier, when all advices matching "viper-" are ;; deactivated. - (if (featurep 'xemacs) - (remove-hook 'mouse-leave-frame-hook #'viper-remember-current-frame)) ) ; end viper-go-away @@ -935,10 +931,7 @@ Two differences: (lambda (orig-fun &rest args) ;; FIXME: Use remapping? (if (and (eq viper-current-state 'vi-state) - ;; Do not use called-interactively-p here. XEmacs does not have it - ;; and interactive-p is just fine. - ;; (called-interactively-p 'interactive)) - (interactive-p)) + (called-interactively-p 'interactive)) (beep 1) (apply orig-fun args)))) @@ -1052,108 +1045,6 @@ Two differences: (setq global-mode-string (append '("" viper-mode-string) (cdr global-mode-string)))) - (if (featurep 'xemacs) - ;; XEmacs - (defadvice describe-key (before viper-describe-key-ad protect activate) - "Force to read key via `viper-read-key-sequence'." - (interactive (list (viper-read-key-sequence "Describe key: ")))) - ;; Emacs - (viper--advice-add 'describe-key :before - (lambda (&rest _) - "Force to read key via `viper-read-key-sequence'." - (interactive (let ((key (viper-read-key-sequence - "Describe key (or click or menu item): "))) - (list key - (prefix-numeric-value current-prefix-arg) - ;; If KEY is a down-event, read also the - ;; corresponding up-event. - (and (vectorp key) - (let ((last-idx (1- (length key)))) - (and (eventp (aref key last-idx)) - (memq 'down (event-modifiers - (aref key last-idx))))) - (or (and (eventp (aref key 0)) - (memq 'down (event-modifiers - (aref key 0))) - ;; For the C-down-mouse-2 popup menu, - ;; there is no subsequent up-event - (= (length key) 1)) - (and (> (length key) 1) - (eventp (aref key 1)) - (memq 'down (event-modifiers (aref key 1))))) - (read-event))))) - nil)) - - ) ; (if (featurep 'xemacs) - - (if (featurep 'xemacs) - ;; XEmacs - (defadvice describe-key-briefly - (before viper-describe-key-briefly-ad protect activate) - "Force to read key via `viper-read-key-sequence'." - (interactive (list (viper-read-key-sequence "Describe key briefly: ")))) - ;; Emacs - (viper--advice-add 'describe-key-briefly :before - (lambda (&rest _) - "Force to read key via `viper-read-key-sequence'." - (interactive (let ((key (viper-read-key-sequence - "Describe key (or click or menu item): "))) - ;; If KEY is a down-event, read and discard the - ;; corresponding up-event. - (and (vectorp key) - (let ((last-idx (1- (length key)))) - (and (eventp (aref key last-idx)) - (memq 'down (event-modifiers (aref key last-idx))))) - (read-event)) - (list key - (if current-prefix-arg - (prefix-numeric-value current-prefix-arg)) - 1))) - nil)) - ) ; (if (featurep 'xemacs) - - ;; FIXME: The default already uses read-file-name, so it looks like this - ;; advice is not needed any more. - ;; (defadvice find-file (before viper-add-suffix-advice activate) - ;; "Use `read-file-name' for reading arguments." - ;; (interactive (cons (read-file-name "Find file: " nil default-directory) - ;; ;; XEmacs: if Mule & prefix arg, ask for coding system - ;; (cond ((and (featurep 'xemacs) (featurep 'mule)) - ;; (list - ;; (and current-prefix-arg - ;; (read-coding-system "Coding-system: ")))) - ;; ;; Emacs: do wildcards - ;; ((and (featurep 'emacs) (boundp 'find-file-wildcards)) - ;; (list find-file-wildcards)))) - ;; )) - ;; (defadvice find-file-other-window (before viper-add-suffix-advice activate) - ;; "Use `read-file-name' for reading arguments." - ;; (interactive (cons (read-file-name "Find file in other window: " - ;; nil default-directory) - ;; ;; XEmacs: if Mule & prefix arg, ask for coding system - ;; (cond ((and (featurep 'xemacs) (featurep 'mule)) - ;; (list - ;; (and current-prefix-arg - ;; (read-coding-system "Coding-system: ")))) - ;; ;; Emacs: do wildcards - ;; ((and (featurep 'emacs) (boundp 'find-file-wildcards)) - ;; (list find-file-wildcards)))) - ;; )) - ;; (defadvice find-file-other-frame (before viper-add-suffix-advice activate) - ;; "Use `read-file-name' for reading arguments." - ;; (interactive (cons (read-file-name "Find file in other frame: " - ;; nil default-directory) - ;; ;; XEmacs: if Mule & prefix arg, ask for coding system - ;; (cond ((and (featurep 'xemacs) (featurep 'mule)) - ;; (list - ;; (and current-prefix-arg - ;; (read-coding-system "Coding-system: ")))) - ;; ;; Emacs: do wildcards - ;; ((and (featurep 'emacs) (boundp 'find-file-wildcards)) - ;; (list find-file-wildcards)))) - ;; )) - - (viper--advice-add 'read-file-name :around (lambda (orig-fun &rest args) "Tell `exit-minibuffer' to run `viper-file-add-suffix' as a hook." @@ -1180,13 +1071,11 @@ This may be needed if the previous `:map' command terminated abnormally." ;; catch frame switching event (if (viper-window-display-p) - (if (featurep 'xemacs) - (add-hook 'mouse-leave-frame-hook - #'viper-remember-current-frame) - (viper--advice-add 'handle-switch-frame :before - (lambda (&rest _) - "Remember the selected frame before the switch-frame event." - (viper-remember-current-frame (selected-frame)))))) + (viper--advice-add + 'handle-switch-frame :before + (lambda (&rest _) + "Remember the selected frame before the switch-frame event." + (viper-remember-current-frame (selected-frame))))) ) ; end viper-non-hook-settings diff --git a/lisp/env.el b/lisp/env.el index 2b8f30660c2..5a4130eb3be 100644 --- a/lisp/env.el +++ b/lisp/env.el @@ -113,11 +113,11 @@ Changes ENV by side-effect, and returns its new value." (not keep-empty) env (stringp (car env)) - (string-match pattern (car env))) + (string-match-p pattern (car env))) (cdr env) ;; Try to find existing entry for VARIABLE in ENV. (while (and scan (stringp (car scan))) - (when (string-match pattern (car scan)) + (when (string-match-p pattern (car scan)) (if value (setcar scan (concat variable "=" value)) (if keep-empty @@ -184,7 +184,7 @@ a side-effect." (setq variable (encode-coding-string variable locale-coding-system))) (if (and value (multibyte-string-p value)) (setq value (encode-coding-string value locale-coding-system))) - (if (string-match "=" variable) + (if (string-match-p "=" variable) (error "Environment variable name `%s' contains `='" variable)) (if (string-equal "TZ" variable) (set-time-zone-rule value)) diff --git a/lisp/epa-file.el b/lisp/epa-file.el index 4d5f3b30a34..d9886d3d67f 100644 --- a/lisp/epa-file.el +++ b/lisp/epa-file.el @@ -105,9 +105,7 @@ encryption is used." (if (fboundp 'decode-coding-inserted-region) (save-restriction (narrow-to-region (point) (point)) - (insert (if enable-multibyte-characters - (string-to-multibyte string) - string)) + (insert string) (decode-coding-inserted-region (point-min) (point-max) (substring file 0 (string-match epa-file-name-regexp file)) @@ -147,7 +145,6 @@ encryption is used." context (cons #'epa-progress-callback-function (format "Decrypting %s" file))) - (setf (epg-context-pinentry-mode context) epa-pinentry-mode) (unwind-protect (progn (if replace @@ -236,7 +233,6 @@ encryption is used." (cons #'epa-progress-callback-function (format "Encrypting %s" file))) (setf (epg-context-armor context) epa-armor) - (setf (epg-context-pinentry-mode context) epa-pinentry-mode) (condition-case error (setq string (epg-encrypt-string diff --git a/lisp/epa-hook.el b/lisp/epa-hook.el index 91d8d2b178f..cb9d997bb8f 100644 --- a/lisp/epa-hook.el +++ b/lisp/epa-hook.el @@ -83,10 +83,7 @@ May either be a string or a list of strings.") (auto-save-mode 0))) (define-minor-mode auto-encryption-mode - "Toggle automatic file encryption/decryption (Auto Encryption mode). -With a prefix argument ARG, enable Auto Encryption mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil." + "Toggle automatic file encryption/decryption (Auto Encryption mode)." :global t :init-value t :group 'epa-file :version "23.1" ;; We'd like to use custom-initialize-set here so the setup is done ;; before dumping, but at the point where the defcustom is evaluated, diff --git a/lisp/epa-mail.el b/lisp/epa-mail.el index 882c4f60cad..e0c9b43f1b2 100644 --- a/lisp/epa-mail.el +++ b/lisp/epa-mail.el @@ -47,10 +47,7 @@ ;;;###autoload (define-minor-mode epa-mail-mode - "A minor-mode for composing encrypted/clearsigned mails. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "A minor-mode for composing encrypted/clearsigned mails." nil " epa-mail" epa-mail-mode-map) (defun epa-mail--find-usable-key (keys usage) @@ -73,7 +70,8 @@ USAGE would be `sign' or `encrypt'." The buffer is expected to contain a mail message." (declare (interactive-only t)) (interactive) - (epa-decrypt-armor-in-region (point-min) (point-max))) + (with-suppressed-warnings ((interactive-only epa-decrypt-armor-in-region)) + (epa-decrypt-armor-in-region (point-min) (point-max)))) ;;;###autoload (defun epa-mail-verify () @@ -81,7 +79,8 @@ The buffer is expected to contain a mail message." The buffer is expected to contain a mail message." (declare (interactive-only t)) (interactive) - (epa-verify-cleartext-in-region (point-min) (point-max))) + (with-suppressed-warnings ((interactive-only epa-verify-cleartext-in-region)) + (epa-verify-cleartext-in-region (point-min) (point-max)))) ;;;###autoload (defun epa-mail-sign (start end signers mode) @@ -95,7 +94,7 @@ The buffer is expected to contain a mail message." (forward-line)) (setq epa-last-coding-system-specified (or coding-system-for-write - (epa--select-safe-coding-system (point) (point-max)))) + (select-safe-coding-system (point) (point-max)))) (let ((verbose current-prefix-arg)) (list (point) (point-max) (if verbose @@ -107,11 +106,12 @@ If no one is selected, default secret key is used. " (epa--read-signature-type) 'clear))))) (let ((inhibit-read-only t)) - (epa-sign-region start end signers mode))) + (with-suppressed-warnings ((interactive-only epa-sign-region)) + (epa-sign-region start end signers mode)))) (defun epa-mail-default-recipients () "Return the default list of encryption recipients for a mail buffer." - (let ((config (epg-configuration)) + (let ((config (epg-find-configuration 'OpenPGP)) recipients-string real-recipients) (save-excursion (goto-char (point-min)) @@ -153,7 +153,7 @@ If no one is selected, default secret key is used. " (mapcar (lambda (recipient) (let ((tem (assoc recipient epa-mail-aliases))) - (if tem (cdr tem) + (if tem (copy-sequence (cdr tem)) (list recipient)))) real-recipients))) ))) @@ -222,11 +222,13 @@ If no one is selected, symmetric encryption will be performed. " (setq epa-last-coding-system-specified (or coding-system-for-write - (epa--select-safe-coding-system (point) (point-max))))) + (select-safe-coding-system (point) (point-max))))) ;; Don't let some read-only text stop us from encrypting. (let ((inhibit-read-only t)) - (epa-encrypt-region start (point-max) recipient-keys signers signers)))) + (with-suppressed-warnings ((interactive-only epa-encrypt-region)) + (epa-encrypt-region start (point-max) + recipient-keys signers signers))))) ;;;###autoload (defun epa-mail-import-keys () @@ -238,10 +240,7 @@ The buffer is expected to contain a mail message." ;;;###autoload (define-minor-mode epa-global-mail-mode - "Minor mode to hook EasyPG into Mail mode. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "Minor mode to hook EasyPG into Mail mode." :global t :init-value nil :group 'epa-mail :version "23.1" (remove-hook 'mail-mode-hook 'epa-mail-mode) (if epa-global-mail-mode diff --git a/lisp/epa.el b/lisp/epa.el index e442c12a7d6..9e6edf463c6 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -56,28 +56,6 @@ If neither t nor nil, ask user for confirmation." :type 'integer :group 'epa) -;; In the doc string below, we say "symbol `error'" to avoid producing -;; a hyperlink for `error' the function. -(defcustom epa-pinentry-mode nil - "The pinentry mode. - -GnuPG 2.1 or later has an option to control the behavior of -Pinentry invocation. The value should be the symbol `error', -`ask', `cancel', or `loopback'. See the GnuPG manual for the -meanings. - -In epa commands, a particularly useful mode is `loopback', which -redirects all Pinentry queries to the caller, so Emacs can query -passphrase through the minibuffer, instead of external Pinentry -program." - :type '(choice (const nil) - (const ask) - (const cancel) - (const error) - (const loopback)) - :group 'epa - :version "25.1") - (defgroup epa-faces nil "Faces for epa-mode." :version "23.1" @@ -307,21 +285,12 @@ You should bind this variable with `let', but do not set it globally.") (epg-sub-key-id (car (epg-key-sub-key-list (widget-get widget :value)))))) -(defalias 'epa--encode-coding-string - (if (fboundp 'encode-coding-string) #'encode-coding-string #'identity)) - -(defalias 'epa--decode-coding-string - (if (fboundp 'decode-coding-string) #'decode-coding-string #'identity)) - (define-derived-mode epa-key-list-mode special-mode "Keys" "Major mode for `epa-list-keys'." (buffer-disable-undo) (setq truncate-lines t buffer-read-only t) (setq-local font-lock-defaults '(epa-font-lock-keywords t)) - ;; In XEmacs, auto-initialization of font-lock is not effective - ;; if buffer-file-name is not set. - (font-lock-set-defaults) (make-local-variable 'epa-exit-buffer-function) (setq-local revert-buffer-function #'epa--key-list-revert-buffer)) @@ -331,9 +300,6 @@ You should bind this variable with `let', but do not set it globally.") (setq truncate-lines t buffer-read-only t) (setq-local font-lock-defaults '(epa-font-lock-keywords t)) - ;; In XEmacs, auto-initialization of font-lock is not effective - ;; if buffer-file-name is not set. - (font-lock-set-defaults) (make-local-variable 'epa-exit-buffer-function)) (define-derived-mode epa-info-mode special-mode "Info" @@ -565,7 +531,7 @@ If SECRET is non-nil, list secret keys instead of public keys." (epg-sub-key-creation-time (car pointer))) (error "????-??-??")) (if (epg-sub-key-expiration-time (car pointer)) - (format (if (time-less-p (current-time) + (format (if (time-less-p nil (epg-sub-key-expiration-time (car pointer))) "\n\tExpires: %s" @@ -625,12 +591,12 @@ If SECRET is non-nil, list secret keys instead of public keys." (erase-buffer) (insert (format (pcase (epg-context-operation context) - (`decrypt "Error while decrypting with \"%s\":") - (`verify "Error while verifying with \"%s\":") - (`sign "Error while signing with \"%s\":") - (`encrypt "Error while encrypting with \"%s\":") - (`import-keys "Error while importing keys with \"%s\":") - (`export-keys "Error while exporting keys with \"%s\":") + ('decrypt "Error while decrypting with \"%s\":") + ('verify "Error while verifying with \"%s\":") + ('sign "Error while signing with \"%s\":") + ('encrypt "Error while encrypting with \"%s\":") + ('import-keys "Error while importing keys with \"%s\":") + ('export-keys "Error while exporting keys with \"%s\":") (_ "Error while executing \"%s\":\n\n")) (epg-context-program context)) "\n\n" @@ -701,7 +667,6 @@ If you do not specify PLAIN-FILE, this functions prompts for the value to use." #'epa-progress-callback-function (format "Decrypting %s..." (file-name-nondirectory decrypt-file)))) - (setf (epg-context-pinentry-mode context) epa-pinentry-mode) (message "Decrypting %s..." (file-name-nondirectory decrypt-file)) (condition-case error (epg-decrypt-file context decrypt-file plain-file) @@ -797,7 +762,6 @@ If no one is selected, default secret key is used. " #'epa-progress-callback-function (format "Signing %s..." (file-name-nondirectory file)))) - (setf (epg-context-pinentry-mode context) epa-pinentry-mode) (message "Signing %s..." (file-name-nondirectory file)) (condition-case error (epg-sign-file context file signature mode) @@ -828,7 +792,6 @@ If no one is selected, symmetric encryption will be performed. "))) #'epa-progress-callback-function (format "Encrypting %s..." (file-name-nondirectory file)))) - (setf (epg-context-pinentry-mode context) epa-pinentry-mode) (message "Encrypting %s..." (file-name-nondirectory file)) (condition-case error (epg-encrypt-file context file recipients cipher) @@ -871,7 +834,6 @@ For example: (cons #'epa-progress-callback-function "Decrypting...")) - (setf (epg-context-pinentry-mode context) epa-pinentry-mode) (message "Decrypting...") (condition-case error (setq plain (epg-decrypt-string context (buffer-substring start end))) @@ -879,7 +841,7 @@ For example: (epa-display-error context) (signal (car error) (cdr error)))) (message "Decrypting...done") - (setq plain (epa--decode-coding-string + (setq plain (decode-coding-string plain (or coding-system-for-read (get-text-property start 'epa-coding-system-used) @@ -904,16 +866,13 @@ For example: (epg-context-result-for context 'verify))))))) (defun epa--find-coding-system-for-mime-charset (mime-charset) - (if (featurep 'xemacs) - (if (fboundp 'find-coding-system) - (find-coding-system mime-charset)) - ;; Find the first coding system which corresponds to MIME-CHARSET. - (let ((pointer (coding-system-list))) - (while (and pointer - (not (eq (coding-system-get (car pointer) 'mime-charset) - mime-charset))) - (setq pointer (cdr pointer))) - (car pointer)))) + ;; Find the first coding system which corresponds to MIME-CHARSET. + (let ((pointer (coding-system-list))) + (while (and pointer + (not (eq (coding-system-get (car pointer) 'mime-charset) + mime-charset))) + (setq pointer (cdr pointer))) + (car pointer))) ;;;###autoload (defun epa-decrypt-armor-in-region (start end) @@ -973,7 +932,7 @@ For example: (condition-case error (setq plain (epg-verify-string context - (epa--encode-coding-string + (encode-coding-string (buffer-substring start end) (or coding-system-for-write (get-text-property start 'epa-coding-system-used))))) @@ -981,7 +940,7 @@ For example: (epa-display-error context) (signal (car error) (cdr error)))) (message "Verifying...done") - (setq plain (epa--decode-coding-string + (setq plain (decode-coding-string plain (or coding-system-for-read (get-text-property start 'epa-coding-system-used) @@ -1027,13 +986,8 @@ See the reason described in the `epa-verify-region' documentation." nil t)) (unless cleartext-end (error "No cleartext tail")) - (epa-verify-region cleartext-start cleartext-end)))))) - -(defalias 'epa--select-safe-coding-system - (if (fboundp 'select-safe-coding-system) - #'select-safe-coding-system - (lambda (_from _to) - buffer-file-coding-system))) + (with-suppressed-warnings ((interactive-only epa-verify-region)) + (epa-verify-region cleartext-start cleartext-end))))))) ;;;###autoload (defun epa-sign-region (start end signers mode) @@ -1057,7 +1011,7 @@ For example: (let ((verbose current-prefix-arg)) (setq epa-last-coding-system-specified (or coding-system-for-write - (epa--select-safe-coding-system + (select-safe-coding-system (region-beginning) (region-end)))) (list (region-beginning) (region-end) (if verbose @@ -1082,11 +1036,10 @@ If no one is selected, default secret key is used. " (cons #'epa-progress-callback-function "Signing...")) - (setf (epg-context-pinentry-mode context) epa-pinentry-mode) (message "Signing...") (condition-case error (setq signature (epg-sign-string context - (epa--encode-coding-string + (encode-coding-string (buffer-substring start end) epa-last-coding-system-specified) mode)) @@ -1098,7 +1051,7 @@ If no one is selected, default secret key is used. " (goto-char start) (add-text-properties (point) (progn - (insert (epa--decode-coding-string + (insert (decode-coding-string signature (or coding-system-for-read epa-last-coding-system-specified))) @@ -1146,7 +1099,7 @@ For example: sign) (setq epa-last-coding-system-specified (or coding-system-for-write - (epa--select-safe-coding-system + (select-safe-coding-system (region-beginning) (region-end)))) (list (region-beginning) (region-end) (epa-select-keys context @@ -1171,11 +1124,10 @@ If no one is selected, symmetric encryption will be performed. ") (cons #'epa-progress-callback-function "Encrypting...")) - (setf (epg-context-pinentry-mode context) epa-pinentry-mode) (message "Encrypting...") (condition-case error (setq cipher (epg-encrypt-string context - (epa--encode-coding-string + (encode-coding-string (buffer-substring start end) epa-last-coding-system-specified) recipients @@ -1322,30 +1274,6 @@ If no one is selected, default public key is exported. "))) (epa-display-error context) (signal (car error) (cdr error)))))) -;; (defun epa-sign-keys (keys &optional local) -;; "Sign selected KEYS. -;; If a prefix-arg is specified, the signature is marked as non exportable. - -;; Don't use this command in Lisp programs!" -;; (declare (interactive-only t)) -;; (interactive -;; (let ((keys (epa--marked-keys))) -;; (unless keys -;; (error "No keys selected")) -;; (list keys current-prefix-arg))) -;; (let ((context (epg-make-context epa-protocol))) -;; (epg-context-set-passphrase-callback context -;; #'epa-passphrase-callback-function) -;; (epg-context-set-progress-callback context -;; (cons -;; #'epa-progress-callback-function -;; "Signing keys...")) -;; (setf (epg-context-pinentry-mode context) epa-pinentry-mode) -;; (message "Signing keys...") -;; (epg-sign-keys context keys local) -;; (message "Signing keys...done"))) -;; (make-obsolete 'epa-sign-keys "Do not use.") - (provide 'epa) ;;; epa.el ends here diff --git a/lisp/epg-config.el b/lisp/epg-config.el index 6b93cf7e27b..55490681698 100644 --- a/lisp/epg-config.el +++ b/lisp/epg-config.el @@ -31,8 +31,8 @@ (defconst epg-version-number "1.0.0" "Version number of this package.") -(defconst epg-bug-report-address "ueno@unixuser.org" - "Report bugs to this address.") +(define-obsolete-variable-alias 'epg-bug-report-address + 'report-emacs-bug-address "27.1") (defgroup epg () "Interface to the GNU Privacy Guard (GnuPG)." @@ -44,48 +44,77 @@ (defcustom epg-gpg-program (if (executable-find "gpg2") "gpg2" "gpg") - "The `gpg' executable. -Setting this variable directly does not take effect; -instead use \\[customize] (see the info node `Easy Customization')." + "Say what gpg program to prefer (if it satisfies minimum requirements). + +If this variable is \"gpg2\", but the version of gpg2 installed +is less than `epg-gpg2-minimum-version', then version 1 of +GnuPG (i.e., \"gpg\") will be used instead. If the version of +version 1 is less than `epg-gpg-minimum-version', then that won't +be used either. + +If you want to explicitly specify what gpg program to use, you +have to use \\[customize] instead (see the info node `Easy +Customization'). Setting this variable without \\[customize] has +no effect." :version "25.1" - :group 'epg :type 'string) (defcustom epg-gpgsm-program "gpgsm" "The `gpgsm' executable. Setting this variable directly does not take effect; instead use \\[customize] (see the info node `Easy Customization')." - :group 'epg :type 'string) (defcustom epg-gpgconf-program "gpgconf" "The `gpgconf' executable." :version "25.1" - :group 'epg :type 'string) (defcustom epg-gpg-home-directory nil "The directory which contains the configuration files of `epg-gpg-program'." - :group 'epg :type '(choice (const :tag "Default" nil) directory)) (defcustom epg-passphrase-coding-system nil "Coding system to use with messages from `epg-gpg-program'." - :group 'epg :type 'symbol) +(define-obsolete-variable-alias + 'epa-pinentry-mode 'epg-pinentry-mode "27.1") + +;; In the doc string below, we say "symbol `error'" to avoid producing +;; a hyperlink for `error' the function. +(defcustom epg-pinentry-mode nil + "The pinentry mode. + +GnuPG 2.1 or later has an option to control the behavior of +Pinentry invocation. The value should be the symbol `error', +`ask', `cancel', or `loopback'. See the GnuPG manual for the +meanings. + +A particularly useful mode is `loopback', which redirects all +Pinentry queries to the caller, so Emacs can query passphrase +through the minibuffer, instead of external Pinentry program." + :type '(choice (const nil) + (const ask) + (const cancel) + (const error) + (const loopback)) + :version "27.1") + (defcustom epg-debug nil "If non-nil, debug output goes to the \" *epg-debug*\" buffer. Note that the buffer name starts with a space." - :group 'epg :type 'boolean) (defconst epg-gpg-minimum-version "1.4.3") +(defconst epg-gpg2-minimum-version "2.1.6") (defconst epg-config--program-alist `((OpenPGP epg-gpg-program - ("gpg2" . "2.1.6") ("gpg" . ,epg-gpg-minimum-version)) + ("gpg2" . ,epg-gpg2-minimum-version) + ("gpg" . ((,epg-gpg-minimum-version . "2.0") + ,epg-gpg2-minimum-version))) (CMS epg-gpgsm-program ("gpgsm" . "2.0.4"))) @@ -211,14 +240,26 @@ version requirement is met." (epg-config--make-gpg-configuration epg-gpg-program)) ;;;###autoload -(defun epg-check-configuration (config &optional minimum-version) - "Verify that a sufficient version of GnuPG is installed." +(defun epg-check-configuration (config &optional req-versions) + "Verify that a sufficient version of GnuPG is installed. +CONFIG should be a `epg-configuration' object (a plist). +REQ-VERSIONS should be a list with elements of the form (MIN +. MAX) where MIN and MAX are version strings indicating a +semi-open range of acceptable versions. REQ-VERSIONS may also be +a single minimum version string." (let ((version (alist-get 'version config))) (unless (stringp version) (error "Undetermined version: %S" version)) - (unless (version<= (or minimum-version - epg-gpg-minimum-version) - version) + (catch 'version-ok + (pcase-dolist ((or `(,min . ,max) + (and min (let max nil))) + (if (listp req-versions) req-versions + (list req-versions))) + (when (and (version<= (or min epg-gpg-minimum-version) + version) + (or (null max) + (version< version max))) + (throw 'version-ok t))) (error "Unsupported version: %s" version)))) ;;;###autoload diff --git a/lisp/epg.el b/lisp/epg.el index 539dcf3ca22..ce58c520f17 100644 --- a/lisp/epg.el +++ b/lisp/epg.el @@ -41,7 +41,7 @@ (defvar epg-agent-file nil) (defvar epg-agent-mtime nil) -;; from gnupg/include/cipher.h +;; from gnupg/common/openpgpdefs.h (defconst epg-cipher-algorithm-alist '((0 . "NONE") (1 . "IDEA") @@ -56,16 +56,20 @@ (12 . "CAMELLIA256") (110 . "DUMMY"))) -;; from gnupg/include/cipher.h +;; from gnupg/common/openpgpdefs.h (defconst epg-pubkey-algorithm-alist '((1 . "RSA") (2 . "RSA_E") (3 . "RSA_S") (16 . "ELGAMAL_E") (17 . "DSA") - (20 . "ELGAMAL"))) + (18 . "ECDH") + (19 . "ECDSA") + (20 . "ELGAMAL") + (22 . "EDDSA") + (110 . "PRIVATE10"))) -;; from gnupg/include/cipher.h +;; from gnupg/common/openpgpdefs.h (defconst epg-digest-algorithm-alist '((1 . "MD5") (2 . "SHA1") @@ -73,14 +77,16 @@ (8 . "SHA256") (9 . "SHA384") (10 . "SHA512") - (11 . "SHA224"))) + (11 . "SHA224") + (110 . "PRIVATE10"))) -;; from gnupg/include/cipher.h +;; from gnupg/common/openpgpdefs.h (defconst epg-compress-algorithm-alist '((0 . "NONE") (1 . "ZIP") (2 . "ZLIB") - (3 . "BZIP2"))) + (3 . "BZIP2") + (110 . "PRIVATE10"))) (defconst epg-invalid-recipients-reason-alist '((0 . "No specific reason given") @@ -174,10 +180,6 @@ (file nil :read-only t) (string nil :read-only t)) -(defmacro epg--gv-nreverse (place) - (gv-letplace (getter setter) place - (funcall setter `(nreverse ,getter)))) - (cl-defstruct (epg-context (:constructor nil) (:constructor epg-context--make @@ -206,12 +208,13 @@ progress-callback edit-callback signers + sender sig-notations process output-file result operation - pinentry-mode + (pinentry-mode epg-pinentry-mode) (error-output "") error-buffer) @@ -612,7 +615,9 @@ callback data (if any)." ;; for more details. (when (and agent-info (string-match "\\(.*\\):[0-9]+:[0-9]+" agent-info)) (setq agent-file (match-string 1 agent-info) - agent-mtime (or (nth 5 (file-attributes agent-file)) '(0 0 0 0)))) + agent-mtime (or (file-attribute-modification-time + (file-attributes agent-file)) + '(0 0 0 0)))) (if epg-debug (save-excursion (unless epg-debug-buffer @@ -739,7 +744,9 @@ callback data (if any)." (if (with-current-buffer (process-buffer (epg-context-process context)) (and epg-agent-file (time-less-p epg-agent-mtime - (or (nth 5 (file-attributes epg-agent-file)) 0)))) + (or (file-attribute-modification-time + (file-attributes epg-agent-file)) + 0)))) (redraw-frame)) (epg-context-set-result-for context 'error @@ -764,20 +771,13 @@ callback data (if any)." (file-exists-p (epg-context-output-file context))) (delete-file (epg-context-output-file context)))) -(eval-and-compile - (if (fboundp 'decode-coding-string) - (defalias 'epg--decode-coding-string 'decode-coding-string) - (defalias 'epg--decode-coding-string 'identity))) - (defun epg--status-USERID_HINT (_context string) (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string) (let* ((key-id (match-string 1 string)) (user-id (match-string 2 string)) (entry (assoc key-id epg-user-id-alist))) (condition-case nil - (setq user-id (epg--decode-coding-string - (epg--decode-percent-escape user-id) - 'utf-8)) + (setq user-id (epg--decode-percent-escape-as-utf-8 user-id)) (error)) (if entry (setcdr entry user-id) @@ -794,17 +794,6 @@ callback data (if any)." (defun epg--status-NEED_PASSPHRASE_PIN (_context _string) (setq epg-key-id 'PIN)) -(eval-and-compile - (if (fboundp 'clear-string) - (defalias 'epg--clear-string 'clear-string) - (defun epg--clear-string (string) - (fillarray string 0)))) - -(eval-and-compile - (if (fboundp 'encode-coding-string) - (defalias 'epg--encode-coding-string 'encode-coding-string) - (defalias 'epg--encode-coding-string 'identity))) - (defun epg--status-GET_HIDDEN (context string) (when (and epg-key-id (string-match "\\`passphrase\\." string)) @@ -825,16 +814,16 @@ callback data (if any)." (cdr (epg-context-passphrase-callback context)))) (when passphrase (setq passphrase-with-new-line (concat passphrase "\n")) - (epg--clear-string passphrase) + (clear-string passphrase) (setq passphrase nil) (if epg-passphrase-coding-system (progn (setq encoded-passphrase-with-new-line - (epg--encode-coding-string + (encode-coding-string passphrase-with-new-line (coding-system-change-eol-conversion epg-passphrase-coding-system 'unix))) - (epg--clear-string passphrase-with-new-line) + (clear-string passphrase-with-new-line) (setq passphrase-with-new-line nil)) (setq encoded-passphrase-with-new-line passphrase-with-new-line @@ -848,11 +837,11 @@ callback data (if any)." (epg-context-result-for context 'error))) (delete-process (epg-context-process context)))) (if passphrase - (epg--clear-string passphrase)) + (clear-string passphrase)) (if passphrase-with-new-line - (epg--clear-string passphrase-with-new-line)) + (clear-string passphrase-with-new-line)) (if encoded-passphrase-with-new-line - (epg--clear-string encoded-passphrase-with-new-line)))))) + (clear-string encoded-passphrase-with-new-line)))))) (defun epg--prompt-GET_BOOL (_context string) (let ((entry (assoc string epg-prompt-alist))) @@ -915,9 +904,7 @@ callback data (if any)." (condition-case nil (if (eq (epg-context-protocol context) 'CMS) (setq user-id (epg-dn-from-string user-id)) - (setq user-id (epg--decode-coding-string - (epg--decode-percent-escape user-id) - 'utf-8))) + (setq user-id (epg--decode-percent-escape-as-utf-8 user-id))) (error)) (if entry (setcdr entry user-id) @@ -962,14 +949,11 @@ callback data (if any)." (cons (cons 'no-seckey string) (epg-context-result-for context 'error)))) -(defun epg--time-from-seconds (seconds) - (let ((number-seconds (string-to-number (concat seconds ".0")))) - (cons (floor (/ number-seconds 65536)) - (floor (mod number-seconds 65536))))) +(defalias 'epg--time-from-seconds #'string-to-number) (defun epg--status-ERRSIG (context string) (if (string-match "\\`\\([^ ]+\\) \\([0-9]+\\) \\([0-9]+\\) \ -\\([0-9A-Fa-f][0-9A-Fa-f]\\) \\([^ ]+\\) \\([0-9]+\\)" +\\([[:xdigit:]][[:xdigit:]]\\) \\([^ ]+\\) \\([0-9]+\\)" string) (let ((signature (epg-make-signature 'error))) (epg-context-set-result-for @@ -993,7 +977,7 @@ callback data (if any)." (when (and signature (eq (epg-signature-status signature) 'good) (string-match "\\`\\([^ ]+\\) [^ ]+ \\([^ ]+\\) \\([^ ]+\\) \ -\\([0-9]+\\) [^ ]+ \\([0-9]+\\) \\([0-9]+\\) \\([0-9A-Fa-f][0-9A-Fa-f]\\) \ +\\([0-9]+\\) [^ ]+ \\([0-9]+\\) \\([0-9]+\\) \\([[:xdigit:]][[:xdigit:]]\\) \ \\(.*\\)" string)) (setf (epg-signature-fingerprint signature) @@ -1163,7 +1147,7 @@ callback data (if any)." (defun epg--status-SIG_CREATED (context string) (if (string-match "\\`\\([DCS]\\) \\([0-9]+\\) \\([0-9]+\\) \ -\\([0-9A-Fa-F][0-9A-Fa-F]\\) \\(.*\\) " string) +\\([[:xdigit:]][[:xdigit:]]\\) \\(.*\\) " string) (epg-context-set-result-for context 'sign (cons (epg-make-new-signature @@ -1196,9 +1180,7 @@ callback data (if any)." (user-id (match-string 2 string)) (entry (assoc key-id epg-user-id-alist))) (condition-case nil - (setq user-id (epg--decode-coding-string - (epg--decode-percent-escape user-id) - 'utf-8)) + (setq user-id (epg--decode-percent-escape-as-utf-8 user-id)) (error)) (if entry (setcdr entry user-id) @@ -1353,7 +1335,7 @@ NAME is either a string or a list of strings." (setq string (replace-match "\\\"" t t string) index (1+ (match-end 0)))) (condition-case nil - (setq string (epg--decode-coding-string + (setq string (decode-coding-string (car (read-from-string (concat "\"" string "\""))) 'utf-8)) (error @@ -1390,70 +1372,14 @@ NAME is either a string or a list of strings." (setq keys (nreverse keys) pointer keys) (while pointer - (epg--gv-nreverse (epg-key-sub-key-list (car pointer))) - (setq pointer-1 (epg--gv-nreverse (epg-key-user-id-list (car pointer)))) + (cl-callf nreverse (epg-key-sub-key-list (car pointer))) + (setq pointer-1 (cl-callf nreverse (epg-key-user-id-list (car pointer)))) (while pointer-1 - (epg--gv-nreverse (epg-user-id-signature-list (car pointer-1))) + (cl-callf nreverse (epg-user-id-signature-list (car pointer-1))) (setq pointer-1 (cdr pointer-1))) (setq pointer (cdr pointer))) keys)) -(eval-and-compile - (if (fboundp 'make-temp-file) - (defalias 'epg--make-temp-file 'make-temp-file) - (defvar temporary-file-directory) - ;; stolen from poe.el. - (defun epg--make-temp-file (prefix) - "Create a temporary file. -The returned file name (created by appending some random characters at the end -of PREFIX, and expanding against `temporary-file-directory' if necessary), -is guaranteed to point to a newly created empty file. -You can then use `write-region' to write new data into the file." - (let ((orig-modes (default-file-modes)) - tempdir tempfile) - (setq prefix (expand-file-name prefix - (if (featurep 'xemacs) - (temp-directory) - temporary-file-directory))) - (unwind-protect - (let (file) - ;; First, create a temporary directory. - (set-default-file-modes #o700) - (while (condition-case () - (progn - (setq tempdir (make-temp-name - (concat - (file-name-directory prefix) - "DIR"))) - ;; return nil or signal an error. - (make-directory tempdir)) - ;; let's try again. - (file-already-exists t))) - ;; Second, create a temporary file in the tempdir. - ;; There *is* a race condition between `make-temp-name' - ;; and `write-region', but we don't care it since we are - ;; in a private directory now. - (setq tempfile (make-temp-name (concat tempdir "/EMU"))) - (write-region "" nil tempfile nil 'silent) - ;; Finally, make a hard-link from the tempfile. - (while (condition-case () - (progn - (setq file (make-temp-name prefix)) - ;; return nil or signal an error. - (add-name-to-file tempfile file)) - ;; let's try again. - (file-already-exists t))) - file) - (set-default-file-modes orig-modes) - ;; Cleanup the tempfile. - (and tempfile - (file-exists-p tempfile) - (delete-file tempfile)) - ;; Cleanup the tempdir. - (and tempdir - (file-directory-p tempdir) - (delete-directory tempdir))))))) - (defun epg--args-from-sig-notations (notations) (apply #'nconc (mapcar @@ -1517,7 +1443,7 @@ If PLAIN is nil, it returns the result as a string." (unwind-protect (progn (setf (epg-context-output-file context) - (or plain (epg--make-temp-file "epg-output"))) + (or plain (make-temp-file "epg-output"))) (epg-start-decrypt context (epg-make-data-from-file cipher)) (epg-wait-for-completion context) (epg--check-error-for-decrypt context) @@ -1529,13 +1455,13 @@ If PLAIN is nil, it returns the result as a string." (defun epg-decrypt-string (context cipher) "Decrypt a string CIPHER and return the plain text." - (let ((input-file (epg--make-temp-file "epg-input")) + (let ((input-file (make-temp-file "epg-input")) (coding-system-for-write 'binary)) (unwind-protect (progn (write-region cipher nil input-file nil 'quiet) (setf (epg-context-output-file context) - (epg--make-temp-file "epg-output")) + (make-temp-file "epg-output")) (epg-start-decrypt context (epg-make-data-from-file input-file)) (epg-wait-for-completion context) (epg--check-error-for-decrypt context) @@ -1606,7 +1532,7 @@ which will return a list of `epg-signature' object." (unwind-protect (progn (setf (epg-context-output-file context) - (or plain (epg--make-temp-file "epg-output"))) + (or plain (make-temp-file "epg-output"))) (if signed-text (epg-start-verify context (epg-make-data-from-file signature) @@ -1643,10 +1569,10 @@ which will return a list of `epg-signature' object." (unwind-protect (progn (setf (epg-context-output-file context) - (epg--make-temp-file "epg-output")) + (make-temp-file "epg-output")) (if signed-text (progn - (setq input-file (epg--make-temp-file "epg-signature")) + (setq input-file (make-temp-file "epg-signature")) (write-region signature nil input-file nil 'quiet) (epg-start-verify context (epg-make-data-from-file input-file) @@ -1691,6 +1617,9 @@ If you are unsure, use synchronous version of this function (epg-sub-key-id (car (epg-key-sub-key-list signer))))) (epg-context-signers context))) + (let ((sender (epg-context-sender context))) + (when (stringp sender) + (list "--sender" sender))) (epg--args-from-sig-notations (epg-context-sig-notations context)) (if (epg-data-file plain) @@ -1714,7 +1643,7 @@ Otherwise, it makes a cleartext signature." (unwind-protect (progn (setf (epg-context-output-file context) - (or signature (epg--make-temp-file "epg-output"))) + (or signature (make-temp-file "epg-output"))) (epg-start-sign context (epg-make-data-from-file plain) mode) (epg-wait-for-completion context) (unless (epg-context-result-for context 'sign) @@ -1734,12 +1663,12 @@ If it is nil or `normal', it makes a normal signature. Otherwise, it makes a cleartext signature." (let ((input-file (unless (eq (epg-context-protocol context) 'CMS) - (epg--make-temp-file "epg-input"))) + (make-temp-file "epg-input"))) (coding-system-for-write 'binary)) (unwind-protect (progn (setf (epg-context-output-file context) - (epg--make-temp-file "epg-output")) + (make-temp-file "epg-output")) (if input-file (write-region plain nil input-file nil 'quiet)) (epg-start-sign context @@ -1786,6 +1715,10 @@ If you are unsure, use synchronous version of this function signer))))) (epg-context-signers context)))) (if sign + (let ((sender (epg-context-sender context))) + (when (stringp sender) + (list "--sender" sender)))) + (if sign (epg--args-from-sig-notations (epg-context-sig-notations context))) (apply #'nconc @@ -1816,7 +1749,7 @@ If RECIPIENTS is nil, it performs symmetric encryption." (unwind-protect (progn (setf (epg-context-output-file context) - (or cipher (epg--make-temp-file "epg-output"))) + (or cipher (make-temp-file "epg-output"))) (epg-start-encrypt context (epg-make-data-from-file plain) recipients sign always-trust) (epg-wait-for-completion context) @@ -1841,12 +1774,12 @@ If RECIPIENTS is nil, it performs symmetric encryption." (let ((input-file (unless (or (not sign) (eq (epg-context-protocol context) 'CMS)) - (epg--make-temp-file "epg-input"))) + (make-temp-file "epg-input"))) (coding-system-for-write 'binary)) (unwind-protect (progn (setf (epg-context-output-file context) - (epg--make-temp-file "epg-output")) + (make-temp-file "epg-output")) (if input-file (write-region plain nil input-file nil 'quiet)) (epg-start-encrypt context @@ -1891,7 +1824,7 @@ If you are unsure, use synchronous version of this function (unwind-protect (progn (setf (epg-context-output-file context) - (or file (epg--make-temp-file "epg-output"))) + (or file (make-temp-file "epg-output"))) (epg-start-export-keys context keys) (epg-wait-for-completion context) (let ((errors (epg-context-result-for context 'error))) @@ -2011,40 +1944,6 @@ If you are unsure, use synchronous version of this function (epg-errors-to-string errors)))))) (epg-reset context))) -(defun epg-start-sign-keys (context keys &optional local) - "Initiate a sign keys operation. - -If you use this function, you will need to wait for the completion of -`epg-gpg-program' by using `epg-wait-for-completion' and call -`epg-reset' to clear a temporary output file. -If you are unsure, use synchronous version of this function -`epg-sign-keys' instead." - (declare (obsolete nil "23.1")) - (setf (epg-context-operation context) 'sign-keys) - (setf (epg-context-result context) nil) - (epg--start context (cons (if local - "--lsign-key" - "--sign-key") - (mapcar - (lambda (key) - (epg-sub-key-id - (car (epg-key-sub-key-list key)))) - keys)))) - -(defun epg-sign-keys (context keys &optional local) - "Sign KEYS from the key ring." - (declare (obsolete nil "23.1")) - (unwind-protect - (progn - (epg-start-sign-keys context keys local) - (epg-wait-for-completion context) - (let ((errors (epg-context-result-for context 'error))) - (if errors - (signal 'epg-error - (list "Sign keys failed" - (epg-errors-to-string errors)))))) - (epg-reset context))) - (defun epg-start-generate-key (context parameters) "Initiate a key generation. PARAMETERS is a string which specifies parameters of the generated key. @@ -2129,21 +2028,26 @@ If you are unsure, use synchronous version of this function (epg-reset context))) (defun epg--decode-percent-escape (string) + (setq string (string-to-unibyte string)) (let ((index 0)) - (while (string-match "%\\(\\(%\\)\\|\\([0-9A-Fa-f][0-9A-Fa-f]\\)\\)" + (while (string-match "%\\(\\(%\\)\\|\\([[:xdigit:]][[:xdigit:]]\\)\\)" string index) (if (match-beginning 2) (setq string (replace-match "%" t t string) index (1- (match-end 0))) (setq string (replace-match - (string (string-to-number (match-string 3 string) 16)) + (byte-to-string + (string-to-number (match-string 3 string) 16)) t t string) index (- (match-end 0) 2)))) string)) +(defun epg--decode-percent-escape-as-utf-8 (string) + (decode-coding-string (epg--decode-percent-escape string) 'utf-8)) + (defun epg--decode-hexstring (string) (let ((index 0)) - (while (eq index (string-match "[0-9A-Fa-f][0-9A-Fa-f]" string index)) + (while (eq index (string-match "[[:xdigit:]][[:xdigit:]]" string index)) (setq string (replace-match (string (string-to-number (match-string 0 string) 16)) t t string) @@ -2153,7 +2057,7 @@ If you are unsure, use synchronous version of this function (defun epg--decode-quotedstring (string) (let ((index 0)) (while (string-match "\\\\\\(\\([,=+<>#;\\\"]\\)\\|\ -\\([0-9A-Fa-f][0-9A-Fa-f]\\)\\)" +\\([[:xdigit:]][[:xdigit:]]\\)\\)" string index) (if (match-beginning 2) (setq string (replace-match "\\2" t nil string) @@ -2190,7 +2094,7 @@ The return value is an alist mapping from types to values." string index)) (setq index (match-end 0) value (epg--decode-quotedstring (match-string 0 string))) - (if (eq index (string-match "#\\([0-9A-Fa-f]+\\)" string index)) + (if (eq index (string-match "#\\([[:xdigit:]]+\\)" string index)) (setq index (match-end 0) value (epg--decode-hexstring (match-string 1 string))) (if (eq index (string-match "\"\\([^\\\"]\\|\\\\.\\)*\"" diff --git a/lisp/erc/erc-autoaway.el b/lisp/erc/erc-autoaway.el index d4fda5c7589..9e224e0b828 100644 --- a/lisp/erc/erc-autoaway.el +++ b/lisp/erc/erc-autoaway.el @@ -82,7 +82,7 @@ This is used when `erc-autoaway-idle-method' is 'user." (unless (erc-autoaway-some-server-buffer) (remove-hook 'post-command-hook 'erc-autoaway-reset-idle-user))) -;;;###autoload (autoload 'erc-autoaway-mode "erc-autoaway") +;;;###autoload(autoload 'erc-autoaway-mode "erc-autoaway") (define-erc-module autoaway nil "In ERC autoaway mode, you can be set away automatically. If `erc-auto-set-away' is set, then you will be set away after @@ -282,6 +282,7 @@ active server buffer available." ;;; erc-autoaway.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 3e2a9bc4e56..210830a2b49 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -466,14 +466,18 @@ If this is set to nil, never try to reconnect." The length is specified in `erc-split-line-length'. Currently this is called by `erc-send-input'." - (if (< (length longline) - erc-split-line-length) - (list longline) + (let ((charset (car (erc-coding-system-for-target nil)))) (with-temp-buffer (insert longline) + ;; The line lengths are in octets, not characters (because these + ;; are server protocol limits), so we have to first make the + ;; text into bytes, then fold the bytes on "word" boundaries, + ;; and then make the bytes into text again. + (encode-coding-region (point-min) (point-max) charset) (let ((fill-column erc-split-line-length)) (fill-region (point-min) (point-max) nil t)) + (decode-coding-region (point-min) (point-max) charset) (split-string (buffer-string) "\n")))) (defun erc-forward-word () @@ -644,22 +648,24 @@ Make sure you are in an ERC buffer when running this." (erc-log-irc-protocol line nil) (erc-parse-server-response process line))))))) -(defsubst erc-server-reconnect-p (event) +(define-inline 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." - (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)))) + (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)))))) (defun erc-process-sentinel-2 (event buffer) "Called when `erc-process-sentinel-1' has detected an unexpected disconnect." @@ -838,10 +844,9 @@ Additionally, detect whether the IRC process has hung." erc-server-last-received-time)) (with-current-buffer buf (if (and erc-server-send-ping-timeout - (> - (erc-time-diff (erc-current-time) - erc-server-last-received-time) - erc-server-send-ping-timeout)) + (time-less-p + erc-server-send-ping-timeout + (time-since erc-server-last-received-time))) (progn ;; if the process is hung, kill it (setq erc-server-timed-out t) @@ -859,16 +864,15 @@ Additionally, detect whether the IRC process has hung." See `erc-server-flood-margin' for an explanation of the flood protection algorithm." (with-current-buffer buffer - (let ((now (erc-current-time))) + (let ((now (current-time))) (when erc-server-flood-timer (erc-cancel-timer erc-server-flood-timer) (setq erc-server-flood-timer nil)) - (when (< erc-server-flood-last-message - now) - (setq erc-server-flood-last-message now)) + (when (time-less-p erc-server-flood-last-message now) + (setq erc-server-flood-last-message (erc-emacs-time-to-erc-time now))) (while (and erc-server-flood-queue - (< erc-server-flood-last-message - (+ now erc-server-flood-margin))) + (time-less-p erc-server-flood-last-message + (time-add now erc-server-flood-margin))) (let ((msg (caar erc-server-flood-queue)) (encoding (cdar erc-server-flood-queue))) (setq erc-server-flood-queue (cdr erc-server-flood-queue) @@ -1064,8 +1068,8 @@ Hands off to helper functions via `erc-call-hooks'." erc-server-prevent-duplicates) (let ((m (erc-response.unparsed parsed-response))) ;; duplicate suppression - (if (< (or (gethash m erc-server-duplicates) 0) - (- (erc-current-time) erc-server-duplicate-timeout)) + (if (time-less-p (or (gethash m erc-server-duplicates) 0) + (time-since erc-server-duplicate-timeout)) (erc-call-hooks process parsed-response)) (puthash m (erc-current-time) erc-server-duplicates)) ;; Hand off to the relevant handler. @@ -1281,7 +1285,7 @@ add things to `%s' instead." (pcase-let ((`(,nick ,login ,host) (erc-parse-user (erc-response.sender parsed)))) ;; strip the stupid combined JOIN facility (IRC 2.9) - (if (string-match "^\\(.*\\)?\^g.*$" chnl) + (if (string-match "^\\(.*\\)\^g.*$" chnl) (setq chnl (match-string 1 chnl))) (save-excursion (let* ((str (cond @@ -1441,7 +1445,7 @@ add things to `%s' instead." "Handle pong messages." nil (let ((time (string-to-number (erc-response.contents parsed)))) (when (> time 0) - (setq erc-server-lag (erc-time-diff time (erc-current-time))) + (setq erc-server-lag (erc-time-diff time nil)) (when erc-verbose-server-ping (erc-display-message parsed 'notice proc 'PONG @@ -1724,7 +1728,7 @@ See `erc-display-server-message'." nil (cdr (erc-response.command-args parsed)))) (setq time (when on-since (format-time-string erc-server-timestamp-format - (erc-string-to-emacs-time on-since)))) + (string-to-number on-since)))) (erc-update-user-nick nick nick nil nil nil (and time (format "on since %s" time))) (if time @@ -1796,7 +1800,7 @@ See `erc-display-server-message'." nil (define-erc-response-handler (329) "Channel creation date." nil (let ((channel (cadr (erc-response.command-args parsed))) - (time (erc-string-to-emacs-time + (time (string-to-number (nth 2 (erc-response.command-args parsed))))) (erc-display-message parsed 'notice (erc-get-buffer channel proc) @@ -1838,7 +1842,7 @@ See `erc-display-server-message'." nil (pcase-let ((`(,channel ,nick ,time) (cdr (erc-response.command-args parsed)))) (setq time (format-time-string erc-server-timestamp-format - (erc-string-to-emacs-time time))) + (string-to-number time))) (erc-update-channel-topic channel (format "\C-o (%s, %s)" nick time) 'append) diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index a381464b8cd..c2702081daf 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -49,7 +49,7 @@ "Define how text can be turned into clickable buttons." :group 'erc) -;;;###autoload (autoload 'erc-button-mode "erc-button" nil t) +;;;###autoload(autoload 'erc-button-mode "erc-button" nil t) (define-erc-module button nil "This mode buttonizes all messages according to `erc-button-alist'." ((add-hook 'erc-insert-modify-hook 'erc-button-add-buttons 'append) @@ -59,11 +59,7 @@ ((remove-hook 'erc-insert-modify-hook 'erc-button-add-buttons) (remove-hook 'erc-send-modify-hook 'erc-button-add-buttons) (remove-hook 'erc-complete-functions 'erc-button-next-function) - (remove-hook 'erc-mode-hook 'erc-button-setup) - (when (featurep 'xemacs) - (dolist (buffer (erc-buffer-list)) - (with-current-buffer buffer - (kill-local-variable 'widget-button-face)))))) + (remove-hook 'erc-mode-hook 'erc-button-setup))) ;;; Variables @@ -121,9 +117,13 @@ longer than `erc-fill-column'." :group 'erc-button :type 'string) -(defcustom erc-button-google-url "http://www.google.com/search?q=%s" - "URL used to browse Google search references. +(define-obsolete-variable-alias 'erc-button-google-url + 'erc-button-search-url "27.1") + +(defcustom erc-button-search-url "http://duckduckgo.com/?q=%s" + "URL used to search for a term. %s is replaced by the search string." + :version "27.1" :group 'erc-button :type 'string) @@ -148,7 +148,7 @@ longer than `erc-fill-column'." ("Lisp:\\([a-zA-Z.+-]+\\)" 0 t erc-browse-emacswiki-lisp 1) ("\\bGoogle:\\([^ \t\n\r\f]+\\)" 0 t (lambda (keywords) - (browse-url (format erc-button-google-url keywords))) + (browse-url (format erc-button-search-url keywords))) 1) ("\\brfc[#: ]?\\([0-9]+\\)" 0 t (lambda (num) @@ -214,9 +214,7 @@ PAR is a number of a regexp grouping whose text will be passed to (defvar erc-button-keymap (let ((map (make-sparse-keymap))) (define-key map (kbd "RET") 'erc-button-press-button) - (if (featurep 'xemacs) - (define-key map (kbd "<button2>") 'erc-button-click-button) - (define-key map (kbd "<mouse-2>") 'erc-button-click-button)) + (define-key map (kbd "<mouse-2>") 'erc-button-click-button) (define-key map (kbd "TAB") 'erc-button-next) (define-key map (kbd "<backtab>") 'erc-button-previous) (define-key map [follow-link] 'mouse-face) @@ -251,8 +249,6 @@ global-level ERC button keys yet.") (defun erc-button-setup () "Add ERC mode-level button movement keys. This is only done once." ;; Make XEmacs use `erc-button-face'. - (when (featurep 'xemacs) - (set (make-local-variable 'widget-button-face) nil)) ;; Add keys. (unless erc-button-keys-added (define-key erc-mode-map (kbd "<backtab>") 'erc-button-previous) @@ -370,18 +366,7 @@ REGEXP is the regular expression which matched for this button." (list 'erc-callback fun) (list 'keymap erc-button-keymap) (list 'rear-nonsticky t) - (and data (list 'erc-data data)))) - (when (featurep 'xemacs) - (widget-convert-button 'link from to :action 'erc-button-press-button - :suppress-face t - ;; Make XEmacs use our faces. - :button-face (if nick-p - erc-button-nickname-face - erc-button-face) - ;; Make XEmacs behave with mouse-clicks, for - ;; some reason, widget stuff overrides the - ;; 'keymap text-property. - :mouse-down-action 'erc-button-click-button))) + (and data (list 'erc-data data))))) (defun erc-button-add-face (from to face) "Add FACE to the region between FROM and TO." @@ -545,5 +530,6 @@ and `apropos' for other symbols." ;;; erc-button.el ends here ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: nil ;; End: diff --git a/lisp/erc/erc-capab.el b/lisp/erc/erc-capab.el index fa7c83a194c..210a7736cc0 100644 --- a/lisp/erc/erc-capab.el +++ b/lisp/erc/erc-capab.el @@ -90,7 +90,7 @@ character not found in IRC nicknames to avoid confusion." ;;; Define module: -;;;###autoload (autoload 'erc-capab-identify-mode "erc-capab" nil t) +;;;###autoload(autoload 'erc-capab-identify-mode "erc-capab" nil t) (define-erc-module capab-identify nil "Handle dancer-ircd's CAPAB IDENTIFY-MSG and IDENTIFY-CTCP." ;; append so that `erc-server-parameters' is already set by `erc-server-005' @@ -207,3 +207,7 @@ PARSED is an `erc-parsed' response struct." (provide 'erc-capab) ;;; erc-capab.el ends here + +;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" +;; End: diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index 243816d4c4d..aae0f09a2c5 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -29,7 +29,7 @@ (require 'format-spec) -;;;###autoload (autoload 'erc-define-minor-mode "erc-compat") +;;;###autoload(autoload 'erc-define-minor-mode "erc-compat") (defalias 'erc-define-minor-mode 'define-minor-mode) (put 'erc-define-minor-mode 'edebug-form-spec 'define-minor-mode) @@ -71,17 +71,13 @@ See `erc-encoding-coding-alist'." are placed. Note that this should end with a directory separator.") -;; XEmacs's `replace-match' does not replace matching subexpressions in strings. (defun erc-replace-match-subexpression-in-string (newtext string match subexp start &optional fixedcase literal) "Replace the subexpression SUBEXP of the last match in STRING with NEWTEXT. MATCH is the text which matched the subexpression (see `match-string'). START is the beginning position of the last match (see `match-beginning'). See `replace-match' for explanations of FIXEDCASE and LITERAL." - (cond ((featurep 'xemacs) - (string-match match string start) - (replace-match newtext fixedcase literal string)) - (t (replace-match newtext fixedcase literal string subexp)))) + (replace-match newtext fixedcase literal string subexp)) (defalias 'erc-with-selected-window 'with-selected-window) (defalias 'erc-cancel-timer 'cancel-timer) @@ -161,6 +157,7 @@ If START or END is negative, it counts from the end." ;;; erc-compat.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index 2b41c8c705b..526add1a61f 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -47,16 +47,15 @@ ;; /dcc get nick [file] - Accept DCC offer from nick ;; /dcc list - List all DCC offers/connections ;; /dcc send nick file - Offer DCC SEND to nick -;; -;; Please note that offering DCC connections (offering chats and sending -;; files) is only supported with Emacs 22. ;;; Code: (require 'erc) -(eval-when-compile (require 'pcomplete)) +;; Strictly speaking, should only be needed at compile time. +;; Require at run-time too to silence compiler. +(require 'pcomplete) -;;;###autoload (autoload 'erc-dcc-mode "erc-dcc") +;;;###autoload(autoload 'erc-dcc-mode "erc-dcc") (define-erc-module dcc nil "Provide Direct Client-to-Client support for ERC." ((add-hook 'erc-server-401-functions 'erc-dcc-no-such-nick)) @@ -222,14 +221,6 @@ which is big-endian." (setq i (1- i))) str)) -(defconst erc-most-positive-int-bytes - (ceiling (/ (ceiling (/ (log most-positive-fixnum) (log 2))) 8.0)) - "Maximum number of bytes for a fixnum.") - -(defconst erc-most-positive-int-msb - (lsh most-positive-fixnum (- 0 (* 8 (1- erc-most-positive-int-bytes)))) - "Content of the most significant byte of most-positive-fixnum.") - (defun erc-unpack-int (str) "Unpack a packed string into an integer." (let ((len (length str))) @@ -240,16 +231,11 @@ which is big-endian." (when (> start 0) (setq str (substring str start)) (setq len (- len start)))) - ;; make sure size is not larger than Emacs can handle - (when (or (> len (min 4 erc-most-positive-int-bytes)) - (and (eq len erc-most-positive-int-bytes) - (> (aref str 0) erc-most-positive-int-msb))) - (error "ERC-DCC (erc-unpack-int): packet to send is too large")) ;; unpack (let ((num 0) (count 0)) (while (< count len) - (setq num (+ num (lsh (aref str (- len count 1)) (* 8 count)))) + (setq num (+ num (ash (aref str (- len count 1)) (* 8 count)))) (setq count (1+ count))) num))) @@ -365,7 +351,6 @@ created subprocess, or nil." :buffer nil :host (erc-dcc-host) :service port - :nowait t :noquery nil :filter filter :sentinel sentinel @@ -433,23 +418,23 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc." (when (fboundp 'make-network-process) '("send")))) (pcomplete-here (pcase (intern (downcase (pcomplete-arg 1))) - (`chat (mapcar (lambda (elt) (plist-get elt :nick)) + ('chat (mapcar (lambda (elt) (plist-get elt :nick)) (erc-remove-if-not #'(lambda (elt) (eq (plist-get elt :type) 'CHAT)) erc-dcc-list))) - (`close (erc-delete-dups + ('close (erc-delete-dups (mapcar (lambda (elt) (symbol-name (plist-get elt :type))) erc-dcc-list))) - (`get (mapcar #'erc-dcc-nick + ('get (mapcar #'erc-dcc-nick (erc-remove-if-not #'(lambda (elt) (eq (plist-get elt :type) 'GET)) erc-dcc-list))) - (`send (pcomplete-erc-all-nicks)))) + ('send (pcomplete-erc-all-nicks)))) (pcomplete-here (pcase (intern (downcase (pcomplete-arg 2))) - (`get (mapcar (lambda (elt) (plist-get elt :file)) + ('get (mapcar (lambda (elt) (plist-get elt :file)) (erc-remove-if-not #'(lambda (elt) (and (eq (plist-get elt :type) 'GET) @@ -457,13 +442,13 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc." (plist-get elt :nick)) (pcomplete-arg 1)))) erc-dcc-list))) - (`close (mapcar #'erc-dcc-nick + ('close (mapcar #'erc-dcc-nick (erc-remove-if-not #'(lambda (elt) (eq (plist-get elt :type) (intern (upcase (pcomplete-arg 1))))) erc-dcc-list))) - (`send (pcomplete-entries))))) + ('send (pcomplete-entries))))) (defun erc-dcc-do-CHAT-command (proc &optional nick) (when nick @@ -649,9 +634,10 @@ that subcommand." "\"\\(\\(.*?\\(\\\\\"\\)?\\)+?\\)\"\\|\\([^ ]+\\)" "\\) \\([0-9]+\\) \\([0-9]+\\) *\\([0-9]*\\)")) -(defsubst erc-dcc-unquote-filename (filename) - (erc-replace-regexp-in-string "\\\\\\\\" "\\" - (erc-replace-regexp-in-string "\\\\\"" "\"" filename t t) t t)) +(define-inline erc-dcc-unquote-filename (filename) + (inline-quote + (erc-replace-regexp-in-string "\\\\\\\\" "\\" + (erc-replace-regexp-in-string "\\\\\"" "\"" ,filename t t) t t))) (defun erc-dcc-handle-ctcp-send (proc query nick login host to) "This is called if a CTCP DCC SEND subcommand is sent to the client. @@ -780,8 +766,8 @@ unconfirmed." :group 'erc-dcc :type '(choice (const nil) integer)) -(defsubst erc-dcc-get-parent (proc) - (plist-get (erc-dcc-member :peer proc) :parent)) +(define-inline erc-dcc-get-parent (proc) + (inline-quote (plist-get (erc-dcc-member :peer ,proc) :parent))) (defun erc-dcc-send-block (proc) "Send one block of data. @@ -824,8 +810,8 @@ bytes sent." ?s (number-to-string (- sent-marker (point-min)))) (setq erc-dcc-list (delete elt erc-dcc-list)) (set-buffer-modified-p nil) - (kill-buffer (current-buffer)) - (delete-process proc)) + (delete-process proc) + (kill-buffer (current-buffer))) ((<= confirmed-marker sent-marker) (while (and (< (- sent-marker confirmed-marker) (or erc-dcc-pump-bytes @@ -838,8 +824,8 @@ bytes sent." (marker-position confirmed-marker) (marker-position sent-marker))) (set-buffer-modified-p nil) - (kill-buffer (current-buffer)) - (delete-process proc)))))) + (delete-process proc) + (kill-buffer (current-buffer))))))) (defun erc-dcc-display-send (proc) (erc-display-message @@ -931,10 +917,7 @@ filter and a process sentinel, and making the connection." (buffer-disable-undo (current-buffer)) ;; This is necessary to have the buffer saved as-is in GNU ;; Emacs. - ;; XEmacs change: We don't have `set-buffer-multibyte', setting - ;; coding system to 'binary below takes care of us. - (when (fboundp 'set-buffer-multibyte) - (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (setq mode-line-process '(":%s") buffer-read-only t) @@ -989,8 +972,9 @@ rather than every 1024 byte block, but nobody seems to care." (let ((inhibit-read-only t) received-bytes) (goto-char (point-max)) - (if str - (insert (string-make-unibyte str))) + (when str + (cl-assert (not (multibyte-string-p str))) + (insert str)) (when (> (point-max) erc-dcc-receive-cache) (erc-dcc-append-contents (current-buffer) erc-dcc-file-name)) @@ -1034,7 +1018,7 @@ transfer is complete." ?s (number-to-string erc-dcc-byte-count) ?t (format "%.0f" (erc-time-diff (plist-get erc-dcc-entry-data :start-time) - (erc-current-time))))) + nil)))) (kill-buffer (process-buffer proc)) (delete-process proc)) @@ -1094,14 +1078,14 @@ Possible values are: ask, auto, ignore." (pcomplete-here '("auto" "ask" "ignore"))) (defalias 'pcomplete/erc-mode/SREQ 'pcomplete/erc-mode/CREQ) +(define-obsolete-variable-alias 'erc-dcc-chat-filter-hook + 'erc-dcc-chat-filter-functions "24.3") + (defvar erc-dcc-chat-filter-functions '(erc-dcc-chat-parse-output) "Abnormal hook run after parsing (and maybe inserting) a DCC message. Each function is called with two arguments: the ERC process and the unprocessed output.") -(define-obsolete-variable-alias 'erc-dcc-chat-filter-hook - 'erc-dcc-chat-filter-functions "24.3") - (defvar erc-dcc-chat-mode-map (let ((map (make-sparse-keymap))) (define-key map (kbd "RET") 'erc-send-current-line) @@ -1260,5 +1244,6 @@ other client." ;;; erc-dcc.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: nil ;; End: diff --git a/lisp/erc/erc-desktop-notifications.el b/lisp/erc/erc-desktop-notifications.el index 66f27d92ebb..41b7420320c 100644 --- a/lisp/erc/erc-desktop-notifications.el +++ b/lisp/erc/erc-desktop-notifications.el @@ -1,4 +1,4 @@ -;; erc-desktop-notifications.el -- Send notification on PRIVMSG or mentions +;; erc-desktop-notifications.el -- Send notification on PRIVMSG or mentions -*- lexical-binding:t -*- ;; Copyright (C) 2012-2019 Free Software Foundation, Inc. @@ -59,13 +59,19 @@ This will replace the last notification sent with this function." (dbus-ignore-errors (setq erc-notifications-last-notification - (notifications-notify :bus erc-notifications-bus - :title (xml-escape-string nick) - :body (xml-escape-string msg) - :replaces-id erc-notifications-last-notification - :app-icon erc-notifications-icon)))) - -(defun erc-notifications-PRIVMSG (proc parsed) + (let ((channel (current-buffer))) + (notifications-notify :bus erc-notifications-bus + :title (format "%s in %s" + (xml-escape-string nick) + channel) + :body (xml-escape-string msg) + :replaces-id erc-notifications-last-notification + :app-icon erc-notifications-icon + :actions '("default" "Switch to buffer") + :on-action (lambda (&rest _) + (pop-to-buffer channel))))))) + +(defun erc-notifications-PRIVMSG (_proc parsed) (let ((nick (car (erc-parse-user (erc-response.sender parsed)))) (target (car (erc-response.command-args parsed))) (msg (erc-response.contents parsed))) @@ -98,3 +104,7 @@ This will replace the last notification sent with this function." (provide 'erc-desktop-notifications) ;;; erc-desktop-notifications.el ends here + +;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" +;; End: diff --git a/lisp/erc/erc-ezbounce.el b/lisp/erc/erc-ezbounce.el index 520ee2ddf17..a2c9336826a 100644 --- a/lisp/erc/erc-ezbounce.el +++ b/lisp/erc/erc-ezbounce.el @@ -175,3 +175,7 @@ in the alist is nil, prompt for the appropriate values." (provide 'erc-ezbounce) ;;; erc-ezbounce.el ends here + +;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" +;; End: diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el index 36187256dc7..934b52a938c 100644 --- a/lisp/erc/erc-fill.el +++ b/lisp/erc/erc-fill.el @@ -37,7 +37,7 @@ "Filling means to reformat long lines in different ways." :group 'erc) -;;;###autoload (autoload 'erc-fill-mode "erc-fill" nil t) +;;;###autoload(autoload 'erc-fill-mode "erc-fill" nil t) (erc-define-minor-mode erc-fill-mode "Toggle ERC fill mode. With a prefix argument ARG, enable ERC fill mode if ARG is @@ -193,5 +193,6 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'." ;;; erc-fill.el ends here ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: nil ;; End: diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index 117b6783b8d..5e7946810be 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -177,18 +177,20 @@ does not appear in the ERC buffer after the user presses ENTER.") "This mode distinguishes non-commands. Commands listed in `erc-insert-this' know how to display themselves." - ((add-hook 'erc-send-pre-hook 'erc-send-distinguish-noncommands)) - ((remove-hook 'erc-send-pre-hook 'erc-send-distinguish-noncommands))) + ((add-hook 'erc-pre-send-functions 'erc-send-distinguish-noncommands)) + ((remove-hook 'erc-pre-send-functions 'erc-send-distinguish-noncommands))) -(defun erc-send-distinguish-noncommands (str) - "If STR is an ERC non-command, set `erc-insert-this' to nil." - (let* ((command (erc-extract-command-from-line str)) +(defun erc-send-distinguish-noncommands (state) + "If STR is an ERC non-command, set `insertp' in STATE to nil." + (let* ((string (erc-input-string state)) + (command (erc-extract-command-from-line string)) (cmd-fun (and command (car command)))) (when (and cmd-fun - (not (string-match "\n.+$" str)) + (not (string-match "\n.+$" string)) (memq cmd-fun erc-noncommands-list)) - (setq erc-insert-this nil)))) + ;; Inhibit sending this string. + (setf (erc-input-insertp state) nil)))) ;;; IRC control character processing. (defgroup erc-control-characters nil @@ -548,7 +550,7 @@ channel that has weird people talking in morse to each other. See also `unmorse-region'." (goto-char (point-min)) - (when (re-search-forward "[.-]+\\([.-]*/? *\\)+[.-]+/?" nil t) + (when (re-search-forward "[.-]+[./ -]*[.-]/?" nil t) (save-restriction (narrow-to-region (match-beginning 0) (match-end 0)) ;; Turn " / " into " " diff --git a/lisp/erc/erc-identd.el b/lisp/erc/erc-identd.el index 385410496a5..d95e0eac0c7 100644 --- a/lisp/erc/erc-identd.el +++ b/lisp/erc/erc-identd.el @@ -55,7 +55,7 @@ This can be either a string or a number." (integer :tag "Port number") (string :tag "Port string"))) -;;;###autoload (autoload 'erc-identd-mode "erc-identd") +;;;###autoload(autoload 'erc-identd-mode "erc-identd") (define-erc-module identd nil "This mode launches an identd server on port 8113." ((add-hook 'erc-connect-pre-hook 'erc-identd-quickstart) @@ -115,6 +115,7 @@ The default port is specified by `erc-identd-port'." ;;; erc-identd.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-imenu.el b/lisp/erc/erc-imenu.el index be8e0b07235..08f52f13647 100644 --- a/lisp/erc/erc-imenu.el +++ b/lisp/erc/erc-imenu.el @@ -131,6 +131,7 @@ Don't rely on this function, read it first!" ;;; erc-imenu.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-join.el b/lisp/erc/erc-join.el index 83f7a045575..c292fdbd797 100644 --- a/lisp/erc/erc-join.el +++ b/lisp/erc/erc-join.el @@ -39,7 +39,7 @@ "Enable autojoining." :group 'erc) -;;;###autoload (autoload 'erc-autojoin-mode "erc-join" nil t) +;;;###autoload(autoload 'erc-autojoin-mode "erc-join" nil t) (define-erc-module autojoin nil "Makes ERC autojoin on connects and reconnects." ((add-hook 'erc-after-connect 'erc-autojoin-channels) @@ -161,6 +161,10 @@ This function is run from `erc-nickserv-identified-hook'." ;; Only auto-join the channels that we aren't already in ;; using a different nick. (when (or (not buffer) + ;; If the same channel is joined on another + ;; server the best-effort is to just join + (not (string-match (car l) + (process-name erc-server-process))) (not (with-current-buffer buffer (erc-server-process-alive)))) (erc-server-join-channel server chan)))))))) @@ -215,6 +219,7 @@ This function is run from `erc-nickserv-identified-hook'." ;;; erc-join.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-list.el b/lisp/erc/erc-list.el index f354ff5ae09..d8d9e17c95a 100644 --- a/lisp/erc/erc-list.el +++ b/lisp/erc/erc-list.el @@ -55,7 +55,7 @@ (defvar erc-list-server-buffer nil) ;; Define module: -;;;###autoload (autoload 'erc-list-mode "erc-list") +;;;###autoload(autoload 'erc-list-mode "erc-list") (define-erc-module list nil "List channels nicely in a separate buffer." ((remove-hook 'erc-server-321-functions 'erc-server-321-message) @@ -225,6 +225,7 @@ to RFC and send the LIST header (#321) at start of list transmission." ;;; erc-list.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el index 59d157576dc..1c046fe20cb 100644 --- a/lisp/erc/erc-log.el +++ b/lisp/erc/erc-log.el @@ -122,7 +122,7 @@ custom function which returns the directory part and set (function :tag "Other function"))) (defcustom erc-truncate-buffer-on-save nil - "Truncate any ERC (channel, query, server) buffer when it is saved." + "Erase the contents of any ERC (channel, query, server) buffer when it is saved." :group 'erc-log :type 'boolean) @@ -195,9 +195,7 @@ If you set this to nil, you may want to enable both :group 'erc-log :type 'boolean) -(defcustom erc-log-file-coding-system (if (featurep 'xemacs) - 'binary - 'emacs-mule) +(defcustom erc-log-file-coding-system 'emacs-mule "The coding system ERC should use for writing log files. This should ideally, be a \"catch-all\" coding system, like @@ -215,7 +213,7 @@ The function should take one argument, which is the text to filter." (const :tag "No filtering" nil))) -;;;###autoload (autoload 'erc-log-mode "erc-log" nil t) +;;;###autoload(autoload 'erc-log-mode "erc-log" nil t) (define-erc-module log nil "Automatically logs things you receive on IRC into files. Files are stored in `erc-log-channels-directory'; file name @@ -344,18 +342,19 @@ If BUFFER is nil, the value of `current-buffer' is used. This is determined by `erc-generate-log-file-name-function'. The result is converted to lowercase, as IRC is case-insensitive" (unless buffer (setq buffer (current-buffer))) - (let ((target (or (buffer-name buffer) (erc-default-target))) - (nick (erc-current-nick)) - (server erc-session-server) - (port erc-session-port)) - (expand-file-name - (erc-log-standardize-name - (funcall erc-generate-log-file-name-function - buffer target nick server port)) - (if (functionp erc-log-channels-directory) - (funcall erc-log-channels-directory - buffer target nick server port) - erc-log-channels-directory)))) + (with-current-buffer buffer + (let ((target (or (buffer-name buffer) (erc-default-target))) + (nick (erc-current-nick)) + (server erc-session-server) + (port erc-session-port)) + (expand-file-name + (erc-log-standardize-name + (funcall erc-generate-log-file-name-function + buffer target nick server port)) + (if (functionp erc-log-channels-directory) + (funcall erc-log-channels-directory + buffer target nick server port) + erc-log-channels-directory))))) (defun erc-generate-log-file-name-with-date (buffer &rest ignore) "This function computes a short log file name. @@ -456,6 +455,7 @@ You can save every individual message by putting this function on ;;; erc-log.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index 250266c82e6..cc4b4a88f11 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -44,7 +44,7 @@ Group containing all things concerning pattern matching in ERC messages." :group 'erc) -;;;###autoload (autoload 'erc-match-mode "erc-match") +;;;###autoload(autoload 'erc-match-mode "erc-match") (define-erc-module match nil "This mode checks whether messages match certain patterns. If so, they are hidden or highlighted. This is controlled via the variables @@ -601,7 +601,7 @@ See `erc-log-match-format'." 'timestamp)))) (away-time (erc-emacs-time-to-erc-time (erc-away-time)))) (when (and away-time last-msg-time - (erc-time-gt last-msg-time away-time)) + (time-less-p away-time last-msg-time)) (erc-display-message nil 'notice 'active (format "You have logged messages waiting in \"%s\"." @@ -648,6 +648,7 @@ This function is meant to be called from `erc-text-matched-hook'." ;;; erc-match.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-menu.el b/lisp/erc/erc-menu.el index 5696306342c..17e36984ea6 100644 --- a/lisp/erc/erc-menu.el +++ b/lisp/erc/erc-menu.el @@ -107,7 +107,7 @@ "Internal variable used to keep track of whether we've defined the ERC menu yet.") -;;;###autoload (autoload 'erc-menu-mode "erc-menu" nil t) +;;;###autoload(autoload 'erc-menu-mode "erc-menu" nil t) (define-erc-module menu nil "Enable a menu in ERC buffers." ((unless erc-menu-defined @@ -115,22 +115,10 @@ ERC menu yet.") ;; activates it immediately (easy-menu-define erc-menu erc-mode-map "ERC menu" erc-menu-definition) (setq erc-menu-defined t)) - (if (featurep 'xemacs) - (progn - ;; the menu isn't automatically added to the menu bar in - ;; XEmacs - (add-hook 'erc-mode-hook 'erc-menu-add) - (dolist (buffer (erc-buffer-list)) - (with-current-buffer buffer (erc-menu-add)))) - (erc-menu-add))) - ((if (featurep 'xemacs) - (progn - (remove-hook 'erc-mode-hook 'erc-menu-add) - (dolist (buffer (erc-buffer-list)) - (with-current-buffer buffer (erc-menu-remove)))) - (erc-menu-remove) - ;; `easy-menu-remove' is a no-op in Emacs 22 - (message "You might have to restart Emacs to remove the ERC menu")))) + (erc-menu-add)) + ((erc-menu-remove) + ;; `easy-menu-remove' is a no-op in Emacs 22 + (message "You might have to restart Emacs to remove the ERC menu"))) ;; silence byte-compiler warning (defvar erc-menu) @@ -148,6 +136,7 @@ ERC menu yet.") ;;; erc-menu.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-netsplit.el b/lisp/erc/erc-netsplit.el index a2f271f2f4b..87c3a61b663 100644 --- a/lisp/erc/erc-netsplit.el +++ b/lisp/erc/erc-netsplit.el @@ -38,7 +38,7 @@ netsplit happens, and filters the QUIT messages. It also keeps track of netsplits, so that it can filter the JOIN messages on a netjoin too." :group 'erc) -;;;###autoload (autoload 'erc-netsplit-mode "erc-netsplit") +;;;###autoload(autoload 'erc-netsplit-mode "erc-netsplit") (define-erc-module netsplit nil "This mode hides quit/join messages if a netsplit occurs." ((erc-netsplit-install-message-catalogs) @@ -205,6 +205,7 @@ join from that split has been detected or not.") ;;; erc-netsplit.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-notify.el b/lisp/erc/erc-notify.el index 19045a6d1bf..45dae899900 100644 --- a/lisp/erc/erc-notify.el +++ b/lisp/erc/erc-notify.el @@ -92,7 +92,7 @@ strings." (notify_on . "Detected %n on IRC network %m") (notify_off . "%n has left IRC network %m")))) -;;;###autoload (autoload 'erc-notify-mode "erc-notify" nil t) +;;;###autoload(autoload 'erc-notify-mode "erc-notify" nil t) (define-erc-module notify nil "Periodically check for the online status of certain users and report changes." @@ -253,6 +253,7 @@ with args, toggle notify status of people." ;;; erc-notify.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-page.el b/lisp/erc/erc-page.el index 7f1378c7243..cb57883ae6f 100644 --- a/lisp/erc/erc-page.el +++ b/lisp/erc/erc-page.el @@ -30,7 +30,7 @@ (require 'erc) -;;;###autoload (autoload 'erc-page-mode "erc-page") +;;;###autoload(autoload 'erc-page-mode "erc-page") (define-erc-module page ctcp-page "Process CTCP PAGE requests from IRC." nil nil) @@ -107,6 +107,7 @@ receive pages if `erc-page-mode' is on." ;;; erc-page.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-pcomplete.el b/lisp/erc/erc-pcomplete.el index a67787fb6f9..dd2da85d0e8 100644 --- a/lisp/erc/erc-pcomplete.el +++ b/lisp/erc/erc-pcomplete.el @@ -60,7 +60,7 @@ the most recent speakers are listed first." :group 'erc-pcomplete :type 'boolean) -;;;###autoload (autoload 'erc-completion-mode "erc-pcomplete" nil t) +;;;###autoload(autoload 'erc-completion-mode "erc-pcomplete" nil t) (define-erc-module pcomplete Completion "In ERC Completion mode, the TAB key does completion whenever possible." ((add-hook 'erc-mode-hook 'pcomplete-erc-setup) @@ -284,5 +284,6 @@ up to where point is right now." ;;; erc-pcomplete.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: nil ;; End: diff --git a/lisp/erc/erc-replace.el b/lisp/erc/erc-replace.el index 80ff99cc975..2e0e54a030f 100644 --- a/lisp/erc/erc-replace.el +++ b/lisp/erc/erc-replace.el @@ -77,7 +77,7 @@ It replaces text according to `erc-replace-alist'." (eval to)))))) erc-replace-alist)) -;;;###autoload (autoload 'erc-replace-mode "erc-replace") +;;;###autoload(autoload 'erc-replace-mode "erc-replace") (define-erc-module replace nil "This mode replaces incoming text according to `erc-replace-alist'." ((add-hook 'erc-insert-modify-hook @@ -90,6 +90,7 @@ It replaces text according to `erc-replace-alist'." ;;; erc-replace.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-ring.el b/lisp/erc/erc-ring.el index 8ec9f8ffa25..453e234a37a 100644 --- a/lisp/erc/erc-ring.el +++ b/lisp/erc/erc-ring.el @@ -42,14 +42,14 @@ "An input ring for ERC." :group 'erc) -;;;###autoload (autoload 'erc-ring-mode "erc-ring" nil t) +;;;###autoload(autoload 'erc-ring-mode "erc-ring" nil t) (define-erc-module ring nil "Stores input in a ring so that previous commands and messages can be recalled using M-p and M-n." - ((add-hook 'erc-send-pre-hook 'erc-add-to-input-ring) + ((add-hook 'erc-pre-send-functions 'erc-add-to-input-ring) (define-key erc-mode-map "\M-p" 'erc-previous-command) (define-key erc-mode-map "\M-n" 'erc-next-command)) - ((remove-hook 'erc-send-pre-hook 'erc-add-to-input-ring) + ((remove-hook 'erc-pre-send-functions 'erc-add-to-input-ring) (define-key erc-mode-map "\M-p" 'undefined) (define-key erc-mode-map "\M-n" 'undefined))) @@ -71,10 +71,10 @@ Call this function when setting up the mode." (setq erc-input-ring (make-ring comint-input-ring-size))) (setq erc-input-ring-index nil)) -(defun erc-add-to-input-ring (s) +(defun erc-add-to-input-ring (state) "Add string S to the input ring and reset history position." (unless erc-input-ring (erc-input-ring-setup)) - (ring-insert erc-input-ring s) + (ring-insert erc-input-ring (erc-input-string state)) (setq erc-input-ring-index nil)) (defun erc-clear-input-ring () @@ -146,5 +146,6 @@ containing a password." ;;; erc-ring.el ends here ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: nil ;; End: diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el index b6bceff205c..886ba60eb47 100644 --- a/lisp/erc/erc-services.el +++ b/lisp/erc/erc-services.el @@ -1,4 +1,4 @@ -;;; erc-services.el --- Identify to NickServ +;;; erc-services.el --- Identify to NickServ -*- lexical-binding:t -*- ;; Copyright (C) 2002-2004, 2006-2019 Free Software Foundation, Inc. @@ -89,7 +89,7 @@ Possible settings are:. latter. nil - Disables automatic Nickserv identification. -You can also use M-x erc-nickserv-identify-mode to change modes." +You can also use \\[erc-nickserv-identify-mode] to change modes." :group 'erc-services :type '(choice (const autodetect) (const nick-change) @@ -101,7 +101,7 @@ You can also use M-x erc-nickserv-identify-mode to change modes." (when (featurep 'erc-services) (erc-nickserv-identify-mode val)))) -;;;###autoload (autoload 'erc-services-mode "erc-services" nil t) +;;;###autoload(autoload 'erc-services-mode "erc-services" nil t) (define-erc-module services nickserv "This mode automates communication with services." ((erc-nickserv-identify-mode erc-nickserv-identify-mode)) @@ -214,7 +214,7 @@ Example of use: "identify" nil nil nil) (Azzurra "NickServ!service@azzurra.org" - "/ns\\s-IDENTIFY\\s-password" + "\^B/ns\\s-IDENTIFY\\s-password\^B" "NickServ" "IDENTIFY" nil nil nil) (BitlBee @@ -223,7 +223,7 @@ Example of use: "identify" nil nil nil) (BRASnet "NickServ!services@brasnet.org" - "/NickServ\\s-IDENTIFY\\s-senha" + "\^B/NickServ\\s-IDENTIFY\\s-\^_senha\^_\^B" "NickServ" "IDENTIFY" nil "" nil) (DALnet @@ -262,7 +262,7 @@ Example of use: nil "NickServ" "IDENTIFY" nil nil - "You\\s-are\\s-successfully\\s-identified\\s-as\\s-") + "You\\s-are\\s-successfully\\s-identified\\s-as\\s-\^B") (Rizon "NickServ!service@rizon.net" "This\\s-nickname\\s-is\\s-registered\\s-and\\s-protected." @@ -275,7 +275,7 @@ Example of use: "auth" t nil nil) (SlashNET "NickServ!services@services.slashnet.org" - "/msg\\s-NickServ\\s-IDENTIFY\\s-password" + "/msg\\s-NickServ\\s-IDENTIFY\\s-\^_password" "NickServ@services.slashnet.org" "IDENTIFY" nil nil nil)) "Alist of NickServer details, sorted by network. @@ -312,26 +312,33 @@ The last two elements are optional." (const :tag "Do not try to detect success" nil))))) -(defsubst erc-nickserv-alist-sender (network &optional entry) - (nth 1 (or entry (assoc network erc-nickserv-alist)))) +(define-inline erc-nickserv-alist-sender (network &optional entry) + (inline-letevals (network entry) + (inline-quote (nth 1 (or ,entry (assoc ,network erc-nickserv-alist)))))) -(defsubst erc-nickserv-alist-regexp (network &optional entry) - (nth 2 (or entry (assoc network erc-nickserv-alist)))) +(define-inline erc-nickserv-alist-regexp (network &optional entry) + (inline-letevals (network entry) + (inline-quote (nth 2 (or ,entry (assoc ,network erc-nickserv-alist)))))) -(defsubst erc-nickserv-alist-nickserv (network &optional entry) - (nth 3 (or entry (assoc network erc-nickserv-alist)))) +(define-inline erc-nickserv-alist-nickserv (network &optional entry) + (inline-letevals (network entry) + (inline-quote (nth 3 (or ,entry (assoc ,network erc-nickserv-alist)))))) -(defsubst erc-nickserv-alist-ident-keyword (network &optional entry) - (nth 4 (or entry (assoc network erc-nickserv-alist)))) +(define-inline erc-nickserv-alist-ident-keyword (network &optional entry) + (inline-letevals (network entry) + (inline-quote (nth 4 (or ,entry (assoc ,network erc-nickserv-alist)))))) -(defsubst erc-nickserv-alist-use-nick-p (network &optional entry) - (nth 5 (or entry (assoc network erc-nickserv-alist)))) +(define-inline erc-nickserv-alist-use-nick-p (network &optional entry) + (inline-letevals (network entry) + (inline-quote (nth 5 (or ,entry (assoc ,network erc-nickserv-alist)))))) -(defsubst erc-nickserv-alist-ident-command (network &optional entry) - (nth 6 (or entry (assoc network erc-nickserv-alist)))) +(define-inline erc-nickserv-alist-ident-command (network &optional entry) + (inline-letevals (network entry) + (inline-quote (nth 6 (or ,entry (assoc ,network erc-nickserv-alist)))))) -(defsubst erc-nickserv-alist-identified-regexp (network &optional entry) - (nth 7 (or entry (assoc network erc-nickserv-alist)))) +(define-inline erc-nickserv-alist-identified-regexp (network &optional entry) + (inline-letevals (network entry) + (inline-quote (nth 7 (or ,entry (assoc ,network erc-nickserv-alist)))))) ;; Functions: @@ -341,7 +348,7 @@ Hooks are called with arguments (NETWORK NICK)." :group 'erc-services :type 'hook) -(defun erc-nickserv-identification-autodetect (proc parsed) +(defun erc-nickserv-identification-autodetect (_proc parsed) "Check for NickServ's successful identification notice. Make sure it is the real NickServ for this network and that it has specifically confirmed a successful identification attempt. @@ -361,7 +368,7 @@ If this is the case, run `erc-nickserv-identified-hook'." (run-hook-with-args 'erc-nickserv-identified-hook network nick) nil))) -(defun erc-nickserv-identify-autodetect (proc parsed) +(defun erc-nickserv-identify-autodetect (_proc parsed) "Identify to NickServ when an identify request is received. Make sure it is the real NickServ for this network. If `erc-prompt-for-nickserv-password' is non-nil, prompt the user for the @@ -383,7 +390,7 @@ password for this nickname, otherwise try to send it automatically." (erc-nickserv-call-identify-function nick) nil)))) -(defun erc-nickserv-identify-on-connect (server nick) +(defun erc-nickserv-identify-on-connect (_server nick) "Identify to Nickserv after the connection to the server is established." (unless (or (and (null erc-nickserv-passwords) (null erc-prompt-for-nickserv-password)) @@ -391,7 +398,7 @@ password for this nickname, otherwise try to send it automatically." (erc-nickserv-alist-regexp (erc-network)))) (erc-nickserv-call-identify-function nick))) -(defun erc-nickserv-identify-on-nick-change (nick old-nick) +(defun erc-nickserv-identify-on-nick-change (nick _old-nick) "Identify to Nickserv whenever your nick changes." (unless (or (and (null erc-nickserv-passwords) (null erc-prompt-for-nickserv-password)) @@ -400,9 +407,9 @@ password for this nickname, otherwise try to send it automatically." (erc-nickserv-call-identify-function nick))) (defun erc-nickserv-call-identify-function (nickname) - "Call `erc-nickserv-identify' interactively or run it with NICKNAME's -password. -The action is determined by the value of `erc-prompt-for-nickserv-password'." + "Call `erc-nickserv-identify'. +Either call it interactively or run it with NICKNAME's password, +depending on the value of `erc-prompt-for-nickserv-password'." (if erc-prompt-for-nickserv-password (call-interactively 'erc-nickserv-identify) (when erc-nickserv-passwords @@ -411,6 +418,8 @@ The action is determined by the value of `erc-prompt-for-nickserv-password'." (nth 1 (assoc (erc-network) erc-nickserv-passwords)))))))) +(defvar erc-auto-discard-away) + ;;;###autoload (defun erc-nickserv-identify (password) "Send an \"identify <PASSWORD>\" message to NickServ. @@ -444,6 +453,7 @@ When called interactively, read the password using `read-passwd'." ;;; erc-services.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-sound.el b/lisp/erc/erc-sound.el index 984ff49d43f..34f7ce62c74 100644 --- a/lisp/erc/erc-sound.el +++ b/lisp/erc/erc-sound.el @@ -46,7 +46,7 @@ (require 'erc) -;;;###autoload (autoload 'erc-sound-mode "erc-sound") +;;;###autoload(autoload 'erc-sound-mode "erc-sound") (define-erc-module sound ctcp-sound "In ERC sound mode, the client will respond to CTCP SOUND requests and play sound files as requested." @@ -145,6 +145,7 @@ See also `play-sound-file'." ;;; erc-sound.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index 0324383300b..8d56c85bec4 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2001-2004, 2006-2019 Free Software Foundation, Inc. ;; Author: Mario Lang <mlang@delysid.org> -;; Contributor: Eric M. Ludlam <eric@siege-engine.com> +;; Contributor: Eric M. Ludlam <zappo@gnu.org> ;; Maintainer: emacs-devel@gnu.org ;; This file is part of GNU Emacs. @@ -140,7 +140,7 @@ This will add a speedbar major display mode." t)))) (defun erc-speedbar-expand-server (text server indent) - (cond ((string-match "+" text) + (cond ((string-match "\\+" text) (speedbar-change-expand-button-char ?-) (if (speedbar-with-writable (save-excursion @@ -185,7 +185,7 @@ This will add a speedbar major display mode." "For the line matching TEXT, in CHANNEL, expand or contract a line. INDENT is the current indentation level." (cond - ((string-match "+" text) + ((string-match "\\+" text) (speedbar-change-expand-button-char ?-) (speedbar-with-writable (save-excursion @@ -285,7 +285,7 @@ is only done when the channel is actually expanded already." (erc-speedbar-expand-channel "+" buffer 1))))) (defun erc-speedbar-expand-user (text token indent) - (cond ((string-match "+" text) + (cond ((string-match "\\+" text) (speedbar-change-expand-button-char ?-) (speedbar-with-writable (save-excursion @@ -361,6 +361,7 @@ The INDENT level is ignored." ;;; erc-speedbar.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-spelling.el b/lisp/erc/erc-spelling.el index cc519b28da5..69a83fa032b 100644 --- a/lisp/erc/erc-spelling.el +++ b/lisp/erc/erc-spelling.el @@ -33,7 +33,7 @@ (require 'erc) (require 'flyspell) -;;;###autoload (autoload 'erc-spelling-mode "erc-spelling" nil t) +;;;###autoload(autoload 'erc-spelling-mode "erc-spelling" nil t) (define-erc-module spelling nil "Enable flyspell mode in ERC buffers." ;; Use erc-connect-pre-hook instead of erc-mode-hook as pre-hook is @@ -109,3 +109,7 @@ The cadr is the beginning and the caddr is the end." (provide 'erc-spelling) ;;; erc-spelling.el ends here + +;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" +;; End: diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el index 4495883734f..b48803452a2 100644 --- a/lisp/erc/erc-stamp.el +++ b/lisp/erc/erc-stamp.el @@ -158,7 +158,7 @@ from entering them and instead jump over them." "ERC timestamp face." :group 'erc-faces) -;;;###autoload (autoload 'erc-timestamp-mode "erc-stamp" nil t) +;;;###autoload(autoload 'erc-timestamp-mode "erc-stamp" nil t) (define-erc-module stamp timestamp "This mode timestamps messages in the channel buffers." ((add-hook 'erc-mode-hook #'erc-munge-invisibility-spec) @@ -227,14 +227,10 @@ the correct column." (integer :tag "Column number") (const :tag "Unspecified" nil))) -(defcustom erc-timestamp-use-align-to (and (not (featurep 'xemacs)) - (>= emacs-major-version 22) - (eq window-system 'x)) +(defcustom erc-timestamp-use-align-to (eq window-system 'x) "If non-nil, use the :align-to display property to align the stamp. This gives better results when variable-width characters (like Asian language characters and math symbols) precede a timestamp. -Unfortunately, it only works in Emacs 22 and when using the X -Window System. A side effect of enabling this is that there will only be one space before a right timestamp in any saved logs." @@ -417,6 +413,7 @@ enabled when the message was inserted." ;;; erc-stamp.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index d53668e2666..53a59207839 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -267,22 +267,12 @@ nil - don't add to mode line." (defun erc-modified-channels-object (strings) "Generate a new `erc-modified-channels-object' based on STRINGS." (if strings - (if (featurep 'xemacs) - (let ((e-m-c-s '("["))) - (push (cons (extent-at 0 (car strings)) (car strings)) - e-m-c-s) - (dolist (string (cdr strings)) - (push "," e-m-c-s) - (push (cons (extent-at 0 string) string) - e-m-c-s)) - (push "] " e-m-c-s) - (reverse e-m-c-s)) - (concat (if (eq erc-track-position-in-mode-line 'after-modes) - "[" " [") - (mapconcat 'identity (nreverse strings) ",") - (if (eq erc-track-position-in-mode-line 'before-modes) - "] " "]"))) - (if (featurep 'xemacs) '() ""))) + (concat (if (eq erc-track-position-in-mode-line 'after-modes) + "[" " [") + (mapconcat 'identity (nreverse strings) ",") + (if (eq erc-track-position-in-mode-line 'before-modes) + "] " "]")) + "")) (defvar erc-modified-channels-object (erc-modified-channels-object nil) "Internal object used for displaying modified channels in the mode line.") @@ -495,9 +485,6 @@ START is the minimum length of the name used." ;;;###autoload (define-minor-mode erc-track-minor-mode "Toggle mode line display of ERC activity (ERC Track minor mode). -With a prefix argument ARG, enable ERC Track minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. ERC Track minor mode is a global minor mode. It exists for the sole purpose of providing the C-c C-SPC and C-c C-@ keybindings. @@ -542,27 +529,20 @@ keybindings will not do anything useful." ;;; Module -;;;###autoload (autoload 'erc-track-mode "erc-track" nil t) +;;;###autoload(autoload 'erc-track-mode "erc-track" nil t) (define-erc-module track nil "This mode tracks ERC channel buffers with activity." ;; Enable: ((when (boundp 'erc-track-when-inactive) (if erc-track-when-inactive (progn - (if (featurep 'xemacs) - (defadvice switch-to-buffer (after erc-update-when-inactive - (&rest args) activate) - (erc-user-is-active)) - (add-hook 'window-configuration-change-hook 'erc-user-is-active)) + (add-hook 'window-configuration-change-hook 'erc-user-is-active) (add-hook 'erc-send-completed-hook 'erc-user-is-active) (add-hook 'erc-server-001-functions 'erc-user-is-active)) (erc-track-add-to-mode-line erc-track-position-in-mode-line) (erc-update-mode-line) - (if (featurep 'xemacs) - (defadvice switch-to-buffer (after erc-update (&rest args) activate) - (erc-modified-channels-update)) - (add-hook 'window-configuration-change-hook - 'erc-window-configuration-change)) + (add-hook 'window-configuration-change-hook + 'erc-window-configuration-change) (add-hook 'erc-insert-post-hook 'erc-track-modified-channels) (add-hook 'erc-disconnected-hook 'erc-modified-channels-update)) ;; enable the tracking keybindings @@ -573,18 +553,13 @@ keybindings will not do anything useful." (erc-track-remove-from-mode-line) (if erc-track-when-inactive (progn - (if (featurep 'xemacs) - (ad-disable-advice 'switch-to-buffer 'after - 'erc-update-when-inactive) - (remove-hook 'window-configuration-change-hook - 'erc-user-is-active)) + (remove-hook 'window-configuration-change-hook + 'erc-user-is-active) (remove-hook 'erc-send-completed-hook 'erc-user-is-active) (remove-hook 'erc-server-001-functions 'erc-user-is-active) (remove-hook 'erc-timer-hook 'erc-user-is-active)) - (if (featurep 'xemacs) - (ad-disable-advice 'switch-to-buffer 'after 'erc-update) - (remove-hook 'window-configuration-change-hook - 'erc-window-configuration-change)) + (remove-hook 'window-configuration-change-hook + 'erc-window-configuration-change) (remove-hook 'erc-disconnected-hook 'erc-modified-channels-update) (remove-hook 'erc-insert-post-hook 'erc-track-modified-channels)) ;; disable the tracking keybindings @@ -633,8 +608,8 @@ only consider active buffers visible.") (if erc-track-when-inactive (when erc-buffer-activity; could be nil (and (erc-track-get-buffer-window buffer erc-track-visibility) - (<= (erc-time-diff erc-buffer-activity (erc-current-time)) - erc-buffer-activity-timeout))) + (not (time-less-p erc-buffer-activity-timeout + (erc-time-diff erc-buffer-activity nil))))) (erc-track-get-buffer-window buffer erc-track-visibility))) ;;; Tracking the channel modifications @@ -643,7 +618,7 @@ only consider active buffers visible.") (unless (minibuffer-window-active-p (minibuffer-window)) ;; delay this until command has finished to make sure window is ;; actually visible before clearing activity - (add-hook 'post-command-hook 'erc-modified-channels-update))) + (erc-modified-channels-update))) (defvar erc-modified-channels-update-inside nil "Variable to prevent running `erc-modified-channels-update' multiple @@ -672,12 +647,9 @@ ARGS are ignored." (erc-modified-channels-remove-buffer buffer)))) erc-modified-channels-alist) (when removed-channel - (erc-modified-channels-display))) - (remove-hook 'post-command-hook 'erc-modified-channels-update))) + (erc-modified-channels-display))))) -(defvar erc-track-mouse-face (if (featurep 'xemacs) - 'modeline-mousable - 'mode-line-highlight) +(defvar erc-track-mouse-face 'mode-line-highlight "The face to use when mouse is over channel names in the mode line.") (defun erc-make-mode-line-buffer-name (string buffer &optional faces count) @@ -932,14 +904,14 @@ relative to `erc-track-switch-direction'" offset) (when (< arg 0) (setq dir (pcase dir - (`oldest 'newest) - (`newest 'oldest) - (`mostactive 'leastactive) - (`leastactive 'mostactive) - (`importance 'oldest))) + ('oldest 'newest) + ('newest 'oldest) + ('mostactive 'leastactive) + ('leastactive 'mostactive) + ('importance 'oldest))) (setq arg (- arg))) (setq offset (pcase dir - ((or `oldest `leastactive) + ((or 'oldest 'leastactive) (- (length erc-modified-channels-alist) arg)) (_ (1- arg)))) ;; normalize out of range user input @@ -974,6 +946,7 @@ switch back to the last non-ERC buffer visited. Next is defined by ;;; erc-track.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-truncate.el b/lisp/erc/erc-truncate.el index 7ff99c8dc4f..04174295520 100644 --- a/lisp/erc/erc-truncate.el +++ b/lisp/erc/erc-truncate.el @@ -43,7 +43,7 @@ Used only when auto-truncation is enabled. :group 'erc-truncate :type 'integer) -;;;###autoload (autoload 'erc-truncate-mode "erc-truncate" nil t) +;;;###autoload(autoload 'erc-truncate-mode "erc-truncate" nil t) (define-erc-module truncate nil "Truncate a query buffer if it gets too large. This prevents the query buffer from getting too large, which can @@ -112,6 +112,7 @@ Meant to be used in hooks, like `erc-insert-post-hook'." ;;; erc-truncate.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-xdcc.el b/lisp/erc/erc-xdcc.el index 07e7ac1be16..162b22e15c6 100644 --- a/lisp/erc/erc-xdcc.el +++ b/lisp/erc/erc-xdcc.el @@ -61,7 +61,7 @@ being evaluated and should return strings." :group 'erc-dcc :type '(repeat (repeat :tag "Message" (choice string sexp)))) -;;;###autoload (autoload 'erc-xdcc-mode "erc-xdcc") +;;;###autoload(autoload 'erc-xdcc-mode "erc-xdcc") (define-erc-module xdcc nil "Act as an XDCC file-server." nil nil) @@ -133,6 +133,7 @@ being evaluated and should return strings." ;;; erc-xdcc.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index feee89d7fea..f5c9decc3a2 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -62,17 +62,17 @@ ;;; History: ;; -(defconst erc-version-string (format "\C-bERC\C-b (IRC client for Emacs %s)" emacs-version) - "ERC version. This is used by function `erc-version'.") - ;;; Code: +(load "erc-loaddefs" nil t) + (eval-when-compile (require 'cl-lib)) (require 'font-lock) (require 'pp) (require 'thingatpt) (require 'auth-source) (require 'erc-compat) +(eval-when-compile (require 'subr-x)) (defvar erc-official-location "https://www.emacswiki.org/emacs/ERC (mailing list: erc-discuss@gnu.org)" @@ -399,25 +399,28 @@ If no server buffer exists, return nil." ;; This is useful for ordered name completion. (last-message-time nil)) -(defsubst erc-get-channel-user (nick) +(define-inline erc-get-channel-user (nick) "Find the (USER . CHANNEL-DATA) element corresponding to NICK in the current buffer's `erc-channel-users' hash table." - (gethash (erc-downcase nick) erc-channel-users)) + (inline-quote (gethash (erc-downcase ,nick) erc-channel-users))) -(defsubst erc-get-server-user (nick) +(define-inline erc-get-server-user (nick) "Find the USER corresponding to NICK in the current server's `erc-server-users' hash table." - (erc-with-server-buffer - (gethash (erc-downcase nick) erc-server-users))) + (inline-letevals (nick) + (inline-quote (erc-with-server-buffer + (gethash (erc-downcase ,nick) erc-server-users))))) -(defsubst erc-add-server-user (nick user) +(define-inline erc-add-server-user (nick user) "This function is for internal use only. Adds USER with nickname NICK to the `erc-server-users' hash table." - (erc-with-server-buffer - (puthash (erc-downcase nick) user erc-server-users))) + (inline-letevals (nick user) + (inline-quote + (erc-with-server-buffer + (puthash (erc-downcase ,nick) ,user erc-server-users))))) -(defsubst erc-remove-server-user (nick) +(define-inline erc-remove-server-user (nick) "This function is for internal use only. Removes the user with nickname NICK from the `erc-server-users' @@ -425,8 +428,10 @@ hash table. This user is not removed from the `erc-channel-users' lists of other buffers. See also: `erc-remove-user'." - (erc-with-server-buffer - (remhash (erc-downcase nick) erc-server-users))) + (inline-letevals (nick) + (inline-quote + (erc-with-server-buffer + (remhash (erc-downcase ,nick) erc-server-users))))) (defun erc-change-user-nickname (user new-nick) "This function is for internal use only. @@ -497,45 +502,55 @@ Removes all users in the current channel. This is called by erc-channel-users) (clrhash erc-channel-users))) -(defsubst erc-channel-user-owner-p (nick) +(define-inline erc-channel-user-owner-p (nick) "Return non-nil if NICK is an owner of the current channel." - (and nick - (hash-table-p erc-channel-users) - (let ((cdata (erc-get-channel-user nick))) - (and cdata (cdr cdata) - (erc-channel-user-owner (cdr cdata)))))) - -(defsubst erc-channel-user-admin-p (nick) + (inline-letevals (nick) + (inline-quote + (and ,nick + (hash-table-p erc-channel-users) + (let ((cdata (erc-get-channel-user ,nick))) + (and cdata (cdr cdata) + (erc-channel-user-owner (cdr cdata)))))))) + +(define-inline erc-channel-user-admin-p (nick) "Return non-nil if NICK is an admin in the current channel." - (and nick + (inline-letevals (nick) + (inline-quote + (and ,nick (hash-table-p erc-channel-users) - (let ((cdata (erc-get-channel-user nick))) + (let ((cdata (erc-get-channel-user ,nick))) (and cdata (cdr cdata) - (erc-channel-user-admin (cdr cdata)))))) + (erc-channel-user-admin (cdr cdata)))))))) -(defsubst erc-channel-user-op-p (nick) +(define-inline erc-channel-user-op-p (nick) "Return non-nil if NICK is an operator in the current channel." - (and nick + (inline-letevals (nick) + (inline-quote + (and ,nick (hash-table-p erc-channel-users) - (let ((cdata (erc-get-channel-user nick))) + (let ((cdata (erc-get-channel-user ,nick))) (and cdata (cdr cdata) - (erc-channel-user-op (cdr cdata)))))) + (erc-channel-user-op (cdr cdata)))))))) -(defsubst erc-channel-user-halfop-p (nick) +(define-inline erc-channel-user-halfop-p (nick) "Return non-nil if NICK is a half-operator in the current channel." - (and nick + (inline-letevals (nick) + (inline-quote + (and ,nick (hash-table-p erc-channel-users) - (let ((cdata (erc-get-channel-user nick))) + (let ((cdata (erc-get-channel-user ,nick))) (and cdata (cdr cdata) - (erc-channel-user-halfop (cdr cdata)))))) + (erc-channel-user-halfop (cdr cdata)))))))) -(defsubst erc-channel-user-voice-p (nick) +(define-inline erc-channel-user-voice-p (nick) "Return non-nil if NICK has voice in the current channel." - (and nick + (inline-letevals (nick) + (inline-quote + (and ,nick (hash-table-p erc-channel-users) - (let ((cdata (erc-get-channel-user nick))) + (let ((cdata (erc-get-channel-user ,nick))) (and cdata (cdr cdata) - (erc-channel-user-voice (cdr cdata)))))) + (erc-channel-user-voice (cdr cdata)))))))) (defun erc-get-channel-user-list () "Return a list of users in the current channel. Each element @@ -1036,6 +1051,21 @@ Note that it's useless to set `erc-send-this' to nil and anyway." :group 'erc-hooks :type 'hook) +(make-obsolete-variable 'erc-send-pre-hook 'erc-pre-send-functions "27.1") + +(defcustom erc-pre-send-functions nil + "List of functions called to possibly alter the string that is sent. +The functions are called with one argument, a `erc-input' struct, +and should alter that struct. + +The struct has three slots: + + `string': The current input string. + `insertp': Whether the string should be inserted into the erc buffer. + `sendp': Whether the string should be sent to the irc server." + :group 'erc + :type '(repeat function) + :version "27.1") (defvar erc-insert-this t "Insert the text into the target buffer or not. @@ -1046,6 +1076,7 @@ if they wish to avoid insertion of a particular string.") "Send the text to the target or not. Functions on `erc-send-pre-hook' can set this variable to nil if they wish to avoid sending of a particular string.") +(make-obsolete-variable 'erc-send-this 'erc-pre-send-functions "27.1") (defcustom erc-insert-modify-hook () "Insertion hook for functions that will change the text's appearance. @@ -1260,7 +1291,7 @@ erc-NAME-enable, and erc-NAME-disable. Example: - ;;;###autoload (autoload \\='erc-replace-mode \"erc-replace\") + ;;;###autoload(autoload \\='erc-replace-mode \"erc-replace\") (define-erc-module replace nil \"This mode replaces incoming text according to `erc-replace-alist'.\" ((add-hook \\='erc-insert-modify-hook @@ -1343,10 +1374,11 @@ capabilities." (add-hook hook fun nil t) fun)) -(defsubst erc-log (string) +(define-inline erc-log (string) "Logs STRING if logging is on (see `erc-log-p')." - (when erc-log-p - (erc-log-aux string))) + (inline-quote + (when erc-log-p + (erc-log-aux ,string)))) (defun erc-server-buffer () "Return the server buffer for the current buffer's process. @@ -1590,18 +1622,18 @@ symbol, it may have these values: (dolist (candidate (list buf-name (concat buf-name "/" server))) (if (and (not buffer-name) erc-reuse-buffers - (get-buffer candidate) - (or target + (or (not (get-buffer candidate)) + (or target + (with-current-buffer (get-buffer candidate) + (and (erc-server-buffer-p) + (not (erc-server-process-alive))))) (with-current-buffer (get-buffer candidate) - (and (erc-server-buffer-p) - (not (erc-server-process-alive))))) - (with-current-buffer (get-buffer candidate) - (and (string= erc-session-server server) - (erc-port-equal erc-session-port port)))) + (and (string= erc-session-server server) + (erc-port-equal erc-session-port port))))) (setq buffer-name candidate))) ;; if buffer-name is unset, neither candidate worked out for us, ;; fallback to the old <N> uniquification method: - (or buffer-name (generate-new-buffer-name buf-name)) )) + (or buffer-name (generate-new-buffer-name (concat buf-name "/" server))))) (defun erc-get-buffer-create (server port target) "Create a new buffer based on the arguments." @@ -1924,15 +1956,15 @@ removed from the list will be disabled." (defun erc-setup-buffer (buffer) "Consults `erc-join-buffer' to find out how to display `BUFFER'." (pcase erc-join-buffer - (`window + ('window (if (active-minibuffer-window) (display-buffer buffer) (switch-to-buffer-other-window buffer))) - (`window-noselect + ('window-noselect (display-buffer buffer)) - (`bury + ('bury nil) - (`frame + ('frame (when (or (not erc-reuse-frames) (not (get-buffer-window buffer t))) (let ((frame (make-frame (or erc-frame-alist @@ -2411,11 +2443,7 @@ If STRING is nil, the function does nothing." ((null (car elt)) ; (nil PROPERTY VALUE BEG . END) (let ((cons (nthcdr 3 elt))) (cl-incf (car cons) shift) - (cl-incf (cdr cons) shift))) - ((and (featurep 'xemacs) - (extentp (car elt))) ; (EXTENT START END) - (cl-incf (nth 1 elt) shift) - (cl-incf (nth 2 elt) shift))) + (cl-incf (cdr cons) shift)))) (setq list (cdr list)))))) (defvar erc-valid-nick-regexp "[]a-zA-Z^[;\\`_{}|][]^[;\\`_{}|a-zA-Z0-9-]*" @@ -2506,10 +2534,7 @@ Returns NICK unmodified unless `erc-lurker-trim-nicks' is non-nil." (if erc-lurker-trim-nicks (replace-regexp-in-string - (format "[%s]" - (mapconcat (lambda (char) - (regexp-quote (char-to-string char))) - erc-lurker-ignore-chars "")) + (regexp-opt-charset (string-to-list erc-lurker-ignore-chars)) "" nick) nick)) @@ -2549,10 +2574,8 @@ consumption for long-lived IRC or Emacs sessions." (maphash (lambda (nick last-PRIVMSG-time) (when - (> (float-time (time-subtract - (current-time) - last-PRIVMSG-time)) - erc-lurker-threshold-time) + (time-less-p erc-lurker-threshold-time + (time-since last-PRIVMSG-time)) (remhash nick hash))) hash) (if (zerop (hash-table-count hash)) @@ -2617,9 +2640,8 @@ server within `erc-lurker-threshold-time'. See also (gethash (erc-lurker-maybe-trim nick) (gethash server erc-lurker-state (make-hash-table))))) (or (null last-PRIVMSG-time) - (> (float-time - (time-subtract (current-time) last-PRIVMSG-time)) - erc-lurker-threshold-time)))) + (time-less-p erc-lurker-threshold-time + (time-since last-PRIVMSG-time))))) (defcustom erc-common-server-suffixes '(("openprojects.net\\'" . "OPN") @@ -3398,7 +3420,7 @@ Otherwise leave the channel indicated by LINE." (defun erc-cmd-PING (recipient) "Ping RECIPIENT." - (let ((time (format "%f" (erc-current-time)))) + (let ((time (format-time-string "%s.%6N"))) (erc-log (format "cmd: PING: %s" time)) (erc-cmd-CTCP recipient "PING" time))) @@ -3472,7 +3494,6 @@ If S is non-nil, it will be used as the quit reason." (defun erc-quit-reason-various (s) "Choose a quit reason based on S (a string)." - (when (featurep 'xemacs) (require 'poe)) (let ((res (car (assoc-default (or s "") erc-quit-reason-various-alist 'string-match)))) (cond @@ -3500,7 +3521,6 @@ If S is non-nil, it will be used as the quit reason." (defun erc-part-reason-various (s) "Choose a part reason based on S (a string)." - (when (featurep 'xemacs) (require 'poe)) (let ((res (car (assoc-default (or s "") erc-part-reason-various-alist 'string-match)))) (cond @@ -3601,8 +3621,7 @@ the message given by REASON." (defun erc-cmd-SV () "Say the current ERC and Emacs version into channel." - (erc-send-message (format "I'm using ERC with %s %s (%s%s)%s." - (if (featurep 'xemacs) "XEmacs" "GNU Emacs") + (erc-send-message (format "I'm using ERC with GNU Emacs %s (%s%s)%s." emacs-version system-configuration (concat @@ -3677,8 +3696,10 @@ be displayed." ((string-match "^\\s-*\\([&#+!]\\S-+\\)\\s-\\(.*\\)$" topic) (let ((ch (match-string 1 topic)) (topic (match-string 2 topic))) - (erc-log (format "cmd: TOPIC [%s]: %s" ch topic)) - (erc-server-send (format "TOPIC %s :%s" ch topic) nil ch)) + ;; Ignore all-whitespace topics. + (unless (equal (string-trim topic) "") + (erc-log (format "cmd: TOPIC [%s]: %s" ch topic)) + (erc-server-send (format "TOPIC %s :%s" ch topic) nil ch))) t) ;; /topic #channel ((string-match "^\\s-*\\([&#+!]\\S-+\\)" topic) @@ -3941,9 +3962,7 @@ If FACE is non-nil, it will be used to propertize the prompt. If it is nil, (let ((minibuffer-allow-text-properties t) (read-map minibuffer-local-map)) (insert (read-from-minibuffer "Message: " - (string (if (featurep 'xemacs) - last-command-char - last-command-event)) + (string last-command-event) read-map)) (erc-send-current-line))) @@ -4270,7 +4289,7 @@ and as second argument the event parsed as a vector." (defun erc-is-message-ctcp-and-not-action-p (message) "Check if MESSAGE is a CTCP message or not." (and (erc-is-message-ctcp-p message) - (not (string-match "^\C-a\\ACTION.*\C-a$" message)))) + (not (string-match "^\C-aACTION.*\C-a$" message)))) (defun erc-format-privmessage (nick msg privp msgp) "Format a PRIVMSG in an insertable fashion." @@ -4476,7 +4495,7 @@ See also: `erc-echo-notice-in-user-buffers', (mapcar #'upcase (cdr (split-string mode))))) erc-channel-banlist))) - ((string-match "^+" mode) + ((string-match "^\\+" mode) ;; Add the banned mask(s) to the ban list (mapc (lambda (mask) @@ -4624,7 +4643,7 @@ See also `erc-display-message'." (user-full-name) (user-login-name) (system-name)))) - (ns (erc-time-diff erc-server-last-sent-time (erc-current-time)))) + (ns (erc-time-diff erc-server-last-sent-time nil))) (when (> ns 0) (setq s (concat s " Idle for " (erc-sec-to-time ns)))) (erc-send-ctcp-notice nick s))) @@ -4713,8 +4732,7 @@ See also `erc-display-message'." nil (let ((time (match-string 1 msg))) (condition-case nil - (let ((delta (erc-time-diff (string-to-number time) - (erc-current-time)))) + (let ((delta (erc-time-diff (string-to-number time) nil))) (erc-display-message nil 'notice 'active 'CTCP-PING ?n nick @@ -4772,10 +4790,7 @@ If non-nil, return from being away." (erc-default-target) (if away-time (format "is back (gone for %s)" - (erc-sec-to-time - (erc-time-diff - (erc-emacs-time-to-erc-time away-time) - (erc-current-time)))) + (erc-sec-to-time (erc-time-diff away-time nil))) "is back"))))))))) (erc-update-mode-line))) @@ -5367,10 +5382,10 @@ submitted line to be intentional." (defun erc-send-current-line () "Parse current line and send it to IRC." (interactive) - (let ((now (float-time))) + (let ((now (current-time))) (if (or (not erc-accidental-paste-threshold-seconds) - (< erc-accidental-paste-threshold-seconds - (- now erc-last-input-time))) + (time-less-p erc-accidental-paste-threshold-seconds + (time-subtract now erc-last-input-time))) (save-restriction (widen) (if (< (point) (erc-beg-of-input-line)) @@ -5416,6 +5431,9 @@ submitted line to be intentional." (defvar erc-command-regexp "^/\\([A-Za-z']+\\)\\(\\s-+.*\\|\\s-*\\)$" "Regular expression used for matching commands in ERC.") +(cl-defstruct erc-input + string insertp sendp) + (defun erc-send-input (input) "Treat INPUT as typed in by the user. It is assumed that the input and the prompt is already deleted. @@ -5431,27 +5449,46 @@ This returns non-nil only if we actually send anything." (beep)) nil) (t - (defvar str) ;; FIXME: Make it obey the "erc-" prefix convention. + ;; This dynamic variable is used by `erc-send-pre-hook'. It's + ;; obsolete, and when it's finally removed, this binding should + ;; also be removed. + (with-suppressed-warnings ((lexical str)) + (defvar str)) (let ((str input) - (erc-insert-this t)) - (setq erc-send-this t) + (erc-insert-this t) + (erc-send-this t) + state) + ;; The calling convention of `erc-send-pre-hook' is that it + ;; should change the dynamic variable `str' or set + ;; `erc-send-this' to nil. This has now been deprecated: + ;; Instead `erc-pre-send-functions' is used as a filter to do + ;; allow both changing and suppressing the string. (run-hook-with-args 'erc-send-pre-hook input) - (when erc-send-this - (if (or (string-match "\n" str) - (not (string-match erc-command-regexp str))) - (mapc - (lambda (line) - (mapc - (lambda (line) - ;; Insert what has to be inserted for this. - (erc-display-msg line) - (erc-process-input-line (concat line "\n") - (null erc-flood-protect) t)) - (or (and erc-flood-protect (erc-split-line line)) - (list line)))) - (split-string str "\n")) - (erc-process-input-line (concat str "\n") t nil)) - t))))) + (setq state (make-erc-input :string str + :insertp erc-insert-this + :sendp erc-send-this)) + (dolist (func erc-pre-send-functions) + ;; The functions can return nil to inhibit sending. + (funcall func state)) + (when (and (erc-input-sendp state) + erc-send-this) + (let ((string (erc-input-string state))) + (if (or (string-match "\n" string) + (not (string-match erc-command-regexp string))) + (mapc + (lambda (line) + (mapc + (lambda (line) + ;; Insert what has to be inserted for this. + (when (erc-input-insertp state) + (erc-display-msg line)) + (erc-process-input-line (concat line "\n") + (null erc-flood-protect) t)) + (or (and erc-flood-protect (erc-split-line line)) + (list line)))) + (split-string string "\n")) + (erc-process-input-line (concat string "\n") t nil)) + t)))))) (defun erc-display-command (line) (when erc-insert-this @@ -5720,8 +5757,6 @@ If \"l\" is pressed, `erc-set-channel-limit' gets called. If \"k\" is pressed, `erc-set-channel-key' gets called. Anything else will be sent to `erc-toggle-channel-mode'." (interactive "kChannel mode (RET to set more than one): ") - (when (featurep 'xemacs) - (setq key (char-to-string (event-to-character (aref key 0))))) (cond ((equal key "\C-g") (keyboard-quit)) ((equal key "\C-m") @@ -6020,23 +6055,20 @@ non-nil value is found. ;; time routines -(defun erc-string-to-emacs-time (string) - "Convert the long number represented by STRING into an Emacs format. -Returns a list of the form (HIGH LOW), compatible with Emacs time format." - (let* ((n (string-to-number (concat string ".0")))) - (list (truncate (/ n 65536)) - (truncate (mod n 65536))))) +(define-obsolete-function-alias 'erc-string-to-emacs-time 'string-to-number + "27.1") (defalias 'erc-emacs-time-to-erc-time 'float-time) (defalias 'erc-current-time 'float-time) (defun erc-time-diff (t1 t2) - "Return the time difference in seconds between T1 and T2." - (abs (- t2 t1))) + "Return the absolute value of the difference in seconds between T1 and T2." + (abs (float-time (time-subtract t1 t2)))) (defun erc-time-gt (t1 t2) "Check whether T1 > T2." - (> t1 t2)) + (declare (obsolete time-less-p "27.1")) + (time-less-p t2 t1)) (defun erc-sec-to-time (ns) "Convert NS to a time string HH:MM.SS." @@ -6368,14 +6400,9 @@ if `erc-away' is non-nil." (funcall erc-header-line-face-method)) (t 'erc-header-line)))) - (cond ((featurep 'xemacs) - (setq modeline-buffer-identification - (list (format-spec erc-mode-line-format spec))) - (setq modeline-process (list process-status))) - (t - (setq mode-line-buffer-identification - (list (format-spec erc-mode-line-format spec))) - (setq mode-line-process (list process-status)))) + (setq mode-line-buffer-identification + (list (format-spec erc-mode-line-format spec))) + (setq mode-line-process (list process-status)) (when (boundp 'header-line-format) (let ((header (if erc-header-line-format (format-spec erc-header-line-format spec) @@ -6403,9 +6430,7 @@ if `erc-away' is non-nil." (if face (erc-propertize header 'face face) header))))))) - (if (featurep 'xemacs) - (redraw-modeline) - (force-mode-line-update)))) + (force-mode-line-update))) (defun erc-update-mode-line (&optional buffer) "Update the mode line in BUFFER. diff --git a/lisp/eshell/em-alias.el b/lisp/eshell/em-alias.el index dbffd52aa76..c465d464d6a 100644 --- a/lisp/eshell/em-alias.el +++ b/lisp/eshell/em-alias.el @@ -90,7 +90,7 @@ ;;; Code: -(require 'eshell) +(require 'esh-mode) ;;;###autoload (progn @@ -141,12 +141,12 @@ file named by `eshell-aliases-file'.") (defvar eshell-failed-commands-alist nil "An alist of command name failures.") -(defun eshell-alias-initialize () +(defun eshell-alias-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the alias handling code." (make-local-variable 'eshell-failed-commands-alist) - (add-hook 'eshell-alternate-command-hook 'eshell-fix-bad-commands t t) + (add-hook 'eshell-alternate-command-hook #'eshell-fix-bad-commands t t) (eshell-read-aliases-list) - (add-hook 'eshell-named-command-hook 'eshell-maybe-replace-by-alias t t) + (add-hook 'eshell-named-command-hook #'eshell-maybe-replace-by-alias t t) (make-local-variable 'eshell-complex-commands) (add-to-list 'eshell-complex-commands 'eshell-command-aliased-p)) diff --git a/lisp/eshell/em-banner.el b/lisp/eshell/em-banner.el index 4a0b265ae0e..c284c1bd70d 100644 --- a/lisp/eshell/em-banner.el +++ b/lisp/eshell/em-banner.el @@ -71,7 +71,7 @@ This can be any sexp, and should end with at least two newlines." :type 'hook :group 'eshell-banner) -(defun eshell-banner-initialize () +(defun eshell-banner-initialize () ;Called from `eshell-mode' via intern-soft! "Output a welcome banner on initialization." ;; it's important to use `eshell-interactive-print' rather than ;; `insert', because `insert' doesn't know how to interact with the diff --git a/lisp/eshell/em-basic.el b/lisp/eshell/em-basic.el index 346fb1c17b0..72a4e6bf801 100644 --- a/lisp/eshell/em-basic.el +++ b/lisp/eshell/em-basic.el @@ -118,7 +118,7 @@ or `eshell-printn' for display." (defun eshell/printnl (&rest args) "Print out each of the arguments, separated by newlines." - (let ((elems (eshell-flatten-list args))) + (let ((elems (flatten-tree args))) (while elems (eshell-printn (eshell-echo (list (car elems)))) (setq elems (cdr elems))))) diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index f834882f7b6..8f6c6781b9c 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el @@ -244,7 +244,7 @@ to writing a completion function." (let ((completion-at-point-functions '(lisp-completion-at-point))) (completion-at-point))) -(defun eshell-cmpl-initialize () +(defun eshell-cmpl-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the completions module." (set (make-local-variable 'pcomplete-command-completion-function) eshell-command-completion-function) @@ -262,8 +262,9 @@ to writing a completion function." eshell-cmpl-ignore-case) (set (make-local-variable 'pcomplete-autolist) eshell-cmpl-autolist) - (set (make-local-variable 'pcomplete-suffix-list) - eshell-cmpl-suffix-list) + (if (boundp 'pcomplete-suffix-list) + (set (make-local-variable 'pcomplete-suffix-list) + eshell-cmpl-suffix-list)) (set (make-local-variable 'pcomplete-recexact) eshell-cmpl-recexact) (set (make-local-variable 'pcomplete-man-function) @@ -287,9 +288,10 @@ to writing a completion function." (function (lambda () (set (make-local-variable 'comint-file-name-quote-list) - eshell-special-chars-outside-quoting))) nil t) - (add-hook 'pcomplete-quote-arg-hook 'eshell-quote-backslash nil t) - (define-key eshell-mode-map [(meta tab)] 'eshell-complete-lisp-symbol) + eshell-special-chars-outside-quoting))) + nil t) + (add-hook 'pcomplete-quote-arg-hook #'eshell-quote-backslash nil t) + ;;(define-key eshell-mode-map [(meta tab)] 'eshell-complete-lisp-symbol) ; Redundant (define-key eshell-mode-map [(meta control ?i)] 'eshell-complete-lisp-symbol) (define-key eshell-command-map [(meta ?h)] 'eshell-completion-help) (define-key eshell-command-map [tab] 'pcomplete-expand-and-complete) @@ -297,15 +299,14 @@ to writing a completion function." 'pcomplete-expand-and-complete) (define-key eshell-command-map [space] 'pcomplete-expand) (define-key eshell-command-map [? ] 'pcomplete-expand) - (define-key eshell-mode-map [tab] 'eshell-pcomplete) - (define-key eshell-mode-map [(control ?i)] 'eshell-pcomplete) + ;;(define-key eshell-mode-map [tab] 'completion-at-point) ;Redundant! + (define-key eshell-mode-map [(control ?i)] 'completion-at-point) (add-hook 'completion-at-point-functions #'pcomplete-completions-at-point nil t) ;; jww (1999-10-19): Will this work on anything but X? - (if (featurep 'xemacs) - (define-key eshell-mode-map [iso-left-tab] 'pcomplete-reverse) - (define-key eshell-mode-map [backtab] 'pcomplete-reverse)) - (define-key eshell-mode-map [(meta ??)] 'pcomplete-list)) + (define-key eshell-mode-map + (if (featurep 'xemacs) [iso-left-tab] [backtab]) 'pcomplete-reverse) + (define-key eshell-mode-map [(meta ??)] 'completion-help-at-point)) (defun eshell-completion-command-name () "Return the command name, possibly sans globbing." @@ -408,13 +409,11 @@ to writing a completion function." (setq filename (substring filename 1) pcomplete-stub filename glob-name t)) - (let* ((paths (eshell-parse-colon-path eshell-path-env)) + (let* ((paths (eshell-get-path)) (cwd (file-name-as-directory (expand-file-name default-directory))) (path "") (comps-in-path ()) (file "") (filepath "") (completions ())) - (if (eshell-under-windows-p) - (push "." paths)) ;; Go thru each path in the search path, finding completions. (while paths (setq path (file-name-as-directory @@ -437,38 +436,28 @@ to writing a completion function." (setq comps-in-path (cdr comps-in-path))) (setq paths (cdr paths))) ;; Add aliases which are currently visible, and Lisp functions. - (pcomplete-uniqify-list + (pcomplete-uniquify-list (if glob-name completions (setq completions - (append (and (eshell-using-module 'eshell-alias) - (funcall (symbol-function 'eshell-alias-completions) - filename)) + (append (if (fboundp 'eshell-alias-completions) + (eshell-alias-completions filename)) (eshell-winnow-list (mapcar (function (lambda (name) (substring name 7))) (all-completions (concat "eshell/" filename) - obarray 'functionp)) + obarray #'functionp)) nil '(eshell-find-alias-function)) completions)) (append (and (or eshell-show-lisp-completions (and eshell-show-lisp-alternatives (null completions))) - (all-completions filename obarray 'functionp)) + (all-completions filename obarray #'functionp)) completions))))))) -(defun eshell-pcomplete (&optional interactively) - "Eshell wrapper for `pcomplete'." - (interactive "p") - ;; Pretend to be pcomplete so that cycling works (bug#13293). - (setq this-command 'pcomplete) - (condition-case nil - (if interactively - (call-interactively 'pcomplete) - (pcomplete)) - (text-read-only (completion-at-point)))) ; Workaround for bug#12838. +(define-obsolete-function-alias 'eshell-pcomplete #'completion-at-point "27.1") (provide 'em-cmpl) diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el index 4d8debb954f..c28fd72f45c 100644 --- a/lisp/eshell/em-dirs.el +++ b/lisp/eshell/em-dirs.el @@ -42,7 +42,8 @@ ;;; Code: -(require 'eshell) +(require 'esh-mode) ;For eshell-directory-name +(require 'esh-var) ;For eshell-variable-aliases-list (require 'ring) (require 'esh-opt) @@ -62,12 +63,11 @@ they lack somewhat in feel from the typical shell equivalents." (defcustom eshell-dirs-load-hook nil "A hook that gets run when `eshell-dirs' is loaded." :version "24.1" ; removed eshell-dirs-initialize - :type 'hook - :group 'eshell-dirs) + :type 'hook) (defcustom eshell-pwd-convert-function (if (eshell-under-windows-p) - 'expand-file-name - 'identity) + #'expand-file-name + #'identity) "The function used to normalize the value of Eshell's `pwd'. The value returned by `pwd' is also used when recording the last-visited directory in the last-dir-ring, so it will affect the @@ -75,8 +75,7 @@ form of the list used by `cd ='." :type '(radio (function-item file-truename) (function-item expand-file-name) (function-item identity) - (function :tag "Other")) - :group 'eshell-dirs) + (function :tag "Other"))) (defcustom eshell-ask-to-save-last-dir 'always "Determine if the last-dir-ring should be automatically saved. @@ -88,63 +87,53 @@ If set to t, always ask if any Eshell buffers are open at exit time. If set to `always', the list-dir-ring will always be saved, silently." :type '(choice (const :tag "Never" nil) (const :tag "Ask" t) - (const :tag "Always save" always)) - :group 'eshell-dirs) + (const :tag "Always save" always))) (defcustom eshell-cd-shows-directory nil "If non-nil, using `cd' will report the directory it changes to." - :type 'boolean - :group 'eshell-dirs) + :type 'boolean) (defcustom eshell-cd-on-directory t "If non-nil, do a cd if a directory is in command position." - :type 'boolean - :group 'eshell-dirs) + :type 'boolean) (defcustom eshell-directory-change-hook nil "A hook to run when the current directory changes." - :type 'hook - :group 'eshell-dirs) + :type 'hook) (defcustom eshell-list-files-after-cd nil "If non-nil, call \"ls\" with any remaining args after doing a cd. This is provided for convenience, since the same effect is easily achieved by adding a function to `eshell-directory-change-hook' that calls \"ls\" and references `eshell-last-arguments'." - :type 'boolean - :group 'eshell-dirs) + :type 'boolean) (defcustom eshell-pushd-tohome nil "If non-nil, make pushd with no arg behave as `pushd ~' (like `cd'). This mirrors the optional behavior of tcsh." - :type 'boolean - :group 'eshell-dirs) + :type 'boolean) (defcustom eshell-pushd-dextract nil "If non-nil, make \"pushd +n\" pop the nth dir to the stack top. This mirrors the optional behavior of tcsh." - :type 'boolean - :group 'eshell-dirs) + :type 'boolean) (defcustom eshell-pushd-dunique nil "If non-nil, make pushd only add unique directories to the stack. This mirrors the optional behavior of tcsh." - :type 'boolean - :group 'eshell-dirs) + :type 'boolean) (defcustom eshell-dirtrack-verbose t "If non-nil, show the directory stack following directory change. This is effective only if directory tracking is enabled." - :type 'boolean - :group 'eshell-dirs) + :type 'boolean) (defcustom eshell-last-dir-ring-file-name (expand-file-name "lastdir" eshell-directory-name) "If non-nil, name of the file to read/write the last-dir-ring. See also `eshell-read-last-dir-ring' and `eshell-write-last-dir-ring'. If it is nil, the last-dir-ring will not be written to disk." - :type 'file - :group 'eshell-dirs) + :type 'file) (defcustom eshell-last-dir-ring-size 32 "If non-nil, the size of the directory history ring. @@ -164,13 +153,11 @@ directories gets pushed, and its size is unlimited. explicitly very much, but every once in a while would like to return to a previously visited directory without having to type in the whole thing again." - :type 'integer - :group 'eshell-dirs) + :type 'integer) (defcustom eshell-last-dir-unique t "If non-nil, `eshell-last-dir-ring' contains only unique entries." - :type 'boolean - :group 'eshell-dirs) + :type 'boolean) ;;; Internal Variables: @@ -183,44 +170,46 @@ Thus, this does not include the current directory.") ;;; Functions: -(defun eshell-dirs-initialize () +(defun eshell-dirs-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the builtin functions for Eshell." (make-local-variable 'eshell-variable-aliases-list) (setq eshell-variable-aliases-list (append eshell-variable-aliases-list - '(("-" (lambda (indices) - (if (not indices) - (unless (ring-empty-p eshell-last-dir-ring) - (expand-file-name - (ring-ref eshell-last-dir-ring 0))) - (expand-file-name - (eshell-apply-indices eshell-last-dir-ring indices))))) - ("+" "PWD") - ("PWD" (lambda (indices) - (expand-file-name (eshell/pwd))) t) - ("OLDPWD" (lambda (indices) + `(("-" ,(lambda (indices) + (if (not indices) (unless (ring-empty-p eshell-last-dir-ring) (expand-file-name - (ring-ref eshell-last-dir-ring 0)))) t)))) + (ring-ref eshell-last-dir-ring 0))) + (expand-file-name + (eshell-apply-indices eshell-last-dir-ring indices))))) + ("+" "PWD") + ("PWD" ,(lambda (_indices) + (expand-file-name (eshell/pwd))) + t) + ("OLDPWD" ,(lambda (_indices) + (unless (ring-empty-p eshell-last-dir-ring) + (expand-file-name + (ring-ref eshell-last-dir-ring 0)))) + t)))) (when eshell-cd-on-directory (make-local-variable 'eshell-interpreter-alist) (setq eshell-interpreter-alist - (cons (cons #'(lambda (file args) + (cons (cons #'(lambda (file _args) (eshell-lone-directory-p file)) 'eshell-dirs-substitute-cd) eshell-interpreter-alist))) (add-hook 'eshell-parse-argument-hook - 'eshell-parse-user-reference nil t) + #'eshell-parse-user-reference nil t) (if (eshell-under-windows-p) (add-hook 'eshell-parse-argument-hook - 'eshell-parse-drive-letter nil t)) + #'eshell-parse-drive-letter nil t)) (when (eshell-using-module 'eshell-cmpl) (add-hook 'pcomplete-try-first-hook - 'eshell-complete-user-reference nil t)) + #'eshell-complete-user-reference nil t)) (make-local-variable 'eshell-dirstack) (make-local-variable 'eshell-last-dir-ring) @@ -230,9 +219,9 @@ Thus, this does not include the current directory.") (unless eshell-last-dir-ring (setq eshell-last-dir-ring (make-ring eshell-last-dir-ring-size))) - (add-hook 'eshell-exit-hook 'eshell-write-last-dir-ring nil t) + (add-hook 'eshell-exit-hook #'eshell-write-last-dir-ring nil t) - (add-hook 'kill-emacs-hook 'eshell-save-some-last-dir)) + (add-hook 'kill-emacs-hook #'eshell-save-some-last-dir)) (defun eshell-save-some-last-dir () "Save the list-dir-ring for any open Eshell buffers." @@ -259,7 +248,7 @@ Thus, this does not include the current directory.") (if (> (length args) 1) (error "%s: command not found" (car args)) (throw 'eshell-replace-command - (eshell-parse-command "cd" (eshell-flatten-list args))))) + (eshell-parse-command "cd" (flatten-tree args))))) (defun eshell-parse-user-reference () "An argument beginning with ~ is a filename to be expanded." @@ -272,7 +261,7 @@ Thus, this does not include the current directory.") (defun eshell-parse-drive-letter () "An argument beginning with X:[^/] is a drive letter reference." (when (and (not eshell-current-argument) - (looking-at "\\([A-Za-z]:\\)\\([^/\\\\]\\|\\'\\)")) + (looking-at "\\([A-Za-z]:\\)\\([^/\\]\\|\\'\\)")) (goto-char (match-end 1)) (let* ((letter (match-string 1)) (regexp (concat "\\`" letter)) @@ -282,7 +271,7 @@ Thus, this does not include the current directory.") (defvar pcomplete-stub) (defvar pcomplete-last-completion-raw) (declare-function pcomplete-actual-arg "pcomplete") -(declare-function pcomplete-uniqify-list "pcomplete") +(declare-function pcomplete-uniquify-list "pcomplete") (defun eshell-complete-user-reference () "If there is a user reference, complete it." @@ -293,47 +282,48 @@ Thus, this does not include the current directory.") (throw 'pcomplete-completions (progn (eshell-read-user-names) - (pcomplete-uniqify-list + (pcomplete-uniquify-list (mapcar (function (lambda (user) (file-name-as-directory (cdr user)))) eshell-user-names))))))) -(defun eshell/pwd (&rest args) +(defun eshell/pwd (&rest _args) "Change output from `pwd' to be cleaner." (let* ((path default-directory) (len (length path))) (if (and (> len 1) (eq (aref path (1- len)) ?/) (not (and (eshell-under-windows-p) - (string-match "\\`[A-Za-z]:[\\\\/]\\'" path)))) + (string-match "\\`[A-Za-z]:[\\/]\\'" path)))) (setq path (substring path 0 (1- (length path))))) - (if eshell-pwd-convert-function - (funcall eshell-pwd-convert-function path) - path))) + (funcall (or eshell-pwd-convert-function #'identity) path))) -(defun eshell-expand-multiple-dots (path) +(defun eshell-expand-multiple-dots (filename) + ;; FIXME: This advice recommendation is rather odd: it's somewhat + ;; dangerous and it claims not to work with minibuffer-completion, which + ;; makes it much less interesting. "Convert `...' to `../..', `....' to `../../..', etc.. 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: - (defadvice expand-file-name - (before translate-multiple-dots - (filename &optional directory) activate) - (setq filename (eshell-expand-multiple-dots filename)))" - (while (string-match "\\(?:^\\|/\\)\\.\\.\\(\\.+\\)\\(?:$\\|/\\)" path) - (let* ((extra-dots (match-string 1 path)) + (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 "\\(?:\\`\\|/\\)\\.\\.\\(\\.+\\)\\(?:\\'\\|/\\)" + filename) + (let* ((extra-dots (match-string 1 filename)) (len (length extra-dots)) replace-text) (while (> len 0) (setq replace-text (concat replace-text "/..") len (1- len))) - (setq path - (replace-match replace-text t t path 1)))) - path) + (setq filename + (replace-match replace-text t t filename 1)))) + filename) (defun eshell-find-previous-directory (regexp) "Find the most recent last-dir matching REGEXP." @@ -351,7 +341,7 @@ in the minibuffer: (defun eshell/cd (&rest args) ; all but first ignored "Alias to extend the behavior of `cd'." - (setq args (eshell-flatten-list args)) + (setq args (flatten-tree args)) (let ((path (car args)) (subpath (car (cdr args))) (case-fold-search (eshell-under-windows-p)) @@ -550,15 +540,16 @@ in the minibuffer: (defun eshell-write-last-dir-ring () "Write the buffer's `eshell-last-dir-ring' to a history file." - (let ((file eshell-last-dir-ring-file-name)) + (let* ((file eshell-last-dir-ring-file-name) + (resolved-file (if (stringp file) (file-truename file)))) (cond ((or (null file) (equal file "") (null eshell-last-dir-ring) (ring-empty-p eshell-last-dir-ring)) nil) - ((not (file-writable-p file)) - (message "Cannot write last-dir-ring file %s" file)) + ((not (file-writable-p resolved-file)) + (message "Cannot write last-dir-ring file %s" resolved-file)) (t (let* ((ring eshell-last-dir-ring) (index (ring-length ring))) @@ -568,7 +559,7 @@ in the minibuffer: (insert (ring-ref ring index) ?\n)) (insert (eshell/pwd) ?\n) (eshell-with-private-file-modes - (write-region (point-min) (point-max) file nil + (write-region (point-min) (point-max) resolved-file nil 'no-message)))))))) (provide 'em-dirs) diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el index f03243a6af4..99c52ea0d30 100644 --- a/lisp/eshell/em-glob.el +++ b/lisp/eshell/em-glob.el @@ -125,7 +125,7 @@ This option slows down recursive glob processing by quite a bit." ;;; Functions: -(defun eshell-glob-initialize () +(defun eshell-glob-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the extended globbing code." ;; it's important that `eshell-glob-chars-list' come first (when (boundp 'eshell-special-chars-outside-quoting) diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el index f0aee6909ea..adb028002be 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -59,6 +59,7 @@ (require 'ring) (require 'esh-opt) +(require 'esh-mode) (require 'em-pred) (require 'eshell) @@ -152,7 +153,7 @@ element, regardless of any text on the command line. In that case, :group 'eshell-hist) (defcustom eshell-hist-word-designator - "^:?\\([0-9]+\\|[$^%*]\\)?\\(\\*\\|-[0-9]*\\|[$^%*]\\)?" + "^:?\\([0-9]+\\|[$^%*]\\)?\\(-[0-9]*\\|[$^%*]\\)?" "The regexp used to identify history word designators." :type 'regexp :group 'eshell-hist) @@ -192,7 +193,6 @@ element, regardless of any text on the command line. In that case, (defvar eshell-isearch-map (let ((map (copy-keymap isearch-mode-map))) (define-key map [(control ?m)] 'eshell-isearch-return) - (define-key map [return] '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) @@ -216,14 +216,11 @@ Returns non-nil if INPUT is blank." Returns nil if INPUT is prepended by blank space, otherwise non-nil." (not (string-match-p "\\`\\s-+" input))) -(defun eshell-hist-initialize () +(defun eshell-hist-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the history management code for one Eshell buffer." - (add-hook 'eshell-expand-input-functions - 'eshell-expand-history-references nil t) - (when (eshell-using-module 'eshell-cmpl) (add-hook 'pcomplete-try-first-hook - 'eshell-complete-history-reference nil t)) + #'eshell-complete-history-reference nil t)) (if (and (eshell-using-module 'eshell-rebind) (not eshell-non-interactive-p)) @@ -238,11 +235,13 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil." (lambda () (if (>= (point) eshell-last-output-end) (setq overriding-terminal-local-map - eshell-isearch-map)))) nil t) + eshell-isearch-map)))) + nil t) (add-hook 'isearch-mode-end-hook (function (lambda () - (setq overriding-terminal-local-map nil))) nil t)) + (setq overriding-terminal-local-map nil))) + nil t)) (define-key eshell-mode-map [up] 'eshell-previous-matching-input-from-input) (define-key eshell-mode-map [down] 'eshell-next-matching-input-from-input) (define-key eshell-mode-map [(control up)] 'eshell-previous-input) @@ -291,17 +290,17 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil." (if eshell-history-file-name (eshell-read-history nil t)) - (add-hook 'eshell-exit-hook 'eshell-write-history nil t)) + (add-hook 'eshell-exit-hook #'eshell-write-history nil t)) (unless eshell-history-ring (setq eshell-history-ring (make-ring eshell-history-size))) - (add-hook 'eshell-exit-hook 'eshell-write-history nil t) + (add-hook 'eshell-exit-hook #'eshell-write-history nil t) - (add-hook 'kill-emacs-hook 'eshell-save-some-history) + (add-hook 'kill-emacs-hook #'eshell-save-some-history) (make-local-variable 'eshell-input-filter-functions) - (add-hook 'eshell-input-filter-functions 'eshell-add-to-history nil t) + (add-hook 'eshell-input-filter-functions #'eshell-add-to-history nil t) (define-key eshell-command-map [(control ?l)] 'eshell-list-history) (define-key eshell-command-map [(control ?x)] 'eshell-get-next-from-history)) @@ -469,15 +468,16 @@ lost if `eshell-history-ring' is not empty. If Useful within process sentinels. See also `eshell-read-history'." - (let ((file (or filename eshell-history-file-name))) + (let* ((file (or filename eshell-history-file-name)) + (resolved-file (if (stringp file) (file-truename file)))) (cond ((or (null file) (equal file "") (null eshell-history-ring) (ring-empty-p eshell-history-ring)) nil) - ((not (file-writable-p file)) - (message "Cannot write history file %s" file)) + ((not (file-writable-p resolved-file)) + (message "Cannot write history file %s" resolved-file)) (t (let* ((ring eshell-history-ring) (index (ring-length ring))) @@ -492,7 +492,7 @@ See also `eshell-read-history'." (insert (substring-no-properties (ring-ref ring index)) ?\n) (subst-char-in-region start (1- (point)) ?\n ?\177))) (eshell-with-private-file-modes - (write-region (point-min) (point-max) file append + (write-region (point-min) (point-max) resolved-file append 'no-message)))))))) (defun eshell-list-history () @@ -584,21 +584,30 @@ See also `eshell-read-history'." (defun eshell-expand-history-references (beg end) "Parse and expand any history references in current input." - (let ((result (eshell-hist-parse-arguments beg end))) + (let ((result (eshell-hist-parse-arguments beg end)) + (full-line (buffer-substring-no-properties beg end))) (when result (let ((textargs (nreverse (nth 0 result))) (posb (nreverse (nth 1 result))) - (pose (nreverse (nth 2 result)))) + (pose (nreverse (nth 2 result))) + (full-line-subst (eshell-history-substitution full-line))) (save-excursion - (while textargs - (let ((str (eshell-history-reference (car textargs)))) - (unless (eq str (car textargs)) - (goto-char (car posb)) - (insert-and-inherit str) - (delete-char (- (car pose) (car posb))))) - (setq textargs (cdr textargs) - posb (cdr posb) - pose (cdr pose)))))))) + (if full-line-subst + ;; Found a ^foo^bar substitution + (progn + (goto-char beg) + (insert-and-inherit full-line-subst) + (delete-char (- end beg))) + ;; Try to expand other substitutions + (while textargs + (let ((str (eshell-history-reference (car textargs)))) + (unless (eq str (car textargs)) + (goto-char (car posb)) + (insert-and-inherit str) + (delete-char (- (car pose) (car posb))))) + (setq textargs (cdr textargs) + posb (cdr posb) + pose (cdr pose))))))))) (defvar pcomplete-stub) (defvar pcomplete-last-completion-raw) @@ -633,20 +642,31 @@ See also `eshell-read-history'." (setq history (cdr history))) (cdr fhist))))))) +(defun eshell-history-substitution (line) + "Expand quick hist substitutions formatted as ^foo^bar^. +Returns nil if string does not match quick substitution format, +and acts like !!:s/foo/bar/ otherwise." + ;; `^string1^string2^' + ;; Quick Substitution. Repeat the last command, replacing + ;; STRING1 with STRING2. Equivalent to `!!:s/string1/string2/' + (when (and (eshell-using-module 'eshell-pred) + (string-match + "^\\^\\([^^]+\\)\\^\\([^^]+\\)\\(?:\\^\\(.*\\)\\)?$" + line)) + ;; Save trailing match as `eshell-history-reference' runs string-match. + (let ((matched-end (match-string 3 line))) + (concat + (eshell-history-reference + (format "!!:s/%s/%s/" + (match-string 1 line) + (match-string 2 line))) + matched-end)))) + (defun eshell-history-reference (reference) "Expand directory stack REFERENCE. The syntax used here was taken from the Bash info manual. Returns the resultant reference, or the same string REFERENCE if none matched." - ;; `^string1^string2^' - ;; Quick Substitution. Repeat the last command, replacing - ;; STRING1 with STRING2. Equivalent to `!!:s/string1/string2/' - (if (and (eshell-using-module 'eshell-pred) - (string-match "\\^\\([^^]+\\)\\^\\([^^]+\\)\\^?\\s-*$" - reference)) - (setq reference (format "!!:s/%s/%s/" - (match-string 1 reference) - (match-string 2 reference)))) ;; `!' ;; Start a history substitution, except when followed by a ;; space, tab, the end of the line, = or (. @@ -736,7 +756,7 @@ matched." (setq nth (eshell-hist-word-reference nth))) (unless (numberp mth) (setq mth (eshell-hist-word-reference mth))) - (cons (mapconcat 'identity (eshell-sublist textargs nth mth) " ") + (cons (mapconcat #'identity (eshell-sublist textargs nth mth) " ") end)))) (defun eshell-hist-parse-modifier (hist reference) diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el index a4118a0da30..b1aab79538f 100644 --- a/lisp/eshell/em-ls.el +++ b/lisp/eshell/em-ls.el @@ -29,7 +29,8 @@ (require 'cl-lib) (require 'esh-util) (require 'esh-opt) -(eval-when-compile (require 'eshell)) +(require 'esh-proc) +(require 'esh-cmd) ;;;###autoload (progn @@ -183,9 +184,9 @@ really need to stick around for very long." "The face used for highlighting junk file names.") (defsubst eshell-ls-filetype-p (attrs type) - "Test whether ATTRS specifies a directory." - (if (nth 8 attrs) - (eq (aref (nth 8 attrs) 0) type))) + "Test whether ATTRS specifies a file of type TYPE." + (if (file-attribute-modes attrs) + (eq (aref (file-attribute-modes attrs) 0) type))) (defmacro eshell-ls-applicable (attrs index func file) "Test whether, for ATTRS, the user can do what corresponds to INDEX. @@ -193,8 +194,8 @@ ATTRS is a string of file modes. See `file-attributes'. If we cannot determine the answer using ATTRS (e.g., if we need to know what group the user is in), compute the return value by calling FUNC with FILE as an argument." - `(let ((owner (nth 2 ,attrs)) - (modes (nth 8 ,attrs))) + `(let ((owner (file-attribute-user-id ,attrs)) + (modes (file-attribute-modes ,attrs))) (cond ((cond ((numberp owner) (= owner (user-uid))) ((stringp owner) @@ -346,7 +347,7 @@ instead." "ls" (if eshell-ls-initial-args (list eshell-ls-initial-args args) args) - `((?a "all" nil show-all + '((?a "all" nil show-all "do not ignore entries starting with .") (?A "almost-all" nil show-almost-all "do not list implied . and ..") @@ -437,7 +438,7 @@ Sort entries alphabetically across.") (defsubst eshell-ls-size-string (attrs size-width) "Return the size string for ATTRS length, using SIZE-WIDTH." - (let* ((str (eshell-ls-printable-size (nth 7 attrs) t)) + (let* ((str (eshell-ls-printable-size (file-attribute-size attrs) t)) (len (length str))) (if (< len size-width) (concat (make-string (- size-width len) ? ) str) @@ -503,19 +504,19 @@ whose cdr is the list of file attributes." (if numeric-uid-gid "%s%4d %-8s %-8s " "%s%4d %-14s %-8s ") - (or (nth 8 attrs) "??????????") - (or (nth 1 attrs) 0) - (or (let ((user (nth 2 attrs))) + (or (file-attribute-modes attrs) "??????????") + (or (file-attribute-link-number attrs) 0) + (or (let ((user (file-attribute-user-id attrs))) (and (stringp user) (eshell-substring user 14))) - (nth 2 attrs) + (file-attribute-user-id attrs) "") - (or (let ((group (nth 3 attrs))) + (or (let ((group (file-attribute-group-id attrs))) (and (stringp group) (eshell-substring group 8))) - (nth 3 attrs) + (file-attribute-group-id attrs) "")) - (let* ((str (eshell-ls-printable-size (nth 7 attrs))) + (let* ((str (eshell-ls-printable-size (file-attribute-size attrs))) (len (length str))) ;; Let file sizes shorter than 9 align neatly. (if (< len (or size-width 8)) @@ -524,12 +525,14 @@ whose cdr is the list of file attributes." " " (format-time-string (concat eshell-ls-date-format " " - (if (= (nth 5 (decode-time)) - (nth 5 (decode-time - (nth (cond - ((eq sort-method 'by-atime) 4) - ((eq sort-method 'by-ctime) 6) - (t 5)) attrs)))) + (if (= (decoded-time-year (decode-time)) + (decoded-time-year + (decode-time + (nth (cond + ((eq sort-method 'by-atime) 4) + ((eq sort-method 'by-ctime) 6) + (t 5)) + attrs)))) "%H:%M" " %Y")) (nth (cond ((eq sort-method 'by-atime) 4) @@ -585,12 +588,12 @@ relative to that directory." (let ((total 0.0)) (setq size-width 0) (dolist (e entries) - (if (nth 7 (cdr e)) - (setq total (+ total (nth 7 (cdr e))) + (if (file-attribute-size (cdr e)) + (setq total (+ total (file-attribute-size (cdr e))) size-width (max size-width (length (eshell-ls-printable-size - (nth 7 (cdr e)) + (file-attribute-size (cdr e)) (not ;; If we are under -l, count length ;; of sizes in bytes, not in blocks. @@ -700,7 +703,7 @@ Each member of FILES is either a string or a cons cell of the form (if (not show-size) (setq display-files (mapcar 'eshell-ls-annotate files)) (dolist (file files) - (let* ((str (eshell-ls-printable-size (nth 7 (cdr file)) t)) + (let* ((str (eshell-ls-printable-size (file-attribute-size (cdr file)) t)) (len (length str))) (if (< len size-width) (setq str (concat (make-string (- size-width len) ? ) str))) @@ -766,14 +769,14 @@ need to be printed." (if show-size (max size-width (length (eshell-ls-printable-size - (nth 7 (cdr entry)) t)))))) + (file-attribute-size (cdr entry)) t)))))) (setq dirs (cons entry dirs))) (setq files (cons entry files) size-width (if show-size (max size-width (length (eshell-ls-printable-size - (nth 7 (cdr entry)) t))))))) + (file-attribute-size (cdr entry)) t))))))) (when files (eshell-ls-files (eshell-ls-sort-entries files) size-width show-recursive) diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index bfabda0ec77..9bc856a2966 100644 --- a/lisp/eshell/em-pred.el +++ b/lisp/eshell/em-pred.el @@ -46,9 +46,7 @@ ;;; Code: -(require 'esh-util) -(require 'esh-arg) -(eval-when-compile (require 'eshell)) +(require 'esh-mode) ;;;###autoload (progn @@ -89,10 +87,12 @@ ordinary strings." (?t . (eshell-pred-file-mode 1000)) ; sticky bit (?U . #'(lambda (file) ; owned by effective uid (if (file-exists-p file) - (= (nth 2 (file-attributes file)) (user-uid))))) + (= (file-attribute-user-id (file-attributes file)) + (user-uid))))) ;; (?G . #'(lambda (file) ; owned by effective gid ;; (if (file-exists-p file) - ;; (= (nth 2 (file-attributes file)) (user-uid))))) + ;; (= (file-attribute-user-id (file-attributes file)) + ;; (user-uid))))) (?* . #'(lambda (file) (and (file-regular-p file) (not (file-symlink-p file)) @@ -131,7 +131,7 @@ The format of each entry is (?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) (eshell-uniqify-list lst))) + (?u . #'(lambda (lst) (eshell-uniquify-list lst))) (?o . #'(lambda (lst) (sort lst 'string-lessp))) (?O . #'(lambda (lst) (nreverse (sort lst 'string-lessp)))) (?j . (eshell-join-members)) @@ -245,10 +245,10 @@ EXAMPLES: (lambda () (insert eshell-modifier-help-string))))) -(defun eshell-pred-initialize () +(defun eshell-pred-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the predicate/modifier code." (add-hook 'eshell-parse-argument-hook - 'eshell-parse-arg-modifier t t) + #'eshell-parse-arg-modifier t t) (define-key eshell-command-map [(meta ?q)] 'eshell-display-predicate-help) (define-key eshell-command-map [(meta ?m)] 'eshell-display-modifier-help)) @@ -419,9 +419,8 @@ resultant list of strings." (forward-char)) (if (looking-at "[0-9]+") (progn - (setq when (- (float-time) - (* (string-to-number (match-string 0)) - quantum))) + (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 '(?\( ?\[ ?\< ?\{))) @@ -436,17 +435,17 @@ resultant list of strings." (attrs (file-attributes file))) (unless attrs (error "Cannot stat file `%s'" file)) - (setq when (float-time (nth attr-index attrs)))) + (setq when (nth attr-index attrs))) (goto-char (1+ end))) `(lambda (file) (let ((attrs (file-attributes file))) (if attrs (,(if (eq qual ?-) - '< + 'time-less-p (if (eq qual ?+) - '> - '=)) ,when (float-time - (nth ,attr-index attrs)))))))) + '(lambda (a b) (time-less-p b a)) + 'time-equal-p)) + ,when (nth ,attr-index attrs))))))) (defun eshell-pred-file-type (type) "Return a test which tests that the file is of a certain TYPE. @@ -460,7 +459,7 @@ that `ls -l' will show in the first column of its display. " `(lambda (file) (let ((attrs (eshell-file-attributes (directory-file-name file)))) (if attrs - (memq (aref (nth 8 attrs) 0) + (memq (aref (file-attribute-modes attrs) 0) ,(if (eq type ?%) '(?b ?c) (list 'quote (list type)))))))) @@ -489,7 +488,8 @@ that `ls -l' will show in the first column of its display. " '< (if (eq qual ?+) '> - '=)) (nth 1 attrs) ,amount)))))) + '=)) + (file-attribute-link-number attrs) ,amount)))))) (defun eshell-pred-file-size () "Return a predicate to test whether a file is of a given size." @@ -518,7 +518,8 @@ that `ls -l' will show in the first column of its display. " '< (if (eq qual ?+) '> - '=)) (nth 7 attrs) ,amount)))))) + '=)) + (file-attribute-size attrs) ,amount)))))) (defun eshell-pred-substitute (&optional repeat) "Return a modifier function that will substitute matches." @@ -545,7 +546,8 @@ that `ls -l' will show in the first column of its display. " (function (lambda (str) (if (string-match ,match str) - (setq str (replace-match ,replace t nil str))) + (setq str (replace-match ,replace t nil str)) + (error (concat str ": substitution failed"))) str)) lst))))) (defun eshell-include-members (&optional invert-p) diff --git a/lisp/eshell/em-prompt.el b/lisp/eshell/em-prompt.el index 3d15a441610..adc68b6c856 100644 --- a/lisp/eshell/em-prompt.el +++ b/lisp/eshell/em-prompt.el @@ -80,7 +80,6 @@ re-entered for it to take effect." For highlighting other kinds of strings -- similar to shell mode's behavior -- simply use an output filer which changes text properties." :group 'eshell-prompt) -(define-obsolete-face-alias 'eshell-prompt-face 'eshell-prompt "22.1") (defcustom eshell-before-prompt-hook nil "A list of functions to call before outputting the prompt." @@ -100,7 +99,7 @@ arriving, or after." ;;; Functions: -(defun eshell-prompt-initialize () +(defun eshell-prompt-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the prompting code." (unless eshell-non-interactive-p (add-hook 'eshell-post-command-hook 'eshell-emit-prompt nil t) diff --git a/lisp/eshell/em-rebind.el b/lisp/eshell/em-rebind.el index 9cb16174f20..a817edbcc99 100644 --- a/lisp/eshell/em-rebind.el +++ b/lisp/eshell/em-rebind.el @@ -145,7 +145,7 @@ This is default behavior of shells like bash." ;;; Functions: -(defun eshell-rebind-initialize () +(defun eshell-rebind-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the inputting code." (unless eshell-non-interactive-p (add-hook 'eshell-mode-hook 'eshell-setup-input-keymap nil t) diff --git a/lisp/eshell/em-script.el b/lisp/eshell/em-script.el index b8a5ecd9002..6970dfc80bd 100644 --- a/lisp/eshell/em-script.el +++ b/lisp/eshell/em-script.el @@ -23,8 +23,7 @@ ;;; Code: -(require 'eshell) -(require 'esh-opt) +(require 'esh-mode) ;;;###autoload (progn @@ -57,11 +56,11 @@ This includes when running `eshell-command'." ;;; Functions: -(defun eshell-script-initialize () +(defun eshell-script-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the script parsing code." (make-local-variable 'eshell-interpreter-alist) (setq eshell-interpreter-alist - (cons (cons #'(lambda (file args) + (cons (cons #'(lambda (file _args) (string= (file-name-nondirectory file) "eshell")) 'eshell/source) @@ -73,13 +72,14 @@ This includes when running `eshell-command'." ;; to ruin it for other modules (let (eshell-inside-quote-regexp eshell-outside-quote-regexp) - (and (not eshell-non-interactive-p) + (and (not (bound-and-true-p eshell-non-interactive-p)) eshell-login-script (file-readable-p eshell-login-script) (eshell-do-eval (list 'eshell-commands (catch 'eshell-replace-command - (eshell-source-file eshell-login-script))) t)) + (eshell-source-file eshell-login-script))) + t)) (and eshell-rc-script (file-readable-p eshell-rc-script) (eshell-do-eval @@ -90,7 +90,6 @@ This includes when running `eshell-command'." (defun eshell-source-file (file &optional args subcommand-p) "Execute a series of Eshell commands in FILE, passing ARGS. Comments begin with `#'." - (interactive "f") (let ((orig (point)) (here (point-max)) (inhibit-point-motion-hooks t)) diff --git a/lisp/eshell/em-smart.el b/lisp/eshell/em-smart.el index 420f8850504..c7965b4187c 100644 --- a/lisp/eshell/em-smart.el +++ b/lisp/eshell/em-smart.el @@ -166,7 +166,7 @@ The options are `begin', `after' or `end'." ;;; Functions: -(defun eshell-smart-initialize () +(defun eshell-smart-initialize () ;Called from `eshell-mode' via intern-soft! "Setup Eshell smart display." (unless eshell-non-interactive-p ;; override a few variables, since they would interfere with the diff --git a/lisp/eshell/em-term.el b/lisp/eshell/em-term.el index 1013bd2b89a..dea90405ad7 100644 --- a/lisp/eshell/em-term.el +++ b/lisp/eshell/em-term.el @@ -147,7 +147,7 @@ behavior for short-lived processes, see bug#18108." ;;; Functions: -(defun eshell-term-initialize () +(defun eshell-term-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the `term' interface code." (make-local-variable 'eshell-interpreter-alist) (setq eshell-interpreter-alist @@ -175,7 +175,7 @@ allowed." (let* (eshell-interpreter-alist (interp (eshell-find-interpreter (car args) (cdr args))) (program (car interp)) - (args (eshell-flatten-list + (args (flatten-tree (eshell-stringify-list (append (cdr interp) (cdr args))))) (term-buf @@ -191,7 +191,7 @@ allowed." (term-exec term-buf program program nil args) (let ((proc (get-buffer-process term-buf))) (if (and proc (eq 'run (process-status proc))) - (set-process-sentinel proc 'eshell-term-sentinel) + (set-process-sentinel proc #'eshell-term-sentinel) (error "Failed to invoke visual command"))) (term-char-mode) (if eshell-escape-control-x diff --git a/lisp/eshell/em-tramp.el b/lisp/eshell/em-tramp.el index 81324800aef..c7916360ee6 100644 --- a/lisp/eshell/em-tramp.el +++ b/lisp/eshell/em-tramp.el @@ -26,6 +26,7 @@ ;;; Code: (require 'esh-util) +(require 'esh-cmd) (eval-when-compile (require 'esh-mode) @@ -45,7 +46,7 @@ :tag "TRAMP Eshell features" :group 'eshell-module)) -(defun eshell-tramp-initialize () +(defun eshell-tramp-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the TRAMP-using commands code." (when (eshell-using-module 'eshell-cmpl) (add-hook 'pcomplete-try-first-hook @@ -61,7 +62,7 @@ "Alias \"su\" to call TRAMP. Uses the system su through TRAMP's su method." - (setq args (eshell-stringify-list (eshell-flatten-list args))) + (setq args (eshell-stringify-list (flatten-tree args))) (let ((orig-args (copy-tree args))) (eshell-eval-using-options "su" args @@ -99,13 +100,14 @@ 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 (eshell-flatten-list args))) + (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 Execute a COMMAND as the superuser or another USER.") (throw 'eshell-external diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el index b4ad5a6532c..25221817218 100644 --- a/lisp/eshell/em-unix.el +++ b/lisp/eshell/em-unix.el @@ -35,8 +35,7 @@ ;;; Code: -(require 'eshell) -(require 'esh-opt) +(require 'esh-mode) (require 'pcomplete) ;;;###autoload @@ -140,7 +139,7 @@ Otherwise, Emacs will attempt to use rsh to invoke du on the remote machine." ;;; Functions: -(defun eshell-unix-initialize () +(defun eshell-unix-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the UNIX support/emulation code." (when (eshell-using-module 'eshell-cmpl) (add-hook 'pcomplete-try-first-hook @@ -231,7 +230,7 @@ Otherwise, Emacs will attempt to use rsh to invoke du on the remote machine." This is implemented to call either `delete-file', `kill-buffer', `kill-process', or `unintern', depending on the nature of the argument." - (setq args (eshell-flatten-list args)) + (setq args (flatten-tree args)) (eshell-eval-using-options "rm" args '((?h "help" nil nil "show this usage screen") @@ -370,12 +369,14 @@ Remove the DIRECTORY(ies), if they are empty.") (or (not (eshell-under-windows-p)) (eq system-type 'ms-dos)) (setq attr (eshell-file-attributes (car files))) - (nth 10 attr-target) (nth 10 attr) - ;; Use equal, not -, since the inode and the device could - ;; cons cells. - (equal (nth 10 attr-target) (nth 10 attr)) - (nth 11 attr-target) (nth 11 attr) - (equal (nth 11 attr-target) (nth 11 attr))) + (file-attribute-inode-number attr-target) + (file-attribute-inode-number attr) + (equal (file-attribute-inode-number attr-target) + (file-attribute-inode-number attr)) + (file-attribute-device-number attr-target) + (file-attribute-device-number attr) + (equal (file-attribute-device-number attr-target) + (file-attribute-device-number attr))) (eshell-error (format-message "%s: `%s' and `%s' are the same file\n" command (car files) target))) (t @@ -397,16 +398,16 @@ Remove the DIRECTORY(ies), if they are empty.") (let (eshell-warn-dot-directories) (if (and (not deep) (eq func 'rename-file) - ;; Use equal, since the device might be a - ;; cons cell. - (equal (nth 11 (eshell-file-attributes - (file-name-directory - (directory-file-name - (expand-file-name source))))) - (nth 11 (eshell-file-attributes - (file-name-directory - (directory-file-name - (expand-file-name target))))))) + (equal (file-attribute-device-number + (eshell-file-attributes + (file-name-directory + (directory-file-name + (expand-file-name source))))) + (file-attribute-device-number + (eshell-file-attributes + (file-name-directory + (directory-file-name + (expand-file-name target))))))) (apply 'eshell-funcalln func source target args) (unless (file-directory-p target) (if em-verbose @@ -479,7 +480,7 @@ Remove the DIRECTORY(ies), if they are empty.") (error "%s: missing destination file or directory" ,command)) (if (= len 1) (nconc args '("."))) - (setq args (eshell-stringify-list (eshell-flatten-list args))) + (setq args (eshell-stringify-list (flatten-tree args))) (if (and ,(not (equal command "ln")) (string-match eshell-tar-regexp (car (last args))) (or (> (length args) 2) @@ -604,7 +605,7 @@ with `--symbolic'. When creating hard links, each TARGET must exist.") "Implementation of cat in Lisp. If in a pipeline, or the file is not a regular file, directory or symlink, then revert to the system's definition of cat." - (setq args (eshell-stringify-list (eshell-flatten-list args))) + (setq args (eshell-stringify-list (flatten-tree args))) (if (or eshell-in-pipeline-p (catch 'special (dolist (arg args) @@ -612,7 +613,8 @@ symlink, then revert to the system's definition of cat." (> (length arg) 0) (eq (aref arg 0) ?-)) (let ((attrs (eshell-file-attributes arg))) - (and attrs (memq (aref (nth 8 attrs) 0) + (and attrs + (memq (aref (file-attribute-modes attrs) 0) '(?d ?l ?-))))) (throw 'special t))))) (let ((ext-cat (eshell-search-path "cat"))) @@ -667,7 +669,7 @@ Fallback to standard make when called synchronously." (compile (concat "make " (eshell-flatten-and-stringify args)))) (throw 'eshell-replace-command (eshell-parse-command "*make" (eshell-stringify-list - (eshell-flatten-list args)))))) + (flatten-tree args)))))) (put 'eshell/make 'eshell-no-numeric-conversions t) @@ -702,7 +704,7 @@ available..." (erase-buffer) (occur-mode) (let ((files (eshell-stringify-list - (eshell-flatten-list (cdr args)))) + (flatten-tree (cdr args)))) (inhibit-redisplay t) string) (when (car args) @@ -747,11 +749,11 @@ external command." (throw 'eshell-replace-command (eshell-parse-command (concat "*" command) (eshell-stringify-list - (eshell-flatten-list args)))) + (flatten-tree args)))) (let* ((args (mapconcat 'identity (mapcar 'shell-quote-argument (eshell-stringify-list - (eshell-flatten-list args))) + (flatten-tree args))) " ")) (cmd (progn (set-text-properties 0 (length args) @@ -843,19 +845,19 @@ external command." (unless (string-match "\\`\\.\\.?\\'" (caar entries)) (let* ((entry (concat path "/" (caar entries))) - (symlink (and (stringp (cadr (car entries))) - (cadr (car entries))))) + (symlink (and (stringp (file-attribute-type (cdar entries))) + (file-attribute-type (cdar entries))))) (unless (or (and symlink (not dereference-links)) (and only-one-filesystem (/= only-one-filesystem - (nth 12 (car entries))))) + (file-attribute-device-number (cdar entries))))) (if symlink (setq entry symlink)) (setq size (+ size - (if (eq t (cadr (car entries))) + (if (eq t (car (cdar entries))) (eshell-du-sum-directory entry (1+ depth)) - (let ((file-size (nth 8 (car entries)))) + (let ((file-size (file-attribute-size (cdar entries)))) (prog1 file-size (if show-all @@ -873,7 +875,7 @@ external command." (defun eshell/du (&rest args) "Implementation of \"du\" in Lisp, passing ARGS." (setq args (if args - (eshell-stringify-list (eshell-flatten-list args)) + (eshell-stringify-list (flatten-tree args)) '("."))) (let ((ext-du (eshell-search-path "du"))) (if (and ext-du @@ -926,7 +928,7 @@ Summarize disk usage of each FILE, recursively for directories.") (while args (if only-one-filesystem (setq only-one-filesystem - (nth 11 (eshell-file-attributes + (file-attribute-device-number (eshell-file-attributes (file-name-as-directory (car args)))))) (setq size (+ size (eshell-du-sum-directory (directory-file-name (car args)) 0))) @@ -940,7 +942,8 @@ Summarize disk usage of each FILE, recursively for directories.") (defvar eshell-time-start nil) (defun eshell-show-elapsed-time () - (let ((elapsed (format "%.3f secs\n" (- (float-time) eshell-time-start)))) + (let ((elapsed (format "%.3f secs\n" + (float-time (time-since eshell-time-start))))) (set-text-properties 0 (length elapsed) '(face bold) elapsed) (eshell-interactive-print elapsed)) (remove-hook 'eshell-post-command-hook 'eshell-show-elapsed-time t)) @@ -973,9 +976,9 @@ Show wall-clock time elapsed during execution of COMMAND.") (eshell-parse-command (car time-args) ;;; https://lists.gnu.org/r/bug-gnu-emacs/2007-08/msg00205.html (eshell-stringify-list - (eshell-flatten-list (cdr time-args)))))))) + (flatten-tree (cdr time-args)))))))) -(defun eshell/whoami (&rest args) +(defun eshell/whoami (&rest _args) "Make \"whoami\" Tramp aware." (or (file-remote-p default-directory 'user) (user-login-name))) @@ -997,7 +1000,7 @@ Show wall-clock time elapsed during execution of COMMAND.") (defun eshell/diff (&rest args) "Alias \"diff\" to call Emacs `diff' function." - (let ((orig-args (eshell-stringify-list (eshell-flatten-list args)))) + (let ((orig-args (eshell-stringify-list (flatten-tree args)))) (if (or eshell-plain-diff-behavior (not (and (eshell-interactive-output-p) (not eshell-in-pipeline-p) @@ -1053,7 +1056,7 @@ Show wall-clock time elapsed during execution of COMMAND.") (string-match "^-" (car args)))) (throw 'eshell-replace-command (eshell-parse-command "*locate" (eshell-stringify-list - (eshell-flatten-list args)))) + (flatten-tree args)))) (save-selected-window (let ((locate-history-list (list (car args)))) (locate-with-filter (car args) (cadr args)))))) diff --git a/lisp/eshell/em-xtra.el b/lisp/eshell/em-xtra.el index d4e5f1a092c..602e8417520 100644 --- a/lisp/eshell/em-xtra.el +++ b/lisp/eshell/em-xtra.el @@ -25,8 +25,10 @@ (require 'esh-util) (eval-when-compile - (require 'eshell) - (require 'pcomplete)) + (require 'eshell)) +;; Strictly speaking, should only be needed at compile time. +;; Require at run-time too to silence compiler. +(require 'pcomplete) (require 'compile) ;; There are no items in this custom group, but eshell modules (ab)use @@ -49,7 +51,7 @@ naturally accessible within Emacs." "Implementation of expr, using the calc package." (if (not (fboundp 'calc-eval)) (throw 'eshell-replace-command - (eshell-parse-command "*expr" (eshell-flatten-list args))) + (eshell-parse-command "*expr" (flatten-tree args))) ;; to fool the byte-compiler... (let ((func 'calc-eval)) (funcall func (eshell-flatten-and-stringify args))))) diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el index 360202b6539..026edc59808 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -25,9 +25,9 @@ ;; hook `eshell-parse-argument-hook'. For a good example of this, see ;; `eshell-parse-drive-letter', defined in eshell-dirs.el. -(provide 'esh-arg) +;;; Code: -(require 'esh-mode) +(require 'esh-util) (defgroup eshell-arg nil "Argument parsing involves transforming the arguments passed on the @@ -36,6 +36,48 @@ yield the values intended." :tag "Argument parsing" :group 'eshell) +;;; Internal Variables: + +(defvar eshell-current-argument nil) +(defvar eshell-current-modifiers nil) +(defvar eshell-arg-listified nil) +(defvar eshell-nested-argument nil) +(defvar eshell-current-quoted nil) +(defvar eshell-inside-quote-regexp nil) +(defvar eshell-outside-quote-regexp nil) + +;;; User Variables: + +(defcustom eshell-arg-load-hook nil + "A hook that gets run when `eshell-arg' is loaded." + :version "24.1" ; removed eshell-arg-initialize + :type 'hook + :group 'eshell-arg) + +(defcustom eshell-delimiter-argument-list '(?\; ?& ?\| ?\> ?\s ?\t ?\n) + "List of characters to recognize as argument separators." + :type '(repeat character) + :group 'eshell-arg) + +(defcustom eshell-special-chars-inside-quoting '(?\\ ?\") + "Characters which are still special inside double quotes." + :type '(repeat character) + :group 'eshell-arg) + +(defcustom eshell-special-chars-outside-quoting + (append eshell-delimiter-argument-list '(?# ?! ?\\ ?\" ?\')) + "Characters that require escaping outside of double quotes. +Without escaping them, they will introduce a change in the argument." + :type '(repeat character) + :group 'eshell-arg) + +(defsubst eshell-arg-delimiter (&optional pos) + "Return non-nil if POS is an argument delimiter. +If POS is nil, the location of point is checked." + (let ((pos (or pos (point)))) + (or (= pos (point-max)) + (memq (char-after pos) eshell-delimiter-argument-list)))) + (defcustom eshell-parse-argument-hook (list ;; a term such as #<buffer NAME>, or #<process NAME> is a buffer @@ -113,47 +155,13 @@ treated as a literal character." :type 'hook :group 'eshell-arg) -;;; Code: - -;;; User Variables: - -(defcustom eshell-arg-load-hook nil - "A hook that gets run when `eshell-arg' is loaded." - :version "24.1" ; removed eshell-arg-initialize - :type 'hook - :group 'eshell-arg) - -(defcustom eshell-delimiter-argument-list '(?\; ?& ?\| ?\> ?\s ?\t ?\n) - "List of characters to recognize as argument separators." - :type '(repeat character) - :group 'eshell-arg) - -(defcustom eshell-special-chars-inside-quoting '(?\\ ?\") - "Characters which are still special inside double quotes." - :type '(repeat character) - :group 'eshell-arg) - -(defcustom eshell-special-chars-outside-quoting - (append eshell-delimiter-argument-list '(?# ?! ?\\ ?\" ?\')) - "Characters that require escaping outside of double quotes. -Without escaping them, they will introduce a change in the argument." - :type '(repeat character) - :group 'eshell-arg) - -;;; Internal Variables: - -(defvar eshell-current-argument nil) -(defvar eshell-current-modifiers nil) -(defvar eshell-arg-listified nil) -(defvar eshell-nested-argument nil) -(defvar eshell-current-quoted nil) -(defvar eshell-inside-quote-regexp nil) -(defvar eshell-outside-quote-regexp nil) - ;;; Functions: -(defun eshell-arg-initialize () +(defun eshell-arg-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the argument parsing code." + ;; This is supposedly run after enabling esh-mode, when eshell-mode-map + ;; already exists. + (defvar eshell-command-map) (define-key eshell-command-map [(meta ?b)] 'eshell-insert-buffer-name) (set (make-local-variable 'eshell-inside-quote-regexp) nil) (set (make-local-variable 'eshell-outside-quote-regexp) nil)) @@ -195,13 +203,6 @@ Without escaping them, they will introduce a change in the argument." (setq eshell-current-argument argument)) (throw 'eshell-arg-done t)) -(defsubst eshell-arg-delimiter (&optional pos) - "Return non-nil if POS is an argument delimiter. -If POS is nil, the location of point is checked." - (let ((pos (or pos (point)))) - (or (= pos (point-max)) - (memq (char-after pos) eshell-delimiter-argument-list)))) - (defun eshell-quote-argument (string) "Return STRING with magic characters quoted. Magic characters are those in `eshell-special-chars-outside-quoting'." @@ -405,4 +406,5 @@ If the form has no `type', the syntax is parsed as if `type' were (char-to-string (char-after))))) (goto-char end))))))) +(provide 'esh-arg) ;;; esh-arg.el ends here diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index 8e1e936b63f..83cc5999dc3 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el @@ -105,12 +105,16 @@ (require 'eldoc)) (require 'esh-arg) (require 'esh-proc) +(require 'esh-module) +(require 'esh-io) (require 'esh-ext) (eval-when-compile (require 'cl-lib) (require 'pcomplete)) +(declare-function pcomplete--here "pcomplete" + (&optional form stub paring form-only)) (defgroup eshell-cmd nil "Executing an Eshell command is as simple as typing it in and @@ -122,24 +126,20 @@ however." (defcustom eshell-prefer-lisp-functions nil "If non-nil, prefer Lisp functions to external commands." - :type 'boolean - :group 'eshell-cmd) + :type 'boolean) (defcustom eshell-lisp-regexp "\\([(`]\\|#'\\)" "A regexp which, if matched at beginning of an argument, means Lisp. Such arguments will be passed to `read', and then evaluated." - :type 'regexp - :group 'eshell-cmd) + :type 'regexp) (defcustom eshell-pre-command-hook nil "A hook run before each interactive command is invoked." - :type 'hook - :group 'eshell-cmd) + :type 'hook) (defcustom eshell-post-command-hook nil "A hook run after each interactive command is invoked." - :type 'hook - :group 'eshell-cmd) + :type 'hook) (defcustom eshell-prepare-command-hook nil "A set of functions called to prepare a named command. @@ -149,8 +149,7 @@ the value of these symbols if necessary. To prevent a command from executing at all, set `eshell-last-command-name' to nil." - :type 'hook - :group 'eshell-cmd) + :type 'hook) (defcustom eshell-named-command-hook nil "A set of functions called before a named command is invoked. @@ -165,7 +164,7 @@ In order to substitute an alternate command form for execution, the hook function should throw it using the tag `eshell-replace-command'. For example: - (add-hook \\='eshell-named-command-hook \\='subst-with-cd) + (add-hook \\='eshell-named-command-hook #\\='subst-with-cd) (defun subst-with-cd (command args) (throw \\='eshell-replace-command (eshell-parse-command \"cd\" args))) @@ -173,8 +172,7 @@ For example: Although useless, the above code will cause any non-glob, non-Lisp command (i.e., `ls' as opposed to `*ls' or `(ls)') to be replaced by a call to `cd' using the arguments that were passed to the function." - :type 'hook - :group 'eshell-cmd) + :type 'hook) (defcustom eshell-pre-rewrite-command-hook '(eshell-no-command-conversion @@ -182,8 +180,7 @@ call to `cd' using the arguments that were passed to the function." "A hook run before command rewriting begins. The terms of the command to be rewritten is passed as arguments, and may be modified in place. Any return value is ignored." - :type 'hook - :group 'eshell-cmd) + :type 'hook) (defcustom eshell-rewrite-command-hook '(eshell-rewrite-for-command @@ -202,8 +199,7 @@ so by adding a function to this hook. The first function to return a substitute command form is the one used. Each function is passed the command's full argument list, which is a list of sexps (typically forms or strings)." - :type 'hook - :group 'eshell-cmd) + :type 'hook) (defvar eshell-post-rewrite-command-function #'identity "Function run after command rewriting is finished. @@ -228,16 +224,14 @@ If an entry is a function, it will be called with the name, and should return non-nil if the command is complex." :type '(repeat :tag "Commands" (choice (string :tag "Name") - (function :tag "Predicate"))) - :group 'eshell-cmd) + (function :tag "Predicate")))) ;;; User Variables: (defcustom eshell-cmd-load-hook nil "A hook that gets run when `eshell-cmd' is loaded." :version "24.1" ; removed eshell-cmd-initialize - :type 'hook - :group 'eshell-cmd) + :type 'hook) (defcustom eshell-debug-command nil "If non-nil, enable Eshell debugging code. @@ -247,9 +241,8 @@ you must re-load `esh-cmd.el'." :initialize 'custom-initialize-default :set (lambda (symbol value) (set symbol value) - (load-library "esh-cmd")) - :type 'boolean - :group 'eshell-cmd) + (load "esh-cmd")) + :type 'boolean) (defcustom eshell-deferrable-commands '(eshell-named-command @@ -259,16 +252,14 @@ you must re-load `esh-cmd.el'." If they return a process object, execution of the calling Eshell command will wait for completion (in the background) before finishing the command." - :type '(repeat function) - :group 'eshell-cmd) + :type '(repeat function)) (defcustom eshell-subcommand-bindings '((eshell-in-subcommand-p t) (default-directory default-directory) (process-environment (eshell-copy-environment))) "A list of `let' bindings for subcommand environments." - :type 'sexp - :group 'eshell-cmd) + :type 'sexp) (put 'risky-local-variable 'eshell-subcommand-bindings t) @@ -298,7 +289,7 @@ otherwise t.") "Return currently running command process, if non-Lisp." eshell-last-async-proc) -(defun eshell-cmd-initialize () +(defun eshell-cmd-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the Eshell command processing module." (set (make-local-variable 'eshell-current-command) nil) (set (make-local-variable 'eshell-command-name) nil) @@ -307,7 +298,7 @@ otherwise t.") (set (make-local-variable 'eshell-last-command-name) nil) (set (make-local-variable 'eshell-last-async-proc) nil) - (add-hook 'eshell-kill-hook 'eshell-resume-command nil t) + (add-hook 'eshell-kill-hook #'eshell-resume-command nil t) ;; make sure that if a command is over, and no process is being ;; waited for, that `eshell-current-command' is set to nil. This @@ -317,16 +308,17 @@ otherwise t.") (function (lambda () (setq eshell-current-command nil - eshell-last-async-proc nil))) nil t) + eshell-last-async-proc nil))) + nil t) (add-hook 'eshell-parse-argument-hook - 'eshell-parse-subcommand-argument nil t) + #'eshell-parse-subcommand-argument nil t) (add-hook 'eshell-parse-argument-hook - 'eshell-parse-lisp-argument nil t) + #'eshell-parse-lisp-argument nil t) (when (eshell-using-module 'eshell-cmpl) (add-hook 'pcomplete-try-first-hook - 'eshell-complete-lisp-symbols nil t))) + #'eshell-complete-lisp-symbols nil t))) (defun eshell-complete-lisp-symbols () "If there is a user reference, complete it." @@ -724,6 +716,8 @@ ensconced in a list." eshell-current-subjob-p) ,object)) +(defvar eshell-this-command-hook nil) + (defmacro eshell-trap-errors (object) "Trap any errors that occur, so they are not entirely fatal. Also, the variable `eshell-this-command-hook' is available for the @@ -736,9 +730,9 @@ this grossness will be made to disappear by using `call/cc'..." (eshell-condition-case err (prog1 ,object - (run-hooks 'eshell-this-command-hook)) + (mapc #'funcall eshell-this-command-hook)) (error - (run-hooks 'eshell-this-command-hook) + (mapc #'funcall eshell-this-command-hook) (eshell-errorn (error-message-string err)) (eshell-close-handles 1))))) @@ -816,7 +810,7 @@ This is used on systems where async subprocesses are not supported." ;; The last process in the pipe should get its handles ;; redirected as we found them before running the pipe. ,(if (null (cdr pipeline)) - `(progn + '(progn (setq eshell-current-handles tail-handles) (setq eshell-in-pipeline-p nil))) (let ((result ,(car pipeline))) @@ -1059,16 +1053,8 @@ be finished later after the completion of an asynchronous subprocess." ((eq (car form) 'setcdr) (setcar (cdr args) (eshell-do-eval (cadr args) synchronous-p)) (eval form)) - ((memq (car form) '(let catch condition-case unwind-protect)) - ;; `let', `condition-case' and `unwind-protect' have to be - ;; handled specially, because we only want to call - ;; `eshell-do-eval' on their first form. - ;; - ;; NOTE: This requires obedience by all forms which this - ;; function might encounter, that they do not contain - ;; other special forms. - (if (and (eq (car form) 'let) - (not (eq (car (cadr args)) 'eshell-do-eval))) + ((eq (car form) 'let) + (if (not (eq (car (cadr args)) 'eshell-do-eval)) (eshell-manipulate "evaluating let args" (dolist (letarg (car args)) (if (and (listp letarg) @@ -1076,6 +1062,21 @@ be finished later after the completion of an asynchronous subprocess." (setcdr letarg (list (eshell-do-eval (cadr letarg) synchronous-p))))))) + (cl-progv + (mapcar (lambda (binding) (if (consp binding) (car binding) binding)) + (car args)) + ;; These expressions should all be constants now. + (mapcar (lambda (binding) (if (consp binding) (eval (cadr binding)))) + (car args)) + (eshell-do-eval (macroexp-progn (cdr args)) synchronous-p))) + ((memq (car form) '(catch condition-case unwind-protect)) + ;; `condition-case' and `unwind-protect' have to be + ;; handled specially, because we only want to call + ;; `eshell-do-eval' on their first form. + ;; + ;; NOTE: This requires obedience by all forms which this + ;; function might encounter, that they do not contain + ;; other special forms. (unless (eq (car form) 'unwind-protect) (setq args (cdr args))) (unless (eq (caar args) 'eshell-do-eval) @@ -1158,10 +1159,9 @@ be finished later after the completion of an asynchronous subprocess." (setq name (substring name 1) direct t)) (if (and (not direct) - (eshell-using-module 'eshell-alias) + (fboundp 'eshell-lookup-alias) (setq alias - (funcall (symbol-function 'eshell-lookup-alias) - name))) + (eshell-lookup-alias name))) (setq program (concat name " is an alias, defined as \"" (cadr alias) "\""))) @@ -1341,7 +1341,7 @@ messages, and errors." (eshell-print "\n")) (eshell-close-handles 0 (list 'quote result))))) -(defalias 'eshell-lisp-command* 'eshell-lisp-command) +(defalias 'eshell-lisp-command* #'eshell-lisp-command) (provide 'esh-cmd) diff --git a/lisp/eshell/esh-ext.el b/lisp/eshell/esh-ext.el index fccdb73b31e..1856d2bd190 100644 --- a/lisp/eshell/esh-ext.el +++ b/lisp/eshell/esh-ext.el @@ -31,17 +31,12 @@ ;;; Code: -(provide 'esh-ext) - (require 'esh-util) -(eval-when-compile - (require 'cl-lib) - (require 'esh-io) - (require 'esh-cmd)) +(eval-when-compile (require 'cl-lib)) +(require 'esh-io) (require 'esh-arg) (require 'esh-opt) -(require 'esh-proc) (defgroup eshell-ext nil "External commands are invoked when operating system executables are @@ -79,10 +74,8 @@ but Eshell will be able to understand "Search the environment path for NAME." (if (file-name-absolute-p name) name - (let ((list (eshell-parse-colon-path eshell-path-env)) + (let ((list (eshell-get-path)) suffixes n1 n2 file) - (if (eshell-under-windows-p) - (push "." list)) (while list (setq n1 (concat (car list) name)) (setq suffixes eshell-binary-suffixes) @@ -177,9 +170,9 @@ external version." ;;; Functions: -(defun eshell-ext-initialize () +(defun eshell-ext-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the external command handling code." - (add-hook 'eshell-named-command-hook 'eshell-explicit-command nil t)) + (add-hook 'eshell-named-command-hook #'eshell-explicit-command nil t)) (defun eshell-explicit-command (command args) "If a command name begins with `*', call it externally always. @@ -193,8 +186,6 @@ This bypasses all Lisp functions and aliases." (error "%s: external command not found" (substring command 1)))))) -(autoload 'eshell-close-handles "esh-io") - (defun eshell-remote-command (command args) "Insert output from a remote COMMAND, using ARGS. A remote command is something that executes on a different machine. @@ -211,7 +202,7 @@ causing the user to wonder if anything's really going on..." (progn (setq exitcode (shell-command - (mapconcat 'shell-quote-argument + (mapconcat #'shell-quote-argument (append (list command) args) " ") outbuf errbuf)) (eshell-print (with-current-buffer outbuf (buffer-string))) @@ -222,7 +213,7 @@ causing the user to wonder if anything's really going on..." (defun eshell-external-command (command args) "Insert output from an external COMMAND, using ARGS." - (setq args (eshell-stringify-list (eshell-flatten-list args))) + (setq args (eshell-stringify-list (flatten-tree args))) (let ((interp (eshell-find-interpreter command args @@ -235,6 +226,8 @@ causing the user to wonder if anything's really going on..." (cl-assert interp) (if (functionp (car interp)) (apply (car interp) (append (cdr interp) args)) + (require 'esh-proc) + (declare-function eshell-gather-process-output "esh-proc" (command args)) (eshell-gather-process-output (car interp) (append (cdr interp) args))))) @@ -249,7 +242,7 @@ Adds the given PATH to $PATH.") (if args (progn (setq eshell-path-env (getenv "PATH") - args (mapconcat 'identity args path-separator) + args (mapconcat #'identity args path-separator) eshell-path-env (if prepend (concat args path-separator eshell-path-env) @@ -336,4 +329,5 @@ line of the form #!<interp>." (cdr interp))))) (or interp (list fullname))))))) +(provide 'esh-ext) ;;; esh-ext.el ends here diff --git a/lisp/eshell/esh-io.el b/lisp/eshell/esh-io.el index c33e7325a82..ce1d021384d 100644 --- a/lisp/eshell/esh-io.el +++ b/lisp/eshell/esh-io.el @@ -68,8 +68,6 @@ ;;; Code: -(provide 'esh-io) - (require 'esh-arg) (require 'esh-util) @@ -171,7 +169,7 @@ not be added to this variable." ;;; Functions: -(defun eshell-io-initialize () +(defun eshell-io-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the I/O subsystem code." (add-hook 'eshell-parse-argument-hook 'eshell-parse-redirection nil t) @@ -511,4 +509,5 @@ Returns what was actually sent, or nil if nothing was sent." (eshell-output-object-to-target object (car target)) (setq target (cdr target)))))) +(provide 'esh-io) ;;; esh-io.el ends here diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index be6123f21ba..80844c3a646 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -58,13 +58,10 @@ ;;; Code: -(provide 'esh-mode) - (require 'esh-util) (require 'esh-module) (require 'esh-cmd) -(require 'esh-io) -(require 'esh-var) +(require 'esh-arg) ;For eshell-parse-arguments (defgroup eshell-mode nil "This module contains code for handling input from the user." @@ -182,10 +179,11 @@ inserted. They return the string as it should be inserted." :group 'eshell-mode) (defcustom eshell-password-prompt-regexp - (format "\\(%s\\).*:\\s *\\'" (regexp-opt password-word-equivalents)) + (format "\\(%s\\)[^::៖]*[::៖]\\s *\\'" (regexp-opt password-word-equivalents)) "Regexp matching prompts for passwords in the inferior process. This is used by `eshell-watch-for-password-prompt'." :type 'regexp + :version "27.1" :group 'eshell-mode) (defcustom eshell-skip-prompt-function nil @@ -201,6 +199,12 @@ This is used by `eshell-watch-for-password-prompt'." :type 'boolean :group 'eshell-mode) +(defcustom eshell-directory-name + (locate-user-emacs-file "eshell/" ".eshell/") + "The directory where Eshell control files should be kept." + :type 'directory + :group 'eshell) + (defvar eshell-first-time-p t "A variable which is non-nil the first time Eshell is loaded.") @@ -291,7 +295,7 @@ and the hook `eshell-exit-hook'." ;; It's fine to run this unconditionally since it can be customized ;; via the `eshell-kill-processes-on-exit' variable. (and (fboundp 'eshell-query-kill-processes) - (not (memq 'eshell-query-kill-processes eshell-exit-hook)) + (not (memq #'eshell-query-kill-processes eshell-exit-hook)) (eshell-query-kill-processes)) (run-hooks 'eshell-exit-hook)) @@ -322,10 +326,6 @@ and the hook `eshell-exit-hook'." (setq-local eshell-command-map (symbol-function eshell-command-prefix)) (define-key eshell-mode-map [(control ?c)] eshell-command-prefix) - ;; without this, find-tag complains about read-only text being - ;; modified - (if (eq (key-binding [(meta ?.)]) 'find-tag) - (define-key eshell-mode-map [(meta ?.)] 'eshell-find-tag)) (define-key eshell-command-map [(meta ?o)] 'eshell-mark-output) (define-key eshell-command-map [(meta ?d)] 'eshell-toggle-direct-send) @@ -333,7 +333,6 @@ and the hook `eshell-exit-hook'." (define-key eshell-command-map [(control ?b)] 'eshell-backward-argument) (define-key eshell-command-map [(control ?e)] 'eshell-show-maximum-output) (define-key eshell-command-map [(control ?f)] 'eshell-forward-argument) - (define-key eshell-command-map [return] 'eshell-copy-old-input) (define-key eshell-command-map [(control ?m)] 'eshell-copy-old-input) (define-key eshell-command-map [(control ?o)] 'eshell-kill-output) (define-key eshell-command-map [(control ?r)] 'eshell-show-output) @@ -409,23 +408,23 @@ and the hook `eshell-exit-hook'." (when (and load-hook (boundp load-hook)) (if (memq initfunc (symbol-value load-hook)) (setq initfunc nil)) (run-hooks load-hook)) - ;; So we don't need the -initialize functions on the hooks (b#5375). + ;; So we don't need the -initialize functions on the hooks (bug#5375). (and initfunc (fboundp initfunc) (funcall initfunc)))) (if eshell-send-direct-to-subprocesses - (add-hook 'pre-command-hook 'eshell-intercept-commands t t)) + (add-hook 'pre-command-hook #'eshell-intercept-commands t t)) (if eshell-scroll-to-bottom-on-input - (add-hook 'pre-command-hook 'eshell-preinput-scroll-to-bottom t t)) + (add-hook 'pre-command-hook #'eshell-preinput-scroll-to-bottom t t)) (when eshell-scroll-show-maximum-output (set (make-local-variable 'scroll-conservatively) 1000)) (when eshell-status-in-mode-line - (add-hook 'eshell-pre-command-hook 'eshell-command-started nil t) - (add-hook 'eshell-post-command-hook 'eshell-command-finished nil t)) + (add-hook 'eshell-pre-command-hook #'eshell-command-started nil t) + (add-hook 'eshell-post-command-hook #'eshell-command-finished nil t)) - (add-hook 'kill-buffer-hook 'eshell-kill-buffer-function t t) + (add-hook 'kill-buffer-hook #'eshell-kill-buffer-function t t) (if eshell-first-time-p (run-hooks 'eshell-first-time-mode-hook)) @@ -450,10 +449,10 @@ and the hook `eshell-exit-hook'." (if eshell-send-direct-to-subprocesses (progn (setq eshell-send-direct-to-subprocesses nil) - (remove-hook 'pre-command-hook 'eshell-intercept-commands t) + (remove-hook 'pre-command-hook #'eshell-intercept-commands t) (message "Sending subprocess input on RET")) (setq eshell-send-direct-to-subprocesses t) - (add-hook 'pre-command-hook 'eshell-intercept-commands t t) + (add-hook 'pre-command-hook #'eshell-intercept-commands t t) (message "Sending subprocess input directly"))) (defun eshell-self-insert-command () @@ -487,13 +486,15 @@ and the hook `eshell-exit-hook'." (defun eshell-find-tag (&optional tagname next-p regexp-p) "A special version of `find-tag' that ignores whether the text is read-only." + (declare (obsolete xref-find-definition "27.1")) (interactive) (require 'etags) (let ((inhibit-read-only t) (no-default (eobp)) (find-tag-default-function 'ignore)) (setq tagname (car (find-tag-interactive "Find tag: " no-default))) - (find-tag tagname next-p regexp-p))) + (with-suppressed-warnings ((obsolete find-tag)) + (find-tag tagname next-p regexp-p)))) (defun eshell-move-argument (limit func property arg) "Move forward ARG arguments." @@ -542,7 +543,7 @@ and the hook `eshell-exit-hook'." "Push a mark at the end of the last input text." (push-mark (1- eshell-last-input-end) t)) -(custom-add-option 'eshell-pre-command-hook 'eshell-push-command-mark) +(custom-add-option 'eshell-pre-command-hook #'eshell-push-command-mark) (defsubst eshell-goto-input-start () "Goto the start of the last command input. @@ -550,7 +551,7 @@ Putting this function on `eshell-pre-command-hook' will mimic Plan 9's 9term behavior." (goto-char eshell-last-input-start)) -(custom-add-option 'eshell-pre-command-hook 'eshell-push-command-mark) +(custom-add-option 'eshell-pre-command-hook #'eshell-goto-input-start) (defsubst eshell-interactive-print (string) "Print STRING to the eshell display buffer." @@ -884,8 +885,7 @@ If SCROLLBACK is non-nil, clear the scrollback contents." (interactive) (if scrollback (eshell/clear-scrollback) - (let ((eshell-input-filter-functions - (remq 'eshell-add-to-history eshell-input-filter-functions))) + (let ((eshell-input-filter-functions nil)) (insert (make-string (window-size) ?\n)) (eshell-send-input)))) @@ -1012,13 +1012,19 @@ This function could be in the list `eshell-output-filter-functions'." 'eshell-handle-control-codes) (autoload 'ansi-color-apply-on-region "ansi-color") +(defvar ansi-color-apply-face-function) +(declare-function ansi-color-apply-text-property-face "ansi-color" + (BEG END FACE)) (defun eshell-handle-ansi-color () "Handle ANSI color codes." - (ansi-color-apply-on-region eshell-last-output-start - eshell-last-output-end)) + (require 'ansi-color) + (let ((ansi-color-apply-face-function #'ansi-color-apply-text-property-face)) + (ansi-color-apply-on-region eshell-last-output-start + eshell-last-output-end))) (custom-add-option 'eshell-output-filter-functions 'eshell-handle-ansi-color) +(provide 'esh-mode) ;;; esh-mode.el ends here diff --git a/lisp/eshell/esh-module.el b/lisp/eshell/esh-module.el index 2583044a446..1911a49a3a4 100644 --- a/lisp/eshell/esh-module.el +++ b/lisp/eshell/esh-module.el @@ -22,9 +22,6 @@ ;;; Code: -(provide 'esh-module) - -(require 'eshell) (require 'esh-util) (defgroup eshell-module nil @@ -101,4 +98,5 @@ customization group. Example: `eshell-cmpl' for that module." (unload-feature module) (message "Unloading %s...done" (symbol-name module)))))) +(provide 'esh-module) ;;; esh-module.el ends here diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el index 6f37a29004a..3ea5873cafd 100644 --- a/lisp/eshell/esh-opt.el +++ b/lisp/eshell/esh-opt.el @@ -23,9 +23,6 @@ ;;; Code: -(provide 'esh-opt) - -(require 'esh-ext) ;; Unused. ;; (defgroup eshell-opt nil @@ -36,6 +33,10 @@ ;;; User Functions: +;; Macro expansion of eshell-eval-using-options refers to eshell-stringify-list +;; defined in esh-util. +(require 'esh-util) + (defmacro eshell-eval-using-options (name macro-args options &rest body-forms) "Process NAME's MACRO-ARGS using a set of command line OPTIONS. After doing so, stores settings in local symbols as declared by OPTIONS; @@ -77,9 +78,13 @@ arguments, some do not. The recognized :KEYWORDS are: arguments. :preserve-args - If present, do not pass MACRO-ARGS through `eshell-flatten-list' + If present, do not pass MACRO-ARGS through `flatten-tree' and `eshell-stringify-list'. +:parse-leading-options-only + If present, do not parse dash or switch arguments after the first +positional argument. Instead, treat them as positional arguments themselves. + For example, OPTIONS might look like: ((?C nil nil multi-column \"multi-column display\") @@ -95,14 +100,14 @@ BODY-FORMS. If instead an external command is run (because of an unknown option), the tag `eshell-external' will be thrown with the new process for its value. -Lastly, any remaining arguments will be available in a locally -interned variable `args' (created using a `let' form)." +Lastly, any remaining arguments will be available in the locally +let-bound variable `args'." (declare (debug (form form sexp body))) `(let* ((temp-args ,(if (memq ':preserve-args (cadr options)) macro-args (list 'eshell-stringify-list - (list 'eshell-flatten-list macro-args)))) + (list 'flatten-tree macro-args)))) (processed-args (eshell--do-opts ,name ,options temp-args)) ,@(delete-dups (delq nil (mapcar (lambda (opt) @@ -111,6 +116,8 @@ interned variable `args' (created using a `let' form)." ;; `options' is of the form (quote OPTS). (cadr options)))) (args processed-args)) + ;; Silence unused lexical variable warning if body does not use `args'. + (ignore args) ,@body-forms)) ;;; Internal Functions: @@ -121,6 +128,8 @@ interned variable `args' (created using a `let' form)." (defun eshell--do-opts (name options args) "Helper function for `eshell-eval-using-options'. This code doesn't really need to be macro expanded everywhere." + (require 'esh-ext) + (declare-function eshell-external-command "esh-ext" (command args)) (let ((ext-command (catch 'eshell-ext-command (let ((usage-msg @@ -139,6 +148,8 @@ This code doesn't really need to be macro expanded everywhere." (defun eshell-show-usage (name options) "Display the usage message for NAME, using OPTIONS." + (require 'esh-ext) + (declare-function eshell-search-path "esh-ext" (name)) (let ((usage (format "usage: %s %s\n\n" name (cadr (memq ':usage options)))) (extcmd (memq ':external options)) @@ -194,11 +205,7 @@ will be modified." (if (eq (nth 2 opt) t) (if (> ai (length eshell--args)) (error "%s: missing option argument" name) - (prog1 (nth ai eshell--args) - (if (> ai 0) - (setcdr (nthcdr (1- ai) eshell--args) - (nthcdr (1+ ai) eshell--args)) - (setq eshell--args (cdr eshell--args))))) + (pop (nthcdr ai eshell--args))) (or (nth 2 opt) t))))) (defun eshell--process-option (name switch kind ai options opt-vals) @@ -243,18 +250,22 @@ switch is unrecognized." (list sym))))) options))) (ai 0) arg - (eshell--args args)) - (while (< ai (length eshell--args)) + (eshell--args args) + (pos-argument-found nil)) + (while (and (< ai (length eshell--args)) + ;; Abort if we saw the first pos argument and option is set + (not (and pos-argument-found + (memq :parse-leading-options-only options)))) (setq arg (nth ai eshell--args)) (if (not (and (stringp arg) (string-match "^-\\(-\\)?\\(.*\\)" arg))) - (setq ai (1+ ai)) + ;; Positional argument found, skip + (setq ai (1+ ai) + pos-argument-found t) + ;; dash or switch argument found, parse (let* ((dash (match-string 1 arg)) (switch (match-string 2 arg))) - (if (= ai 0) - (setq eshell--args (cdr eshell--args)) - (setcdr (nthcdr (1- ai) eshell--args) - (nthcdr (1+ ai) eshell--args))) + (pop (nthcdr ai eshell--args)) (if dash (if (> (length switch) 0) (eshell--process-option name switch 1 ai options opt-vals) @@ -267,4 +278,5 @@ switch is unrecognized." (setq index (1+ index)))))))) (nconc (mapcar #'cdr opt-vals) eshell--args))) +(provide 'esh-opt) ;;; esh-opt.el ends here diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el index e5ccdf7f210..32a3eecb523 100644 --- a/lisp/eshell/esh-proc.el +++ b/lisp/eshell/esh-proc.el @@ -23,9 +23,7 @@ ;;; Code: -(provide 'esh-proc) - -(require 'esh-cmd) +(require 'esh-io) (defgroup eshell-proc nil "When Eshell invokes external commands, it always does so @@ -118,14 +116,17 @@ information, for example." 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. - (if (memq 'eshell-reset-after-proc eshell-kill-hook) - (setq eshell-kill-hook (delq 'eshell-reset-after-proc eshell-kill-hook))) + (if (memq #'eshell-reset-after-proc eshell-kill-hook) + (setq eshell-kill-hook (delq #'eshell-reset-after-proc eshell-kill-hook))) (eshell-reset-after-proc status) (run-hook-with-args 'eshell-kill-hook proc status)) -(defun eshell-proc-initialize () +(defun eshell-proc-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the process handling code." (make-local-variable 'eshell-process-list) + ;; This is supposedly run after enabling esh-mode, when eshell-command-map + ;; already exists. + (defvar eshell-command-map) (define-key eshell-command-map [(meta ?i)] 'eshell-insert-process) (define-key eshell-command-map [(control ?c)] 'eshell-interrupt-process) (define-key eshell-command-map [(control ?k)] 'eshell-kill-process) @@ -139,9 +140,11 @@ PROC and STATUS to functions on the latter." "Reset the command input location after a process terminates. The signals which will cause this to happen are matched by `eshell-reset-signals'." - (if (and (stringp status) - (string-match eshell-reset-signals status)) - (eshell-reset))) + (when (and (stringp status) + (string-match eshell-reset-signals status)) + (require 'esh-mode) + (declare-function eshell-reset "esh-mode" (&optional no-hooks)) + (eshell-reset))) (defun eshell-wait-for-process (&rest procs) "Wait until PROC has successfully completed." @@ -158,7 +161,7 @@ The signals which will cause this to happen are matched by (defalias 'eshell/wait 'eshell-wait-for-process) -(defun eshell/jobs (&rest args) +(defun eshell/jobs (&rest _args) "List processes, if there are any." (and (fboundp 'process-list) (process-list) @@ -167,7 +170,8 @@ The signals which will cause this to happen are matched by (defun eshell/kill (&rest args) "Kill processes. Usage: kill [-<signal>] <pid>|<process> ... -Accepts PIDs and process objects." +Accepts PIDs and process objects. Optionally accept signals +and signal names." ;; If the first argument starts with a dash, treat it as the signal ;; specifier. (let ((signum 'SIGINT)) @@ -178,12 +182,12 @@ Accepts PIDs and process objects." ((string-match "\\`-[[:digit:]]+\\'" arg) (setq signum (abs (string-to-number arg)))) ((string-match "\\`-\\([[:upper:]]+\\|[[:lower:]]+\\)\\'" arg) - (setq signum (abs (string-to-number arg))))) + (setq signum (intern (substring arg 1))))) (setq args (cdr args)))) (while args (let ((arg (if (eshell-processp (car args)) (process-id (car args)) - (car args)))) + (string-to-number (car args))))) (when arg (cond ((null arg) @@ -198,6 +202,8 @@ Accepts PIDs and process objects." (setq args (cdr args)))) nil) +(put 'eshell/kill 'eshell-no-numeric-conversions t) + (defun eshell-read-process-name (prompt) "Read the name of a process from the minibuffer, using completion. The prompt will be set to PROMPT." @@ -206,7 +212,8 @@ The prompt will be set to PROMPT." (function (lambda (proc) (cons (process-name proc) t))) - (process-list)) nil t)) + (process-list)) + nil t)) (defun eshell-insert-process (process) "Insert the name of PROCESS into the current buffer at point." @@ -217,10 +224,12 @@ The prompt will be set to PROMPT." (defsubst eshell-record-process-object (object) "Record OBJECT as now running." - (if (and (eshell-processp object) - eshell-current-subjob-p) - (eshell-interactive-print - (format "[%s] %d\n" (process-name object) (process-id object)))) + (when (and (eshell-processp object) + eshell-current-subjob-p) + (require 'esh-mode) + (declare-function eshell-interactive-print "esh-mode" (string)) + (eshell-interactive-print + (format "[%s] %d\n" (process-name object) (process-id object)))) (setq eshell-process-list (cons (list object eshell-current-handles eshell-current-subjob-p nil nil) @@ -255,7 +264,7 @@ the full name of a command, otherwise just the nondirectory part must match.") (defun eshell-needs-pipe-p (command) "Return non-nil if COMMAND needs `process-connection-type' to be nil. See `eshell-needs-pipe'." - (and eshell-in-pipeline-p + (and (bound-and-true-p eshell-in-pipeline-p) (not (eq eshell-in-pipeline-p 'first)) ;; FIXME should this return non-nil for anything that is ;; neither 'first nor 'last? See bug#1388 discussion. @@ -268,6 +277,8 @@ See `eshell-needs-pipe'." (defun eshell-gather-process-output (command args) "Gather the output from COMMAND + ARGS." + (require 'esh-var) + (declare-function eshell-environment-variables "esh-var" ()) (unless (and (file-executable-p command) (file-regular-p (file-truename command))) (error "%s: not an executable file" command)) @@ -284,14 +295,14 @@ See `eshell-needs-pipe'." (unless (eshell-needs-pipe-p command) process-connection-type)) (command (file-local-name (expand-file-name command)))) - (apply 'start-file-process + (apply #'start-file-process (file-name-nondirectory command) nil command args))) (eshell-record-process-object proc) (set-process-buffer proc (current-buffer)) - (if (eshell-interactive-output-p) - (set-process-filter proc 'eshell-output-filter) - (set-process-filter proc 'eshell-insertion-filter)) - (set-process-sentinel proc 'eshell-sentinel) + (set-process-filter proc (if (eshell-interactive-output-p) + #'eshell-output-filter + #'eshell-insertion-filter)) + (set-process-sentinel proc #'eshell-sentinel) (run-hook-with-args 'eshell-exec-hook proc) (when (fboundp 'process-coding-system) (let ((coding-systems (process-coding-system proc))) @@ -326,14 +337,14 @@ See `eshell-needs-pipe'." (set-buffer oldbuf) (run-hook-with-args 'eshell-exec-hook command) (setq exit-status - (apply 'call-process-region + (apply #'call-process-region (append (list eshell-last-sync-output-start (point) command t eshell-scratch-buffer nil) args))) ;; When in a pipeline, record the place where the output of ;; this process will begin. - (and eshell-in-pipeline-p + (and (bound-and-true-p eshell-in-pipeline-p) (set-marker eshell-last-sync-output-start (point))) ;; Simulate the effect of the process filter. (when (numberp exit-status) @@ -350,11 +361,14 @@ See `eshell-needs-pipe'." (setq lbeg lend) (set-buffer proc-buf)) (set-buffer oldbuf)) + (require 'esh-mode) + (declare-function eshell-update-markers "esh-mode" (pmark)) + (defvar eshell-last-output-end) ;Defined in esh-mode.el. (eshell-update-markers eshell-last-output-end) ;; Simulate the effect of eshell-sentinel. (eshell-close-handles (if (numberp exit-status) exit-status -1)) (eshell-kill-process-function command exit-status) - (or eshell-in-pipeline-p + (or (bound-and-true-p eshell-in-pipeline-p) (setq eshell-last-sync-output-start nil)) (if (not (numberp exit-status)) (error "%s: external command failed: %s" command exit-status)) @@ -499,7 +513,7 @@ See the variable `eshell-kill-processes-on-exit'." (buffer-name)))) (eshell-round-robin-kill (if (eq eshell-kill-processes-on-exit 'every) - (format-message "Kill Eshell child process `%s'? ")))) + "Kill Eshell child process `%s'? "))) (let ((buf (get-buffer "*Process List*"))) (if (and buf (buffer-live-p buf)) (kill-buffer buf))) @@ -541,7 +555,11 @@ See the variable `eshell-kill-processes-on-exit'." (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 f8dd6f08f45..4835e63baa9 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -232,6 +232,14 @@ It might be different from \(getenv \"PATH\"), when `default-directory' points to a remote host.") (make-variable-buffer-local 'eshell-path-env) +(defun eshell-get-path () + "Return $PATH as a list. +Add the current directory on MS-Windows." + (eshell-parse-colon-path + (if (eshell-under-windows-p) + (concat "." path-separator eshell-path-env) + eshell-path-env))) + (defun eshell-parse-colon-path (path-env) "Split string with `parse-colon-path'. Prepend remote identification of `default-directory', if any." @@ -285,17 +293,9 @@ Prepend remote identification of `default-directory', if any." ,@forms) (setq list-iter (cdr list-iter))))) -(defun eshell-flatten-list (args) - "Flatten any lists within ARGS, so that there are no sublists." - (let ((new-list (list t))) - (dolist (a args) - (if (and (listp a) - (listp (cdr a))) - (nconc new-list (eshell-flatten-list a)) - (nconc new-list (list a)))) - (cdr new-list))) - -(defun eshell-uniqify-list (l) +(define-obsolete-function-alias 'eshell-flatten-list #'flatten-tree "27.1") + +(defun eshell-uniquify-list (l) "Remove occurring multiples in L. You probably want to sort first." (let ((m l)) (while m @@ -305,6 +305,9 @@ Prepend remote identification of `default-directory', if any." (setcdr m (cddr m))) (setq m (cdr m)))) l) +(define-obsolete-function-alias + 'eshell-uniqify-list + 'eshell-uniquify-list "27.1") (defun eshell-stringify (object) "Convert OBJECT into a string value." @@ -327,7 +330,7 @@ Prepend remote identification of `default-directory', if any." (defsubst eshell-flatten-and-stringify (&rest args) "Flatten and stringify all of the ARGS into a single string." - (mapconcat 'eshell-stringify (eshell-flatten-list args) " ")) + (mapconcat 'eshell-stringify (flatten-tree args) " ")) (defsubst eshell-directory-files (regexp &optional directory) "Return a list of files in the given DIRECTORY matching REGEXP." @@ -444,7 +447,7 @@ list." (not (symbol-value timestamp-var)) (time-less-p (symbol-value timestamp-var) - (nth 5 (file-attributes file)))) + (file-attribute-modification-time (file-attributes file)))) (progn (set result-var (eshell-read-passwd-file file)) (set timestamp-var (current-time)))) @@ -483,24 +486,22 @@ list." (insert-file-contents (or filename eshell-hosts-file)) (goto-char (point-min)) (while (re-search-forward - "^\\([^#[:space:]]+\\)\\s-+\\(\\S-+\\)\\(\\s-*\\(\\S-+\\)\\)?" nil t) - (if (match-string 1) - (cl-pushnew (match-string 1) hosts :test #'equal)) - (if (match-string 2) - (cl-pushnew (match-string 2) hosts :test #'equal)) - (if (match-string 4) - (cl-pushnew (match-string 4) hosts :test #'equal)))) - (sort hosts #'string-lessp))) + ;; "^ \t\\([^# \t\n]+\\)[ \t]+\\([^ \t\n]+\\)\\([ \t]*\\([^ \t\n]+\\)\\)?" + "^[ \t]*\\([^# \t\n]+\\)[ \t]+\\([^ \t\n].+\\)" nil t) + (push (cons (match-string 1) + (split-string (match-string 2))) + hosts))) + (nreverse hosts))) (defun eshell-read-hosts (file result-var timestamp-var) - "Read the contents of /etc/passwd for user names." + "Read the contents of /etc/hosts for host names." (if (or (not (symbol-value result-var)) (not (symbol-value timestamp-var)) (time-less-p (symbol-value timestamp-var) - (nth 5 (file-attributes file)))) + (file-attribute-modification-time (file-attributes file)))) (progn - (set result-var (eshell-read-hosts-file file)) + (set result-var (apply #'nconc (eshell-read-hosts-file file))) (set timestamp-var (current-time)))) (symbol-value result-var)) @@ -653,11 +654,11 @@ If NOSORT is non-nil, the list is not sorted--its order is unpredictable. (match-string 6)))) (if (nth 0 moment) (setcar (nthcdr 5 moment) - (nth 5 (decode-time))) + (decoded-time-year (decode-time))) (setcar (nthcdr 0 moment) 0) (setcar (nthcdr 1 moment) 0) (setcar (nthcdr 2 moment) 0)) - (apply 'encode-time moment)) + (encode-time moment)) (ange-ftp-file-modtime (expand-file-name name dir)))) symlink) (if (string-match "\\(.+\\) -> \\(.+\\)" name) diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index b3f54cf048d..b08a5d242fe 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -105,11 +105,12 @@ ;;; Code: -(provide 'esh-var) - (require 'esh-util) (require 'esh-cmd) (require 'esh-opt) +(require 'esh-module) +(require 'esh-arg) +(require 'esh-io) (require 'pcomplete) (require 'env) @@ -128,60 +129,55 @@ variable value, a subcommand, or even the result of a Lisp form." (defcustom eshell-var-load-hook nil "A list of functions to call when loading `eshell-var'." :version "24.1" ; removed eshell-var-initialize - :type 'hook - :group 'eshell-var) + :type 'hook) (defcustom eshell-prefer-lisp-variables nil "If non-nil, prefer Lisp variables to environment variables." - :type 'boolean - :group 'eshell-var) + :type 'boolean) (defcustom eshell-complete-export-definition t "If non-nil, completing names for `export' shows current definition." - :type 'boolean - :group 'eshell-var) + :type 'boolean) (defcustom eshell-modify-global-environment nil "If non-nil, using `export' changes Emacs's global environment." - :type 'boolean - :group 'eshell-var) + :type 'boolean) (defcustom eshell-variable-name-regexp "[A-Za-z0-9_-]+" "A regexp identifying what constitutes a variable name reference. Note that this only applies for `$NAME'. If the syntax `$<NAME>' is used, then NAME can contain any character, including angle brackets, if they are quoted with a backslash." - :type 'regexp - :group 'eshell-var) + :type 'regexp) (defcustom eshell-variable-aliases-list - '(;; for eshell.el - ("COLUMNS" (lambda (indices) (window-width)) t) - ("LINES" (lambda (indices) (window-height)) t) + `(;; for eshell.el + ("COLUMNS" ,(lambda (_indices) (window-width)) t) + ("LINES" ,(lambda (_indices) (window-height)) t) ;; for eshell-cmd.el - ("_" (lambda (indices) - (if (not indices) - (car (last eshell-last-arguments)) - (eshell-apply-indices eshell-last-arguments - indices)))) + ("_" ,(lambda (indices) + (if (not indices) + (car (last eshell-last-arguments)) + (eshell-apply-indices eshell-last-arguments + indices)))) ("?" eshell-last-command-status) ("$" eshell-last-command-result) ("0" eshell-command-name) - ("1" (lambda (indices) (nth 0 eshell-command-arguments))) - ("2" (lambda (indices) (nth 1 eshell-command-arguments))) - ("3" (lambda (indices) (nth 2 eshell-command-arguments))) - ("4" (lambda (indices) (nth 3 eshell-command-arguments))) - ("5" (lambda (indices) (nth 4 eshell-command-arguments))) - ("6" (lambda (indices) (nth 5 eshell-command-arguments))) - ("7" (lambda (indices) (nth 6 eshell-command-arguments))) - ("8" (lambda (indices) (nth 7 eshell-command-arguments))) - ("9" (lambda (indices) (nth 8 eshell-command-arguments))) - ("*" (lambda (indices) - (if (not indices) - eshell-command-arguments - (eshell-apply-indices eshell-command-arguments - indices))))) + ("1" ,(lambda (_indices) (nth 0 eshell-command-arguments))) + ("2" ,(lambda (_indices) (nth 1 eshell-command-arguments))) + ("3" ,(lambda (_indices) (nth 2 eshell-command-arguments))) + ("4" ,(lambda (_indices) (nth 3 eshell-command-arguments))) + ("5" ,(lambda (_indices) (nth 4 eshell-command-arguments))) + ("6" ,(lambda (_indices) (nth 5 eshell-command-arguments))) + ("7" ,(lambda (_indices) (nth 6 eshell-command-arguments))) + ("8" ,(lambda (_indices) (nth 7 eshell-command-arguments))) + ("9" ,(lambda (_indices) (nth 8 eshell-command-arguments))) + ("*" ,(lambda (indices) + (if (not indices) + eshell-command-arguments + (eshell-apply-indices eshell-command-arguments + indices))))) "This list provides aliasing for variable references. It is very similar in concept to what `eshell-user-aliases-list' does for commands. Each member of this defines the name of a command, @@ -197,14 +193,13 @@ function), and the arguments passed to this function would be the list '(10 20)', and nil." :type '(repeat (list string sexp (choice (const :tag "Copy to environment" t) - (const :tag "Use only in Eshell" nil)))) - :group 'eshell-var) + (const :tag "Use only in Eshell" nil))))) (put 'eshell-variable-aliases-list 'risky-local-variable t) ;;; Functions: -(defun eshell-var-initialize () +(defun eshell-var-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the variable handle code." ;; Break the association with our parent's environment. Otherwise, ;; changing a variable will affect all of Emacs. @@ -212,6 +207,9 @@ function), and the arguments passed to this function would be the list (set (make-local-variable 'process-environment) (eshell-copy-environment))) + ;; This is supposedly run after enabling esh-mode, when eshell-command-map + ;; already exists. + (defvar eshell-command-map) (define-key eshell-command-map [(meta ?v)] 'eshell-insert-envvar) (set (make-local-variable 'eshell-special-chars-inside-quoting) @@ -219,16 +217,16 @@ function), and the arguments passed to this function would be the list (set (make-local-variable 'eshell-special-chars-outside-quoting) (append eshell-special-chars-outside-quoting '(?$))) - (add-hook 'eshell-parse-argument-hook 'eshell-interpolate-variable t t) + (add-hook 'eshell-parse-argument-hook #'eshell-interpolate-variable t t) (add-hook 'eshell-prepare-command-hook - 'eshell-handle-local-variables nil t) + #'eshell-handle-local-variables nil t) (when (eshell-using-module 'eshell-cmpl) (add-hook 'pcomplete-try-first-hook - 'eshell-complete-variable-reference nil t) + #'eshell-complete-variable-reference nil t) (add-hook 'pcomplete-try-first-hook - 'eshell-complete-variable-assignment nil t))) + #'eshell-complete-variable-assignment nil t))) (defun eshell-handle-local-variables () "Allow for the syntax `VAR=val <command> <args>'." @@ -343,6 +341,8 @@ This function is explicit for adding to `eshell-parse-argument-hook'." obarray 'boundp)) (pcomplete-here)))) +;; FIXME the real "env" command does more than this, it runs a program +;; in a modified environment. (defun eshell/env (&rest args) "Implementation of `env' in Lisp." (eshell-init-print-buffer) @@ -395,6 +395,8 @@ process any indices that come after the variable reference." 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) @@ -417,18 +419,17 @@ Possible options are: (if (not end) (throw 'eshell-incomplete ?\{) (prog1 - (list 'eshell-convert - (list 'eshell-command-to-value - (list 'eshell-as-subcommand - (eshell-parse-command - (cons (1+ (point)) end))))) + `(eshell-convert + (eshell-command-to-value + (eshell-as-subcommand + ,(eshell-parse-command (cons (1+ (point)) end))))) (goto-char (1+ end)))))) ((memq (char-after) '(?\' ?\")) (let ((name (if (eq (char-after) ?\') (eshell-parse-literal-quote) (eshell-parse-double-quote)))) (if name - (list 'eshell-get-variable (eval name) 'indices)))) + `(eshell-get-variable ,(eval name) indices)))) ((eq (char-after) ?\<) (let ((end (eshell-find-delimiter ?\< ?\>))) (if (not end) @@ -437,37 +438,30 @@ Possible options are: (cmd (concat (buffer-substring (1+ (point)) end) " > " temp))) (prog1 - (list - 'let (list (list 'eshell-current-handles - (list 'eshell-create-handles temp - (list 'quote 'overwrite)))) - (list - 'progn - (list 'eshell-as-subcommand - (eshell-parse-command cmd)) - (list 'ignore - (list 'nconc 'eshell-this-command-hook - (list 'list - (list 'function - (list 'lambda nil - (list 'delete-file temp)))))) - (list 'quote temp))) + `(let ((eshell-current-handles + (eshell-create-handles ,temp 'overwrite))) + (progn + (eshell-as-subcommand ,(eshell-parse-command cmd)) + (ignore + (nconc eshell-this-command-hook + (list (function (lambda () + (delete-file ,temp)))))) + (quote ,temp))) (goto-char (1+ end))))))) ((eq (char-after) ?\() (condition-case nil - (list 'eshell-command-to-value - (list 'eshell-lisp-command - (list 'quote (read (current-buffer))))) + `(eshell-command-to-value + (eshell-lisp-command + ',(read (current-buffer)))) (end-of-file (throw 'eshell-incomplete ?\()))) ((assoc (char-to-string (char-after)) eshell-variable-aliases-list) (forward-char) - (list 'eshell-get-variable - (char-to-string (char-before)) 'indices)) + `(eshell-get-variable ,(char-to-string (char-before)) indices)) ((looking-at eshell-variable-name-regexp) (prog1 - (list 'eshell-get-variable (match-string 0) 'indices) + `(eshell-get-variable ,(match-string 0) indices) (goto-char (match-end 0)))) (t (error "Invalid variable reference")))) @@ -542,7 +536,7 @@ For example, to retrieve the second element of a user's record in (setq separator (caar indices) refs (cdr refs))) (setq value - (mapcar 'eshell-convert + (mapcar #'eshell-convert (split-string value separator))))) (cond ((< (length refs) 0) @@ -628,4 +622,5 @@ For example, to retrieve the second element of a user's record in (setq pcomplete-stub (substring arg pos)) (throw 'pcomplete-completions (pcomplete-entries))))) +(provide 'esh-var) ;;; esh-var.el ends here diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el index 45168007565..db20f7d9ec5 100644 --- a/lisp/eshell/eshell.el +++ b/lisp/eshell/eshell.el @@ -175,7 +175,10 @@ (eval-when-compile (require 'cl-lib)) (require 'esh-util) -(require 'esh-mode) +(require 'esh-module) ;For eshell-using-module +(require 'esh-proc) ;For eshell-wait-for-process +(require 'esh-io) ;For eshell-last-command-status +(require 'esh-cmd) (defgroup eshell nil "Command shell implemented entirely in Emacs Lisp. @@ -217,12 +220,6 @@ shells such as bash, zsh, rc, 4dos." :type 'string :group 'eshell) -(defcustom eshell-directory-name - (locate-user-emacs-file "eshell/" ".eshell/") - "The directory where Eshell control files should be kept." - :type 'directory - :group 'eshell) - ;;;_* Running Eshell ;; ;; There are only three commands used to invoke Eshell. The first two @@ -256,11 +253,12 @@ buffer selected (or created)." buf)) (defun eshell-return-exits-minibuffer () + ;; This is supposedly run after enabling esh-mode, when eshell-mode-map + ;; already exists. + (defvar eshell-mode-map) (define-key eshell-mode-map [(control ?g)] 'abort-recursive-edit) - (define-key eshell-mode-map [return] 'exit-minibuffer) (define-key eshell-mode-map [(control ?m)] 'exit-minibuffer) (define-key eshell-mode-map [(control ?j)] 'exit-minibuffer) - (define-key eshell-mode-map [(meta return)] 'exit-minibuffer) (define-key eshell-mode-map [(meta control ?m)] 'exit-minibuffer)) (defvar eshell-non-interactive-p nil @@ -275,7 +273,6 @@ non-interactive sessions, such as when using `eshell-command'.") "Execute the Eshell command string COMMAND. With prefix ARG, insert output into the current buffer at point." (interactive) - (require 'esh-cmd) (unless arg (setq arg current-prefix-arg)) (let ((eshell-non-interactive-p t)) @@ -363,7 +360,8 @@ corresponding to a successful execution." (let ((result (eshell-do-eval (list 'eshell-commands (list 'eshell-command-to-value - (eshell-parse-command command))) t))) + (eshell-parse-command command))) + t))) (cl-assert (eq (car result) 'quote)) (if (and status-var (symbolp status-var)) (set status-var eshell-last-command-status)) @@ -404,5 +402,4 @@ Emacs." (run-hooks 'eshell-load-hook) (provide 'eshell) - ;;; eshell.el ends here diff --git a/lisp/expand.el b/lisp/expand.el index 0c4d343090c..da76effc260 100644 --- a/lisp/expand.el +++ b/lisp/expand.el @@ -66,9 +66,6 @@ ;; Jerome Santini <santini@chambord.univ-orleans.fr>, ;; Jari Aalto <jaalto@tre.tele.nokia.fi>. ;; -;; Please send me a word to give me your feeling about this feature or -;; to explain me how you use it (your expansions table for example) using -;; the function expand-submit-report. ;;; Code: ;;; Constants: diff --git a/lisp/face-remap.el b/lisp/face-remap.el index 5a1c44f2096..1a0cc646c35 100644 --- a/lisp/face-remap.el +++ b/lisp/face-remap.el @@ -229,9 +229,6 @@ Each positive or negative step scales the default face height by this amount." (define-minor-mode text-scale-mode "Minor mode for displaying buffer text in a larger/smaller font. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. The amount of scaling is determined by the variable `text-scale-mode-amount': one step scales the global default @@ -387,10 +384,9 @@ plist, etc." ;;;###autoload (define-minor-mode buffer-face-mode "Minor mode for a buffer-specific default face. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. When enabled, the face specified by the -variable `buffer-face-mode-face' is used to display the buffer text." + +When enabled, the face specified by the variable +`buffer-face-mode-face' is used to display the buffer text." :lighter " BufFace" (when buffer-face-mode-remapping (face-remap-remove-relative buffer-face-mode-remapping)) diff --git a/lisp/facemenu.el b/lisp/facemenu.el index ddba3f20ea5..44b3941b24d 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el @@ -188,6 +188,8 @@ it will remove any faces not explicitly in the list." (let ((map (make-sparse-keymap "Special"))) (define-key map [?s] (cons (purecopy "Remove Special") 'facemenu-remove-special)) + (define-key map [?c] (cons (purecopy "Charset") + 'facemenu-set-charset)) (define-key map [?t] (cons (purecopy "Intangible") 'facemenu-set-intangible)) (define-key map [?v] (cons (purecopy "Invisible") @@ -433,6 +435,28 @@ This sets the `read-only' text property; it can be undone with (interactive "r") (add-text-properties start end '(read-only t))) +(defun facemenu-set-charset (cset &optional start end) + "Apply CHARSET text property to the region or next character typed. + +If the region is active (normally true except in Transient +Mark mode) and nonempty, and there is no prefix argument, +this command adds CHARSET property to the region. Otherwise, it +sets the CHARSET property of the character at point." + (interactive (list (progn + (barf-if-buffer-read-only) + (read-charset + (format "Use charset (default %s): " (charset-after)) + (charset-after))) + (if (and mark-active (not current-prefix-arg)) + (region-beginning)) + (if (and mark-active (not current-prefix-arg)) + (region-end)))) + (or start + (setq start (min (point) (1- (point-max))) + end (1+ start))) + (remove-text-properties start end '(charset nil)) + (put-text-property start end 'charset cset)) + (defun facemenu-remove-face-props (start end) "Remove `face' and `mouse-face' text properties." (interactive "*r") ; error if buffer is read-only despite the next line. @@ -452,7 +476,7 @@ These special properties include `invisible', `intangible' and `read-only'." (interactive "*r") ; error if buffer is read-only despite the next line. (let ((inhibit-read-only t)) (remove-text-properties - start end '(invisible nil intangible nil read-only nil)))) + start end '(invisible nil intangible nil read-only nil charset nil)))) (defalias 'facemenu-read-color 'read-color) @@ -614,7 +638,7 @@ color. The function should accept a single argument, the color name." (insert " ") (insert (propertize (apply 'format "#%02x%02x%02x" - (mapcar (lambda (c) (lsh c -8)) + (mapcar (lambda (c) (ash c -8)) color-values)) 'mouse-face 'highlight 'help-echo diff --git a/lisp/faces.el b/lisp/faces.el index 3ed98f651f1..5193c216d0a 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -55,6 +55,7 @@ This means to treat a terminal of type TYPE as if it were of type ALIAS." :group 'terminals :version "25.1") +(declare-function display-graphic-p "frame" (&optional display)) (declare-function xw-defined-colors "term/common-win" (&optional frame)) (defvar help-xref-stack-item) @@ -1084,27 +1085,27 @@ of a set of discrete values. Value is `integerp' if ATTRIBUTE expects an integer value." (let ((valid (pcase attribute - (`:family + (:family (if (window-system frame) (mapcar (lambda (x) (cons x x)) (font-family-list)) ;; Only one font on TTYs. (list (cons "default" "default")))) - (`:foundry + (:foundry (list nil)) - (`:width + (:width (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) font-width-table)) - (`:weight + (:weight (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) font-weight-table)) - (`:slant + (:slant (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) font-slant-table)) - (`:inverse-video + (:inverse-video (mapcar #'(lambda (x) (cons (symbol-name x) x)) (internal-lisp-face-attribute-values attribute))) - ((or `:underline `:overline `:strike-through `:box) + ((or :underline :overline :strike-through :box) (if (window-system frame) (nconc (mapcar #'(lambda (x) (cons (symbol-name x) x)) (internal-lisp-face-attribute-values attribute)) @@ -1112,12 +1113,12 @@ an integer value." (defined-colors frame))) (mapcar #'(lambda (x) (cons (symbol-name x) x)) (internal-lisp-face-attribute-values attribute)))) - ((or `:foreground `:background) + ((or :foreground :background) (mapcar #'(lambda (c) (cons c c)) (defined-colors frame))) - (`:height + (:height 'integerp) - (`:stipple + (:stipple (and (memq (window-system frame) '(x ns)) ; No stipple on w32 (mapcar #'list (apply #'nconc @@ -1126,7 +1127,7 @@ an integer value." (file-directory-p dir) (directory-files dir))) x-bitmap-file-path))))) - (`:inherit + (:inherit (cons '("none" . nil) (mapcar #'(lambda (c) (cons (symbol-name c) c)) (face-list)))) @@ -1239,7 +1240,7 @@ of a global face. Value is the new attribute value." ;; explicitly in VALID, using color approximation code ;; in tty-colors.el. (when (and (memq attribute '(:foreground :background)) - (not (memq (window-system frame) '(x w32 ns))) + (not (display-graphic-p frame)) (not (member new-value '("unspecified" "unspecified-fg" "unspecified-bg")))) @@ -1415,6 +1416,8 @@ argument, prompt for a regular expression using `read-regexp'." (dolist (face (face-list)) (copy-face face face frame disp-frame))))) +(declare-function describe-variable-custom-version-info "help-fns" + (variable &optional type)) (defun describe-face (face &optional frame) "Display the properties of face FACE on FRAME. @@ -1427,6 +1430,7 @@ If FRAME is omitted or nil, use the selected frame." (interactive (list (read-face-name "Describe face" (or (face-at-point t) 'default) t))) + (require 'help-fns) (let* ((attrs '((:family . "Family") (:foundry . "Foundry") (:width . "Width") @@ -1523,7 +1527,12 @@ If FRAME is omitted or nil, use the selected frame." (re-search-backward ": \\([^:]+\\)" nil t) (help-xref-button 1 'help-face attr))) (insert "\n"))))) - (terpri))))))) + (terpri) + (let ((version-info (describe-variable-custom-version-info + f 'face))) + (when version-info + (insert version-info) + (terpri))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1833,7 +1842,7 @@ The argument FRAME specifies which frame to try. The value may be different for frames on different display types. If FRAME doesn't support colors, the value is nil. If FRAME is nil, that stands for the selected frame." - (if (memq (framep (or frame (selected-frame))) '(x w32 ns)) + (if (display-graphic-p frame) (xw-defined-colors frame) (mapcar 'car (tty-color-alist frame)))) (defalias 'x-defined-colors 'defined-colors) @@ -1877,7 +1886,7 @@ or one of the strings \"unspecified-fg\" or \"unspecified-bg\". If FRAME is omitted or nil, use the selected frame." (unless (member color '(unspecified "unspecified-bg" "unspecified-fg")) - (if (member (framep (or frame (selected-frame))) '(x w32 ns)) + (if (display-graphic-p frame) (xw-color-defined-p color frame) (numberp (tty-color-translate color frame))))) (defalias 'x-color-defined-p 'color-defined-p) @@ -1903,7 +1912,7 @@ return value is nil." (cond ((member color '(unspecified "unspecified-fg" "unspecified-bg")) nil) - ((memq (framep (or frame (selected-frame))) '(x w32 ns)) + ((display-graphic-p frame) (xw-color-values color frame)) (t (tty-color-values color frame)))) @@ -1917,7 +1926,7 @@ return value is nil." The optional argument DISPLAY specifies which display to ask about. DISPLAY should be either a frame or a display name (a string). If omitted or nil, that stands for the selected frame's display." - (if (memq (framep-on-display display) '(x w32 ns)) + (if (display-graphic-p display) (xw-display-color-p display) (tty-display-color-p display))) (defalias 'x-display-color-p 'display-color-p) @@ -1928,12 +1937,9 @@ If omitted or nil, that stands for the selected frame's display." "Return non-nil if frames on DISPLAY can display shades of gray. DISPLAY should be either a frame or a display name (a string). If omitted or nil, that stands for the selected frame's display." - (let ((frame-type (framep-on-display display))) - (cond - ((memq frame-type '(x w32 ns)) - (x-display-grayscale-p display)) - (t - (> (tty-color-gray-shades display) 2))))) + (if (display-graphic-p display) + (x-display-grayscale-p display) + (> (tty-color-gray-shades display) 2))) (defun read-color (&optional prompt convert-to-RGB allow-empty-name msg) "Read a color name or RGB triplet. @@ -1999,7 +2005,7 @@ resulting color name in the echo area." (when (and convert-to-RGB (not (string-equal color ""))) (let ((components (x-color-values color))) - (unless (string-match-p "^#\\(?:[a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color) + (unless (string-match-p "^#\\(?:[[:xdigit:]][[:xdigit:]][[:xdigit:]]\\)+$" color) (setq color (format "#%04X%04X%04X" (logand 65535 (nth 0 components)) (logand 65535 (nth 1 components)) @@ -2502,6 +2508,18 @@ unwanted effects." :group 'basic-faces :group 'display-line-numbers) +;; Definition stolen from display-line-numbers. +(defface fill-column-indicator + '((t :inherit shadow :weight normal :slant normal + :underline nil :overline nil :strike-through nil + :box nil :inverse-video nil :stipple nil)) + "Face for displaying fill column indicator. +This face is used when `display-fill-column-indicator-mode' is +non-nil." + :version "27.1" + :group 'basic-faces + :group 'display-fill-column-indicator) + (defface escape-glyph '((((background dark)) :foreground "cyan") ;; See the comment in minibuffer-prompt for diff --git a/lisp/ffap.el b/lisp/ffap.el index 83bd1d65111..33854a6c0d4 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -104,6 +104,7 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) (require 'url-parse) (require 'thingatpt) @@ -512,7 +513,9 @@ When using jka-compr (a.k.a. `auto-compression-mode'), the returned name may have a suffix added from `ffap-compression-suffixes'. The optional NOMODIFY argument suppresses the extra search." (cond - ((not file) nil) ; quietly reject nil + ((or (not file) ; quietly reject nil + (zerop (length file))) ; and also "" + nil) ((file-exists-p file) file) ; try unmodified first ;; three reasons to suppress search: (nomodify nil) @@ -1078,9 +1081,9 @@ If a given RFC isn't in these then `ffap-rfc-path' is offered." '( ;; The default, used when the `major-mode' is not found. ;; Slightly controversial decisions: - ;; * strip trailing "@" and ":" + ;; * strip trailing "@", ":" and enclosing "{"/"}". ;; * no commas (good for latex) - (file "--:\\\\${}+<>@-Z_[:alpha:]~*?" "<@" "@>;.,!:") + (file "--:\\\\${}+<>@-Z_[:alpha:]~*?" "{<@" "@>;.,!:}") ;; An url, or maybe an email/news message-id: (url "--:=&?$+@-Z_[:alpha:]~#,%;*()!'" "^[0-9a-zA-Z]" ":;.,!?") ;; Find a string that does *not* contain a colon: @@ -1325,6 +1328,7 @@ which may actually result in an URL rather than a filename." ;; 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 ((alist ffap-alist) tem try case-fold-search) @@ -1509,7 +1513,7 @@ Uses the face `ffap' if it is defined, or else `highlight'." (ffap-file-at-point) ; may yield url! (ffap-fixup-machine (ffap-machine-at-point)))) -(defun ffap-prompter (&optional guess) +(defun ffap-prompter (&optional guess suffix) ;; Does guess and prompt step for find-file-at-point. ;; Extra complication for the temporary highlighting. (unwind-protect @@ -1517,7 +1521,9 @@ Uses the face `ffap' if it is defined, or else `highlight'." ;; and then maybe skip over this prompt (ff-paths, for example). (catch 'ffap-prompter (ffap-read-file-or-url - (if ffap-url-regexp "Find file or URL: " "Find file: ") + (if ffap-url-regexp + (format "Find file or URL%s: " (or suffix "")) + (format "Find file%s: " (or suffix ""))) (prog1 (let ((mark-active nil)) ;; Don't use the region here, since it can be something @@ -1764,18 +1770,18 @@ Return value: ;; at least two new user variables, and there is no w3-fetch-noselect. ;; So instead, we just fake it with a slow save-window-excursion. -(defun ffap-other-window () +(defun ffap-other-window (filename) "Like `ffap', but put buffer in another window. Only intended for interactive use." - (interactive) - (pcase (save-window-excursion (call-interactively 'ffap)) + (interactive (list (ffap-prompter nil " other window"))) + (pcase (save-window-excursion (find-file-at-point filename)) ((or (and (pred bufferp) b) `(,(and (pred bufferp) b) . ,_)) (switch-to-buffer-other-window b)))) -(defun ffap-other-frame () +(defun ffap-other-frame (filename) "Like `ffap', but put buffer in another frame. Only intended for interactive use." - (interactive) + (interactive (list (ffap-prompter nil " other frame"))) ;; Extra code works around dedicated windows (noted by JENS, 7/96): (let* ((win (selected-window)) (wdp (window-dedicated-p win)) @@ -1785,7 +1791,7 @@ Only intended for interactive use." (set-window-dedicated-p win nil) (switch-to-buffer-other-frame (save-window-excursion - (setq value (call-interactively 'ffap)) + (setq value (find-file-at-point filename)) (unless (or (bufferp value) (bufferp (car-safe value))) (setq value (current-buffer))) (current-buffer)))) @@ -1799,52 +1805,52 @@ Only intended for interactive use." (with-current-buffer buffer (read-only-mode 1)))) -(defun ffap-read-only () +(defun ffap-read-only (filename) "Like `ffap', but mark buffer as read-only. Only intended for interactive use." - (interactive) - (let ((value (call-interactively 'ffap))) + (interactive (list (ffap-prompter nil " read only"))) + (let ((value (find-file-at-point filename))) (unless (or (bufferp value) (bufferp (car-safe value))) (setq value (current-buffer))) (ffap--toggle-read-only value) value)) -(defun ffap-read-only-other-window () +(defun ffap-read-only-other-window (filename) "Like `ffap', but put buffer in another window and mark as read-only. Only intended for interactive use." - (interactive) - (let ((value (ffap-other-window))) + (interactive (list (ffap-prompter nil " read only other window"))) + (let ((value (ffap-other-window filename))) (ffap--toggle-read-only value) value)) -(defun ffap-read-only-other-frame () +(defun ffap-read-only-other-frame (filename) "Like `ffap', but put buffer in another frame and mark as read-only. Only intended for interactive use." - (interactive) - (let ((value (ffap-other-frame))) + (interactive (list (ffap-prompter nil " read only other frame"))) + (let ((value (ffap-other-frame filename))) (ffap--toggle-read-only value) value)) -(defun ffap-alternate-file () +(defun ffap-alternate-file (filename) "Like `ffap' and `find-alternate-file'. Only intended for interactive use." - (interactive) + (interactive (list (ffap-prompter nil " alternate file"))) (let ((ffap-file-finder 'find-alternate-file)) - (call-interactively 'ffap))) + (find-file-at-point filename))) -(defun ffap-alternate-file-other-window () +(defun ffap-alternate-file-other-window (filename) "Like `ffap' and `find-alternate-file-other-window'. Only intended for interactive use." - (interactive) + (interactive (list (ffap-prompter nil " alternate file other window"))) (let ((ffap-file-finder 'find-alternate-file-other-window)) - (call-interactively 'ffap))) + (find-file-at-point filename))) -(defun ffap-literally () +(defun ffap-literally (filename) "Like `ffap' and command `find-file-literally'. Only intended for interactive use." - (interactive) + (interactive (list (ffap-prompter nil " literally"))) (let ((ffap-file-finder 'find-file-literally)) - (call-interactively 'ffap))) + (find-file-at-point filename))) (defalias 'find-file-literally-at-point 'ffap-literally) @@ -2041,19 +2047,19 @@ This hook is intended to be put in `file-name-at-point-functions'." '((global-set-key [S-mouse-3] 'ffap-at-mouse) (global-set-key [C-S-mouse-3] 'ffap-menu) - (global-set-key "\C-x\C-f" 'find-file-at-point) - (global-set-key "\C-x\C-r" 'ffap-read-only) - (global-set-key "\C-x\C-v" 'ffap-alternate-file) + (global-set-key [remap find-file] 'find-file-at-point) + (global-set-key [remap find-file-read-only] 'ffap-read-only) + (global-set-key [remap find-alternate-file] 'ffap-alternate-file) - (global-set-key "\C-x4f" 'ffap-other-window) - (global-set-key "\C-x5f" 'ffap-other-frame) - (global-set-key "\C-x4r" 'ffap-read-only-other-window) - (global-set-key "\C-x5r" 'ffap-read-only-other-frame) + (global-set-key [remap find-file-other-window] 'ffap-other-window) + (global-set-key [remap find-file-other-frame] 'ffap-other-frame) + (global-set-key [remap find-file-read-only-other-window] 'ffap-read-only-other-window) + (global-set-key [remap find-file-read-only-other-frame] 'ffap-read-only-other-frame) - (global-set-key "\C-xd" 'dired-at-point) - (global-set-key "\C-x4d" 'ffap-dired-other-window) - (global-set-key "\C-x5d" 'ffap-dired-other-frame) - (global-set-key "\C-x\C-d" 'ffap-list-directory) + (global-set-key [remap dired] 'dired-at-point) + (global-set-key [remap dired-other-window] 'ffap-dired-other-window) + (global-set-key [remap dired-other-frame] 'ffap-dired-other-frame) + (global-set-key [remap list-directory] 'ffap-list-directory) (add-hook 'gnus-summary-mode-hook 'ffap-gnus-hook) (add-hook 'gnus-article-mode-hook 'ffap-gnus-hook) diff --git a/lisp/filecache.el b/lisp/filecache.el index eb4a64b768f..63268bf2ebc 100644 --- a/lisp/filecache.el +++ b/lisp/filecache.el @@ -1,8 +1,8 @@ -;;; filecache.el --- find files using a pre-loaded cache +;;; filecache.el --- find files using a pre-loaded cache -*- lexical-binding:t -*- ;; Copyright (C) 1996, 2000-2019 Free Software Foundation, Inc. -;; Author: Peter Breton <pbreton@cs.umb.edu> +;; Author: Peter Breton <pbreton@cs.umb.edu> ;; Created: Sun Nov 10 1996 ;; Keywords: convenience @@ -25,16 +25,16 @@ ;; ;; The file-cache package is an attempt to make it easy to locate files ;; by name, without having to remember exactly where they are located. -;; This is very handy when working with source trees. You can also add +;; This is very handy when working with source trees. You can also add ;; frequently used files to the cache to create a hotlist effect. ;; The cache can be used with any interactive command which takes a ;; filename as an argument. ;; ;; It is worth noting that this package works best when most of the files ;; in the cache have unique names, or (if they have the same name) exist in -;; only a few directories. The worst case is many files all with +;; only a few directories. The worst case is many files all with ;; the same name and in different directories, for example a big source tree -;; with a Makefile in each directory. In such a case, you should probably +;; with a Makefile in each directory. In such a case, you should probably ;; use an alternate strategy to find the files. ;; ;; ADDING FILES TO THE CACHE: @@ -49,11 +49,11 @@ ;; `file-cache-delete-regexps' to eliminate unwanted files: ;; ;; * `file-cache-add-directory': Adds the files in a directory to the -;; cache. You can also specify a regular expression to match the files +;; cache. You can also specify a regular expression to match the files ;; which should be added. ;; ;; * `file-cache-add-directory-list': Same as above, but acts on a list -;; of directories. You can use `load-path', `exec-path' and the like. +;; of directories. You can use `load-path', `exec-path' and the like. ;; ;; * `file-cache-add-directory-using-find': Uses the `find' command to ;; add a directory tree to the cache. @@ -65,7 +65,7 @@ ;; add all files matching a pattern to the cache. ;; ;; Use the function `file-cache-clear-cache' to remove all items from the -;; cache. There are a number of `file-cache-delete' functions provided +;; cache. There are a number of `file-cache-delete' functions provided ;; as well, but in general it is probably better to not worry too much ;; about extra files in the cache. ;; @@ -76,7 +76,7 @@ ;; FINDING FILES USING THE CACHE: ;; ;; You can use the file-cache with any function that expects a filename as -;; an argument. For example: +;; an argument. For example: ;; ;; 1) Invoke a function which expects a filename as an argument: ;; M-x find-file @@ -160,13 +160,11 @@ File names which match these expressions will not be added to the cache. Note that the functions `file-cache-add-file' and `file-cache-add-file-list' do not use this variable." :version "25.1" ; added "/\\.#" - :type '(repeat regexp) - :group 'file-cache) + :type '(repeat regexp)) (defcustom file-cache-find-command "find" "External program used by `file-cache-add-directory-using-find'." - :type 'string - :group 'file-cache) + :type 'string) (defcustom file-cache-find-command-posix-flag 'not-defined "Set to t, if `file-cache-find-command' handles wildcards POSIX style. @@ -178,30 +176,25 @@ Under Windows operating system where Cygwin is available, this value should be t." :type '(choice (const :tag "Yes" t) (const :tag "No" nil) - (const :tag "Unknown" not-defined)) - :group 'file-cache) + (const :tag "Unknown" not-defined))) (defcustom file-cache-locate-command "locate" "External program used by `file-cache-add-directory-using-locate'." - :type 'string - :group 'file-cache) + :type 'string) ;; Minibuffer messages (defcustom file-cache-no-match-message " [File Cache: No match]" "Message to display when there is no completion." - :type 'string - :group 'file-cache) + :type 'string) (defcustom file-cache-sole-match-message " [File Cache: sole completion]" "Message to display when there is only one completion." - :type 'string - :group 'file-cache) + :type 'string) (defcustom file-cache-non-unique-message " [File Cache: complete but not unique]" "Message to display when there is a non-unique completion." - :type 'string - :group 'file-cache) + :type 'string) (defcustom file-cache-completion-ignore-case (if (memq system-type '(ms-dos windows-nt cygwin)) @@ -209,8 +202,7 @@ should be t." completion-ignore-case) "If non-nil, file-cache completion should ignore case. Defaults to the value of `completion-ignore-case'." - :type 'boolean - :group 'file-cache) + :type 'boolean) (defcustom file-cache-case-fold-search (if (memq system-type '(ms-dos windows-nt cygwin)) @@ -218,15 +210,13 @@ Defaults to the value of `completion-ignore-case'." case-fold-search) "If non-nil, file-cache completion should ignore case. Defaults to the value of `case-fold-search'." - :type 'boolean - :group 'file-cache) + :type 'boolean) (defcustom file-cache-ignore-case (memq system-type '(ms-dos windows-nt cygwin)) "Non-nil means ignore case when checking completions in the file cache. Defaults to nil on DOS and Windows, and t on other systems." - :type 'boolean - :group 'file-cache) + :type 'boolean) (defvar file-cache-multiple-directory-message nil) @@ -235,18 +225,10 @@ Defaults to nil on DOS and Windows, and t on other systems." ;; switch-to-completions in simple.el expects (defcustom file-cache-completions-buffer "*Completions*" "Buffer to display completions when using the file cache." - :type 'string - :group 'file-cache) + :type 'string) -(defcustom file-cache-buffer "*File Cache*" - "Buffer to hold the cache of file names." - :type 'string - :group 'file-cache) - -(defcustom file-cache-buffer-default-regexp "^.+$" - "Regexp to match files in `file-cache-buffer'." - :type 'regexp - :group 'file-cache) +(defvar file-cache-buffer-default-regexp "^.+$" + "Regexp to match files in find and locate's output.") (defvar file-cache-last-completion nil) @@ -362,36 +344,31 @@ Find is run in DIRECTORY." (if (eq file-cache-find-command-posix-flag 'not-defined) (setq file-cache-find-command-posix-flag (executable-command-find-posix-p file-cache-find-command)))) - (set-buffer (get-buffer-create file-cache-buffer)) - (erase-buffer) - (call-process file-cache-find-command nil - (get-buffer file-cache-buffer) nil - dir "-name" - (if (memq system-type '(windows-nt cygwin)) - (if file-cache-find-command-posix-flag - "\\*" - "'*'") - "*") - "-print") - (file-cache-add-from-file-cache-buffer))) + (with-temp-buffer + (call-process file-cache-find-command nil t nil + dir "-name" + (if (memq system-type '(windows-nt cygwin)) + (if file-cache-find-command-posix-flag + "\\*" + "'*'") + "*") + "-print") + (file-cache--add-from-buffer)))) ;;;###autoload (defun file-cache-add-directory-using-locate (string) "Use the `locate' command to add files to the file cache. STRING is passed as an argument to the locate command." (interactive "sAdd files using locate string: ") - (set-buffer (get-buffer-create file-cache-buffer)) - (erase-buffer) - (call-process file-cache-locate-command nil - (get-buffer file-cache-buffer) nil - string) - (file-cache-add-from-file-cache-buffer)) + (with-temp-buffer + (call-process file-cache-locate-command nil t nil string) + (file-cache--add-from-buffer))) (autoload 'find-lisp-find-files "find-lisp") ;;;###autoload (defun file-cache-add-directory-recursively (dir &optional regexp) - "Adds DIR and any subdirectories to the file-cache. + "Add DIR and any subdirectories to the file-cache. This function does not use any external programs. If the optional REGEXP argument is non-nil, only files which match it will be added to the cache. Note that the REGEXP is applied to the @@ -408,22 +385,16 @@ files in each directory, not to the directory list itself." (file-cache-add-file file))) (find-lisp-find-files dir (or regexp "^")))) -(defun file-cache-add-from-file-cache-buffer (&optional regexp) - "Add any entries found in the file cache buffer. +(defun file-cache--add-from-buffer () + "Add any entries found in the current buffer. Each entry matches the regular expression `file-cache-buffer-default-regexp' or the optional REGEXP argument." - (set-buffer file-cache-buffer) (dolist (elt file-cache-filter-regexps) (goto-char (point-min)) (delete-matching-lines elt)) (goto-char (point-min)) - (let ((full-filename)) - (while (re-search-forward - (or regexp file-cache-buffer-default-regexp) - (point-max) t) - (setq full-filename (buffer-substring-no-properties - (match-beginning 0) (match-end 0))) - (file-cache-add-file full-filename)))) + (while (re-search-forward file-cache-buffer-default-regexp nil t) + (file-cache-add-file (match-string-no-properties 0)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Functions to delete from the cache @@ -566,68 +537,65 @@ the directories that the name is available in. With a prefix argument, the name is considered already unique; only the second substitution \(directories) is done." (interactive "P") - (let* - ( - (completion-ignore-case file-cache-completion-ignore-case) - (case-fold-search file-cache-case-fold-search) - (string (file-name-nondirectory (minibuffer-contents))) - (completion-string (try-completion string file-cache-alist)) - (completion-list) - (len) - (file-cache-string)) + (let* ((completion-ignore-case file-cache-completion-ignore-case) + (case-fold-search file-cache-case-fold-search) + (string (file-name-nondirectory (minibuffer-contents))) + (completion (completion-try-completion + string file-cache-alist nil 0))) (cond ;; If it's the only match, replace the original contents - ((or arg (eq completion-string t)) - (setq file-cache-string (file-cache-file-name string)) - (if (string= file-cache-string (minibuffer-contents)) - (minibuffer-message file-cache-sole-match-message) - (delete-minibuffer-contents) - (insert file-cache-string) - (if file-cache-multiple-directory-message - (minibuffer-message file-cache-multiple-directory-message)))) + ((or arg (eq completion t)) + (let ((file-name (file-cache-file-name string))) + (if (string= file-name (minibuffer-contents)) + (minibuffer-message file-cache-sole-match-message) + (delete-minibuffer-contents) + (insert file-name) + (if file-cache-multiple-directory-message + (minibuffer-message file-cache-multiple-directory-message))))) ;; If it's the longest match, insert it - ((stringp completion-string) - ;; If we've already inserted a unique string, see if the user - ;; wants to use that one - (if (and (string= string completion-string) - (assoc-string string file-cache-alist - file-cache-ignore-case)) - (if (and (eq last-command this-command) - (string= file-cache-last-completion completion-string)) - (progn - (delete-minibuffer-contents) - (insert (file-cache-file-name completion-string)) - (setq file-cache-last-completion nil)) - (minibuffer-message file-cache-non-unique-message) - (setq file-cache-last-completion string)) - (setq file-cache-last-completion string) - (setq completion-list (all-completions string file-cache-alist) - len (length completion-list)) - (if (> len 1) - (progn - (goto-char (point-max)) - (insert - (substring completion-string (length string))) - ;; Add our own setup function to the Completions Buffer - (let ((completion-setup-hook - (append completion-setup-hook - (list 'file-cache-completion-setup-function)))) - (with-output-to-temp-buffer file-cache-completions-buffer - (display-completion-list - (completion-hilit-commonality completion-list - (length string)))))) - (setq file-cache-string (file-cache-file-name completion-string)) - (if (string= file-cache-string (minibuffer-contents)) - (minibuffer-message file-cache-sole-match-message) - (delete-minibuffer-contents) - (insert file-cache-string) - (if file-cache-multiple-directory-message - (minibuffer-message file-cache-multiple-directory-message))) - ))) + ((consp completion) + (let ((newstring (car completion)) + (newpoint (cdr completion))) + ;; If we've already inserted a unique string, see if the user + ;; wants to use that one + (if (and (string= string newstring) + (assoc-string string file-cache-alist + file-cache-ignore-case)) + (if (and (eq last-command this-command) + (string= file-cache-last-completion newstring)) + (progn + (delete-minibuffer-contents) + (insert (file-cache-file-name newstring)) + (setq file-cache-last-completion nil)) + (minibuffer-message file-cache-non-unique-message) + (setq file-cache-last-completion string)) + (setq file-cache-last-completion string) + (let* ((completion-list (completion-all-completions + newstring file-cache-alist nil newpoint)) + (base-size (cdr (last completion-list)))) + (when base-size + (setcdr (last completion-list) nil)) + (if (> (length completion-list) 1) + (progn + (delete-region (- (point-max) (length string)) (point-max)) + (save-excursion (insert newstring)) + (forward-char newpoint) + (with-output-to-temp-buffer file-cache-completions-buffer + (display-completion-list completion-list) + ;; Add our own setup function to the Completions Buffer + (file-cache-completion-setup-function))) + (let ((file-name (file-cache-file-name newstring))) + (if (string= file-name (minibuffer-contents)) + (minibuffer-message file-cache-sole-match-message) + (delete-minibuffer-contents) + (insert file-name) + (if file-cache-multiple-directory-message + (minibuffer-message + file-cache-multiple-directory-message))))))))) ;; No match - ((eq completion-string nil) + ((eq completion nil) (minibuffer-message file-cache-no-match-message))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -647,7 +615,7 @@ the name is considered already unique; only the second substitution (file-cache-minibuffer-complete nil))) (define-obsolete-function-alias 'file-cache-mouse-choose-completion - 'file-cache-choose-completion "23.2") + #'file-cache-choose-completion "23.2") (defun file-cache-complete () "Complete the word at point, using the filecache." diff --git a/lisp/fileloop.el b/lisp/fileloop.el new file mode 100644 index 00000000000..2e77811a576 --- /dev/null +++ b/lisp/fileloop.el @@ -0,0 +1,217 @@ +;;; fileloop.el --- Operations on multiple files -*- lexical-binding: t; -*- + +;; Copyright (C) 2018-2019 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Support functions for operations like search or query&replace applied to +;; several files. This code was largely inspired&extracted from an earlier +;; version of etags.el. + +;; TODO: +;; - Maybe it would make sense to replace the fileloop--* vars with a single +;; global var holding a struct, and then stash those structs into a history +;; of past operations, so you can perform a fileloop-search while in the +;; middle of a fileloop-replace and later go back to that +;; fileloop-replace. +;; - Make multi-isearch work on top of this library (might require changes +;; to this library, of course). + +;;; Code: + +(require 'generator) + +(defgroup fileloop nil + "Operations on multiple files." + :group 'tools) + +(defcustom fileloop-revert-buffers 'silent + "Whether to revert files during fileloop operation. + `silent' means to only do it if `revert-without-query' is applicable; + t means to offer to do it for all applicable files; + nil means never to do it" + :type '(choice (const silent) (const t) (const nil))) + +;; FIXME: This already exists in GNU ELPA's iterator.el. Maybe it should move +;; to generator.el? +(iter-defun fileloop--list-to-iterator (list) + (while list (iter-yield (pop list)))) + +(defvar fileloop--iterator iter-empty) +(defvar fileloop--scan-function + (lambda () (user-error "No operation in progress"))) +(defvar fileloop--operate-function #'ignore) +(defvar fileloop--freshly-initialized nil) + +;;;###autoload +(defun fileloop-initialize (files scan-function operate-function) + "Initialize a new round of operation on several files. +FILES can be either a list of file names, or an iterator (used with `iter-next') +which returns a file name at each step. +SCAN-FUNCTION is a function called with no argument inside a buffer +and it should return non-nil if that buffer has something on which to operate. +OPERATE-FUNCTION is a function called with no argument; it is expected +to perform the operation on the current file buffer and when done +should return non-nil to mean that we should immediately continue +operating on the next file and nil otherwise." + (setq fileloop--iterator + (if (and (listp files) (not (functionp files))) + (fileloop--list-to-iterator files) + files)) + (setq fileloop--scan-function scan-function) + (setq fileloop--operate-function operate-function) + (setq fileloop--freshly-initialized t)) + +(defun fileloop-next-file (&optional novisit) + ;; FIXME: Should we provide an interactive command, like tags-next-file? + (let ((next (condition-case nil + (iter-next fileloop--iterator) + (iter-end-of-sequence nil)))) + (unless next + (and novisit + (get-buffer " *next-file*") + (kill-buffer " *next-file*")) + (user-error "All files processed")) + (let* ((buffer (get-file-buffer next)) + (new (not buffer))) + ;; Optionally offer to revert buffers + ;; if the files have changed on disk. + (and buffer fileloop-revert-buffers + (not (verify-visited-file-modtime buffer)) + (if (eq fileloop-revert-buffers 'silent) + (and (not (buffer-modified-p buffer)) + (let ((revertible nil)) + (dolist (re revert-without-query) + (when (string-match-p re next) + (setq revertible t))) + revertible)) + (y-or-n-p + (format + (if (buffer-modified-p buffer) + "File %s changed on disk. Discard your edits? " + "File %s changed on disk. Reread from disk? ") + next))) + (with-current-buffer buffer + (revert-buffer t t))) + (if (not (and new novisit)) + (set-buffer (find-file-noselect next)) + ;; Like find-file, but avoids random warning messages. + (set-buffer (get-buffer-create " *next-file*")) + (kill-all-local-variables) + (erase-buffer) + (setq new next) + (insert-file-contents new nil)) + new))) + +(defun fileloop-continue () + "Continue last multi-file operation." + (interactive) + (let (new + ;; Non-nil means we have finished one file + ;; and should not scan it again. + file-finished + original-point + (messaged nil)) + (while + (progn + ;; Scan files quickly for the first or next interesting one. + ;; This starts at point in the current buffer. + (while (or fileloop--freshly-initialized file-finished + (save-restriction + (widen) + (not (funcall fileloop--scan-function)))) + ;; If nothing was found in the previous file, and + ;; that file isn't in a temp buffer, restore point to + ;; where it was. + (when original-point + (goto-char original-point)) + + (setq file-finished nil) + (setq new (fileloop-next-file t)) + + ;; If NEW is non-nil, we got a temp buffer, + ;; and NEW is the file name. + (when (or messaged + (and (not fileloop--freshly-initialized) + (> baud-rate search-slow-speed) + (setq messaged t))) + (message "Scanning file %s..." (or new buffer-file-name))) + + (setq fileloop--freshly-initialized nil) + (setq original-point (if new nil (point))) + (goto-char (point-min))) + + ;; If we visited it in a temp buffer, visit it now for real. + (if new + (let ((pos (point))) + (erase-buffer) + (set-buffer (find-file-noselect new)) + (setq new nil) ;No longer in a temp buffer. + (widen) + (goto-char pos)) + (push-mark original-point t)) + + (switch-to-buffer (current-buffer)) + + ;; Now operate on the file. + ;; If value is non-nil, continue to scan the next file. + (save-restriction + (widen) + (funcall fileloop--operate-function))) + (setq file-finished t)))) + +;;;###autoload +(defun fileloop-initialize-search (regexp files case-fold) + (let ((last-buffer (current-buffer))) + (fileloop-initialize + files + (lambda () + (let ((case-fold-search + (if (memq case-fold '(t nil)) case-fold case-fold-search))) + (re-search-forward regexp nil t))) + (lambda () + (unless (eq last-buffer (current-buffer)) + (setq last-buffer (current-buffer)) + (message "Scanning file %s...found" buffer-file-name)) + nil)))) + +;;;###autoload +(defun fileloop-initialize-replace (from to files case-fold &optional delimited) + "Initialize a new round of query&replace on several files. +FROM is a regexp and TO is the replacement to use. +FILES describes the file, as in `fileloop-initialize'. +CASE-FOLD can be t, nil, or `default', the latter one meaning to obey +the default setting of `case-fold-search'. +DELIMITED if non-nil means replace only word-delimited matches." + ;; FIXME: Not sure how the delimited-flag interacts with the regexp-flag in + ;; `perform-replace', so I just try to mimic the old code. + (fileloop-initialize + files + (lambda () + (let ((case-fold-search + (if (memql case-fold '(nil t)) case-fold case-fold-search))) + (if (re-search-forward from nil t) + ;; When we find a match, move back + ;; to the beginning of it so perform-replace + ;; will see it. + (goto-char (match-beginning 0))))) + (lambda () + (perform-replace from to t t delimited nil multi-query-replace-map)))) + +(provide 'fileloop) +;;; fileloop.el ends here diff --git a/lisp/filenotify.el b/lisp/filenotify.el index 101ddb6be09..e5dc353186d 100644 --- a/lisp/filenotify.el +++ b/lisp/filenotify.el @@ -30,6 +30,9 @@ (require 'cl-lib) (eval-when-compile (require 'subr-x)) +(defvar file-notify-debug nil + "Use for debug messages.") + (defconst file-notify--library (cond ((featurep 'inotify) 'inotify) @@ -45,11 +48,11 @@ could use another implementation.") (:constructor nil) (:constructor file-notify--watch-make (directory filename callback))) - ;; Watched directory + ;; Watched directory. directory ;; Watched relative filename, nil if watching the directory. filename - ;; Function to propagate events to + ;; Function to propagate events to, or nil if watch is being removed. callback) (defun file-notify--watch-absolute-filename (watch) @@ -72,12 +75,15 @@ struct.") DESCRIPTOR should be an object returned by `file-notify-add-watch'. If it is registered in `file-notify-descriptors', a stopped event is sent." (when-let* ((watch (gethash descriptor file-notify-descriptors))) - ;; Send `stopped' event. - (unwind-protect - (funcall - (file-notify--watch-callback watch) - `(,descriptor stopped ,(file-notify--watch-absolute-filename watch))) - (remhash descriptor file-notify-descriptors)))) + (let ((callback (file-notify--watch-callback watch))) + ;; Make sure this is the last time the callback is invoked. + (setf (file-notify--watch-callback watch) nil) + ;; Send `stopped' event. + (unwind-protect + (funcall + callback + `(,descriptor stopped ,(file-notify--watch-absolute-filename watch))) + (remhash descriptor file-notify-descriptors))))) ;; This function is used by `inotify', `kqueue', `gfilenotify' and ;; `w32notify' events. @@ -90,7 +96,8 @@ If EVENT is a filewatch event, call its callback. It has the format Otherwise, signal a `file-notify-error'." (interactive "e") - ;;(message "file-notify-handle-event %S" event) + (when file-notify-debug + (message "file-notify-handle-event %S" event)) (if (and (consp event) (eq (car event) 'file-notify) (>= (length event) 3)) @@ -98,169 +105,269 @@ Otherwise, signal a `file-notify-error'." (signal 'file-notify-error (cons "Not a valid file-notify event" event)))) -;; Needed for `inotify' and `w32notify'. In the latter case, COOKIE is nil. -(defvar file-notify--pending-event nil - "A pending file notification event for a future `renamed' action. -It is a form ((DESCRIPTOR ACTION FILE [FILE1-OR-COOKIE]) CALLBACK).") - -(defun file-notify--event-watched-file (event) - "Return file or directory being watched. -Could be different from the directory watched by the backend library." - (when-let* ((watch (gethash (car event) file-notify-descriptors))) - (file-notify--watch-absolute-filename watch))) - -(defun file-notify--event-file-name (event) - "Return file name of file notification event, or nil." - (when-let* ((watch (gethash (car event) file-notify-descriptors))) - (directory-file-name - (expand-file-name - (or (and (stringp (nth 2 event)) (nth 2 event)) "") - (file-notify--watch-directory watch))))) - -;; Only `gfilenotify' could return two file names. -(defun file-notify--event-file1-name (event) - "Return second file name of file notification event, or nil. -This is available in case a file has been moved." - (when-let* ((watch (gethash (car event) file-notify-descriptors))) - (and (stringp (nth 3 event)) - (directory-file-name - (expand-file-name - (nth 3 event) (file-notify--watch-directory watch)))))) - -;; Cookies are offered by `inotify' only. -(defun file-notify--event-cookie (event) - "Return cookie of file notification event, or nil. -This is available in case a file has been moved." - (nth 3 event)) - -;; The callback function used to map between specific flags of the -;; respective file notifications, and the ones we return. -(defun file-notify-callback (event) - "Handle an EVENT returned from file notification. -EVENT is the cadr of the event in `file-notify-handle-event' -\(DESCRIPTOR ACTIONS FILE [FILE1-OR-COOKIE])." - (let* ((desc (car event)) - (watch (gethash desc file-notify-descriptors)) - (actions (nth 1 event)) - (file (file-notify--event-file-name event)) - file1 pending-event stopped) - - ;; Make actions a list. - (unless (consp actions) (setq actions (cons actions nil))) - +(cl-defstruct (file-notify--rename + (:constructor nil) + (:constructor + file-notify--rename-make (watch desc from-file cookie))) + watch desc from-file cookie) + +(defvar file-notify--pending-rename nil + "A pending rename event awaiting the destination file name. +It is nil or a `file-notify--rename' where the cookie can be nil.") + +(defun file-notify--expand-file-name (watch file) + "Full file name of FILE reported for WATCH." + (directory-file-name + (expand-file-name file (file-notify--watch-directory watch)))) + +(cl-defun file-notify--callback-inotify ((desc actions file + &optional file1-or-cookie)) + "Notification callback for inotify." + (file-notify--handle-event + desc + (delq nil (mapcar (lambda (action) + (cond + ((eq action 'create) 'created) + ((eq action 'modify) 'changed) + ((eq action 'attrib) 'attribute-changed) + ((memq action '(delete delete-self move-self)) 'deleted) + ((eq action 'moved-from) 'renamed-from) + ((eq action 'moved-to) 'renamed-to) + ((eq action 'ignored) 'stopped))) + actions)) + file file1-or-cookie)) + +(cl-defun file-notify--callback-kqueue ((desc actions file + &optional file1-or-cookie)) + "Notification callback for kqueue." + (file-notify--handle-event + desc + (delq nil (mapcar (lambda (action) + (cond + ((eq action 'create) 'created) + ((eq action 'write) 'changed) + ((memq action '(attrib link)) 'attribute-changed) + ((eq action 'delete) 'deleted) + ((eq action 'rename) 'renamed))) + actions)) + file file1-or-cookie)) + +(cl-defun file-notify--callback-w32notify ((desc actions file + &optional file1-or-cookie)) + "Notification callback for w32notify." + (let ((action (pcase actions + ('added 'created) + ('modified 'changed) + ('removed 'deleted) + ('renamed-from 'renamed-from) + ('renamed-to 'renamed-to)))) + (when action + (file-notify--handle-event desc (list action) file file1-or-cookie)))) + +(cl-defun file-notify--callback-gfilenotify ((desc actions file + &optional file1-or-cookie)) + "Notification callback for gfilenotify." + (file-notify--handle-event + desc + (delq nil (mapcar (lambda (action) + (cond + ((memq action + '(created changed attribute-changed deleted)) + action) + ((eq action 'moved) 'renamed))) + (if (consp actions) actions (list actions)))) + file file1-or-cookie)) + +(cl-defun file-notify-callback ((desc actions file &optional file1-or-cookie)) + "Notification callback for file name handlers." + (file-notify--handle-event + desc + ;; File name handlers use gfilenotify or inotify actions. + (delq nil (mapcar + (lambda (action) + (cond + ;; gfilenotify actions: + ((memq action '(created changed attribute-changed deleted)) + action) + ((eq action 'moved) 'renamed) + ;; inotify actions: + ((eq action 'create) 'created) + ((eq action 'modify) 'changed) + ((eq action 'attrib) 'attribute-changed) + ((memq action '(delete delete-self move-self)) 'deleted) + ((eq action 'moved-from) 'renamed-from) + ((eq action 'moved-to) 'renamed-to) + ((eq action 'ignored) 'stopped))) + (if (consp actions) actions (list actions)))) + file file1-or-cookie)) + +(defun file-notify--call-handler (watch desc action file file1) + "Call the handler of WATCH with the arguments DESC, ACTION, FILE and FILE1." + (when (or + ;; If there is no relative file name for that + ;; watch, we watch the whole directory. + (null (file-notify--watch-filename watch)) + ;; File matches. + (string-equal + (file-notify--watch-filename watch) + (file-name-nondirectory file)) + + ;; Directory matches. + ;; FIXME: What purpose would this condition serve? + ;; Doesn't it just slip through events for files + ;; having the same name as the last component of the + ;; directory of the file that we are really watching? + ;;(string-equal + ;; (file-name-nondirectory file) + ;; (file-name-nondirectory (file-notify--watch-directory watch))) + + ;; File1 matches. + (and (stringp file1) + (string-equal (file-notify--watch-filename watch) + (file-name-nondirectory file1)))) + (when file-notify-debug + (message + "file-notify-callback %S %S %S %S %S %S %S" + desc action file file1 watch + (file-notify--watch-absolute-filename watch) + (file-notify--watch-directory watch))) + (funcall (file-notify--watch-callback watch) + (if file1 + (list desc action file file1) + (list desc action file))))) + +(defun file-notify--handle-event (desc actions file file1-or-cookie) + "Handle an event returned from file notification. +DESC is the back-end descriptor. ACTIONS is a list of: + `created' + `changed' + `attribute-changed' + `deleted' + `renamed' -- FILE is old name, FILE1-OR-COOKIE is new name or nil + `renamed-from' -- FILE is old name, FILE1-OR-COOKIE is cookie or nil + `renamed-to' -- FILE is new name, FILE1-OR-COOKIE is cookie or nil + `stopped' -- no more events after this should be sent" + (let* ((watch (gethash desc file-notify-descriptors)) + (file (and watch (file-notify--expand-file-name watch file)))) (when watch - ;; Loop over actions. In fact, more than one action happens only - ;; for `inotify' and `kqueue'. (while actions (let ((action (pop actions))) - ;; Send pending event, if it doesn't match. - (when (and file-notify--pending-event - ;; The cookie doesn't match. - (not (equal (file-notify--event-cookie - (car file-notify--pending-event)) - (file-notify--event-cookie event))) - (or - ;; inotify. - (and (eq (nth 1 (car file-notify--pending-event)) - 'moved-from) - (not (eq action 'moved-to))) - ;; w32notify. - (and (eq (nth 1 (car file-notify--pending-event)) - 'renamed-from) - (not (eq action 'renamed-to))))) - (setq pending-event file-notify--pending-event - file-notify--pending-event nil) - (setcar (cdar pending-event) 'deleted)) - - ;; Map action. We ignore all events which cannot be mapped. - (setq action - (cond - ((memq action - '(attribute-changed changed created deleted renamed)) - action) - ((memq action '(moved rename)) - ;; The kqueue rename event does not return file1 in - ;; case a file monitor is established. - (if (setq file1 (file-notify--event-file1-name event)) - 'renamed 'deleted)) - ((eq action 'ignored) - (setq stopped t actions nil)) - ((memq action '(attrib link)) 'attribute-changed) - ((memq action '(create added)) 'created) - ((memq action '(modify modified write)) 'changed) - ((memq action '(delete delete-self move-self removed)) - 'deleted) - ;; Make the event pending. - ((memq action '(moved-from renamed-from)) - (setq file-notify--pending-event - `((,desc ,action ,file - ,(file-notify--event-cookie event)) - ,(file-notify--watch-callback watch))) - nil) - ;; Look for pending event. - ((memq action '(moved-to renamed-to)) - (if (null file-notify--pending-event) - 'created - (setq file1 file - file (file-notify--event-file-name - (car file-notify--pending-event))) + ;; We only handle {renamed,moved}-{from,to} pairs when these + ;; arrive in order without anything else in-between. + ;; If there is a pending rename that does not match this event, + ;; then send the former as a deletion (since we don't know the + ;; rename destination). + (when file-notify--pending-rename + (unless (and (equal (file-notify--rename-cookie + file-notify--pending-rename) + file1-or-cookie) + (eq action 'renamed-to)) + (let ((callback (file-notify--watch-callback + (file-notify--rename-watch + file-notify--pending-rename)))) + (when callback + (funcall callback (list (file-notify--rename-desc + file-notify--pending-rename) + 'deleted + (file-notify--rename-from-file + file-notify--pending-rename)))) + (setq file-notify--pending-rename nil)))) + + (let ((file1 nil)) + (cond + ((eq action 'renamed) + ;; A `renamed' event may not have a destination name; + ;; if none, treat it as a deletion. + (if file1-or-cookie + (setq file1 + (file-notify--expand-file-name watch file1-or-cookie)) + (setq action 'deleted))) + ((eq action 'stopped) + (file-notify-rm-watch desc) + (setq actions nil) + (setq action nil)) + ;; Make the event pending. + ((eq action 'renamed-from) + (setq file-notify--pending-rename + (file-notify--rename-make watch desc file file1-or-cookie)) + (setq action nil)) + ;; Look for pending event. + ((eq action 'renamed-to) + (if file-notify--pending-rename + (let ((callback (file-notify--watch-callback + (file-notify--rename-watch + file-notify--pending-rename))) + (pending-desc (file-notify--rename-desc + file-notify--pending-rename)) + (from-file (file-notify--rename-from-file + file-notify--pending-rename))) + (setq file1 file) + (setq file from-file) ;; If the source is handled by another watch, we ;; must fire the rename event there as well. - (unless (equal desc (caar file-notify--pending-event)) - (setq pending-event - `((,(caar file-notify--pending-event) - renamed ,file ,file1) - ,(cadr file-notify--pending-event)))) - (setq file-notify--pending-event nil) - 'renamed)))) - - ;; Apply pending callback. - (when pending-event - (funcall (cadr pending-event) (car pending-event)) - (setq pending-event nil)) - - ;; Apply callback. - (when (and action - (or - ;; If there is no relative file name for that - ;; watch, we watch the whole directory. - (null (file-notify--watch-filename watch)) - ;; File matches. - (string-equal - (file-notify--watch-filename watch) - (file-name-nondirectory file)) - ;; Directory matches. - (string-equal - (file-name-nondirectory file) - (file-name-nondirectory - (file-notify--watch-directory watch))) - ;; File1 matches. - (and (stringp file1) - (string-equal - (file-notify--watch-filename watch) - (file-name-nondirectory file1))))) - ;;(message - ;;"file-notify-callback %S %S %S %S %S" - ;;desc action file file1 watch) - (if file1 - (funcall (file-notify--watch-callback watch) - `(,desc ,action ,file ,file1)) - (funcall (file-notify--watch-callback watch) - `(,desc ,action ,file)))) - - ;; Send `stopped' event. - (when (or stopped - (and (memq action '(deleted renamed)) - ;; Not, when a file is backed up. - (not (and (stringp file1) (backup-file-name-p file1))) - ;; Watched file or directory is concerned. - (string-equal - file (file-notify--event-watched-file event)))) - (file-notify-rm-watch desc))))))) - -;; `kqueue', `gfilenotify' and `w32notify' return a unique descriptor -;; for every `file-notify-add-watch', while `inotify' returns a unique -;; descriptor per inode only. + (when (and (not (equal desc pending-desc)) + callback) + (funcall callback + (list pending-desc 'renamed file file1))) + (setq file-notify--pending-rename nil) + (setq action 'renamed)) + (setq action 'created)))) + + (when action + (file-notify--call-handler watch desc action file file1)) + + ;; Send `stopped' event. + (when (and (memq action '(deleted renamed)) + ;; Not when a file is backed up. + (not (and (stringp file1) (backup-file-name-p file1))) + ;; Watched file or directory is concerned. + (string-equal + file (file-notify--watch-absolute-filename watch))) + (file-notify-rm-watch desc)))))))) + +(declare-function inotify-add-watch "inotify.c" (file flags callback)) +(declare-function kqueue-add-watch "kqueue.c" (file flags callback)) +(declare-function w32notify-add-watch "w32notify.c" (file flags callback)) +(declare-function gfile-add-watch "gfilenotify.c" (file flags callback)) + +(defun file-notify--add-watch-inotify (_file dir flags) + "Add a watch for FILE in DIR with FLAGS, using inotify." + (inotify-add-watch dir + (append + (and (memq 'change flags) + '(create delete delete-self modify move-self move)) + (and (memq 'attribute-change flags) + '(attrib))) + #'file-notify--callback-inotify)) + +(defun file-notify--add-watch-kqueue (file _dir flags) + "Add a watch for FILE in DIR with FLAGS, using kqueue." + ;; kqueue does not report changes to file contents when watching + ;; directories, so we watch each file directly. + (kqueue-add-watch file + (append + (and (memq 'change flags) + '(create delete write extend rename)) + (and (memq 'attribute-change flags) + '(attrib))) + #'file-notify--callback-kqueue)) + +(defun file-notify--add-watch-w32notify (_file dir flags) + "Add a watch for FILE in DIR with FLAGS, using w32notify." + (w32notify-add-watch dir + (append + (and (memq 'change flags) + '(file-name directory-name size last-write-time)) + (and (memq 'attribute-change flags) + '(attributes))) + #'file-notify--callback-w32notify)) + +(defun file-notify--add-watch-gfilenotify (_file dir flags) + "Add a watch for FILE in DIR with FLAGS, using gfilenotify." + (gfile-add-watch dir + (append '(watch-mounts send-moved) flags) + #'file-notify--callback-gfilenotify)) + (defun file-notify-add-watch (file flags callback) "Add a watch for filesystem events pertaining to FILE. This arranges for filesystem events pertaining to FILE to be reported @@ -307,97 +414,64 @@ FILE is the name of the file whose event is being reported." (unless (functionp callback) (signal 'wrong-type-argument `(,callback))) - (let* ((quoted (file-name-quoted-p file)) - (file (file-name-unquote file)) - (file-name-handler-alist (if quoted nil file-name-handler-alist)) - (handler (find-file-name-handler file 'file-notify-add-watch)) - (dir (directory-file-name - (if (file-directory-p file) - file - (file-name-directory file)))) - desc func l-flags) + (let ((handler (find-file-name-handler file 'file-notify-add-watch)) + (dir (directory-file-name + (if (file-directory-p file) + file + (file-name-directory file))))) (unless (file-directory-p dir) (signal 'file-notify-error `("Directory does not exist" ,dir))) - (if handler - ;; A file name handler could exist even if there is no local - ;; file notification support. - (setq desc (funcall handler 'file-notify-add-watch dir flags callback)) - - ;; Check, whether Emacs has been compiled with file notification - ;; support. - (unless file-notify--library - (signal 'file-notify-error - '("No file notification package available"))) - - ;; Determine low-level function to be called. - (setq func - (cond - ((eq file-notify--library 'inotify) 'inotify-add-watch) - ((eq file-notify--library 'kqueue) 'kqueue-add-watch) - ((eq file-notify--library 'gfilenotify) 'gfile-add-watch) - ((eq file-notify--library 'w32notify) 'w32notify-add-watch))) - - ;; Determine respective flags. - (if (eq file-notify--library 'gfilenotify) - (setq l-flags (append '(watch-mounts send-moved) flags)) - (when (memq 'change flags) - (setq - l-flags - (cond - ((eq file-notify--library 'inotify) - '(create delete delete-self modify move-self move)) - ((eq file-notify--library 'kqueue) - '(create delete write extend rename)) - ((eq file-notify--library 'w32notify) - '(file-name directory-name size last-write-time))))) - (when (memq 'attribute-change flags) - (push (cond - ((eq file-notify--library 'inotify) 'attrib) - ((eq file-notify--library 'kqueue) 'attrib) - ((eq file-notify--library 'w32notify) 'attributes)) - l-flags))) - - ;; Call low-level function. - (setq desc (funcall - ;; kqueue does not report file changes in directory - ;; monitor. So we must watch the file itself. - func (if (eq file-notify--library 'kqueue) file dir) - l-flags 'file-notify-callback))) - - ;; Modify `file-notify-descriptors'. - (let ((watch (file-notify--watch-make - dir - (unless (file-directory-p file) (file-name-nondirectory file)) - callback))) - (puthash desc watch file-notify-descriptors)) - ;; Return descriptor. - desc)) + (let ((desc + (if handler + (funcall handler 'file-notify-add-watch dir flags callback) + (funcall + (pcase file-notify--library + ('inotify #'file-notify--add-watch-inotify) + ('kqueue #'file-notify--add-watch-kqueue) + ('w32notify #'file-notify--add-watch-w32notify) + ('gfilenotify #'file-notify--add-watch-gfilenotify) + (_ (signal 'file-notify-error + '("No file notification package available")))) + file dir flags)))) + + ;; Modify `file-notify-descriptors'. + (let ((watch (file-notify--watch-make + ;; We do not want to enter quoted file names into the hash. + (file-name-unquote dir) + (unless (file-directory-p file) + (file-name-nondirectory file)) + callback))) + (puthash desc watch file-notify-descriptors)) + ;; Return descriptor. + desc))) (defun file-notify-rm-watch (descriptor) "Remove an existing watch specified by its DESCRIPTOR. DESCRIPTOR should be an object returned by `file-notify-add-watch'." (when-let* ((watch (gethash descriptor file-notify-descriptors))) - (let ((handler (find-file-name-handler - (file-notify--watch-directory watch) - 'file-notify-rm-watch))) - (condition-case nil - (if handler - ;; A file name handler could exist even if there is no - ;; local file notification support. - (funcall handler 'file-notify-rm-watch descriptor) - - (funcall - (cond - ((eq file-notify--library 'inotify) 'inotify-rm-watch) - ((eq file-notify--library 'kqueue) 'kqueue-rm-watch) - ((eq file-notify--library 'gfilenotify) 'gfile-rm-watch) - ((eq file-notify--library 'w32notify) 'w32notify-rm-watch)) - descriptor)) - (file-notify-error nil))) - ;; Modify `file-notify-descriptors'. - (file-notify--rm-descriptor descriptor))) + ;; If we are called from a `stopped' event, do nothing. + (when (file-notify--watch-callback watch) + (let ((handler (find-file-name-handler + (file-notify--watch-directory watch) + 'file-notify-rm-watch))) + (condition-case nil + (if handler + ;; A file name handler could exist even if there is no + ;; local file notification support. + (funcall handler 'file-notify-rm-watch descriptor) + + (funcall + (cond + ((eq file-notify--library 'inotify) 'inotify-rm-watch) + ((eq file-notify--library 'kqueue) 'kqueue-rm-watch) + ((eq file-notify--library 'gfilenotify) 'gfile-rm-watch) + ((eq file-notify--library 'w32notify) 'w32notify-rm-watch)) + descriptor)) + (file-notify-error nil))) + ;; Modify `file-notify-descriptors' and send a `stopped' event. + (file-notify--rm-descriptor descriptor)))) (defun file-notify-valid-p (descriptor) "Check a watch specified by its DESCRIPTOR. @@ -419,11 +493,9 @@ DESCRIPTOR should be an object returned by `file-notify-add-watch'." descriptor)) t)))) - ;; TODO: -;; * Watching a /dir/file may receive events for dir. -;; (This may be the desired behavior.) -;; * Watching a file in an already watched directory + +;; * Watching a file in an already watched directory. ;; If the file is created and *then* a watch is added to that file, the ;; watch might receive events which occurred prior to it being created, ;; due to the way events are propagated during idle time. Note: This diff --git a/lisp/files-x.el b/lisp/files-x.el index 1e4efa01f63..b71e9204f32 100644 --- a/lisp/files-x.el +++ b/lisp/files-x.el @@ -30,6 +30,8 @@ ;;; Code: +(eval-when-compile (require 'subr-x)) ; for string-trim-right + ;;; Commands to add/delete file-local/directory-local variables. @@ -484,7 +486,7 @@ from the MODE alist ignoring the input argument VALUE." (if (memq variable '(mode eval)) (cdr mode-assoc) (assq-delete-all variable (cdr mode-assoc)))))) - (assq-delete-all mode variables))) + (assoc-delete-all mode variables))) (setq variables (cons `(,mode . ((,variable . ,value))) variables)))) @@ -492,15 +494,34 @@ from the MODE alist ignoring the input argument VALUE." ;; Insert modified alist of directory-local variables. (insert ";;; Directory Local Variables\n") (insert ";;; For more information see (info \"(emacs) Directory Variables\")\n\n") - (pp (sort variables - (lambda (a b) - (cond - ((null (car a)) t) - ((null (car b)) nil) - ((and (symbolp (car a)) (stringp (car b))) t) - ((and (symbolp (car b)) (stringp (car a))) nil) - (t (string< (car a) (car b)))))) - (current-buffer))))) + (princ (dir-locals-to-string + (sort variables + (lambda (a b) + (cond + ((null (car a)) t) + ((null (car b)) nil) + ((and (symbolp (car a)) (stringp (car b))) t) + ((and (symbolp (car b)) (stringp (car a))) nil) + (t (string< (car a) (car b))))))) + (current-buffer)) + (goto-char (point-min)) + (indent-sexp)))) + +(defun dir-locals-to-string (variables) + "Output alists of VARIABLES to string in dotted pair notation syntax." + (format "(%s)" (mapconcat + (lambda (mode-variables) + (format "(%S . %s)" + (car mode-variables) + (format "(%s)" (mapconcat + (lambda (variable-value) + (format "(%S . %s)" + (car variable-value) + (string-trim-right + (pp-to-string + (cdr variable-value))))) + (cdr mode-variables) "\n")))) + variables "\n"))) ;;;###autoload (defun add-dir-local-variable (mode variable value) @@ -561,7 +582,7 @@ changed by the user.") (setq ignored-local-variables (cons 'connection-local-variables-alist ignored-local-variables)) -(defvar connection-local-profile-alist '() +(defvar 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). @@ -569,7 +590,7 @@ 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 '() +(defvar 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 @@ -664,7 +685,12 @@ This does nothing if `enable-connection-local-variables' is nil." ;; Loop over variables. (dolist (variable (connection-local-get-profile-variables profile)) (unless (assq (car variable) connection-local-variables-alist) - (push variable connection-local-variables-alist)))))) + (push variable connection-local-variables-alist)))) + ;; Push them to `file-local-variables-alist'. Connection-local + ;; variables do not appear from external files. So we can regard + ;; them as safe. + (let ((enable-local-variables :all)) + (hack-local-variables-filter connection-local-variables-alist nil)))) ;;;###autoload (defun hack-connection-local-variables-apply (criteria) @@ -676,24 +702,35 @@ will not be changed." (copy-tree connection-local-variables-alist))) (hack-local-variables-apply))) +(defsubst connection-local-criteria-for-default-directory () + "Return a connection-local criteria, which represents `default-directory'." + (when (file-remote-p default-directory) + `(:application tramp + :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-profiles (profiles &rest body) - "Apply connection-local variables according to PROFILES in current buffer. +(defmacro with-connection-local-variables (&rest body) + "Apply connection-local variables according to `default-directory'. Execute BODY, and unwind connection-local variables." - (declare (indent 1) (debug t)) - `(let ((enable-connection-local-variables t) - (old-buffer-local-variables (buffer-local-variables)) - connection-local-variables-alist connection-local-criteria-alist) - (apply 'connection-local-set-profiles nil ,profiles) - (hack-connection-local-variables-apply nil) - (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)))))))) + (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)) diff --git a/lisp/files.el b/lisp/files.el index 2187eba1a42..184421f54f2 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -423,14 +423,10 @@ idle for `auto-save-visited-interval' seconds." (define-minor-mode auto-save-visited-mode "Toggle automatic saving to file-visiting buffers on or off. -With a prefix argument ARG, enable regular saving of all buffers -visiting a file if ARG is positive, and disable it otherwise. + Unlike `auto-save-mode', this mode will auto-save buffer contents to the visited files directly and will also run all save-related -hooks. See Info node `Saving' for details of the save process. - -If called from Lisp, enable the mode if ARG is omitted or nil, -and toggle it if ARG is `toggle'." +hooks. See Info node `Saving' for details of the save process." :group 'auto-save :global t (when auto-save--timer (cancel-timer auto-save--timer)) @@ -478,7 +474,7 @@ location of point in the current buffer." :group 'find-file) ;;;It is not useful to make this a local variable. -;;;(put 'find-file-not-found-hooks 'permanent-local t) +;;;(put 'find-file-not-found-functions 'permanent-local t) (define-obsolete-variable-alias 'find-file-not-found-hooks 'find-file-not-found-functions "22.1") (defvar find-file-not-found-functions nil @@ -488,7 +484,8 @@ Variable `buffer-file-name' is already set up. The functions are called in the order given until one of them returns non-nil.") ;;;It is not useful to make this a local variable. -;;;(put 'find-file-hooks 'permanent-local t) +;;;(put 'find-file-hook 'permanent-local t) +;; I found some external files still using the obsolete form in 2018. (define-obsolete-variable-alias 'find-file-hooks 'find-file-hook "22.1") (defcustom find-file-hook nil "List of functions to be called after a buffer is loaded from a file. @@ -500,6 +497,7 @@ for the file's directory." :options '(auto-insert) :version "22.1") +;; I found some external files still using the obsolete form in 2018. (define-obsolete-variable-alias 'write-file-hooks 'write-file-functions "22.1") (defvar write-file-functions nil "List of functions to be called before saving a buffer to a file. @@ -519,11 +517,13 @@ node `(elisp)Saving Buffers'.) To perform various checks or updates before the buffer is saved, use `before-save-hook'.") (put 'write-file-functions 'permanent-local t) +;; I found some files still using the obsolete form in 2018. (defvar local-write-file-hooks nil) (make-variable-buffer-local 'local-write-file-hooks) (put 'local-write-file-hooks 'permanent-local t) (make-obsolete-variable 'local-write-file-hooks 'write-file-functions "22.1") +;; I found some files still using the obsolete form in 2018. (define-obsolete-variable-alias 'write-contents-hooks 'write-contents-functions "22.1") (defvar write-contents-functions nil @@ -758,9 +758,10 @@ nil (meaning `default-directory') as the associated list element." ;; do end up using a superficially different directory. (setq dir (expand-file-name dir)) (if (not (file-directory-p dir)) - (if (file-exists-p dir) - (error "%s is not a directory" dir) - (error "%s: no such directory" dir)) + (error (if (file-exists-p dir) + "%s is not a directory" + "%s: no such directory") + dir) (unless (file-accessible-directory-p dir) (error "Cannot cd to %s: Permission denied" dir)) (setq default-directory dir) @@ -811,34 +812,61 @@ The path separator is colon in GNU and GNU-like systems." (lambda (f) (and (file-directory-p f) 'dir-ok))) (error "No such directory found via CDPATH environment variable")))) -(defun directory-files-recursively (dir regexp &optional include-directories) +(defun directory-files-recursively (dir regexp + &optional include-directories predicate + follow-symlinks) "Return list of all files under DIR that have file names matching REGEXP. -This function works recursively. Files are returned in \"depth first\" -order, and files from each directory are sorted in alphabetical order. -Each file name appears in the returned list in its absolute form. -Optional argument INCLUDE-DIRECTORIES non-nil means also include in the -output directories whose names match REGEXP." - (let ((result nil) - (files nil) - ;; When DIR is "/", remote file names like "/method:" could - ;; also be offered. We shall suppress them. - (tramp-mode (and tramp-mode (file-remote-p (expand-file-name dir))))) +This function works recursively. Files are returned in \"depth +first\" order, and files from each directory are sorted in +alphabetical order. Each file name appears in the returned list +in its absolute form. + +Optional argument INCLUDE-DIRECTORIES non-nil means also include +in the output directories whose names match REGEXP. + +PREDICATE can be either nil (which means that all subdirectories +are descended into), t (which means that subdirectories that +can't be read are ignored), or a function (which is called with +name name of the subdirectory and should return non-nil if the +subdirectory is to be descended into). + +If FOLLOW-SYMLINKS, symbolic links that point to directories are +followed. Note that this can lead to infinite recursion." + (let* ((result nil) + (files nil) + (dir (directory-file-name dir)) + ;; When DIR is "/", remote file names like "/method:" could + ;; also be offered. We shall suppress them. + (tramp-mode (and tramp-mode (file-remote-p (expand-file-name dir))))) (dolist (file (sort (file-name-all-completions "" dir) 'string<)) (unless (member file '("./" "../")) (if (directory-name-p file) (let* ((leaf (substring file 0 (1- (length file)))) - (full-file (expand-file-name leaf dir))) + (full-file (concat dir "/" leaf))) ;; Don't follow symlinks to other directories. - (unless (file-symlink-p full-file) - (setq result - (nconc result (directory-files-recursively - full-file regexp include-directories)))) + (when (and (or (not (file-symlink-p full-file)) + (and (file-symlink-p full-file) + follow-symlinks)) + ;; Allow filtering subdirectories. + (or (eq predicate nil) + (eq predicate t) + (funcall predicate full-file))) + (let ((sub-files + (if (eq predicate t) + (ignore-error file-error + (directory-files-recursively + full-file regexp include-directories + predicate follow-symlinks)) + (directory-files-recursively + full-file regexp include-directories + predicate follow-symlinks)))) + (setq result (nconc result sub-files)))) (when (and include-directories (string-match regexp leaf)) (setq result (nconc result (list full-file))))) (when (string-match regexp file) - (push (expand-file-name file dir) files))))) + (push (concat dir "/" file) files))))) (nconc result (nreverse files)))) (defvar module-file-suffix) @@ -868,7 +896,7 @@ This function will normally skip directories, so if you want it to find directories, make sure the PREDICATE function returns `dir-ok' for them. PREDICATE can also be an integer to pass to the `access' system call, -in which case file-name handlers are ignored. This usage is deprecated. +in which case file name handlers are ignored. This usage is deprecated. For compatibility, PREDICATE can also be one of the symbols `executable', `readable', `writable', or `exists', or a list of one or more of those symbols." @@ -975,7 +1003,8 @@ the function needs to examine, starting with FILE." (null file) (string-match locate-dominating-stop-dir-regexp file))) (setq try (if (stringp name) - (file-exists-p (expand-file-name name file)) + (and (file-directory-p file) + (file-exists-p (expand-file-name name file))) (funcall name file))) (cond (try (setq root file)) ((equal file (setq file (file-name-directory @@ -1007,7 +1036,7 @@ directory if it does not exist." ;; Make sure `user-emacs-directory' exists, ;; unless we're in batch mode or dumping Emacs. (or noninteractive - purify-flag + dump-mode (let (errtype) (if (file-directory-p user-emacs-directory) (or (file-accessible-directory-p user-emacs-directory) @@ -1030,13 +1059,34 @@ customize the variable `user-emacs-directory-warning'." errtype user-emacs-directory))))) bestname)))) +(defun exec-path () + "Return list of directories to search programs to run in remote subprocesses. +The remote host is identified by `default-directory'. For remote +hosts which do not support subprocesses, this returns `nil'. +If `default-directory' is a local directory, this function returns +the value of the variable `exec-path'." + (let ((handler (find-file-name-handler default-directory 'exec-path))) + (if handler + (funcall handler 'exec-path) + exec-path))) -(defun executable-find (command) +(defun executable-find (command &optional remote) "Search for COMMAND in `exec-path' and return the absolute file name. -Return nil if COMMAND is not found anywhere in `exec-path'." - ;; Use 1 rather than file-executable-p to better match the behavior of - ;; call-process. - (locate-file command exec-path exec-suffixes 1)) +Return nil if COMMAND is not found anywhere in `exec-path'. If +REMOTE is non-nil, search on the remote host indicated by +`default-directory' instead." + (if (and remote (file-remote-p default-directory)) + (let ((res (locate-file + command + (mapcar + (lambda (x) (concat (file-remote-p default-directory) x)) + (exec-path)) + exec-suffixes 'file-executable-p))) + (when (stringp res) (file-local-name res))) + ;; Use 1 rather than file-executable-p to better match the + ;; behavior of call-process. + (let ((default-directory (file-name-quote default-directory 'top))) + (locate-file command exec-path exec-suffixes 1)))) (defun load-library (library) "Load the Emacs Lisp library named LIBRARY. @@ -1138,10 +1188,11 @@ consecutive checks. For example: (defun display-time-file-nonempty-p (file) (let ((remote-file-name-inhibit-cache (- display-time-interval 5))) (and (file-exists-p file) - (< 0 (nth 7 (file-attributes (file-chase-links file)))))))" + (< 0 (file-attribute-size + (file-attributes (file-chase-links file)))))))" :group 'files :version "24.1" - :type `(choice + :type '(choice (const :tag "Do not inhibit file name cache" nil) (const :tag "Do not use file name cache" t) (integer :tag "Do not use file name cache" @@ -1179,10 +1230,11 @@ names beginning with `~'." "Splice DIRNAME to FILE like the operating system would. If FILE is relative, return DIRNAME concatenated to FILE. Otherwise return FILE, quoted as needed if DIRNAME and FILE have -different handlers; although this quoting is dubious if DIRNAME -is magic, it is not clear what would be better. This function -differs from `expand-file-name' in that DIRNAME must be a -directory name and leading `~' and `/:' are not special in FILE." +different file name handlers; although this quoting is dubious if +DIRNAME is magic, it is not clear what would be better. This +function differs from `expand-file-name' in that DIRNAME must be +a directory name and leading `~' and `/:' are not special in +FILE." (let ((unquoted (if (files--name-absolute-system-p file) file (concat dirname file)))) @@ -1333,7 +1385,7 @@ it means chase no more than that many links and then stop." ;; A handy function to display file sizes in human-readable form. ;; See http://en.wikipedia.org/wiki/Kibibyte for the reference. -(defun file-size-human-readable (file-size &optional flavor) +(defun file-size-human-readable (file-size &optional flavor space unit) "Produce a string showing FILE-SIZE in human-readable form. Optional second argument FLAVOR controls the units and the display format: @@ -1343,24 +1395,36 @@ Optional second argument FLAVOR controls the units and the display format: If FLAVOR is `si', each kilobyte is 1000 bytes and the produced suffixes are \"k\", \"M\", \"G\", \"T\", etc. If FLAVOR is `iec', each kilobyte is 1024 bytes and the produced suffixes - are \"KiB\", \"MiB\", \"GiB\", \"TiB\", etc." + are \"KiB\", \"MiB\", \"GiB\", \"TiB\", etc. + +Optional third argument SPACE is a string put between the number and unit. +It defaults to the empty string. We recommend a single space or +non-breaking space, unless other constraints prohibit a space in that +position. + +Optional fourth argument UNIT is the unit to use. It defaults to \"B\" +when FLAVOR is `iec' and the empty string otherwise. We recommend \"B\" +in all cases, since that is the standard symbol for byte." (let ((power (if (or (null flavor) (eq flavor 'iec)) 1024.0 1000.0)) - (post-fixes - ;; none, kilo, mega, giga, tera, peta, exa, zetta, yotta - (list "" "k" "M" "G" "T" "P" "E" "Z" "Y"))) - (while (and (>= file-size power) (cdr post-fixes)) + (prefixes '("" "k" "M" "G" "T" "P" "E" "Z" "Y"))) + (while (and (>= file-size power) (cdr prefixes)) (setq file-size (/ file-size power) - post-fixes (cdr post-fixes))) - (format (if (> (mod file-size 1.0) 0.05) - "%.1f%s%s" - "%.0f%s%s") - file-size - (if (and (eq flavor 'iec) (string= (car post-fixes) "k")) - "K" - (car post-fixes)) - (if (eq flavor 'iec) "iB" "")))) + prefixes (cdr prefixes))) + (let* ((prefix (car prefixes)) + (prefixed-unit (if (eq flavor 'iec) + (concat + (if (string= prefix "k") "K" prefix) + (if (string= prefix "") "" "i") + (or unit "B")) + (concat prefix unit)))) + (format (if (> (mod file-size 1.0) 0.05) + "%.1f%s%s" + "%.0f%s%s") + file-size + (if (string= prefixed-unit "") "" (or space "")) + prefixed-unit)))) (defcustom mounted-file-systems (if (memq system-type '(windows-nt cygwin)) @@ -1816,7 +1880,11 @@ killed." (setq buffer-file-truename nil) ;; Likewise for dired buffers. (setq dired-directory nil) - (find-file filename wildcards)) + ;; Don't use `find-file' because it may end up using another window + ;; in some corner cases, e.g. when the selected window is + ;; softly-dedicated. + (let ((newbuf (find-file-noselect filename nil nil wildcards))) + (switch-to-buffer (if (consp newbuf) (car newbuf) newbuf)))) (when (eq obuf (current-buffer)) ;; This executes if find-file gets an error ;; and does not really find anything. @@ -1878,7 +1946,7 @@ afterwards (so long as the home directory does not change; 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 + (save-match-data ;FIXME: Why? (if (and automount-dir-prefix (string-match automount-dir-prefix filename) (file-exists-p (file-name-directory @@ -1901,12 +1969,13 @@ started Emacs, set `abbreviated-home-dir' to nil so it will be recalculated)." (unless abbreviated-home-dir (put 'abbreviated-home-dir 'home (expand-file-name "~")) (setq abbreviated-home-dir - (let ((abbreviated-home-dir "$foo")) - (setq abbreviated-home-dir + (let* ((abbreviated-home-dir "\\`\\'.") ;Impossible regexp. + (regexp (concat "\\`" - (abbreviate-file-name - (get 'abbreviated-home-dir 'home)) - "\\(/\\|\\'\\)")) + (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 @@ -1914,9 +1983,9 @@ started Emacs, set `abbreviated-home-dir' to nil so it will be recalculated)." ;; 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 abbreviated-home-dir) - abbreviated-home-dir - (decode-coding-string abbreviated-home-dir + (if (multibyte-string-p regexp) + regexp + (decode-coding-string regexp (if (eq system-type 'windows-nt) 'utf-8 locale-coding-system)))))) @@ -1929,22 +1998,22 @@ started Emacs, set `abbreviated-home-dir' to nil so it will be recalculated)." ;; is likely temporary (eg for testing). ;; FIXME Is it even worth caching abbreviated-home-dir? ;; Ref: https://debbugs.gnu.org/19657#20 - (if (and (string-match abbreviated-home-dir filename) - ;; 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)) - (save-match-data - (string-match "^[a-zA-`]:/$" filename)))) - (equal (get 'abbreviated-home-dir 'home) - (save-match-data (expand-file-name "~")))) - (setq filename - (concat "~" - (match-string 1 filename) - (substring filename (match-end 0))))) - filename))) + (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). @@ -2019,15 +2088,47 @@ think it does, because \"free\" is pretty hard to define in practice." :version "25.1" :type '(choice integer (const :tag "Never issue warning" nil))) -(defun abort-if-file-too-large (size op-type filename) +(declare-function x-popup-dialog "menu.c" (position contents &optional header)) + +(defun files--ask-user-about-large-file (size op-type filename offer-raw) + (let ((prompt (format "File %s is large (%s), really %s?" + (file-name-nondirectory filename) + (file-size-human-readable size 'iec " ") op-type))) + (if (not offer-raw) + (if (y-or-n-p prompt) nil 'abort) + (let* ((use-dialog (and (display-popup-menus-p) + last-input-event + (listp last-nonmenu-event) + use-dialog-box)) + (choice + (if use-dialog + (x-popup-dialog t `(,prompt + ("Yes" . ?y) + ("No" . ?n) + ("Open literally" . ?l))) + (read-char-choice + (concat prompt " (y)es or (n)o or (l)iterally ") + '(?y ?Y ?n ?N ?l ?L))))) + (cond ((memq choice '(?y ?Y)) nil) + ((memq choice '(?l ?L)) 'raw) + (t 'abort)))))) + +(defun abort-if-file-too-large (size op-type filename &optional offer-raw) "If file SIZE larger than `large-file-warning-threshold', allow user to abort. -OP-TYPE specifies the file operation being performed (for message to user)." - (when (and large-file-warning-threshold size - (> size large-file-warning-threshold) - (not (y-or-n-p (format "File %s is large (%s), really %s? " - (file-name-nondirectory filename) - (file-size-human-readable size) op-type)))) - (user-error "Aborted"))) +OP-TYPE specifies the file operation being performed (for message +to user). If OFFER-RAW is true, give user the additional option +to open the file literally. If the user chooses this option, +`abort-if-file-too-large' returns the symbol `raw'. Otherwise, it +returns nil or exits non-locally." + (let ((choice (and large-file-warning-threshold size + (> size large-file-warning-threshold) + ;; No point in warning if we can't read it. + (file-readable-p filename) + (files--ask-user-about-large-file + size op-type filename offer-raw)))) + (when (eq choice 'abort) + (user-error "Aborted")) + choice)) (defun warn-maybe-out-of-memory (size) "Warn if an attempt to open file of SIZE bytes may run out of memory." @@ -2044,9 +2145,10 @@ OP-TYPE specifies the file operation being performed (for message to user)." exceeds the %S%% of currently available free memory (%s). If that fails, try to open it with `find-file-literally' \(but note that some characters might be displayed incorrectly)." - (file-size-human-readable size) + (file-size-human-readable size 'iec " ") out-of-memory-warning-percentage - (file-size-human-readable (* total-free-memory 1024))))))))) + (file-size-human-readable (* total-free-memory 1024) + 'iec " ")))))))) (defun files--message (format &rest args) "Like `message', except sometimes don't print to minibuffer. @@ -2107,8 +2209,11 @@ the various files." (setq buf other)))) ;; Check to see if the file looks uncommonly large. (when (not (or buf nowarn)) - (abort-if-file-too-large (nth 7 attributes) "open" filename) - (warn-maybe-out-of-memory (nth 7 attributes))) + (when (eq (abort-if-file-too-large + (file-attribute-size attributes) "open" filename t) + 'raw) + (setf rawfile t)) + (warn-maybe-out-of-memory (file-attribute-size attributes))) (if buf ;; We are using an existing buffer. (let (nonexistent) @@ -2243,8 +2348,7 @@ Do you want to revisit the file normally now? ") (kill-local-variable 'cursor-type) (let ((inhibit-read-only t)) (erase-buffer)) - (and (default-value 'enable-multibyte-characters) - (not rawfile) + (and (not rawfile) (set-buffer-multibyte t)) (if rawfile (condition-case () @@ -2272,9 +2376,9 @@ Do you want to revisit the file normally now? ") ;; If they fail too, set error. (setq error t))))) ;; Record the file's truename, and maybe use that as visited name. - (if (equal filename buffer-file-name) - (setq buffer-file-truename truename) - (setq buffer-file-truename + (setq buffer-file-truename + (if (equal filename buffer-file-name) + truename (abbreviate-file-name (file-truename buffer-file-name)))) (setq buffer-file-number number) (if find-file-visit-truename @@ -2313,7 +2417,8 @@ This function ensures that none of these modifications will take place." ;; FIXME: Yuck!! We should turn insert-file-contents-literally ;; into a file operation instead! (append '(jka-compr-handler image-file-handler epa-file-handler) - inhibit-file-name-handlers)) + (and (eq inhibit-file-name-operation 'insert-file-contents) + inhibit-file-name-handlers))) (inhibit-file-name-operation 'insert-file-contents)) (insert-file-contents filename visit beg end replace))) @@ -2322,7 +2427,8 @@ This function ensures that none of these modifications will take place." (signal 'file-error (list "Opening input file" "Is a directory" filename))) ;; Check whether the file is uncommonly large - (abort-if-file-too-large (nth 7 (file-attributes filename)) "insert" filename) + (abort-if-file-too-large (file-attribute-size (file-attributes filename)) + "insert" filename) (let* ((buffer (find-buffer-visiting (abbreviate-file-name (file-truename filename)) #'buffer-modified-p)) (tem (funcall insert-func filename))) @@ -2640,9 +2746,10 @@ ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|CBR\\|7Z\\)\\'" . archive-mo ("\\.dbk\\'" . xml-mode) ("\\.dtd\\'" . sgml-mode) ("\\.ds\\(ss\\)?l\\'" . dsssl-mode) - ("\\.jsm?\\'" . javascript-mode) + ("\\.js[mx]?\\'" . javascript-mode) + ;; https://en.wikipedia.org/wiki/.har + ("\\.har\\'" . javascript-mode) ("\\.json\\'" . javascript-mode) - ("\\.jsx\\'" . js-jsx-mode) ("\\.[ds]?vh?\\'" . verilog-mode) ("\\.by\\'" . bovine-grammar-mode) ("\\.wy\\'" . wisent-grammar-mode) @@ -2864,9 +2971,9 @@ associated with that interpreter in `interpreter-mode-alist'.") "Alist of buffer beginnings vs. corresponding major mode functions. Each element looks like (REGEXP . FUNCTION) or (MATCH-FUNCTION . FUNCTION). After visiting a file, if REGEXP matches the text at the beginning of the -buffer, or calling MATCH-FUNCTION returns non-nil, `normal-mode' will -call FUNCTION rather than allowing `auto-mode-alist' to decide the buffer's -major mode. +buffer (case-sensitively), or calling MATCH-FUNCTION returns non-nil, +`normal-mode' will call FUNCTION rather than allowing `auto-mode-alist' to +decide the buffer's major mode. If FUNCTION is nil, then it is not called. (That is a way of saying \"allow `auto-mode-alist' to decide for these files.\")") @@ -2898,9 +3005,9 @@ If FUNCTION is nil, then it is not called. (That is a way of saying "Like `magic-mode-alist' but has lower priority than `auto-mode-alist'. Each element looks like (REGEXP . FUNCTION) or (MATCH-FUNCTION . FUNCTION). After visiting a file, if REGEXP matches the text at the beginning of the -buffer, or calling MATCH-FUNCTION returns non-nil, `normal-mode' will -call FUNCTION, provided that `magic-mode-alist' and `auto-mode-alist' -have not specified a mode for this file. +buffer (case-sensitively), or calling MATCH-FUNCTION returns non-nil, +`normal-mode' will call FUNCTION, provided that `magic-mode-alist' and +`auto-mode-alist' have not specified a mode for this file. If FUNCTION is nil, then it is not called.") (put 'magic-fallback-mode-alist 'risky-local-variable t) @@ -3017,7 +3124,8 @@ we don't actually set it to the same mode the buffer already has." ((functionp re) (funcall re)) ((stringp re) - (looking-at re)) + (let ((case-fold-search nil)) + (looking-at re))) (t (error "Problem in magic-mode-alist with element %s" @@ -3078,7 +3186,8 @@ we don't actually set it to the same mode the buffer already has." ((functionp re) (funcall re)) ((stringp re) - (looking-at re)) + (let ((case-fold-search nil)) + (looking-at re))) (t (error "Problem with magic-fallback-mode-alist element: %s" @@ -3332,7 +3441,7 @@ n -- to ignore the local variables list.") ;; Display the buffer and read a choice. (save-window-excursion - (pop-to-buffer buf) + (pop-to-buffer buf '(display-buffer--maybe-at-bottom)) (let* ((exit-chars '(?y ?n ?\s ?\C-g ?\C-v)) (prompt (format "Please type %s%s: " (if offer-save "y, n, or !" "y or n") @@ -3403,6 +3512,8 @@ return as the symbol specifying the mode." (let* ((key (intern (match-string 1))) (val (save-restriction (narrow-to-region (point) end) + ;; As a defensive measure, we do not allow + ;; circular data in the file-local data. (let ((read-circle nil)) (read (current-buffer))))) ;; It is traditional to ignore @@ -3524,6 +3635,13 @@ local variables, but directory-local variables may still be applied." result) (unless (eq handle-mode t) (setq file-local-variables-alist nil) + (when (and (file-remote-p default-directory) + (fboundp 'hack-connection-local-variables) + (fboundp 'connection-local-criteria-for-default-directory)) + (with-demoted-errors "Connection-local variables error: %s" + ;; Note this is a no-op if enable-local-variables is nil. + (hack-connection-local-variables + (connection-local-criteria-for-default-directory)))) (with-demoted-errors "Directory-local variables error: %s" ;; Note this is a no-op if enable-local-variables is nil. (hack-dir-local-variables))) @@ -3612,6 +3730,8 @@ local variables, but directory-local variables may still be applied." ;; Read the variable value. (skip-chars-forward "^:") (forward-char 1) + ;; As a defensive measure, we do not allow + ;; circular data in the file-local data. (let ((read-circle nil)) (setq val (read (current-buffer)))) (if (eq handle-mode t) @@ -3642,7 +3762,8 @@ local variables, but directory-local variables may still be applied." (push (cons (if (eq var 'eval) 'eval (indirect-variable var)) - val) result)))))) + val) + result)))))) (forward-line 1)))))))) ;; Now we've read all the local variables. ;; If HANDLE-MODE is t, return whether the mode was specified. @@ -3778,13 +3899,13 @@ It is dangerous if either of these conditions are met: If VAR is `mode', call `VAL-mode' as a function unless it's already the major mode." (pcase var - (`mode + ('mode (let ((mode (intern (concat (downcase (symbol-name val)) "-mode")))) (unless (eq (indirect-function mode) (indirect-function major-mode)) (funcall mode)))) - (`eval + ('eval (pcase val (`(add-hook ',hook . ,_) (hack-one-local-variable--obsolete hook))) (save-excursion (eval val))) @@ -3808,8 +3929,8 @@ Each element in this list has the form (DIR CLASS MTIME). DIR is the name of the directory. CLASS is the name of a variable class (a symbol). MTIME is the recorded modification time of the directory-local -variables file associated with this entry. This time is a list -of integers (the same format as `file-attributes'), and is +variables file associated with this entry. This time is a Lisp +timestamp (the same format as `current-time'), and is used to test whether the cache entry is still valid. Alternatively, MTIME can be nil, which means the entry is always considered valid.") @@ -3957,6 +4078,8 @@ those in the first." (dolist (f (list file-2 file-1)) (when (and f (file-readable-p f) + ;; FIXME: Aren't file-regular-p and + ;; file-directory-p mutually exclusive? (file-regular-p f) (not (file-directory-p f))) (push f out))) @@ -4013,7 +4136,9 @@ This function returns either: (equal (nth 2 dir-elt) (let ((latest 0)) (dolist (f cached-files latest) - (let ((f-time (nth 5 (file-attributes f)))) + (let ((f-time + (file-attribute-modification-time + (file-attributes f)))) (if (time-less-p latest f-time) (setq latest f-time))))))))) ;; This cache entry is OK. @@ -4027,6 +4152,9 @@ This function returns either: ;; No cache entry. locals-dir))) +(declare-function map-merge-with "map" (type function &rest maps)) +(declare-function map-merge "map" (type &rest maps)) + (defun dir-locals--get-sort-score (node) "Return a number used for sorting the definitions of dir locals. NODE is assumed to be a cons cell where the car is either a @@ -4044,7 +4172,7 @@ That way the value can be used to sort the list such that deeper modes will be after the other modes. This will be followed by directory entries in order of length. If the entries are all applied in order then that means the more specific modes will -override the values specified by the earlier modes and directory + override the values specified by the earlier modes and directory variables will override modes." (let ((key (car node))) (cond ((null key) -1) @@ -4079,27 +4207,36 @@ DIR is the absolute name of a directory which must contain at least one dir-local file (which is a file holding variables to apply). Return the new class name, which is a symbol named DIR." - (require 'map) (let* ((class-name (intern dir)) (files (dir-locals--all-files dir)) - (read-circle nil) ;; If there was a problem, use the values we could get but ;; don't let the cache prevent future reads. (latest 0) (success 0) (variables)) (with-demoted-errors "Error reading dir-locals: %S" (dolist (file files) - (let ((file-time (nth 5 (file-attributes file)))) + (let ((file-time (file-attribute-modification-time + (file-attributes file)))) (if (time-less-p latest file-time) (setq latest file-time))) (with-temp-buffer (insert-file-contents file) - (condition-case-unless-debug nil - (setq variables + (let ((newvars + (condition-case-unless-debug nil + ;; As a defensive measure, we do not allow + ;; circular data in the file/dir-local data. + (let ((read-circle nil)) + (read (current-buffer))) + (end-of-file nil)))) + (setq variables + ;; Try and avoid loading `map' since that also loads cl-lib + ;; which then might hamper bytecomp warnings (bug#30635). + (if (not (and newvars variables)) + (or newvars variables) + (require 'map) (map-merge-with 'list (lambda (a b) (map-merge 'list a b)) variables - (read (current-buffer)))) - (end-of-file nil)))) + newvars)))))) (setq success latest)) (setq variables (dir-locals--sort-variables variables)) (dir-locals-set-class-variables class-name variables) @@ -4177,6 +4314,9 @@ However, the mode will not be changed if :type 'boolean :group 'editing-basics) +(defvar after-set-visited-file-name-hook nil + "Normal hook run just after setting visited file name of current buffer.") + (defun set-visited-file-name (filename &optional no-query along-with-file) "Change name of file visited in current buffer to FILENAME. This also renames the buffer to correspond to the new file. @@ -4297,7 +4437,8 @@ the old visited file has been renamed to the new name FILENAME." (set-auto-mode t) (or (eq old major-mode) (hack-local-variables)))) - (error nil)))) + (error nil)) + (run-hooks 'after-set-visited-file-name-hook))) (defun write-file (filename &optional confirm) "Write current buffer into file FILENAME. @@ -4438,7 +4579,7 @@ BACKUPNAME is the backup file name, which is the old file renamed." (let ((attr (file-attributes real-file-name 'integer))) - (<= (nth 2 attr) + (<= (file-attribute-user-id attr) copy-when-priv-mismatch)))) (not (file-ownership-preserved-p real-file-name t))))) @@ -4530,32 +4671,36 @@ the group would be preserved too." ;; Return t if the file doesn't exist, since it's true that no ;; information would be lost by an (attempted) delete and create. (or (null attributes) - (and (or (= (nth 2 attributes) (user-uid)) + (and (or (= (file-attribute-user-id attributes) (user-uid)) ;; Files created on Windows by Administrator (RID=500) ;; have the Administrators group (RID=544) recorded as ;; their owner. Rewriting them will still preserve the ;; owner. (and (eq system-type 'windows-nt) - (= (user-uid) 500) (= (nth 2 attributes) 544))) + (= (user-uid) 500) + (= (file-attribute-user-id attributes) 544))) (or (not group) ;; On BSD-derived systems files always inherit the parent ;; directory's group, so skip the group-gid test. (memq system-type '(berkeley-unix darwin gnu/kfreebsd)) - (= (nth 3 attributes) (group-gid))) + (= (file-attribute-group-id attributes) (group-gid))) (let* ((parent (or (file-name-directory file) ".")) (parent-attributes (file-attributes parent 'integer))) (and parent-attributes ;; On some systems, a file created in a setuid directory ;; inherits that directory's owner. (or - (= (nth 2 parent-attributes) (user-uid)) - (string-match "^...[^sS]" (nth 8 parent-attributes))) + (= (file-attribute-user-id parent-attributes) + (user-uid)) + (string-match + "^...[^sS]" + (file-attribute-modes parent-attributes))) ;; On many systems, a file created in a setgid directory ;; inherits that directory's group. On some systems ;; this happens even if the setgid bit is not set. (or (not group) - (= (nth 3 parent-attributes) - (nth 3 attributes))))))))))) + (= (file-attribute-group-id parent-attributes) + (file-attribute-group-id attributes))))))))))) (defun file-name-sans-extension (filename) "Return FILENAME sans final \"extension\". @@ -4594,8 +4739,8 @@ extension, the value is \"\"." ""))))) (defun file-name-base (&optional filename) - "Return the base name of the FILENAME: no directory, no extension. -FILENAME defaults to `buffer-file-name'." + "Return the base name of the FILENAME: no directory, no extension." + (declare (advertised-calling-convention (filename) "27.1")) (file-name-sans-extension (file-name-nondirectory (or filename (buffer-file-name))))) @@ -4821,8 +4966,8 @@ Uses `backup-directory-alist' in the same way as (list (make-backup-file-name fn)) (cons (format "%s.~%d~" basic-name (1+ high-water-mark)) (if (and (> number-to-delete 0) - ;; Delete nothing if there is overflow - ;; in the number of versions to keep. + ;; Delete nothing if kept-new-versions and + ;; kept-old-versions combine to an outlandish value. (>= (+ kept-new-versions kept-old-versions -1) 0)) (mapcar (lambda (n) (format "%s.~%d~" basic-name n)) @@ -5209,7 +5354,7 @@ Before and after saving the buffer, this function runs (set-file-extended-attributes buffer-file-name (nth 1 setmodes))) (set-file-modes buffer-file-name - (logior (car setmodes) 128)))))) + (logior (car setmodes) 128))))) (let (success) (unwind-protect (progn @@ -5225,7 +5370,7 @@ Before and after saving the buffer, this function runs (and setmodes (not success) (progn (rename-file (nth 2 setmodes) buffer-file-name t) - (setq buffer-backed-up nil)))))) + (setq buffer-backed-up nil))))))) setmodes)) (declare-function diff-no-select "diff" @@ -5275,9 +5420,14 @@ about certain files that you'd usually rather not save." (defun save-some-buffers (&optional arg pred) "Save some modified file-visiting buffers. Asks user about each one. -You can answer `y' to save, `n' not to save, `C-r' to look at the -buffer in question with `view-buffer' before deciding or `d' to -view the differences using `diff-buffer-with-file'. +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 +help message describing these options. This command first saves any buffers where `buffer-save-without-query' is non-nil, without asking. @@ -5507,6 +5657,21 @@ raised." (dolist (dir create-list) (files--ensure-directory dir))))))) +(defun make-empty-file (filename &optional parents) + "Create an empty file FILENAME. +Optional arg PARENTS, if non-nil then creates parent dirs as needed. + +If called interactively, then PARENTS is non-nil." + (interactive + (let ((filename (read-file-name "Create empty file: "))) + (list filename t))) + (when (and (file-exists-p filename) (null parents)) + (signal 'file-already-exists `("File exists" ,filename))) + (let ((paren-dir (file-name-directory filename))) + (when (and paren-dir (not (file-exists-p paren-dir))) + (make-directory paren-dir parents))) + (write-region "" nil filename nil 0)) + (defconst directory-files-no-dot-files-regexp "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*" "Regexp matching any file name except \".\" and \"..\".") @@ -5695,7 +5860,8 @@ into NEWNAME instead." ;; Set directory attributes. (let ((modes (file-modes directory)) - (times (and keep-time (nth 5 (file-attributes directory))))) + (times (and keep-time (file-attribute-modification-time + (file-attributes directory))))) (if modes (set-file-modes newname modes)) (if times (set-file-times newname times)))))) @@ -5773,6 +5939,16 @@ This should not be relied upon. For more information on how this variable is used by Auto Revert mode, see Info node `(emacs)Supporting additional buffers'.") +(defvar-local buffer-auto-revert-by-notification nil + "Whether a buffer can rely on notification in Auto-Revert mode. +If non-nil, monitoring changes to the directory of the current +buffer is sufficient for knowing when that buffer needs to be +updated in Auto Revert Mode. Such notification does not include +changes to files in that directory, only to the directory itself. + +This variable only applies to buffers where `buffer-file-name' is +nil; other buffers are tracked by their files.") + (defvar before-revert-hook nil "Normal hook for `revert-buffer' to run before reverting. The function `revert-buffer--default' runs this. @@ -5974,14 +6150,18 @@ an auto-save file." (interactive "FRecover file: ") (setq file (expand-file-name file)) (if (auto-save-file-name-p (file-name-nondirectory file)) - (error "%s is an auto-save file" (abbreviate-file-name file))) + (user-error "%s is an auto-save file" (abbreviate-file-name file))) (let ((file-name (let ((buffer-file-name file)) (make-auto-save-file-name)))) - (cond ((if (file-exists-p file) + (cond ((and (file-exists-p file) + (not (file-exists-p file-name))) + (error "Auto save file %s does not exist" + (abbreviate-file-name file-name))) + ((if (file-exists-p file) (not (file-newer-than-file-p file-name file)) (not (file-exists-p file-name))) - (error "Auto-save file %s not current" - (abbreviate-file-name file-name))) + (user-error "Auto-save file %s not current" + (abbreviate-file-name file-name))) ((with-temp-buffer-window "*Directory*" nil #'(lambda (window _value) @@ -6244,7 +6424,7 @@ See also `auto-save-file-name-p'." ;; We do this on all platforms, because even if we are not ;; running on DOS/Windows, the current directory may be on a ;; mounted VFAT filesystem, such as a USB memory stick. - (while (string-match "[^A-Za-z0-9-_.~#+]" buffer-name limit) + (while (string-match "[^A-Za-z0-9_.~#+-]" buffer-name limit) (let* ((character (aref buffer-name (match-beginning 0))) (replacement ;; For multibyte characters, this will produce more than @@ -6509,58 +6689,38 @@ if you want to specify options, use `directory-free-space-args'. A value of nil disables this feature. -If the function `file-system-info' is defined, it is always used in -preference to the program given by this variable." +This variable is obsolete; Emacs no longer uses it." :type '(choice (string :tag "Program") (const :tag "None" nil)) :group 'dired) +(make-obsolete-variable 'directory-free-space-program + "ignored, as Emacs uses `file-system-info' instead" + "27.1") (defcustom directory-free-space-args (purecopy (if (eq system-type 'darwin) "-k" "-Pk")) "Options to use when running `directory-free-space-program'." :type 'string :group 'dired) +(make-obsolete-variable 'directory-free-space-args + "ignored, as Emacs uses `file-system-info' instead" + "27.1") + +(defcustom file-size-function #'file-size-human-readable + "Function that transforms the number of bytes into a human-readable string." + :type `(radio + (function-item :tag "Default" file-size-human-readable) + (function-item :tag "IEC" + ,(lambda (size) (file-size-human-readable size 'iec " "))) + (function :tag "Custom function")) + :version "27.1") (defun get-free-disk-space (dir) - "Return the amount of free space on directory DIR's file system. -The return value is a string describing the amount of free -space (normally, the number of free 1KB blocks). - -This function calls `file-system-info' if it is available, or -invokes the program specified by `directory-free-space-program' -and `directory-free-space-args'. If the system call or program -is unsuccessful, or if DIR is a remote directory, this function -returns nil." - (unless (file-remote-p (expand-file-name dir)) - ;; Try to find the number of free blocks. Non-Posix systems don't - ;; always have df, but might have an equivalent system call. - (if (fboundp 'file-system-info) - (let ((fsinfo (file-system-info dir))) - (if fsinfo - (format "%.0f" (/ (nth 2 fsinfo) 1024)))) - (setq dir (expand-file-name dir)) - (save-match-data - (with-temp-buffer - (when (and directory-free-space-program - ;; Avoid failure if the default directory does - ;; not exist (Bug#2631, Bug#3911). - (let ((default-directory - (locate-dominating-file dir 'file-directory-p))) - (eq (process-file directory-free-space-program - nil t nil - directory-free-space-args - (file-relative-name dir)) - 0))) - ;; Assume that the "available" column is before the - ;; "capacity" column. Find the "%" and scan backward. - (goto-char (point-min)) - (forward-line 1) - (when (re-search-forward - "[[:space:]]+[^[:space:]]+%[^%]*$" - (line-end-position) t) - (goto-char (match-beginning 0)) - (let ((endpt (point))) - (skip-chars-backward "^[:space:]") - (buffer-substring-no-properties (point) endpt))))))))) + "String describing the amount of free space on DIR's file system. +If DIR's free space cannot be obtained, this function returns nil." + (save-match-data + (let ((avail (nth 2 (file-system-info dir)))) + (if avail + (funcall file-size-function avail))))) ;; The following expression replaces `dired-move-to-filename-regexp'. (defvar directory-listing-before-filename-regexp @@ -6707,7 +6867,7 @@ Valid wildcards are '*', '?', '[abc]' and '[a-z]'." ;; dired-after-subdir-garbage (defines what a "total" line is) ;; - variable dired-subdir-regexp ;; - may be passed "--dired" as the first argument in SWITCHES. -;; Filename handlers might have to remove this switch if their +;; File name handlers might have to remove this switch if their ;; "ls" command does not support it. (defun insert-directory (file switches &optional wildcard full-directory-p) "Insert directory listing for FILE, formatted according to SWITCHES. @@ -7010,8 +7170,9 @@ if any returns nil. If `confirm-kill-emacs' is non-nil, calls it." (setq active t)) (setq processes (cdr processes))) (or (not active) - (with-current-buffer-window - (get-buffer-create "*Process List*") nil + (with-displayed-buffer-window + (get-buffer-create "*Process List*") + '(display-buffer--maybe-at-bottom) #'(lambda (window _value) (with-selected-window window (unwind-protect @@ -7051,20 +7212,28 @@ only these files will be asked to be saved." ;; We depend on being the last handler on the list, ;; so that anything else which does need handling ;; has been handled already. -;; So it is safe for us to inhibit *all* magic file name handlers. +;; So it is safe for us to inhibit *all* magic file name handlers for +;; operations, which return a file name. See Bug#29579. (defun file-name-non-special (operation &rest arguments) - (let ((file-name-handler-alist nil) - (default-directory - ;; Some operations respect file name handlers in - ;; `default-directory'. Because core function like - ;; `call-process' don't care about file name handlers in - ;; `default-directory', we here have to resolve the - ;; directory into a local one. For `process-file', - ;; `start-file-process', and `shell-command', this fixes - ;; Bug#25949. - (if (memq operation '(insert-directory process-file start-file-process - shell-command)) + (let (;; In general, we don't want any file name handler. For some + ;; few cases, operations with two file name arguments which + ;; might be bound to different file name handlers, we still + ;; need this. + (saved-file-name-handler-alist file-name-handler-alist) + file-name-handler-alist + ;; Some operations respect file name handlers in + ;; `default-directory'. Because core function like + ;; `call-process' don't care about file name handlers in + ;; `default-directory', we here have to resolve the directory + ;; into a local one. For `process-file', + ;; `start-file-process', and `shell-command', this fixes + ;; Bug#25949. + (default-directory + (if (memq operation + '(insert-directory process-file start-file-process + make-process shell-command + temporary-file-directory)) (directory-file-name (expand-file-name (unhandled-file-name-directory default-directory))) @@ -7072,35 +7241,55 @@ only these files will be asked to be saved." ;; Get a list of the indices of the args which are file names. (file-arg-indices (cdr (or (assq operation - ;; The first six 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. - '((expand-file-name . nil) - (file-name-directory . nil) - (file-name-as-directory . nil) - (directory-file-name . nil) - (file-name-sans-versions . nil) - (find-backup-file-name . nil) - ;; `identity' means just return the first arg - ;; not stripped of its quoting. + '(;; The first seven 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. + (directory-file-name) + (expand-file-name) + (file-name-as-directory) + (file-name-directory) + (file-name-sans-versions) + (file-remote-p) + (find-backup-file-name) + ;; `identity' means just return the first + ;; arg not stripped of its quoting. (substitute-in-file-name identity) ;; `add' means add "/:" to the result. (file-truename add 0) + ;;`insert-file-contents' needs special handling. (insert-file-contents insert-file-contents 0) ;; `unquote-then-quote' means set buffer-file-name ;; temporarily to unquoted filename. (verify-visited-file-modtime unquote-then-quote) + ;; Unquote `buffer-file-name' temporarily. + (make-auto-save-file-name buffer-file-name) + (set-visited-file-modtime buffer-file-name) + ;; Use a temporary local copy. + (copy-file local-copy) + (rename-file local-copy) + (copy-directory local-copy) ;; List the arguments which are filenames. - (file-name-completion 1) - (file-name-all-completions 1) + (file-name-completion 0 1) + (file-name-all-completions 0 1) + (file-equal-p 0 1) + (file-newer-than-file-p 0 1) (write-region 2 5) - (rename-file 0 1) - (copy-file 0 1) + (file-in-directory-p 0 1) (make-symbolic-link 0 1) - (add-name-to-file 0 1))) - ;; For all other operations, treat the first argument only - ;; as the file name. + (add-name-to-file 0 1) + ;; These file-notify-* operations take a + ;; descriptor. + (file-notify-rm-watch) + (file-notify-valid-p) + ;; `make-process' uses keyword arguments and + ;; doesn't mangle its filenames in any way. + ;; It already strips /: from the binary + ;; filename, so we don't have to do this + ;; here. + (make-process))) + ;; For all other operations, treat the first + ;; argument only as the file name. '(nil 0)))) method ;; Copy ARGUMENTS so we can replace elements in it. @@ -7108,26 +7297,25 @@ only these files will be asked to be saved." (if (symbolp (car file-arg-indices)) (setq method (pop file-arg-indices))) ;; Strip off the /: from the file names that have it. - (save-match-data + (save-match-data ;FIXME: Why? (while (consp file-arg-indices) (let ((pair (nthcdr (car file-arg-indices) arguments))) - (and (car pair) - (string-match "\\`/:" (car pair)) - (setcar pair - (if (= (length (car pair)) 2) - "/" - (substring (car pair) 2))))) + (when (car pair) + (setcar pair (file-name-unquote (car pair) t)))) (setq file-arg-indices (cdr file-arg-indices)))) (pcase method - (`identity (car arguments)) - (`add (file-name-quote (apply operation arguments))) - (`insert-file-contents + ('identity (car arguments)) + ('add (file-name-quote (apply operation arguments) t)) + ('buffer-file-name + (let ((buffer-file-name (file-name-unquote buffer-file-name t))) + (apply operation arguments))) + ('insert-file-contents (let ((visit (nth 1 arguments))) (unwind-protect (apply operation arguments) (when (and visit buffer-file-name) - (setq buffer-file-name (concat "/:" buffer-file-name)))))) - (`unquote-then-quote + (setq buffer-file-name (file-name-quote buffer-file-name t)))))) + ('unquote-then-quote ;; We can't use `cl-letf' with `(buffer-local-value)' here ;; because it wouldn't work during bootstrapping. (let ((buffer (current-buffer))) @@ -7135,32 +7323,73 @@ only these files will be asked to be saved." ;; `verify-visited-file-modtime' action, which takes a buffer ;; as only optional argument. (with-current-buffer (or (car arguments) buffer) - (let ((buffer-file-name (substring buffer-file-name 2))) + (let ((buffer-file-name (file-name-unquote buffer-file-name t))) ;; Make sure to hide the temporary buffer change from the ;; underlying operation. (with-current-buffer buffer (apply operation arguments)))))) + ('local-copy + (let* ((file-name-handler-alist saved-file-name-handler-alist) + (source (car arguments)) + (target (car (cdr arguments))) + (prefix (expand-file-name + "file-name-non-special" temporary-file-directory)) + tmpfile) + (cond + ;; If source is remote, we must create a local copy. + ((file-remote-p source) + (setq tmpfile (make-temp-name prefix)) + (apply operation source tmpfile (cddr arguments)) + (setq source tmpfile)) + ;; If source is quoted, and the unquoted source looks + ;; remote, we must create a local copy. + ((file-name-quoted-p source t) + (setq source (file-name-unquote source t)) + (when (file-remote-p source) + (setq tmpfile (make-temp-name prefix)) + (let (file-name-handler-alist) + (apply operation source tmpfile (cddr arguments))) + (setq source tmpfile)))) + ;; If target is quoted, and the unquoted target looks remote, + ;; we must disable the file name handler. + (when (file-name-quoted-p target t) + (setq target (file-name-unquote target t)) + (when (file-remote-p target) + (setq file-name-handler-alist nil))) + ;; Do it. + (setcar arguments source) + (setcar (cdr arguments) target) + (apply operation arguments) + ;; Cleanup. + (when (and tmpfile (file-exists-p tmpfile)) + (if (file-directory-p tmpfile) + (delete-directory tmpfile 'recursive) (delete-file tmpfile))))) (_ (apply operation arguments))))) -(defsubst file-name-quoted-p (name) +(defsubst file-name-quoted-p (name &optional top) "Whether NAME is quoted with prefix \"/:\". -If NAME is a remote file name, check the local part of NAME." - (string-prefix-p "/:" (file-local-name name))) +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 "/:" (file-local-name name)))) -(defsubst file-name-quote (name) +(defsubst file-name-quote (name &optional top) "Add the quotation prefix \"/:\" to file NAME. -If NAME is a remote file name, the local part of NAME is quoted. -If NAME is already a quoted file name, NAME is returned unchanged." - (if (file-name-quoted-p name) - name - (concat (file-remote-p name) "/:" (file-local-name name)))) - -(defsubst file-name-unquote (name) +If NAME is a remote file name and TOP is nil, the local part of +NAME is quoted. If NAME is already a quoted file name, NAME is +returned unchanged." + (let ((file-name-handler-alist (unless top file-name-handler-alist))) + (if (file-name-quoted-p name top) + name + (concat (file-remote-p name) "/:" (file-local-name name))))) + +(defsubst file-name-unquote (name &optional top) "Remove quotation prefix \"/:\" from file NAME, if any. -If NAME is a remote file name, the local part of NAME is unquoted." - (let ((localname (file-local-name name))) - (when (file-name-quoted-p localname) +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 (file-local-name name))) + (when (file-name-quoted-p localname top) (setq localname (if (= (length localname) 2) "/" (substring localname 2)))) (concat (file-remote-p name) localname))) @@ -7261,7 +7490,7 @@ based on existing mode bits, as in \"og+rX-w\"." (let* ((modes (or (if orig-file (file-modes orig-file) 0) (error "File not found"))) (modestr (and (stringp orig-file) - (nth 8 (file-attributes orig-file)))) + (file-attribute-modes (file-attributes orig-file)))) (default (and (stringp modestr) (string-match "^.\\(...\\)\\(...\\)\\(...\\)$" modestr) @@ -7310,7 +7539,10 @@ Otherwise, trash FILENAME using the freedesktop.org conventions, like the GNOME, KDE and XFCE desktop environments. Emacs only moves files to \"home trash\", ignoring per-volume trashcans." (interactive "fMove file to trash: ") - (cond (trash-directory + ;; If `system-move-file-to-trash' is defined, use it. + (cond ((fboundp 'system-move-file-to-trash) + (system-move-file-to-trash filename)) + (trash-directory ;; If `trash-directory' is non-nil, move the file there. (let* ((trash-dir (expand-file-name trash-directory)) (fn (directory-file-name (expand-file-name filename))) @@ -7329,9 +7561,6 @@ Otherwise, trash FILENAME using the freedesktop.org conventions, (setq new-fn (car (find-backup-file-name new-fn))))) (let (delete-by-moving-to-trash) (rename-file fn new-fn)))) - ;; If `system-move-file-to-trash' is defined, use it. - ((fboundp 'system-move-file-to-trash) - (system-move-file-to-trash filename)) ;; Otherwise, use the freedesktop.org method, as specified at ;; http://freedesktop.org/wiki/Specifications/trash-spec (t @@ -7441,27 +7670,24 @@ returned." (defsubst file-attribute-access-time (attributes) "The last access time in ATTRIBUTES returned by `file-attributes'. -This a list of integers (HIGH LOW USEC PSEC) in the same style -as (current-time)." +This a Lisp timestamp in the style of `current-time'." (nth 4 attributes)) (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 style of `current-time'." (nth 5 attributes)) (defsubst file-attribute-status-change-time (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 list of integers (HIGH -LOW USEC PSEC) in the same style as (current-time)." +and group, access mode bits, etc., and is a Lisp timestamp in the +style of `current-time'." (nth 6 attributes)) (defsubst file-attribute-size (attributes) - "The size (in bytes) in ATTRIBUTES returned by `file-attributes'. -This is a floating point number if the size is too large for an integer." + "The integer size (in bytes) in ATTRIBUTES returned by `file-attributes'." (nth 7 attributes)) (defsubst file-attribute-modes (attributes) @@ -7471,20 +7697,12 @@ This is a string of ten letters or dashes as in ls -l." (defsubst file-attribute-inode-number (attributes) "The inode number in ATTRIBUTES returned by `file-attributes'. -If it is larger than what an Emacs integer can hold, this is of -the form (HIGH . LOW): first the high bits, then the low 16 bits. -If even HIGH is too large for an Emacs integer, this is instead -of the form (HIGH MIDDLE . LOW): first the high bits, then the -middle 24 bits, and finally the low 16 bits." +It is a nonnegative integer." (nth 10 attributes)) (defsubst file-attribute-device-number (attributes) "The file system device number in ATTRIBUTES returned by `file-attributes'. -If it is larger than what an Emacs integer can hold, this is of -the form (HIGH . LOW): first the high bits, then the low 16 bits. -If even HIGH is too large for an Emacs integer, this is instead -of the form (HIGH MIDDLE . LOW): first the high bits, then the -middle 24 bits, and finally the low 16 bits." +It is an integer." (nth 11 attributes)) (defun file-attribute-collect (attributes &rest attr-names) diff --git a/lisp/filesets.el b/lisp/filesets.el index ea626867d5d..b74b4a8a400 100644 --- a/lisp/filesets.el +++ b/lisp/filesets.el @@ -242,8 +242,7 @@ key is supported." (defun filesets-set-config (fileset var val) "Set-default wrapper function." (filesets-reset-fileset fileset) - (set-default var val)) -; (customize-set-variable var val)) + (customize-set-variable var val)) ; (filesets-build-menu)) ;; It seems this is a workaround for the XEmacs issue described in the @@ -566,7 +565,7 @@ including directory trees to the menu can take a lot of memory." :group 'filesets) (defcustom filesets-commands - `(("Isearch" + '(("Isearch" multi-isearch-files (filesets-cmd-isearch-getargs)) ("Isearch (regexp)" @@ -1287,10 +1286,10 @@ on-close-all ... Not used" (filesets-get-external-viewer filename))))) (filesets-alist-get def (pcase event - (`on-open-all ':ignore-on-open-all) - (`on-grep ':ignore-on-read-text) - (`on-cmd nil) - (`on-close-all nil)) + ('on-open-all ':ignore-on-open-all) + ('on-grep ':ignore-on-read-text) + ('on-cmd nil) + ('on-close-all nil)) nil t))) (defun filesets-filetype-get-prop (property filename &optional entry) @@ -1560,7 +1559,7 @@ SAVE-FUNCTION takes no argument, but works on the current buffer." (defun filesets-get-fileset-from-name (name &optional mode) "Get fileset definition for NAME." (pcase mode - ((or `:ingroup `:tree) name) + ((or :ingroup :tree) name) (_ (assoc name filesets-data)))) diff --git a/lisp/find-dired.el b/lisp/find-dired.el index 00df68d8f1b..9e9fbfcb1a7 100644 --- a/lisp/find-dired.el +++ b/lisp/find-dired.el @@ -51,19 +51,23 @@ than the latter." :group 'find-dired :type 'string) +(defvar find-ls-option-default-ls + (cons "-ls" (if (eq system-type 'berkeley-unix) "-gilsb" "-dilsb"))) + +(defvar find-ls-option-default-exec + (cons (format "-exec ls -ld {} %s" find-exec-terminator) "-ld")) + +(defvar find-ls-option-default-xargs + (cons "-print0 | sort -z | xargs -0 -e ls -ld" "-ld")) + ;; find's -ls corresponds to these switches. ;; Note -b, at least GNU find quotes spaces etc. in filenames (defcustom find-ls-option (if (eq 0 (ignore-errors (process-file find-program nil nil nil null-device "-ls"))) - (cons "-ls" - (if (eq system-type 'berkeley-unix) - "-gilsb" - "-dilsb")) - (cons - (format "-exec ls -ld {} %s" find-exec-terminator) - "-ld")) + find-ls-option-default-ls + find-ls-option-default-exec) "A pair of options to produce and parse an `ls -l'-type list from `find'. This is a cons of two strings (FIND-OPTION . LS-SWITCHES). FIND-OPTION is the option (or options) passed to `find' to produce @@ -77,10 +81,26 @@ For example, to use human-readable file sizes with GNU ls: To use GNU find's inbuilt \"-ls\" option to list files: (\"-ls\" . \"-dilsb\") since GNU find's output has the same format as using GNU ls with -the options \"-dilsb\"." - :version "24.1" ; add tests for -ls and -exec + support - :type '(cons (string :tag "Find Option") - (string :tag "Ls Switches")) +the options \"-dilsb\". + +While the option `find -ls' often produces unsorted output, the option +`find -exec ls -ld' maintains the sorting order only on short output, +whereas `find -print | sort | xargs' produced sorted output even +on the large number of files." + :version "27.1" ; add choice of predefined set of options + :type `(choice + (cons :tag "find -ls" + (string ,(car find-ls-option-default-ls)) + (string ,(cdr find-ls-option-default-ls))) + (cons :tag "find -exec ls -ld" + (string ,(car find-ls-option-default-exec)) + (string ,(cdr find-ls-option-default-exec))) + (cons :tag "find -print | sort | xargs" + (string ,(car find-ls-option-default-xargs)) + (string ,(cdr find-ls-option-default-xargs))) + (cons :tag "Other values" + (string :tag "Find Option") + (string :tag "Ls Switches"))) :group 'find-dired) (defcustom find-ls-subdir-switches @@ -117,6 +137,17 @@ find also ignores case. Otherwise, -name is used." :group 'find-dired :version "22.2") +(defcustom find-dired-refine-function #'find-dired-sort-by-filename + "If non-nil, a function for refining the *Find* buffer of `find-dired'. +This function takes no arguments. The *Find* buffer is narrowed to the +output of `find' (one file per line) when this function is called." + :version "27.1" + :group 'find-dired + :type '(choice (const :tag "Sort file names lexicographically" + find-dired-sort-by-filename) + (function :tag "Refining function") + (const :tag "No refining" nil))) + (defvar find-args nil "Last arguments given to `find' by \\[find-dired].") @@ -144,7 +175,7 @@ use in place of \"-ls\" as the final argument." ;; Check that it's really a directory. (or (file-directory-p dir) (error "find-dired needs a directory: %s" dir)) - (switch-to-buffer (get-buffer-create "*Find*")) + (pop-to-buffer-same-window (get-buffer-create "*Find*")) ;; See if there's still a `find' running, and offer to kill ;; it first, if it is. @@ -175,7 +206,7 @@ use in place of \"-ls\" as the final argument." " " args " " (shell-quote-argument ")") " ")) - (if (string-match "\\`\\(.*\\) {} \\(\\\\;\\|+\\)\\'" + (if (string-match "\\`\\(.*\\) {} \\(\\\\;\\|\\+\\)\\'" (car find-ls-option)) (format "%s %s %s" (match-string 1 (car find-ls-option)) @@ -295,7 +326,7 @@ specifies what to use in place of \"-ls\" as the final argument." (l-opt (and (consp find-ls-option) (string-match "l" (cdr find-ls-option)))) (ls-regexp (concat "^ +[^ \t\r\n]+\\( +[^ \t\r\n]+\\) +" - "[^ \t\r\n]+ +[^ \t\r\n]+\\( +[0-9]+\\)"))) + "[^ \t\r\n]+ +[^ \t\r\n]+\\( +[^[:space:]]+\\)"))) (goto-char beg) (insert string) (goto-char beg) @@ -334,28 +365,43 @@ specifies what to use in place of \"-ls\" as the final argument." (delete-process proc)))) (defun find-dired-sentinel (proc state) - ;; Sentinel for \\[find-dired] processes. - (let ((buf (process-buffer proc)) - (inhibit-read-only t)) + "Sentinel for \\[find-dired] processes." + (let ((buf (process-buffer proc))) (if (buffer-name buf) (with-current-buffer buf - (let ((buffer-read-only nil)) + (let ((inhibit-read-only t)) (save-excursion - (goto-char (point-max)) - (let ((point (point))) - (insert "\n find " state) - (forward-char -1) ;Back up before \n at end of STATE. - (insert " at " (substring (current-time-string) 0 19)) - (dired-insert-set-properties point (point))) - (setq mode-line-process - (concat ":" - (symbol-name (process-status proc)))) + (save-restriction + (widen) + (when find-dired-refine-function + ;; `find-dired-filter' puts two whitespace characters + ;; at the beginning of every line. + (narrow-to-region (point) (- (point-max) 2)) + (funcall find-dired-refine-function) + (widen)) + (let ((point (point-max))) + (goto-char point) + (insert "\n find " + (substring state 0 -1) ; omit \n at end of STATE. + " at " (substring (current-time-string) 0 19)) + (dired-insert-set-properties point (point)))) + (setq mode-line-process + (format ":%s" (process-status proc))) ;; Since the buffer and mode line will show that the ;; process is dead, we can delete it now. Otherwise it - ;; will stay around until M-x list-processes. + ;; will stay around until M-x `list-processes'. (delete-process proc) - (force-mode-line-update))) - (message "find-dired %s finished." (current-buffer)))))) + (force-mode-line-update)))) + (message "find-dired %s finished." buf)))) + +(defun find-dired-sort-by-filename () + "Sort entries in *Find* buffer by file name lexicographically." + (sort-subr nil 'forward-line 'end-of-line + (lambda () + (buffer-substring-no-properties + (next-single-property-change + (point) 'dired-filename) + (line-end-position))))) (provide 'find-dired) diff --git a/lisp/find-lisp.el b/lisp/find-lisp.el index b356a74619c..073e2bc573f 100644 --- a/lisp/find-lisp.el +++ b/lisp/find-lisp.el @@ -300,24 +300,24 @@ It is a function which takes two arguments, the directory and its parent." "Format one line of long ls output for file FILE-NAME. FILE-ATTR and FILE-SIZE give the file's attributes and size. SWITCHES and TIME-INDEX give the full switch list and time data." - (let ((file-type (nth 0 file-attr))) + (let ((file-type (file-attribute-type file-attr))) (concat (if (memq ?i switches) ; inode number - (format "%6d " (nth 10 file-attr))) + (format "%6d " (file-attribute-inode-number file-attr))) ;; nil is treated like "" in concat (if (memq ?s switches) ; size in K - (format "%4d " (1+ (/ (nth 7 file-attr) 1024)))) - (nth 8 file-attr) ; permission bits + (format "%4d " (1+ (/ (file-attribute-size file-attr) 1024)))) + (file-attribute-modes file-attr) (format " %3d %-8s %-8s %8d " - (nth 1 file-attr) ; no. of links - (if (numberp (nth 2 file-attr)) - (int-to-string (nth 2 file-attr)) - (nth 2 file-attr)) ; uid + (file-attribute-link-number file-attr) + (if (numberp (file-attribute-user-id file-attr)) + (int-to-string (file-attribute-user-id file-attr)) + (file-attribute-user-id file-attr)) (if (eq system-type 'ms-dos) "root" ; everything is root on MSDOS. - (if (numberp (nth 3 file-attr)) - (int-to-string (nth 3 file-attr)) - (nth 3 file-attr))) ; gid - (nth 7 file-attr) ; size in bytes + (if (numberp (file-attribute-group-id file-attr)) + (int-to-string (file-attribute-group-id file-attr)) + (file-attribute-group-id file-attr))) + (file-attribute-size file-attr) ) (find-lisp-format-time file-attr switches now) " " @@ -342,16 +342,11 @@ list of ls option letters of which c and u are recognized). Use the same method as \"ls\" to decide whether to show time-of-day or year, depending on distance between file date and NOW." (let* ((time (nth (find-lisp-time-index switches) file-attr)) - (diff16 (- (car time) (car now))) - (diff (+ (ash diff16 16) (- (car (cdr time)) (car (cdr now))))) - (past-cutoff (- (* 6 30 24 60 60))) ; 6 30-day months + (diff (encode-time (time-subtract time now) 'integer)) + (past-cutoff -15778476) ; 1/2 of a Gregorian year (future-cutoff (* 60 60))) ; 1 hour (format-time-string - (if (and - (<= past-cutoff diff) (<= diff future-cutoff) - ;; Sanity check in case `diff' computation overflowed. - (<= (1- (ash past-cutoff -16)) diff16) - (<= diff16 (1+ (ash future-cutoff -16)))) + (if (<= past-cutoff diff future-cutoff) "%b %e %H:%M" "%b %e %Y") time))) diff --git a/lisp/finder.el b/lisp/finder.el index 54a0758949a..89706cf7dbd 100644 --- a/lisp/finder.el +++ b/lisp/finder.el @@ -188,67 +188,79 @@ from; the default is `load-path'." ;; Allow compressed files also. (setq package--builtins nil) (setq finder-keywords-hash (make-hash-table :test 'eq)) - (let ((el-file-regexp "^\\([^=].*\\)\\.el\\(\\.\\(gz\\|Z\\)\\)?$") - package-override files base-name ; processed - summary keywords package version entry desc) - (dolist (d (or dirs load-path)) - (when (file-exists-p (directory-file-name d)) - (message "Scanning %s for finder" d) - (setq package-override + (let* ((el-file-regexp "^\\([^=].*\\)\\.el\\(\\.\\(gz\\|Z\\)\\)?$") + (file-count 0) + (files (cl-loop for d in (or dirs load-path) + when (file-exists-p (directory-file-name d)) + append (mapcar + (lambda (f) + (cons d f)) + (directory-files d nil el-file-regexp)))) + (progress (make-progress-reporter + (byte-compile-info-string "Scanning files for finder") + 0 (length files))) + package-override base-name ; processed + summary keywords package version entry desc) + (dolist (elem files) + (let* ((d (car elem)) + (f (cdr elem)) + (package-override (intern-soft (cdr-safe - (assoc (file-name-nondirectory (directory-file-name d)) - finder--builtins-alist)))) - (setq files (directory-files d nil el-file-regexp)) - (dolist (f files) - (unless (or (string-match finder-no-scan-regexp f) - (null (setq base-name - (and (string-match el-file-regexp f) - (intern (match-string 1 f)))))) -;; (memq base-name processed)) -;; There are multiple files in the tree with the same basename. -;; So skipping files based on basename means you randomly (depending -;; on which order the files are traversed in) miss some packages. -;; https://debbugs.gnu.org/14010 -;; You might think this could lead to two files providing the same package, -;; but it does not, because the duplicates are (at time of writing) -;; all due to files in cedet, which end up with package-override set. -;; FIXME this is obviously fragile. -;; Make the (eq base-name package) case below issue a warning if -;; package-override is nil? -;; (push base-name processed) - (with-temp-buffer - (insert-file-contents (expand-file-name f d)) - (setq keywords (mapcar 'intern (lm-keywords-list)) - package (or package-override - (let ((str (lm-header "package"))) - (if str (intern str))) - base-name) - summary (or (cdr - (assq package finder--builtins-descriptions)) - (lm-synopsis)) - version (lm-header "version"))) - (when summary - (setq version (ignore-errors (version-to-list version))) - (setq entry (assq package package--builtins)) - (cond ((null entry) - (push (cons package - (package-make-builtin version summary)) - package--builtins)) - ;; The idea here is that eg calc.el gets to define - ;; the description of the calc package. - ;; This does not work for eg nxml-mode.el. - ((or (eq base-name package) version) - (setq desc (cdr entry)) - (aset desc 0 version) - (aset desc 2 summary))) - (dolist (kw keywords) - (puthash kw - (cons package - (delq package - (gethash kw finder-keywords-hash))) - finder-keywords-hash)))))))) - + (assoc (file-name-nondirectory + (directory-file-name d)) + finder--builtins-alist))))) + (progress-reporter-update progress (setq file-count (1+ file-count))) + (unless (or (string-match finder-no-scan-regexp f) + (null (setq base-name + (and (string-match el-file-regexp f) + (intern (match-string 1 f)))))) + ;; (memq base-name processed)) + ;; There are multiple files in the tree with the same + ;; basename. So skipping files based on basename means you + ;; randomly (depending on which order the files are + ;; traversed in) miss some packages. + ;; https://debbugs.gnu.org/14010 + ;; You might think this could lead to two files providing + ;; the same package, but it does not, because the duplicates + ;; are (at time of writing) all due to files in cedet, which + ;; end up with package-override set. FIXME this is + ;; obviously fragile. Make the (eq base-name package) case + ;; below issue a warning if package-override is nil? + ;; (push base-name processed) + (with-temp-buffer + (insert-file-contents (expand-file-name f d)) + (setq keywords (mapcar 'intern (lm-keywords-list)) + package (or package-override + (let ((str (lm-header "package"))) + (if str (intern str))) + base-name) + summary (or (cdr + (assq package finder--builtins-descriptions)) + (lm-synopsis)) + version (lm-header "version"))) + (when summary + (setq version (or (ignore-errors (version-to-list version)) + (alist-get package package--builtin-versions))) + (setq entry (assq package package--builtins)) + (cond ((null entry) + (push (cons package + (package-make-builtin version summary)) + package--builtins)) + ;; The idea here is that eg calc.el gets to define + ;; the description of the calc package. + ;; This does not work for eg nxml-mode.el. + ((or (eq base-name package) version) + (setq desc (cdr entry)) + (aset desc 0 version) + (aset desc 2 summary))) + (dolist (kw keywords) + (puthash kw + (cons package + (delq package + (gethash kw finder-keywords-hash))) + finder-keywords-hash)))))) + (progress-reporter-done progress)) (setq package--builtins (sort package--builtins (lambda (a b) (string< (symbol-name (car a)) @@ -453,11 +465,12 @@ finder directory, \\[finder-exit] = quit, \\[finder-summary] = help"))) (defun finder-exit () "Exit Finder mode. -Delete the window and kill all Finder-related buffers." +Quit the window and kill all Finder-related buffers." (interactive) - (ignore-errors (delete-window)) (let ((buf "*Finder*")) - (and (get-buffer buf) (kill-buffer buf)))) + (if (equal (current-buffer) buf) + (quit-window t) + (and (get-buffer buf) (kill-buffer buf))))) (defun finder-unload-function () "Unload the Finder library." diff --git a/lisp/foldout.el b/lisp/foldout.el index ae0eb0ff2b3..3ef88fe686a 100644 --- a/lisp/foldout.el +++ b/lisp/foldout.el @@ -209,10 +209,6 @@ (require 'outline) -;; something has gone very wrong if outline-minor-mode isn't bound now. -(if (not (boundp 'outline-minor-mode)) - (error "Can't find outline-minor-mode")) - (defvar foldout-fold-list nil "List of start and end markers for the folds currently entered. An end marker of nil means the fold ends after (point-max).") diff --git a/lisp/follow.el b/lisp/follow.el index 2ab44b21dd5..faac87986bb 100644 --- a/lisp/follow.el +++ b/lisp/follow.el @@ -187,8 +187,8 @@ ;; Implementation: ;; ;; The main method by which Follow mode aligns windows is via the -;; function `follow-post-command-hook', which is run after each -;; command. This "fixes up" the alignment of other windows which are +;; function `follow-pre-redisplay-function', which is run before each +;; redisplay. This "fixes up" the alignment of other windows which are ;; showing the same Follow mode buffer, on the same frame as the ;; selected window. It does not try to deal with buffers other than ;; the buffer of the selected frame, or windows on other frames. @@ -311,6 +311,17 @@ are \" Fw\", or simply \"\"." (remove-hook 'find-file-hook 'follow-find-file-hook)) (set-default symbol value))) +(defcustom follow-hide-ghost-cursors t ; Maybe this should be nil. + "When non-nil, Follow mode attempts to hide the obtrusive cursors +in the non-selected windows of a window group. + +This variable takes effect when `follow-mode' is initialized. + +Due to limitations in Emacs, this only operates on the followers +of the selected window." + :type 'boolean + :group 'follow) + (defvar follow-cache-command-list '(next-line previous-line forward-char backward-char right-char left-char) "List of commands that don't require recalculation. @@ -383,9 +394,6 @@ This is typically set by explicit scrolling commands.") ;;;###autoload (define-minor-mode follow-mode "Toggle Follow mode. -With a prefix argument ARG, enable Follow mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Follow mode is a minor mode that combines windows into one tall virtual window. This is accomplished by two main techniques: @@ -421,7 +429,7 @@ Keys specific to Follow mode: (if follow-mode (progn (add-hook 'compilation-filter-hook 'follow-align-compilation-windows t t) - (add-hook 'post-command-hook 'follow-post-command-hook t) + (add-function :before pre-redisplay-function 'follow-pre-redisplay-function) (add-hook 'window-size-change-functions 'follow-window-size-change t) (add-hook 'after-change-functions 'follow-after-change nil t) (add-hook 'isearch-update-post-hook 'follow-post-command-hook nil t) @@ -430,6 +438,8 @@ Keys specific to Follow mode: (when isearch-lazy-highlight (setq-local isearch-lazy-highlight 'all-windows)) + (when follow-hide-ghost-cursors + (setq-local cursor-in-non-selected-windows nil)) (setq window-group-start-function 'follow-window-start) (setq window-group-end-function 'follow-window-end) @@ -448,7 +458,7 @@ Keys specific to Follow mode: (setq following (buffer-local-value 'follow-mode (car buffers)) buffers (cdr buffers))) (unless following - (remove-hook 'post-command-hook 'follow-post-command-hook) + (remove-function pre-redisplay-function 'follow-pre-redisplay-function) (remove-hook 'window-size-change-functions 'follow-window-size-change))) (kill-local-variable 'move-to-window-group-line-function) @@ -459,6 +469,8 @@ Keys specific to Follow mode: (kill-local-variable 'window-group-end-function) (kill-local-variable 'window-group-start-function) + (kill-local-variable 'cursor-in-non-selected-windows) + (remove-hook 'ispell-update-post-hook 'follow-post-command-hook t) (remove-hook 'replace-update-post-hook 'follow-post-command-hook t) (remove-hook 'isearch-update-post-hook 'follow-post-command-hook t) @@ -545,7 +557,7 @@ This is an internal function for `follow-scroll-up' and (let ((opoint (point)) (owin (selected-window))) (while ;; If we are too near EOB, try scrolling the previous window. - (condition-case nil (progn (scroll-up arg) nil) + (condition-case nil (progn (scroll-up-command arg) nil) (end-of-buffer (condition-case nil (progn (follow-previous-window) t) (error @@ -564,7 +576,7 @@ If ARG is nil, scroll the size of the current window. This is an internal function for `follow-scroll-down' and `follow-scroll-down-window'." (let ((opoint (point))) - (scroll-down arg) + (scroll-down-command arg) (unless (and scroll-preserve-screen-position (get this-command 'scroll-command)) (goto-char opoint)) @@ -584,7 +596,7 @@ Negative ARG means scroll downward. Works like `scroll-up' when not in Follow mode." (interactive "P") (cond ((not follow-mode) - (scroll-up arg)) + (scroll-up-command arg)) ((eq arg '-) (follow-scroll-down-window)) (t (follow-scroll-up-arg arg)))) @@ -604,7 +616,7 @@ Negative ARG means scroll upward. Works like `scroll-down' when not in Follow mode." (interactive "P") (cond ((not follow-mode) - (scroll-down arg)) + (scroll-down-command arg)) ((eq arg '-) (follow-scroll-up-window)) (t (follow-scroll-down-arg arg)))) @@ -623,13 +635,16 @@ Negative ARG means scroll downward. Works like `scroll-up' when not in Follow mode." (interactive "P") (cond ((not follow-mode) - (scroll-up arg)) + (scroll-up-command arg)) (arg (follow-scroll-up-arg arg)) (t (let* ((windows (follow-all-followers)) (end (window-end (car (reverse windows))))) (if (eq end (point-max)) - (signal 'end-of-buffer nil) + (if (or (null scroll-error-top-bottom) + (eobp)) + (signal 'end-of-buffer nil) + (goto-char (point-max))) (select-window (car windows)) ;; `window-end' might return nil. (if end @@ -651,14 +666,17 @@ Negative ARG means scroll upward. Works like `scroll-down' when not in Follow mode." (interactive "P") (cond ((not follow-mode) - (scroll-down arg)) + (scroll-down-command arg)) (arg (follow-scroll-down-arg arg)) (t (let* ((windows (follow-all-followers)) (win (car (reverse windows))) (start (window-start (car windows)))) (if (eq start (point-min)) - (signal 'beginning-of-buffer nil) + (if (or (null scroll-error-top-bottom) + (bobp)) + (signal 'beginning-of-buffer nil) + (goto-char (point-min))) (select-window win) (goto-char start) (vertical-motion (- (- (window-height win) @@ -1263,10 +1281,31 @@ non-first windows in Follow mode." (not (eq win top)))) ;; Loop while this is true. (set-buffer orig-buffer)))) -;;; Post Command Hook +;;; Pre Display Function + +(defvar follow-prev-buffer nil + "The buffer current at the last call to `follow-adjust-window' or nil. +follow-mode is not necessarily enabled in this buffer.") -;; The magic little box. This function is called after every command. +;; This function is added to `pre-display-function' and is thus called +;; before each redisplay operation. It supersedes (2018-09) the +;; former use of the post command hook, and now does the right thing +;; when a program calls `redisplay' or `sit-for'. +(defun follow-pre-redisplay-function (wins) + (if (or (eq wins t) + (null wins) + (and (listp wins) + (memq (selected-window) wins))) + (follow-post-command-hook))) + +;;; Post Command Hook + +;; The magic little box. This function was formerly called after every +;; command. It is now called before each redisplay operation (see +;; `follow-pre-redisplay-function' above), and at the end of several +;; search/replace commands. It retains its historical name. +;; ;; This is not as complicated as it seems. It is simply a list of common ;; display situations and the actions to take, plus commands for redrawing ;; the screen if it should be unaligned. @@ -1287,9 +1326,33 @@ non-first windows in Follow mode." (setq follow-windows-start-end-cache nil)) (follow-adjust-window win))))) +;; NOTE: to debug follow-mode with edebug, it is helpful to add +;; `follow-post-command-hook' to `post-command-hook' temporarily. Do +;; this locally to the target buffer with, say,: +;; M-: (add-hook 'post-command-hook 'follow-post-command-hook t t) +;; . + (defun follow-adjust-window (win) ;; Adjust the window WIN and its followers. (cl-assert (eq (window-buffer win) (current-buffer))) + + ;; Have we moved out of or into a follow-mode window group? + ;; If so, attend to the visibility of the cursors. + (when (not (eq (current-buffer) follow-prev-buffer)) + ;; Do we need to switch off cursor handling in the previous buffer? + (when (buffer-live-p follow-prev-buffer) + (with-current-buffer follow-prev-buffer + (when (and follow-mode + (local-variable-p 'cursor-in-non-selected-windows)) + (setq cursor-in-non-selected-windows + (default-value 'cursor-in-non-selected-windows))))) + ;; Do we need to switch on cursor handling in the current buffer? + (when (and follow-mode + (local-variable-p 'cursor-in-non-selected-windows)) + (setq cursor-in-non-selected-windows nil)) + (when (buffer-live-p (current-buffer)) + (setq follow-prev-buffer (current-buffer)))) + (when (and follow-mode (not (window-minibuffer-p win))) (let ((windows (follow-all-followers win))) diff --git a/lisp/font-core.el b/lisp/font-core.el index 8e190bb2ade..6b26f0cb92e 100644 --- a/lisp/font-core.el +++ b/lisp/font-core.el @@ -78,9 +78,6 @@ It will be passed one argument, which is the current value of (define-minor-mode font-lock-mode "Toggle syntax highlighting in this buffer (Font Lock mode). -With a prefix argument ARG, enable Font Lock mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. When Font Lock mode is enabled, text is fontified as you type it: diff --git a/lisp/font-lock.el b/lisp/font-lock.el index d3828cf6b47..3991a4ee8ef 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -1,4 +1,4 @@ -;;; font-lock.el --- Electric font lock mode +;;; font-lock.el --- Electric font lock mode -*- lexical-binding:t -*- ;; Copyright (C) 1992-2019 Free Software Foundation, Inc. @@ -327,6 +327,9 @@ If a number, only buffers greater than this size have fontification messages." (defvar font-lock-type-face 'font-lock-type-face "Face name to use for type and class names.") +(define-obsolete-variable-alias + 'font-lock-reference-face 'font-lock-constant-face "20.3") + (defvar font-lock-constant-face 'font-lock-constant-face "Face name to use for constant and label names.") @@ -340,9 +343,6 @@ This can be an \"!\" or the \"n\" in \"ifndef\".") (defvar font-lock-preprocessor-face 'font-lock-preprocessor-face "Face name to use for preprocessor directives.") -(define-obsolete-variable-alias - 'font-lock-reference-face 'font-lock-constant-face "20.3") - ;; Fontification variables: (defvar font-lock-keywords nil @@ -631,10 +631,7 @@ Major/minor modes can set this variable if they know which option applies.") (declare (indent 0) (debug t)) `(let ((inhibit-point-motion-hooks t)) (with-silent-modifications - ,@body))) - ;; - ;; Shut up the byte compiler. - (defvar font-lock-face-attributes)) ; Obsolete but respected if set. + ,@body)))) (defvar-local font-lock-set-defaults nil) ; Whether we have set up defaults. @@ -659,7 +656,7 @@ be enabled." (cond (font-lock-fontified nil) ((or (null max-size) (> max-size (buffer-size))) - (font-lock-fontify-buffer)) + (with-no-warnings (font-lock-fontify-buffer))) (font-lock-verbose (message "Fontifying %s...buffer size greater than font-lock-maximum-size" (buffer-name))))))) @@ -929,9 +926,9 @@ The value of this variable is used when Font Lock mode is turned on." (defun font-lock-turn-on-thing-lock () (pcase (font-lock-value-in-major-mode font-lock-support-mode) - (`fast-lock-mode (fast-lock-mode t)) - (`lazy-lock-mode (lazy-lock-mode t)) - (`jit-lock-mode + ('fast-lock-mode (fast-lock-mode t)) + ('lazy-lock-mode (lazy-lock-mode t)) + ('jit-lock-mode ;; Prepare for jit-lock (remove-hook 'after-change-functions #'font-lock-after-change-function t) @@ -1096,14 +1093,10 @@ accessible portion of the current buffer." (or beg (point-min)) (or end (point-max))))) (defvar font-lock-ensure-function - (lambda (_beg _end) + (lambda (beg end) (unless font-lock-fontified - (font-lock-default-fontify-buffer) - (unless font-lock-mode - ;; If font-lock is not enabled, we don't have the hooks in place to - ;; track modifications, so a subsequent call to font-lock-ensure can't - ;; assume that the fontification is still valid. - (setq font-lock-fontified nil)))) + (save-excursion + (font-lock-fontify-region beg end)))) "Function to make sure a region has been fontified. Called with two arguments BEG and END.") @@ -1394,12 +1387,19 @@ delimit the region to fontify." ;; below and given a `font-lock-' prefix. Those that are not used are defined ;; in Lisp below and commented out. sm. -(defun font-lock-prepend-text-property (start end prop value &optional object) - "Prepend to one property of the text from START to END. -Arguments PROP and VALUE specify the property and value to prepend to the value -already in place. The resulting property values are always lists. -Optional argument OBJECT is the string or buffer containing the text." - (let ((val (if (listp value) value (list value))) next prev) +(defun font-lock--add-text-property (start end prop value object append) + "Add an element to a property of the text from START to END. +Arguments PROP and VALUE specify the property and value to add to +the value already in place. The resulting property values are +always lists. Argument OBJECT is the string or buffer containing +the text. If argument APPEND is non-nil, VALUE will be appended, +otherwise it will be prepended." + (let ((val (if (and (listp value) (not (keywordp (car value)))) + ;; Already a list of faces. + value + ;; A single face (e.g. a plist of face properties). + (list value))) + next prev) (while (/= start end) (setq next (next-single-property-change start prop object end) prev (get-text-property start prop object)) @@ -1409,30 +1409,26 @@ Optional argument OBJECT is the string or buffer containing the text." (or (keywordp (car prev)) (memq (car prev) '(foreground-color background-color))) (setq prev (list prev))) - (put-text-property start next prop - (append val (if (listp prev) prev (list prev))) - object) + (let* ((list-prev (if (listp prev) prev (list prev))) + (new-value (if append + (append list-prev val) + (append val list-prev)))) + (put-text-property start next prop new-value object)) (setq start next)))) +(defun font-lock-prepend-text-property (start end prop value &optional object) + "Prepend to one property of the text from START to END. +Arguments PROP and VALUE specify the property and value to prepend to the value +already in place. The resulting property values are always lists. +Optional argument OBJECT is the string or buffer containing the text." + (font-lock--add-text-property start end prop value object nil)) + (defun font-lock-append-text-property (start end prop value &optional object) "Append to one property of the text from START to END. Arguments PROP and VALUE specify the property and value to append to the value already in place. The resulting property values are always lists. Optional argument OBJECT is the string or buffer containing the text." - (let ((val (if (listp value) value (list value))) next prev) - (while (/= start end) - (setq next (next-single-property-change start prop object end) - prev (get-text-property start prop object)) - ;; Canonicalize old forms of face property. - (and (memq prop '(face font-lock-face)) - (listp prev) - (or (keywordp (car prev)) - (memq (car prev) '(foreground-color background-color))) - (setq prev (list prev))) - (put-text-property start next prop - (append (if (listp prev) prev (list prev)) val) - object) - (setq start next)))) + (font-lock--add-text-property start end prop value object t)) (defun font-lock-fillin-text-property (start end prop value &optional object) "Fill in one property of the text from START to END. @@ -1503,7 +1499,7 @@ see `font-lock-syntactic-keywords'." ;; Flush the syntax-cache. I believe this is not necessary for ;; font-lock's use of syntax-ppss, but I'm not 100% sure and it can ;; still be necessary for other users of syntax-ppss anyway. - (syntax-ppss-after-change-function start) + (syntax-ppss-flush-cache start) (cond ((not override) ;; Cannot override existing fontification. @@ -1787,7 +1783,7 @@ If SYNTACTIC-KEYWORDS is non-nil, it means these keywords are used for (cons t (cons keywords (mapcar #'font-lock-compile-keyword keywords)))) (if (and (not syntactic-keywords) - (let ((beg-function syntax-begin-function)) + (let ((beg-function (with-no-warnings syntax-begin-function))) (or (eq beg-function #'beginning-of-defun) (if (symbolp beg-function) (get beg-function 'font-lock-syntax-paren-check)))) diff --git a/lisp/format-spec.el b/lisp/format-spec.el index db6b8768088..fec93ce83d9 100644 --- a/lisp/format-spec.el +++ b/lisp/format-spec.el @@ -24,44 +24,114 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile + (require 'subr-x)) -(defun format-spec (format specification) +(defun format-spec (format specification &optional only-present) "Return a string based on FORMAT and SPECIFICATION. -FORMAT is a string containing `format'-like specs like \"bash %u %k\", +FORMAT is a string containing `format'-like specs like \"su - %u %k\", while SPECIFICATION is an alist mapping from format spec characters -to values. Any text properties on a %-spec itself are propagated to -the text that it generates." +to values. + +For instance: + + (format-spec \"su - %u %l\" + `((?u . ,(user-login-name)) + (?l . \"ls\"))) + +Each format spec can have modifiers, where \"%<010b\" means \"if +the expansion is shorter than ten characters, zero-pad it, and if +it's longer, chop off characters from the left size\". + +The following modifiers are allowed: + +* 0: Use zero-padding. +* -: Pad to the right. +* ^: Upper-case the expansion. +* _: Lower-case the expansion. +* <: Limit the length by removing chars from the left. +* >: Limit the length by removing chars from the right. + +Any text properties on a %-spec itself are propagated to the text +that it generates. + +If ONLY-PRESENT, format spec characters not present in +SPECIFICATION are ignored, and the \"%\" characters are left +where they are, including \"%%\" strings." (with-temp-buffer (insert format) (goto-char (point-min)) (while (search-forward "%" nil t) (cond - ;; Quoted percent sign. - ((eq (char-after) ?%) - (delete-char 1)) - ;; Valid format spec. - ((looking-at "\\([-0-9.]*\\)\\([a-zA-Z]\\)") - (let* ((num (match-string 1)) - (spec (string-to-char (match-string 2))) - (val (assq spec specification))) - (unless val - (error "Invalid format character: `%%%c'" spec)) - (setq val (cdr val)) - ;; Pad result to desired length. - (let ((text (format (concat "%" num "s") val))) - ;; Insert first, to preserve text properties. - (insert-and-inherit text) - ;; Delete the specifier body. - (delete-region (+ (match-beginning 0) (length text)) - (+ (match-end 0) (length text))) - ;; Delete the percent sign. - (delete-region (1- (match-beginning 0)) (match-beginning 0))))) - ;; Signal an error on bogus format strings. - (t - (error "Invalid format string")))) + ;; Quoted percent sign. + ((eq (char-after) ?%) + (unless only-present + (delete-char 1))) + ;; Valid format spec. + ((looking-at "\\([-0 _^<>]*\\)\\([0-9.]*\\)\\([a-zA-Z]\\)") + (let* ((modifiers (match-string 1)) + (num (match-string 2)) + (spec (string-to-char (match-string 3))) + (val (assq spec specification))) + (if (not val) + (unless only-present + (error "Invalid format character: `%%%c'" spec)) + (setq val (cdr val) + modifiers (format-spec--parse-modifiers modifiers)) + ;; Pad result to desired length. + (let ((text (format "%s" val))) + (when num + (setq num (string-to-number num)) + (setq text (format-spec--pad text num modifiers)) + (when (> (length text) num) + (cond + ((memq :chop-left modifiers) + (setq text (substring text (- (length text) num)))) + ((memq :chop-right modifiers) + (setq text (substring text 0 num)))))) + (when (memq :uppercase modifiers) + (setq text (upcase text))) + (when (memq :lowercase modifiers) + (setq text (downcase text))) + ;; Insert first, to preserve text properties. + (insert-and-inherit text) + ;; Delete the specifier body. + (delete-region (+ (match-beginning 0) (length text)) + (+ (match-end 0) (length text))) + ;; Delete the percent sign. + (delete-region (1- (match-beginning 0)) (match-beginning 0)))))) + ;; Signal an error on bogus format strings. + (t + (unless only-present + (error "Invalid format string"))))) (buffer-string))) +(defun format-spec--pad (text total-length modifiers) + (if (> (length text) total-length) + ;; The text is longer than the specified length; do nothing. + text + (let ((padding (make-string (- total-length (length text)) + (if (memq :zero-pad modifiers) + ?0 + ?\s)))) + (if (memq :right-pad modifiers) + (concat text padding) + (concat padding text))))) + +(defun format-spec--parse-modifiers (modifiers) + (mapcan (lambda (char) + (when-let ((modifier + (pcase char + (?0 :zero-pad) + (?\s :space-pad) + (?^ :uppercase) + (?_ :lowercase) + (?- :right-pad) + (?< :chop-left) + (?> :chop-right)))) + (list modifier))) + modifiers)) + (defun format-spec-make (&rest pairs) "Return an alist suitable for use in `format-spec' based on PAIRS. PAIRS is a list where every other element is a character and a value, diff --git a/lisp/format.el b/lisp/format.el index 811b1dd1bfa..93f131bbcca 100644 --- a/lisp/format.el +++ b/lisp/format.el @@ -84,7 +84,7 @@ iso-sgml2iso iso-iso2sgml t nil) (rot13 ,(purecopy "rot13") nil - ,(purecopy "tr a-mn-z n-za-m") ,(purecopy "tr a-mn-z n-za-m") t nil) + rot13-region rot13-region t nil) (duden ,(purecopy "Duden Ersatzdarstellung") nil ,(purecopy "diac") iso-iso2duden t nil) @@ -539,13 +539,7 @@ Compare using `equal'." (setq tail next))) (cons acopy bcopy))) -(defun format-proper-list-p (list) - "Return t if LIST is a proper list. -A proper list is a list ending with a nil cdr, not with an atom " - (when (listp list) - (while (consp list) - (setq list (cdr list))) - (null list))) +(define-obsolete-function-alias 'format-proper-list-p 'proper-list-p "27.1") (defun format-reorder (items order) "Arrange ITEMS to follow partial ORDER. @@ -1005,12 +999,10 @@ either strings, or lists of the form (PARAMETER VALUE)." ;; If either old or new is a list, have to treat both that way. (if (and (or (listp old) (listp new)) (not (get prop 'format-list-atomic-p))) - (if (or (not (format-proper-list-p old)) - (not (format-proper-list-p new))) + (if (not (and (proper-list-p old) + (proper-list-p new))) (format-annotate-atomic-property-change prop-alist old new) - (let* ((old (if (listp old) old (list old))) - (new (if (listp new) new (list new))) - close open) + (let (close open) (while old (setq close (append (car (format-annotate-atomic-property-change diff --git a/lisp/frame.el b/lisp/frame.el index 6dc72669685..fd7e872fb6d 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -129,22 +129,107 @@ appended when the minibuffer frame is created." ;; Gildea@x.org says it is ok to ask questions before terminating. (save-buffers-kill-emacs)))) -(defun handle-focus-in (_event) +(defun frame-focus-state (&optional frame) + "Return FRAME's last known focus state. +If nil or omitted, FRAME defaults to the selected frame. + +Return nil if the frame is definitely known not be focused, t if +the frame is known to be focused, and `unknown' if we don't know." + (let* ((frame (or frame (selected-frame))) + (tty-top-frame (tty-top-frame frame))) + (if (not tty-top-frame) + (frame-parameter frame 'last-focus-update) + ;; All tty frames are frame-visible-p if the terminal is + ;; visible, so check whether the frame is the top tty frame + ;; before checking visibility. + (cond ((not (eq tty-top-frame frame)) nil) + ((not (frame-visible-p frame)) nil) + (t (let ((tty-focus-state + (terminal-parameter frame 'tty-focus-state))) + (cond ((eq tty-focus-state 'focused) t) + ((eq tty-focus-state 'defocused) nil) + (t 'unknown)))))))) + +(defvar after-focus-change-function #'ignore + "Function called after frame focus may have changed. + +This function is called with no arguments when Emacs notices that +the set of focused frames may have changed. Code wanting to do +something when frame focus changes should use `add-function' to +add a function to this one, and in this added function, re-scan +the set of focused frames, calling `frame-focus-state' to +retrieve the last known focus state of each frame. Focus events +are delivered asynchronously, and frame input focus according to +an external system may not correspond to the notion of the Emacs +selected frame. Multiple frames may appear to have input focus +simultaneously due to focus event delivery differences, the +presence of multiple Emacs terminals, and other factors, and code +should be robust in the face of this situation. + +Depending on window system, focus events may also be delivered +repeatedly and with different focus states before settling to the +expected values. Code relying on focus notifications should +\"debounce\" any user-visible updates arising from focus changes, +perhaps by deferring work until redisplay. + +This function may be called in arbitrary contexts, including from +inside `read-event', so take the same care as you might when +writing a process filter.") + +(defvar focus-in-hook nil + "Normal hook run when a frame gains focus. +The frame gaining focus is selected at the time this hook is run. + +This hook is obsolete. Despite its name, this hook may be run in +situations other than when a frame obtains input focus: for +example, we also run this hook when switching the selected frame +internally to handle certain input events (like mouse wheel +scrolling) even when the user's notion of input focus +hasn't changed. + +Prefer using `after-focus-change-function'.") +(make-obsolete-variable + 'focus-in-hook "after-focus-change-function" "27.1" 'set) + +(defvar focus-out-hook nil + "Normal hook run when all frames lost input focus. + +This hook is obsolete; see `focus-in-hook'. Depending on timing, +this hook may be delivered when a frame does in fact have focus. +Prefer `after-focus-change-function'.") +(make-obsolete-variable + 'focus-out-hook "after-focus-change-function" "27.1" 'set) + +(defun handle-focus-in (event) "Handle a focus-in event. -Focus-in events are usually bound to this function. -Focus-in events occur when a frame has focus, but a switch-frame event -is not generated. -This function runs the hook `focus-in-hook'." +Focus-in events are bound to this function; do not change this +binding. Focus-in events occur when a frame receives focus from +the window system." + ;; N.B. tty focus goes down a different path; see xterm.el. (interactive "e") - (run-hooks 'focus-in-hook)) - -(defun handle-focus-out (_event) + (unless (eq (car-safe event) 'focus-in) + (error "handle-focus-in should handle focus-in events")) + (let ((frame (nth 1 event))) + (when (frame-live-p frame) + (internal-handle-focus-in event) + (setf (frame-parameter frame 'last-focus-update) t) + (run-hooks 'focus-in-hook))) + (funcall after-focus-change-function)) + +(defun handle-focus-out (event) "Handle a focus-out event. -Focus-out events are usually bound to this function. -Focus-out events occur when no frame has focus. -This function runs the hook `focus-out-hook'." +Focus-out events are bound to this function; do not change this +binding. Focus-out events occur when a frame loses focus, but +that's not the whole story: see `after-focus-change-function'." + ;; N.B. tty focus goes down a different path; see xterm.el. (interactive "e") - (run-hooks 'focus-out-hook)) + (unless (eq (car event) 'focus-out) + (error "handle-focus-out should handle focus-out events")) + (let ((frame (nth 1 event))) + (when (frame-live-p frame) + (setf (frame-parameter frame 'last-focus-update) nil) + (run-hooks 'focus-out-hook))) + (funcall after-focus-change-function)) (defun handle-move-frame (event) "Handle a move-frame event. @@ -231,10 +316,15 @@ there (in decreasing order of priority)." ;; want to use save-excursion here, because that may also try to set ;; the buffer of the selected window, which fails when the selected ;; window is the minibuffer. - (let ((old-buffer (current-buffer)) - (window-system-frame-alist - (cdr (assq initial-window-system - window-system-default-frame-alist)))) + (let* ((old-buffer (current-buffer)) + (window-system-frame-alist + (cdr (assq initial-window-system + window-system-default-frame-alist))) + (minibuffer + (cdr (or (assq 'minibuffer initial-frame-alist) + (assq 'minibuffer window-system-frame-alist) + (assq 'minibuffer default-frame-alist) + '(minibuffer . t))))) (when (and frame-notice-user-settings (null frame-initial-frame)) @@ -325,11 +415,7 @@ there (in decreasing order of priority)." ;; default-frame-alist in the parameters of the screen we ;; create here, so that its new value, gleaned from the user's ;; init file, will be applied to the existing screen. - (if (not (eq (cdr (or (assq 'minibuffer initial-frame-alist) - (assq 'minibuffer window-system-frame-alist) - (assq 'minibuffer default-frame-alist) - '(minibuffer . t))) - t)) + (if (not (eq minibuffer t)) ;; Create the new frame. (let (parms new) ;; MS-Windows needs this to avoid inflooping below. @@ -357,7 +443,15 @@ there (in decreasing order of priority)." parms nil)) - ;; Get rid of `reverse', because that was handled + (when (eq minibuffer 'child-frame) + ;; When the minibuffer shall be shown in a child frame, + ;; remove the 'minibuffer' parameter from PARMS. It + ;; will get assigned by the usual routines to the child + ;; frame's root window below. + (setq parms (cons '(minibuffer) + (delq (assq 'minibuffer parms) parms)))) + + ;; Get rid of `reverse', because that was handled ;; when we first made the frame. (setq parms (cons '(reverse) (delq (assq 'reverse parms) parms))) @@ -380,7 +474,18 @@ there (in decreasing order of priority)." ;; the only frame with a minibuffer. If it is, create a ;; new one. (or (delq frame-initial-frame (minibuffer-frame-list)) - (make-initial-minibuffer-frame nil)) + (and (eq minibuffer 'child-frame) + ;; Create a minibuffer child frame and parent it + ;; immediately. Take any other parameters for + ;; the child frame from 'minibuffer-frame-list'. + (let* ((minibuffer-frame-alist + (cons `(parent-frame . ,new) minibuffer-frame-alist))) + (make-initial-minibuffer-frame nil) + ;; With a minibuffer child frame we do not want + ;; to select the minibuffer frame initially as + ;; we do for standard minibuffer-only frames. + (select-frame new))) + (make-initial-minibuffer-frame nil)) ;; If the initial frame is serving as a surrogate ;; minibuffer frame for any frames, we need to wean them @@ -559,9 +664,36 @@ Return nil if we don't know how to interpret DISPLAY." (defun make-frame-on-display (display &optional parameters) "Make a frame on display DISPLAY. The optional argument PARAMETERS specifies additional frame parameters." - (interactive "sMake frame on display: ") + (interactive (list (completing-read + (format "Make frame on display: ") + (x-display-list)))) (make-frame (cons (cons 'display display) parameters))) +(defun make-frame-on-monitor (monitor &optional display parameters) + "Make a frame on monitor MONITOR. +The optional argument DISPLAY can be a display name, and the optional +argument PARAMETERS specifies additional frame parameters." + (interactive + (list + (let* ((default (cdr (assq 'name (frame-monitor-attributes))))) + (completing-read + (format "Make frame on monitor (default %s): " default) + (or (delq nil (mapcar (lambda (a) + (cdr (assq 'name a))) + (display-monitor-attributes-list))) + '("")) + nil nil nil nil default)))) + (let* ((monitor-workarea + (catch 'done + (dolist (a (display-monitor-attributes-list display)) + (when (equal (cdr (assq 'name a)) monitor) + (throw 'done (cdr (assq 'workarea a))))))) + (geometry-parameters + (when monitor-workarea + `((top . ,(nth 1 monitor-workarea)) + (left . ,(nth 0 monitor-workarea)))))) + (make-frame (append geometry-parameters parameters)))) + (declare-function x-close-connection "xfns.c" (terminal)) (defun close-display-connection (display) @@ -616,9 +748,6 @@ frame.") (defvar after-setting-font-hook nil "Functions to run after a frame's font has been changed.") -;; Alias, kept temporarily. -(define-obsolete-function-alias 'new-frame 'make-frame "22.1") - (defvar frame-inherited-parameters '() "Parameters `make-frame' copies from the selected to the new frame.") @@ -681,7 +810,7 @@ the new frame according to its own rules." (t window-system))) (oldframe (selected-frame)) (params parameters) - frame) + frame child-frame) (unless (get w 'window-system-initialized) (let ((window-system w)) ;Hack attack! @@ -697,17 +826,44 @@ the new frame according to its own rules." (dolist (p default-frame-alist) (unless (assq (car p) params) (push p params))) - ;; Now make the frame. - (run-hooks 'before-make-frame-hook) ;; (setq frame-size-history '(1000)) - (setq frame (let ((window-system w)) ;Hack attack! + (when (eq (cdr (or (assq 'minibuffer params) '(minibuffer . t))) + 'child-frame) + ;; If the 'minibuffer' parameter equals 'child-frame' make a + ;; frame without minibuffer first using the root window of + ;; 'default-minibuffer-frame' as its minibuffer window + (setq child-frame t) + (setq params (cons '(minibuffer) + (delq (assq 'minibuffer params) params)))) + + ;; Now make the frame. + (run-hooks 'before-make-frame-hook) + + (setq frame (let ((window-system w)) ; Hack attack! (frame-creation-function params))) + + (when child-frame + ;; When we want to equip the new frame with a minibuffer-only + ;; child frame, make that frame and reparent it immediately. + (setq child-frame + (make-frame + (append + `((display . ,display) (minibuffer . only) + (parent-frame . ,frame)) + minibuffer-frame-alist))) + (when (frame-live-p child-frame) + ;; Have the 'minibuffer' parameter of our new frame refer to + ;; its child frame's root window. + (set-frame-parameter + frame 'minibuffer (frame-root-window child-frame)))) + (normal-erase-is-backspace-setup-frame frame) - ;; Inherit the original frame's parameters. + ;; Inherit original frame's parameters unless they are overridden + ;; by explicit parameters. (dolist (param frame-inherited-parameters) - (unless (assq param parameters) ;Overridden by explicit parameters. + (unless (assq param parameters) (let ((val (frame-parameter oldframe param))) (when val (set-frame-parameter frame param val))))) @@ -815,15 +971,16 @@ recently selected windows nor the buffer list." (select-frame frame norecord) (raise-frame frame) ;; Ensure, if possible, that FRAME gets input focus. - (when (memq (window-system frame) '(x w32 ns)) + (when (display-multi-frame-p frame) (x-focus-frame frame)) ;; Move mouse cursor if necessary. (cond (mouse-autoselect-window - (let ((edges (window-inside-edges (frame-selected-window frame)))) + (let ((edges (window-edges (frame-selected-window frame) + t nil t))) ;; Move mouse cursor into FRAME's selected window to avoid that ;; Emacs mouse-autoselects another window. - (set-mouse-position frame (nth 2 edges) (nth 1 edges)))) + (set-mouse-pixel-position frame (1- (nth 2 edges)) (nth 1 edges)))) (focus-follows-mouse ;; Move mouse cursor into FRAME to avoid that another frame gets ;; selected by the window manager. @@ -868,16 +1025,15 @@ that variable should be nil." "Do whatever is right to suspend the current frame. Calls `suspend-emacs' if invoked from the controlling tty device, `suspend-tty' from a secondary tty device, and -`iconify-or-deiconify-frame' from an X frame." +`iconify-or-deiconify-frame' from a graphical frame." (interactive) - (let ((type (framep (selected-frame)))) - (cond - ((memq type '(x ns w32)) (iconify-or-deiconify-frame)) - ((eq type t) - (if (controlling-tty-p) - (suspend-emacs) - (suspend-tty))) - (t (suspend-emacs))))) + (cond + ((display-multi-frame-p) (iconify-or-deiconify-frame)) + ((eq (framep (selected-frame)) t) + (if (controlling-tty-p) + (suspend-emacs) + (suspend-tty))) + (t (suspend-emacs)))) (defun make-frame-names-alist () ;; Only consider the frames on the same display. @@ -958,7 +1114,7 @@ face specs for the new background mode." (default-bg-mode (if (or (window-system frame) (and tty-type - (string-match "^\\(xterm\\|\\rxvt\\|dtterm\\|eterm\\)" + (string-match "^\\(xterm\\|rxvt\\|dtterm\\|eterm\\)" tty-type))) 'light 'dark)) @@ -1005,9 +1161,23 @@ face specs for the new background mode." ;; most faces are unmodified). (dolist (face (face-list)) (and (not (get face 'face-override-spec)) - (not (face-spec-match-p face - (face-user-default-spec face) - (selected-frame))) + (not (and + ;; If the face was not yet realized for the + ;; frame, face-spec-match-p will signal an + ;; error, so treat such a missing face as + ;; having a mismatched spec; the call to + ;; face-spec-recalc below will then realize + ;; the face for the frame. This happens + ;; during startup with -rv on the command + ;; line for the initial frame, because frames + ;; are not recorded in the pdump file. + (assq face (frame-face-alist)) + (face-spec-match-p face + (face-user-default-spec face) + ;; FIXME: why selected-frame and + ;; not the frame that is the + ;; argument to this function? + (selected-frame)))) (push face locally-modified-faces))) ;; Now change to the new frame parameters (modify-frame-parameters frame params) @@ -1149,8 +1319,6 @@ FRAME defaults to the selected frame." (declare-function x-list-fonts "xfaces.c" (pattern &optional face frame maximum width)) -(define-obsolete-function-alias 'set-default-font 'set-frame-font "23.1") - (defun set-frame-font (font &optional keep-size frames) "Set the default font to FONT. When called interactively, prompt for the name of a font, and use @@ -1304,9 +1472,6 @@ To get the frame's current border color, use `frame-parameters'." (define-minor-mode auto-raise-mode "Toggle whether or not selected frames should auto-raise. -With a prefix argument ARG, enable Auto Raise mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Auto Raise mode does nothing under most window managers, which switch focus on mouse clicks. It only has an effect if your @@ -1324,9 +1489,6 @@ often have their own auto-raise feature." (define-minor-mode auto-lower-mode "Toggle whether or not the selected frame should auto-lower. -With a prefix argument ARG, enable Auto Lower mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Auto Lower mode does nothing under most window managers, which switch focus on mouse clicks. It only has an effect if your @@ -1537,7 +1699,10 @@ keys and their meanings." (or frame (setq frame (selected-frame))) (cl-loop for attributes in (display-monitor-attributes-list frame) for frames = (cdr (assq 'frames attributes)) - if (memq frame frames) return attributes)) + if (memq frame frames) return attributes + ;; On broken frames monitor attributes, + ;; fall back to the last monitor. + finally return attributes)) (defun frame-monitor-attribute (attribute &optional frame x y) "Return the value of ATTRIBUTE on FRAME's monitor. @@ -1675,20 +1840,17 @@ for FRAME." (let* ((frame (window-normalize-frame frame)) (root (frame-root-window frame)) (mini (minibuffer-window frame)) - (mini-height-before-size-change 0) + (mini-old-height 0) (mini-height 0)) ;; FRAME's minibuffer window counts iff it's on FRAME and FRAME is ;; not a minibuffer-only frame. (when (and (eq (window-frame mini) frame) (not (eq mini root))) - (setq mini-height-before-size-change - (window-pixel-height-before-size-change mini)) + (setq mini-old-height (window-old-pixel-height mini)) (setq mini-height (window-pixel-height mini))) ;; Return non-nil when either the width of the root or the sum of ;; the heights of root and minibuffer window changed. - (or (/= (window-pixel-width-before-size-change root) - (window-pixel-width root)) - (/= (+ (window-pixel-height-before-size-change root) - mini-height-before-size-change) + (or (/= (window-old-pixel-width root) (window-pixel-width root)) + (/= (+ (window-old-pixel-height root) mini-old-height) (+ (window-pixel-height root) mini-height))))) ;;;; Frame/display capabilities. @@ -1751,6 +1913,7 @@ frame's display)." (fboundp 'image-mask-p) (fboundp 'image-size))) +(defalias 'display-blink-cursor-p 'display-graphic-p) (defalias 'display-multi-frame-p 'display-graphic-p) (defalias 'display-multi-font-p 'display-graphic-p) @@ -1772,6 +1935,16 @@ frame's display)." (t nil)))) +(defun display-symbol-keys-p (&optional display) + "Return non-nil if DISPLAY supports symbol names as keys. +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)) + ;; MS-DOS and MS-Windows terminals have built-in support for + ;; function (symbol) keys + (memq system-type '(ms-dos windows-nt))))) + (declare-function x-display-screens "xfns.c" (&optional terminal)) (defun display-screens (&optional display) @@ -1928,7 +2101,7 @@ If DISPLAY is omitted or nil, it defaults to the selected frame's display." ((eq frame-type 'pc) 4) (t - (truncate (log (length (tty-color-alist)) 2)))))) + (logb (length (tty-color-alist))))))) (declare-function x-display-color-cells "xfns.c" (&optional terminal)) @@ -2125,10 +2298,6 @@ a live frame and defaults to the selected one." (delete-frame this)) (setq this next)))) -;; miscellaneous obsolescence declarations -(define-obsolete-variable-alias 'delete-frame-hook - 'delete-frame-functions "22.1") - ;;; Window dividers. (defgroup window-divider nil @@ -2233,9 +2402,6 @@ all divider widths to zero." (define-minor-mode window-divider-mode "Display dividers between windows (Window Divider mode). -With a prefix argument ARG, enable Window Divider mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. The option `window-divider-default-places' specifies on which side of a window dividers are displayed. The options @@ -2334,7 +2500,6 @@ command starts, by installing a pre-command hook." (blink-cursor-suspend) (add-hook 'post-command-hook 'blink-cursor-check))) - (defun blink-cursor-end () "Stop cursor blinking. This is installed as a pre-command hook by `blink-cursor-start'. @@ -2356,22 +2521,37 @@ frame receives focus." (cancel-timer blink-cursor-idle-timer) (setq blink-cursor-idle-timer nil))) +(defun blink-cursor--should-blink () + "Determine whether we should be blinking. +Returns whether we have any focused non-TTY frame." + (and blink-cursor-mode + (let ((frame-list (frame-list)) + (any-graphical-focused nil)) + (while frame-list + (let ((frame (pop frame-list))) + (when (and (display-graphic-p frame) (frame-focus-state frame)) + (setf any-graphical-focused t) + (setf frame-list nil)))) + any-graphical-focused))) + (defun blink-cursor-check () "Check if cursor blinking shall be restarted. -This is done when a frame gets focus. Blink timers may be stopped by -`blink-cursor-suspend'." - (when (and blink-cursor-mode - (not blink-cursor-idle-timer)) - (remove-hook 'post-command-hook 'blink-cursor-check) - (blink-cursor--start-idle-timer))) - -(define-obsolete-variable-alias 'blink-cursor 'blink-cursor-mode "22.1") +This is done when a frame gets focus. Blink timers may be +stopped by `blink-cursor-suspend'. Internally calls +`blink-cursor--should-blink' and returns its result." + (let ((should-blink (blink-cursor--should-blink))) + (when (and should-blink (not blink-cursor-idle-timer)) + (remove-hook 'post-command-hook 'blink-cursor-check) + (blink-cursor--start-idle-timer)) + should-blink)) + +(defun blink-cursor--rescan-frames (&optional _ign) + "Called when the set of focused frames changes or when we delete a frame." + (unless (blink-cursor-check) + (blink-cursor-suspend))) (define-minor-mode blink-cursor-mode "Toggle cursor blinking (Blink Cursor mode). -With a prefix argument ARG, enable Blink Cursor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. If the value of `blink-cursor-blinks' is positive (10 by default), the cursor stops blinking after that number of blinks, if Emacs @@ -2384,24 +2564,23 @@ terminals, cursor blinking is controlled by the terminal." :init-value (not (or noninteractive no-blinking-cursor (eq system-type 'ms-dos) - (not (memq window-system '(x w32 ns))))) + (not (display-blink-cursor-p)))) :initialize 'custom-initialize-delay :group 'cursor :global t (blink-cursor-suspend) - (remove-hook 'focus-in-hook #'blink-cursor-check) - (remove-hook 'focus-out-hook #'blink-cursor-suspend) + (remove-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames) + (remove-function after-focus-change-function #'blink-cursor--rescan-frames) (when blink-cursor-mode - (add-hook 'focus-in-hook #'blink-cursor-check) - (add-hook 'focus-out-hook #'blink-cursor-suspend) + (add-function :after after-focus-change-function #'blink-cursor--rescan-frames) + (add-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames) (blink-cursor--start-idle-timer))) - ;; Frame maximization/fullscreen -(defun toggle-frame-maximized () - "Toggle maximization state of selected frame. +(defun toggle-frame-maximized (&optional frame) + "Toggle maximization state of FRAME. Maximize selected frame or un-maximize if it is already maximized. If the frame is in fullscreen state, don't change its state, but @@ -2416,19 +2595,19 @@ transitions from one fullscreen state to another. See also `toggle-frame-fullscreen'." (interactive) - (let ((fullscreen (frame-parameter nil 'fullscreen))) + (let ((fullscreen (frame-parameter frame 'fullscreen))) (cond ((memq fullscreen '(fullscreen fullboth)) - (set-frame-parameter nil 'fullscreen-restore 'maximized)) + (set-frame-parameter frame 'fullscreen-restore 'maximized)) ((eq fullscreen 'maximized) - (set-frame-parameter nil 'fullscreen nil)) + (set-frame-parameter frame 'fullscreen nil)) (t - (set-frame-parameter nil 'fullscreen 'maximized))))) + (set-frame-parameter frame 'fullscreen 'maximized))))) -(defun toggle-frame-fullscreen () - "Toggle fullscreen state of selected frame. -Make selected frame fullscreen or restore its previous size if it -is already fullscreen. +(defun toggle-frame-fullscreen (&optional frame) + "Toggle fullscreen state of FRAME. +Make selected frame fullscreen or restore its previous size +if it is already fullscreen. Before making the frame fullscreen remember the current value of the frame's `fullscreen' parameter in the `fullscreen-restore' @@ -2443,18 +2622,19 @@ transitions from one fullscreen state to another. See also `toggle-frame-maximized'." (interactive) - (let ((fullscreen (frame-parameter nil 'fullscreen))) + (let ((fullscreen (frame-parameter frame 'fullscreen))) (if (memq fullscreen '(fullscreen fullboth)) - (let ((fullscreen-restore (frame-parameter nil 'fullscreen-restore))) + (let ((fullscreen-restore (frame-parameter frame 'fullscreen-restore))) (if (memq fullscreen-restore '(maximized fullheight fullwidth)) - (set-frame-parameter nil 'fullscreen fullscreen-restore) - (set-frame-parameter nil 'fullscreen nil))) + (set-frame-parameter frame 'fullscreen fullscreen-restore) + (set-frame-parameter frame 'fullscreen nil))) (modify-frame-parameters - nil `((fullscreen . fullboth) (fullscreen-restore . ,fullscreen)))) + frame `((fullscreen . fullboth) (fullscreen-restore . ,fullscreen)))) ;; Manipulating a frame without waiting for the fullscreen ;; animation to complete can cause a crash, or other unexpected ;; behavior, on macOS (bug#28496). (when (featurep 'cocoa) (sleep-for 0.5)))) + ;;;; Key bindings @@ -2502,6 +2682,9 @@ See also `toggle-frame-maximized'." display-line-numbers-width display-line-numbers-current-absolute display-line-numbers-widen + display-fill-column-indicator + display-fill-column-indicator-column + display-fill-column-indicator-character bidi-paragraph-direction bidi-display-reordering)) diff --git a/lisp/frameset.el b/lisp/frameset.el index 5fdcc0d2c8a..73b2071a5a0 100644 --- a/lisp/frameset.el +++ b/lisp/frameset.el @@ -675,7 +675,7 @@ nil while the filtering is done to restore it." ;; of a frameset, so we must copy parameters to avoid inadvertent ;; modifications. (pcase (cdr (assq (car current) filter-alist)) - (`nil + ('nil (push (if saving current (copy-tree current)) filtered)) (:never nil) @@ -800,22 +800,17 @@ Internal use only." (cons nil (and mb-frame (frameset-frame-id mb-frame))))))))) - ;; Now store text-pixel width and height if it differs from the calculated - ;; width and height and the frame is not fullscreen. + ;; Now store text-pixel width and height if `frame-resize-pixelwise' + ;; is set. (Bug#30141) (dolist (frame frame-list) - (unless (frame-parameter frame 'fullscreen) - (unless (eq (* (frame-parameter frame 'width) - (frame-char-width frame)) - (frame-text-width frame)) - (set-frame-parameter - frame 'frameset--text-pixel-width - (frame-text-width frame))) - (unless (eq (* (frame-parameter frame 'height) - (frame-char-height frame)) - (frame-text-height frame)) - (set-frame-parameter - frame 'frameset--text-pixel-height - (frame-text-height frame)))))) + (when (and frame-resize-pixelwise + (not (frame-parameter frame 'fullscreen))) + (set-frame-parameter + frame 'frameset--text-pixel-width + (frame-text-width frame)) + (set-frame-parameter + frame 'frameset--text-pixel-height + (frame-text-height frame))))) ;;;###autoload (cl-defun frameset-save (frame-list @@ -908,7 +903,7 @@ NOTE: This only works for non-iconified frames." (< fr-right left) (> fr-right right) (< fr-top top) (> fr-top bottom))) ;; Displaced to the left, right, above or below the screen. - (`t (or (> fr-left right) + ('t (or (> fr-left right) (< fr-right left) (> fr-top bottom) (< fr-bottom top))) @@ -975,8 +970,7 @@ is the parameter alist of the frame being restored. Internal use only." ;; that frame has already been loaded (which can happen after ;; M-x desktop-read). (setq frame (frameset--find-frame-if - (lambda (f id) - (frameset-frame-id-equal-p f id)) + #'frameset-frame-id-equal-p display (frameset-cfg-id parameters))) ;; If it has not been loaded, and it is not a minibuffer-only frame, ;; let's look for an existing non-minibuffer-only frame to reuse. @@ -1200,11 +1194,11 @@ All keyword parameters default to nil." ;; will decide which ones can be reused, and how to deal with any leftover. (frameset--reuse-list (pcase reuse-frames - (`t + ('t frames) - (`nil + ('nil nil) - (`match + ('match (cl-loop for (state) in (frameset-states frameset) when (frameset-frame-with-id (frameset-cfg-id state) frames) collect it)) @@ -1355,41 +1349,44 @@ All keyword parameters default to nil." ;; Register support -;;;###autoload -(defun frameset--jump-to-register (data) - "Restore frameset from DATA stored in register. -Called from `jump-to-register'. Internal use only." +(cl-defstruct (frameset-register + (:constructor nil) + (:constructor frameset-make-register (frameset frame-id point))) + frameset frame-id point) + +(cl-defmethod register-val-jump-to ((data frameset-register) arg) (frameset-restore - (aref data 0) + (frameset-register-frameset data) :filters frameset-session-filter-alist - :reuse-frames (if current-prefix-arg t 'match) - :cleanup-frames (if current-prefix-arg + :reuse-frames (if arg t 'match) + :cleanup-frames (if arg ;; delete frames nil ;; iconify frames (lambda (frame action) (pcase action - (`rejected (iconify-frame frame)) + ('rejected (iconify-frame frame)) ;; In the unexpected case that a frame was a candidate ;; (matching frame id) and yet not restored, remove it ;; because it is in fact a duplicate. - (`ignored (delete-frame frame)))))) + ('ignored (delete-frame frame)))))) ;; Restore selected frame, buffer and point. - (let ((frame (frameset-frame-with-id (aref data 1))) + (let ((frame (frameset-frame-with-id (frameset-register-frame-id data))) + (marker (frameset-register-point data)) buffer window) (when frame (select-frame-set-input-focus frame) - (when (and (buffer-live-p (setq buffer (marker-buffer (aref data 2)))) + (when (and (buffer-live-p + (setq buffer (marker-buffer marker))) (window-live-p (setq window (get-buffer-window buffer frame)))) (set-frame-selected-window frame window) - (with-current-buffer buffer (goto-char (aref data 2))))))) + (with-current-buffer buffer (goto-char marker)))))) -;;;###autoload -(defun frameset--print-register (data) +(cl-defmethod register-val-describe ((data frameset-register) _verbose) "Print basic info about frameset stored in DATA. Called from `list-registers' and `view-register'. Internal use only." - (let* ((fs (aref data 0)) + (let* ((fs (frameset-register-frameset data)) (ns (length (frameset-states fs)))) (princ (format "a frameset (%d frame%s, saved on %s)." ns @@ -1405,16 +1402,14 @@ Argument is a character, naming the register. Interactively, reads the register using `register-read-with-preview'." (interactive (list (register-read-with-preview "Frameset to register: "))) (set-register register - (registerv-make - (vector (frameset-save nil - :app 'register - :filters frameset-session-filter-alist) - ;; frameset-save does not include the value of point - ;; in the current buffer, so record that separately. - (frameset-frame-id nil) - (point-marker)) - :print-func #'frameset--print-register - :jump-func #'frameset--jump-to-register))) + (frameset-make-register + (frameset-save nil + :app 'register + :filters frameset-session-filter-alist) + ;; frameset-save does not include the value of point + ;; in the current buffer, so record that separately. + (frameset-frame-id nil) + (point-marker)))) (provide 'frameset) diff --git a/lisp/fringe.el b/lisp/fringe.el index 31d80a8a77d..92387a21571 100644 --- a/lisp/fringe.el +++ b/lisp/fringe.el @@ -1,4 +1,4 @@ -;;; fringe.el --- fringe setup and control +;;; fringe.el --- fringe setup and control -*- lexical-binding:t -*- ;; Copyright (C) 2002-2019 Free Software Foundation, Inc. @@ -291,6 +291,24 @@ SIDE must be the symbol `left' or `right'." 0) (float (frame-char-width)))) +;;;###autoload +(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. +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’, +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 +should be repeated. +If BITMAP already exists, the existing definition is replaced." + ;; This is a fallback for non-GUI builds. + ;; The real implementation is in src/fringe.c. + )) + (provide 'fringe) ;;; fringe.el ends here diff --git a/lisp/generic-x.el b/lisp/generic-x.el index 52d0a19cb06..4ad7379bbc8 100644 --- a/lisp/generic-x.el +++ b/lisp/generic-x.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1997-1998, 2001-2019 Free Software Foundation, Inc. -;; Author: Peter Breton <pbreton@cs.umb.edu> +;; Author: Peter Breton <pbreton@cs.umb.edu> ;; Created: Tue Oct 08 1996 ;; Keywords: generic, comment, font-lock ;; Package: emacs @@ -241,30 +241,11 @@ This hook will be installed if the variable spice-generic-mode) "List of generic modes that are not defined by default.") -(defcustom generic-define-mswindows-modes - (memq system-type '(windows-nt ms-dos)) - "Non-nil means the modes in `generic-mswindows-modes' will be defined. -This is a list of MS-Windows specific generic modes. This variable -only affects the default value of `generic-extras-enable-list'." - :group 'generic-x - :type 'boolean - :version "22.1") -(make-obsolete-variable 'generic-define-mswindows-modes 'generic-extras-enable-list "22.1") - -(defcustom generic-define-unix-modes - (not (memq system-type '(windows-nt ms-dos))) - "Non-nil means the modes in `generic-unix-modes' will be defined. -This is a list of Unix specific generic modes. This variable only -affects the default value of `generic-extras-enable-list'." - :group 'generic-x - :type 'boolean - :version "22.1") -(make-obsolete-variable 'generic-define-unix-modes 'generic-extras-enable-list "22.1") - (defcustom generic-extras-enable-list (append generic-default-modes - (if generic-define-mswindows-modes generic-mswindows-modes) - (if generic-define-unix-modes generic-unix-modes) + (if (memq system-type '(windows-nt ms-dos)) + generic-mswindows-modes + generic-unix-modes) nil) "List of generic modes to define. Each entry in the list should be a symbol. If you set this variable @@ -313,7 +294,7 @@ your changes into effect." nil nil ;; Hostname ? user date request return-code number-of-bytes - '(("^\\([-a-zA-z0-9.]+\\) - [-A-Za-z]+ \\(\\[.*\\]\\)" + '(("^\\([-a-zA-Z0-9.]+\\) - [-A-Za-z]+ \\(\\[.*\\]\\)" (1 font-lock-constant-face) (2 font-lock-variable-name-face))) '("access_log\\'") @@ -1509,7 +1490,8 @@ like an INI file. You can add this hook to `find-file-hook'." '("^\\([^:]+\\):\\([^:]*\\):\\([0-9]+\\):\\(.*\\)$" (1 font-lock-type-face) (4 font-lock-variable-name-face)))) - '("/etc/passwd\\'" "/etc/group\\'") + ;; /etc/passwd- is a backup file for /etc/passwd, so is group- and shadow- + '("/etc/passwd-?\\'" "/etc/group-?\\'" "/etc/shadow-?\\'") (list (function (lambda () @@ -1610,7 +1592,6 @@ like an INI file. You can add this hook to `find-file-hook'." (t (:weight bold))) "Font Lock mode face used to highlight TABs." :group 'generic-x) -(define-obsolete-face-alias 'show-tabs-tab-face 'show-tabs-tab "22.1") (defface show-tabs-space '((((class grayscale) (background light)) (:background "DimGray" :weight bold)) @@ -1620,7 +1601,6 @@ like an INI file. You can add this hook to `find-file-hook'." (t (:weight bold))) "Font Lock mode face used to highlight spaces." :group 'generic-x) -(define-obsolete-face-alias 'show-tabs-space-face 'show-tabs-space "22.1") (define-generic-mode show-tabs-generic-mode nil ;; no comment char diff --git a/lisp/gnus/ChangeLog.1 b/lisp/gnus/ChangeLog.1 index 333da55bd82..7c59bde4914 100644 --- a/lisp/gnus/ChangeLog.1 +++ b/lisp/gnus/ChangeLog.1 @@ -1263,7 +1263,7 @@ * gnus-uu.el (gnus-uu-default-view-rules): make sed kill ^M only at the end of line. -1998-06-05 Hrvoje Niksic <hniksic@srce.hr> +1998-06-05 Hrvoje Nikšić <hniksic@srce.hr> * nnmail.el (nnmail-get-split-group): Don't regexp-quote nnmail-procmail-suffix. @@ -1334,7 +1334,7 @@ * gnus-msg.el (gnus-bug-create-help-buffer): New variable. (gnus-bug): Use it. -1998-05-07 Hrvoje Niksic <hniksic@srce.hr> +1998-05-07 Hrvoje Nikšić <hniksic@srce.hr> * nnmail.el (nnmail-get-split-group): Use `regexp-quote' when file name is a part of pattern. @@ -1346,7 +1346,7 @@ * gnus-score.el (gnus-score-load-file): Use `regexp-quote' when file name is a part of pattern. -1998-05-06 Hrvoje Niksic <hniksic@srce.hr> +1998-05-06 Hrvoje Nikšić <hniksic@srce.hr> * gnus-cache.el (gnus-cache-generate-active): Use `regexp-quote' when file name is a part of pattern. @@ -2169,12 +2169,12 @@ * nnmail.el (nnmail-purge-split-history): Alist; not a list of alists. -1998-02-16 Hrvoje Niksic <hniksic@srce.hr> +1998-02-16 Hrvoje Nikšić <hniksic@srce.hr> * message.el (message-kill-to-signature): Do the right thing when there is no signature. -1998-02-16 Hrvoje Niksic <hniksic@srce.hr> +1998-02-16 Hrvoje Nikšić <hniksic@srce.hr> * message.el (message-elide-elipsis): Add type and group. (message-elide-region): Docfix. @@ -2690,7 +2690,7 @@ * nnml.el (nnml-request-create-group): Check for files. -1997-12-19 Hrvoje Niksic <hniksic@srce.hr> +1997-12-19 Hrvoje Nikšić <hniksic@srce.hr> * message.el (message-mode): Fixed font-lock. @@ -2924,12 +2924,12 @@ * gnus-sum.el (gnus-summary-update-info): Would use wrong group name. -1997-11-26 Hrvoje Niksic <hniksic@srce.hr> +1997-11-26 Hrvoje Nikšić <hniksic@srce.hr> * gnus-spec.el (gnus-compile): Avoid multiple `c*addr's. (gnus-compile): Require `bytecomp'. -1997-11-25 Hrvoje Niksic <hniksic@srce.hr> +1997-11-25 Hrvoje Nikšić <hniksic@srce.hr> * gnus-util.el (gnus-prin1): Bind `print-readably' to t. @@ -3047,13 +3047,13 @@ * nnml.el (nnml-parse-head): Work in empty buffers. -1997-10-14 Hrvoje Niksic <hniksic@srce.hr> +1997-10-14 Hrvoje Nikšić <hniksic@srce.hr> * gnus-xmas.el (gnus-xmas-group-startup-message): Check for image formats correctly. (gnus-xmas-modeline-glyph): Ditto. -1997-11-24 Hrvoje Niksic <hniksic@srce.hr> +1997-11-24 Hrvoje Nikšić <hniksic@srce.hr> * gnus-spec.el (gnus-compile): Work under XEmacs. @@ -3337,7 +3337,7 @@ * gnus-picon.el: Doc fixes. -1997-09-23 Hrvoje Niksic <hniksic@srce.hr> +1997-09-23 Hrvoje Nikšić <hniksic@srce.hr> * gnus.el: Removed definition of `custom-face-lookup'. diff --git a/lisp/gnus/ChangeLog.2 b/lisp/gnus/ChangeLog.2 index bc507d59dc3..fcdc7a899d2 100644 --- a/lisp/gnus/ChangeLog.2 +++ b/lisp/gnus/ChangeLog.2 @@ -6549,12 +6549,12 @@ * nnmail.el (nnmail-split-it): Add tracing to `:' split rule. -2002-08-13 Hrvoje Niksic <hniksic@xemacs.org> +2002-08-13 Hrvoje Nikšić <hniksic@xemacs.org> * mm-decode.el (mm-mailcap-command): Remove the quotes around '%s' and "%s" so we don't overquote them. -2002-08-13 Hrvoje Niksic <hniksic@xemacs.org> +2002-08-13 Hrvoje Nikšić <hniksic@xemacs.org> * (mm-display-external): Display the actual command that has been executed in the echo area. @@ -8654,7 +8654,7 @@ (gnus-summary-news-other-window, gnus-summary-post-news): Bind gnus-article-copy to nil, thereby inhibiting the `header' posting style match to use data from last viewed article. - Suggested by Hrvoje Niksic. + Suggested by Hrvoje Nikšić. 2002-06-04 Katsumi Yamaoka <yamaoka@jpl.org> @@ -9684,7 +9684,7 @@ 2002-02-17 ShengHuo ZHU <zsh@cs.rochester.edu> - Some ideas is inspired by code from Hrvoje Niksic + Some ideas is inspired by code from Hrvoje Nikšić <hniksic@arsdigita.com> * gnus-art.el (gnus-article-wash-function): Set the default to @@ -15154,7 +15154,7 @@ * mm-decode.el (mm-handle-set-external-undisplayer): Don't generate compiler warnings. -2001-06-04 Hrvoje Niksic <hniksic@arsdigita.com> +2001-06-04 Hrvoje Nikšić <hniksic@arsdigita.com> * mm-decode.el (mm-pipe-part): Bind coding-system-for-write to binary so that we don't transmit ISO 2022 garbage to the process. @@ -15339,7 +15339,7 @@ * mm-uu.el (mm-uu-configure-list): Fix customize type. -2001-04-24 Hrvoje Niksic <hniksic@arsdigita.com> +2001-04-24 Hrvoje Nikšić <hniksic@arsdigita.com> * mm-view.el (mm-display-inline-fontify): Allow XEmacs to fully fontify HANDLE. @@ -18253,7 +18253,7 @@ (gnus-set-global-variables): Globalize them. (gnus-summary-exit): Kill them. -2000-11-02 Hrvoje Niksic <hniksic@arsdigita.com> +2000-11-02 Hrvoje Nikšić <hniksic@arsdigita.com> * rfc2047.el (rfc2047-encoded-word-regexp): Allow empty encoded word. diff --git a/lisp/gnus/ChangeLog.3 b/lisp/gnus/ChangeLog.3 index 3bd9f897290..b8070668efd 100644 --- a/lisp/gnus/ChangeLog.3 +++ b/lisp/gnus/ChangeLog.3 @@ -20440,7 +20440,7 @@ * gnus-msg.el (gnus-inews-insert-gcc): Fix the mistake of using list, not listp. -2005-09-02 Hrvoje Niksic <hniksic@xemacs.org> +2005-09-02 Hrvoje Nikšić <hniksic@xemacs.org> * mm-encode.el (mm-encode-content-transfer-encoding): Likewise when encoding. diff --git a/lisp/gnus/canlock.el b/lisp/gnus/canlock.el index 1961a1100be..7edc91a2a46 100644 --- a/lisp/gnus/canlock.el +++ b/lisp/gnus/canlock.el @@ -41,9 +41,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - (require 'sha1) (defvar mail-header-separator) diff --git a/lisp/gnus/deuglify.el b/lisp/gnus/deuglify.el index 35b53af724d..2fdc34e3e18 100644 --- a/lisp/gnus/deuglify.el +++ b/lisp/gnus/deuglify.el @@ -299,8 +299,12 @@ It is run after `gnus-article-prepare-hook'." ;; it. Calling `gnus-article-prepare-display' on an already ;; prepared article removes all MIME parts. I'm unsure whether ;; this is a bug or not. - (gnus-article-highlight t) - (gnus-treat-article nil) + (save-excursion + (save-restriction + (widen) + (article-goto-body) + (narrow-to-region (point) (point-max)) + (gnus-treat-article nil))) (gnus-run-hooks 'gnus-article-prepare-hook 'gnus-outlook-display-hook))) diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 068d8d7c835..40d0d246056 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -31,8 +31,7 @@ (require 'gnus-srvr) (require 'gnus-util) (require 'timer) -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (autoload 'gnus-server-update-server "gnus-srvr") (autoload 'gnus-agent-customize-category "gnus-cus") @@ -226,7 +225,9 @@ NOTES: (defvar gnus-agent-overview-buffer nil) (defvar gnus-category-predicate-cache nil) (defvar gnus-category-group-cache nil) -(defvar gnus-agent-spam-hashtb nil) +(defvar gnus-agent-spam-hashtb nil + "Cache of message subjects for spam messages. +Actually a hash table holding subjects mapped to t.") (defvar gnus-agent-file-name nil) (defvar gnus-agent-file-coding-system 'raw-text) (defvar gnus-agent-file-loading-cache nil) @@ -275,7 +276,7 @@ NOTES: (defmacro gnus-agent-with-refreshed-group (group &rest body) "Performs the body then updates the group's line in the group buffer. Automatically blocks multiple updates due to recursion." -`(prog1 (let ((gnus-agent-inhibit-update-total-fetched-for t)) ,@body) + `(prog1 (let ((gnus-agent-inhibit-update-total-fetched-for t)) ,@body) (when (and gnus-agent-need-update-total-fetched-for (not gnus-agent-inhibit-update-total-fetched-for)) (with-current-buffer gnus-group-buffer @@ -310,9 +311,10 @@ buffer. Automatically blocks multiple updates due to recursion." (defun gnus-agent-cat-set-property (category property value) (if value (setcdr (or (assq property category) - (let ((cell (cons property nil))) + (let ((cell (cons property nil))) (setcdr category (cons cell (cdr category))) - cell)) value) + cell)) + value) (let ((category category)) (while (cond ((eq property (caadr category)) (setcdr category (cddr category)) @@ -332,9 +334,9 @@ manipulated as follows: `(progn (defmacro ,name (category) (list 'cdr (list 'assq '',prop-name category))) - (defsetf ,name (category) (value) - (list 'gnus-agent-cat-set-property - category '',prop-name value)))) + (gv-define-setter ,name (value category) + (list 'gnus-agent-cat-set-property + category '',prop-name value)))) ) (defmacro gnus-agent-cat-name (category) @@ -361,11 +363,7 @@ manipulated as follows: (gnus-agent-cat-defaccessor gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces) - -;; This form may expand to code that uses CL functions at run-time, -;; but that's OK since those functions will only ever be called from -;; something like `setf', so only when CL is loaded anyway. -(defsetf gnus-agent-cat-groups gnus-agent-set-cat-groups) +(gv-define-simple-setter gnus-agent-cat-groups gnus-agent-set-cat-groups) (defun gnus-agent-set-cat-groups (category groups) (unless (eq groups 'ignore) @@ -381,7 +379,8 @@ manipulated as follows: (setcdr (or (assq 'agent-groups category) (let ((cell (cons 'agent-groups nil))) (setcdr category (cons cell (cdr category))) - cell)) new-g)) + cell)) + new-g)) (t (let ((groups groups)) (while groups @@ -398,7 +397,8 @@ manipulated as follows: (setcdr (or (assq 'agent-groups category) (let ((cell (cons 'agent-groups nil))) (setcdr category (cons cell (cdr category))) - cell)) groups)))))) + cell)) + groups)))))) (defsubst gnus-agent-cat-make (name &optional default-agent-predicate) (list name `(agent-predicate . ,(or default-agent-predicate 'false)))) @@ -647,8 +647,8 @@ minor mode in all Gnus buffers." (defun gnus-agent-queue-setup (&optional group-name) "Make sure the queue group exists. Optional arg GROUP-NAME allows another group to be specified." - (unless (gnus-gethash (format "nndraft:%s" (or group-name "queue")) - gnus-newsrc-hashtb) + (unless (gethash (format "nndraft:%s" (or group-name "queue")) + gnus-newsrc-hashtb) (gnus-request-create-group (or group-name "queue") '(nndraft "")) (let ((gnus-level-default-subscribed 1)) (gnus-subscribe-group (format "nndraft:%s" (or group-name "queue")) @@ -1108,7 +1108,7 @@ downloadable." gnus-newsgroup-cached) (setq articles (gnus-sorted-ndifference (gnus-sorted-ndifference - (gnus-copy-sequence articles) + (copy-tree articles) gnus-newsgroup-downloadable) gnus-newsgroup-cached))) @@ -1123,7 +1123,7 @@ downloadable." (when gnus-newsgroup-processable (setq gnus-newsgroup-downloadable (let* ((dl gnus-newsgroup-downloadable) - (processable (sort (gnus-copy-sequence gnus-newsgroup-processable) '<)) + (processable (sort (copy-tree gnus-newsgroup-processable) '<)) (gnus-newsgroup-downloadable processable)) (gnus-agent-summary-fetch-group) @@ -1193,7 +1193,7 @@ This can be added to `gnus-select-article-hook' or ;;; (defun gnus-agent-synchronize-group-flags (group actions server) -"Update a plugged group by performing the indicated actions." + "Update a plugged group by performing the indicated actions." (let* ((gnus-command-method (gnus-server-to-method server)) (info ;; This initializer is required as gnus-request-set-mark @@ -1227,18 +1227,21 @@ This can be added to `gnus-select-article-hook' or ((memq mark '(tick)) (let ((info-marks (assoc mark (gnus-info-marks info)))) (unless info-marks - (gnus-info-set-marks info (cons (setq info-marks (list mark)) (gnus-info-marks info)))) - (setcdr info-marks (funcall (if (eq what 'add) - 'gnus-range-add - 'gnus-remove-from-range) - (cdr info-marks) - range)))))))) - - ;;Marks can be synchronized at any time by simply toggling from - ;;unplugged to plugged. If that is what is happening right now, make - ;;sure that the group buffer is up to date. - (when (gnus-buffer-live-p gnus-group-buffer) - (gnus-group-update-group group t))) + (gnus-info-set-marks + info (cons (setq info-marks (list mark)) + (gnus-info-marks info)))) + (setcdr info-marks + (funcall (if (eq what 'add) + 'gnus-range-add + 'gnus-remove-from-range) + (cdr info-marks) + range)))))))) + + ;; Marks can be synchronized at any time by simply toggling from + ;; unplugged to plugged. If that is what is happening right now, + ;; make sure that the group buffer is up to date. + (when (gnus-buffer-live-p gnus-group-buffer) + (gnus-group-update-group group t))) nil)) (defun gnus-agent-save-active (method &optional groups-p) @@ -1335,11 +1338,11 @@ downloaded into the agent." (when (re-search-forward (concat "^" (regexp-quote group) " ") nil t) (save-excursion - (setq oactive-max (read (current-buffer)) ;; max + (setq oactive-max (read (current-buffer)) ;; max oactive-min (read (current-buffer)))) ;; min (gnus-delete-line))) (when active - (insert (format "%S %d %d y\n" (intern group) + (insert (format "%s %d %d y\n" group (max (or oactive-max (cdr active)) (cdr active)) (min (or oactive-min (car active)) (car active)))) (goto-char (point-max)) @@ -1513,7 +1516,7 @@ downloaded into the agent." (let* ((fetched-articles (list nil)) (tail-fetched-articles fetched-articles) (dir (gnus-agent-group-pathname group)) - (date (time-to-days (current-time))) + (date (time-to-days nil)) (case-fold-search t) pos crosses (file-name-coding-system nnmail-pathname-coding-system)) @@ -1560,11 +1563,8 @@ downloaded into the agent." (skip-chars-forward " ") (setq crosses nil) (while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) *") - (push (cons (buffer-substring (match-beginning 1) - (match-end 1)) - (string-to-number - (buffer-substring (match-beginning 2) - (match-end 2)))) + (push (cons (match-string 1) + (string-to-number (match-string 2))) crosses) (goto-char (match-end 0))) (gnus-agent-crosspost crosses (caar pos) date))) @@ -1608,7 +1608,8 @@ downloaded into the agent." (number-to-string have-this))) (size-file (float (or (and gnus-agent-total-fetched-hashtb - (nth 7 (file-attributes file-name))) + (file-attribute-size + (file-attributes file-name))) 0))) (file-name-coding-system nnmail-pathname-coding-system)) @@ -1908,21 +1909,8 @@ article numbers will be returned." (defsubst gnus-agent-read-article-number () "Reads the article number at point. Returns nil when a valid article number can not be read." - ;; It is unfortunate but the read function quietly overflows - ;; integer. As a result, I have to use string operations to test - ;; for overflow BEFORE calling read. (when (looking-at "[0-9]+\t") - (let ((len (- (match-end 0) (match-beginning 0)))) - (cond ((< len 9) - (read (current-buffer))) - ((= len 9) - ;; Many 9 digit base-10 numbers can be represented in a 27-bit int - ;; Back convert from int to string to ensure that this is one of them. - (let* ((str1 (buffer-substring (match-beginning 0) (1- (match-end 0)))) - (num (read (current-buffer))) - (str2 (int-to-string num))) - (when (equal str1 str2) - num))))))) + (read (current-buffer)))) (defsubst gnus-agent-copy-nov-line (article) "Copy the indicated ARTICLE from the overview buffer to the nntp server buffer." @@ -2101,12 +2089,16 @@ doesn't exist, to valid the overview buffer." (let* (alist (file-name-coding-system nnmail-pathname-coding-system) (file-attributes (directory-files-and-attributes - (gnus-agent-article-name "" - gnus-agent-read-agentview) nil "^[0-9]+$" t))) + (gnus-agent-article-name + "" gnus-agent-read-agentview) + nil "^[0-9]+$" t))) (while file-attributes (let ((fa (pop file-attributes))) - (unless (nth 1 fa) - (push (cons (string-to-number (nth 0 fa)) (time-to-days (nth 5 fa))) alist)))) + (unless (file-attribute-type (cdr fa)) + (push (cons (string-to-number (car fa)) + (time-to-days + (file-attribute-access-time (cdr fa)))) + alist)))) alist) (file-error nil)))))) @@ -2161,7 +2153,10 @@ doesn't exist, to valid the overview buffer." (gnus-agent-update-view-total-fetched-for group nil))) -(defvar gnus-agent-article-local nil) +;; FIXME: Why would this be a hash table? Wouldn't a simple alist or +;; something suffice? +(defvar gnus-agent-article-local nil + "Hashtable holding information about a group.") (defvar gnus-agent-article-local-times nil) (defvar gnus-agent-file-loading-local nil) @@ -2173,14 +2168,14 @@ article counts for each of the method's subscribed groups." (zerop gnus-agent-article-local-times) (not (gnus-methods-equal-p gnus-command-method - (symbol-value (intern "+method" gnus-agent-article-local))))) + (gethash "+method" gnus-agent-article-local)))) (setq gnus-agent-article-local (gnus-cache-file-contents (gnus-agent-lib-file "local") 'gnus-agent-file-loading-local - 'gnus-agent-read-and-cache-local)) + #'gnus-agent-read-and-cache-local)) (when gnus-agent-article-local-times - (incf gnus-agent-article-local-times))) + (cl-incf gnus-agent-article-local-times))) gnus-agent-article-local)) (defun gnus-agent-read-and-cache-local (file) @@ -2188,14 +2183,15 @@ article counts for each of the method's subscribed groups." gnus-agent-article-local. If that variable had `dirty' (also known as modified) original contents, they are first saved to their own file." (if (and gnus-agent-article-local - (symbol-value (intern "+dirty" gnus-agent-article-local))) + (gethash "+dirty" gnus-agent-article-local)) (gnus-agent-save-local)) (gnus-agent-read-local file)) (defun gnus-agent-read-local (file) "Load FILE and do a `read' there." - (let ((my-obarray (gnus-make-hashtable (count-lines (point-min) - (point-max)))) + (let ((hashtb (gnus-make-hashtable + (count-lines (point-min) + (point-max)))) (line 1)) (with-temp-buffer (condition-case nil @@ -2204,7 +2200,8 @@ modified) original contents, they are first saved to their own file." (file-error)) (goto-char (point-min)) - ;; Skip any comments at the beginning of the file (the only place where they may appear) + ;; Skip any comments at the beginning of the file (the only + ;; place where they may appear) (while (= (following-char) ?\;) (forward-line 1) (setq line (1+ line))) @@ -2214,33 +2211,32 @@ modified) original contents, they are first saved to their own file." (let (group min max - (cur (current-buffer)) - (obarray my-obarray)) + (cur (current-buffer))) (setq group (read cur) min (read cur) max (read cur)) - (when (stringp group) - (setq group (intern group my-obarray))) + (unless (stringp group) + (setq group (symbol-name group))) ;; NOTE: The '+ 0' ensure that min and max are both numerics. - (set group (cons (+ 0 min) (+ 0 max)))) + (puthash group (cons (+ 0 min) (+ 0 max)) hashtb)) (error (gnus-message 3 "Warning - invalid agent local: %s on line %d: %s" file line (error-message-string err)))) (forward-line 1) (setq line (1+ line)))) - (set (intern "+dirty" my-obarray) nil) - (set (intern "+method" my-obarray) gnus-command-method) - my-obarray)) + (puthash "+dirty" nil hashtb) + (puthash "+method" gnus-command-method hashtb) + hashtb)) (defun gnus-agent-save-local (&optional force) "Save gnus-agent-article-local under it method's agent.lib directory." - (let ((my-obarray gnus-agent-article-local)) - (when (and my-obarray - (or force (symbol-value (intern "+dirty" my-obarray)))) - (let* ((gnus-command-method (symbol-value (intern "+method" my-obarray))) + (let ((hashtb gnus-agent-article-local)) + (when (and hashtb + (or force (gethash "+dirty" hashtb))) + (let* ((gnus-command-method (gethash "+method" hashtb)) ;; NOTE: gnus-command-method is used within gnus-agent-lib-file. (dest (gnus-agent-lib-file "local"))) (gnus-make-directory (gnus-agent-lib-file "")) @@ -2248,31 +2244,30 @@ modified) original contents, they are first saved to their own file." (let ((coding-system-for-write gnus-agent-file-coding-system) (file-name-coding-system nnmail-pathname-coding-system)) (with-temp-file dest - (let ((gnus-command-method (symbol-value (intern "+method" my-obarray))) + ;; FIXME: Why are we letting this again? + (let ((gnus-command-method (gethash "+method" hashtb)) print-level print-length (standard-output (current-buffer))) - (mapatoms (lambda (symbol) - (cond ((not (boundp symbol)) - nil) - ((member (symbol-name symbol) '("+dirty" "+method")) - nil) - (t - (let ((range (symbol-value symbol))) - (when range - (prin1 symbol) - (princ " ") - (princ (car range)) - (princ " ") - (princ (cdr range)) - (princ "\n")))))) - my-obarray)))))))) + (maphash (lambda (group active) + (cond ((null active) + nil) + ((member group '("+dirty" "+method")) + nil) + (t + (when active + (prin1 group) + (princ " ") + (princ (car active)) + (princ " ") + (princ (cdr active)) + (princ "\n"))))) + hashtb)))))))) (defun gnus-agent-get-local (group &optional gmane method) (let* ((gmane (or gmane (gnus-group-real-name group))) (gnus-command-method (or method (gnus-find-method-for-group group))) (local (gnus-agent-load-local)) - (symb (intern gmane local)) - (minmax (and (boundp symb) (symbol-value symb)))) + (minmax (gethash gmane local))) (unless minmax ;; Bind these so that gnus-agent-load-alist doesn't change the ;; current alist (i.e. gnus-agent-article-alist) @@ -2291,24 +2286,23 @@ modified) original contents, they are first saved to their own file." (let* ((gmane (or gmane (gnus-group-real-name group))) (gnus-command-method (or method (gnus-find-method-for-group group))) (local (or local (gnus-agent-load-local))) - (symb (intern gmane local)) - (minmax (and (boundp symb) (symbol-value symb)))) + (minmax (gethash gmane local))) (if (cond ((and minmax (or (not (eq min (car minmax))) (not (eq max (cdr minmax)))) min max) - (setcar minmax min) - (setcdr minmax max) + (setcar (gethash gmane local) min) + (setcdr (gethash gmane local) max) t) (minmax nil) ((and min max) - (set symb (cons min max)) + (puthash gmane (cons min max) local) t) (t - (unintern symb local))) - (set (intern "+dirty" local) t)))) + (remhash gmane local))) + (puthash "+dirty" t local)))) (defun gnus-agent-article-name (article group) (expand-file-name article @@ -2435,7 +2429,7 @@ modified) original contents, they are first saved to their own file." ;; Parse them and see which articles we want to fetch. (setq gnus-newsgroup-dependencies (or gnus-newsgroup-dependencies - (make-vector (length articles) 0))) + (gnus-make-hashtable (length articles)))) (setq gnus-newsgroup-headers (or gnus-newsgroup-headers (gnus-get-newsgroup-headers-xover articles nil nil @@ -2575,9 +2569,6 @@ modified) original contents, they are first saved to their own file." ;;; Agent Category Mode ;;; -(defvar gnus-category-mode-hook nil - "Hook run in `gnus-category-mode' buffers.") - (defvar gnus-category-line-format " %(%20c%): %g\n" "Format of category lines. @@ -2603,17 +2594,16 @@ General format specifiers can also be used. See Info node (defvar gnus-tmp-groups) (defvar gnus-category-line-format-alist - `((?c gnus-tmp-name ?s) + '((?c gnus-tmp-name ?s) (?g gnus-tmp-groups ?d))) (defvar gnus-category-mode-line-format-alist - `((?u user-defined ?s))) + '((?u user-defined ?s))) (defvar gnus-category-line-format-spec nil) (defvar gnus-category-mode-line-format-spec nil) (defvar gnus-category-mode-map nil) -(put 'gnus-category-mode 'mode-class 'special) (unless gnus-category-mode-map (setq gnus-category-mode-map (make-sparse-keymap)) @@ -2655,9 +2645,8 @@ General format specifiers can also be used. See Info node (gnus-run-hooks 'gnus-category-menu-hook))) -(define-derived-mode gnus-category-mode fundamental-mode "Category" +(define-derived-mode gnus-category-mode gnus-mode "Category" "Major mode for listing and editing agent categories. - All normal editing commands are switched off. \\<gnus-category-mode-map> For more in-depth information on this mode, read the manual @@ -2672,8 +2661,7 @@ The following commands are available: (gnus-set-default-directory) (setq mode-line-process nil) (buffer-disable-undo) - (setq truncate-lines t) - (setq buffer-read-only t)) + (setq truncate-lines t)) (defalias 'gnus-category-position-point 'gnus-goto-colon) @@ -2833,7 +2821,7 @@ The following commands are available: "Copy the current category." (interactive (list (gnus-category-name) (intern (read-string "New name: ")))) (let ((info (assq category gnus-category-alist))) - (push (let ((newcat (gnus-copy-sequence info))) + (push (let ((newcat (copy-tree info))) (setf (gnus-agent-cat-name newcat) to) (setf (gnus-agent-cat-groups newcat) nil) newcat) @@ -2884,8 +2872,8 @@ The following commands are available: nil (let ((string (gnus-simplify-subject (mail-header-subject gnus-headers)))) (prog1 - (gnus-gethash string gnus-agent-spam-hashtb) - (gnus-sethash string t gnus-agent-spam-hashtb))))) + (gethash string gnus-agent-spam-hashtb) + (puthash string t gnus-agent-spam-hashtb))))) (defun gnus-agent-short-p () "Say whether an article is short or not." @@ -2941,7 +2929,7 @@ The following commands are available: 'or) ((memq (car predicate) gnus-category-not) 'not)) - ,@(mapcar 'gnus-category-make-function-1 (cdr predicate)))) + ,@(mapcar #'gnus-category-make-function-1 (cdr predicate)))) (t (error "Unknown predicate type: %s" predicate)))) @@ -2967,7 +2955,7 @@ return read articles, nil when it is known to always return read articles, and t_nil when the function may return both read and unread articles." (let ((func (car function)) - (args (mapcar 'gnus-function-implies-unread-1 (cdr function)))) + (args (mapcar #'gnus-function-implies-unread-1 (cdr function)))) (cond ((eq func 'and) (cond ((memq t args) ; if any argument returns only unread articles ;; then that argument constrains the result to only unread articles. @@ -3013,13 +3001,13 @@ articles." (unless gnus-category-group-cache (setq gnus-category-group-cache (gnus-make-hashtable 1000)) (let ((cs gnus-category-alist) - groups cat) - (while (setq cat (pop cs)) + groups) + (dolist (cat cs) (setq groups (gnus-agent-cat-groups cat)) - (while groups - (gnus-sethash (pop groups) cat gnus-category-group-cache))))) - (or (gnus-gethash group gnus-category-group-cache) - (assq 'default gnus-category-alist))) + (dolist (g groups) + (puthash g cat gnus-category-group-cache))))) + (gethash group gnus-category-group-cache + (assq 'default gnus-category-alist))) (defvar gnus-agent-expire-current-dirs) (defvar gnus-agent-expire-stats) @@ -3059,7 +3047,7 @@ FORCE is equivalent to setting the expiration predicates to true." (count-lines (point-min) (point-max)))))) (save-excursion (gnus-agent-expire-group-1 - group overview (gnus-gethash-safe group orig) + group overview (gethash group orig) articles force)))) (kill-buffer overview)))) (gnus-message 4 "%s" (gnus-agent-expire-done-message))))) @@ -3089,7 +3077,7 @@ FORCE is equivalent to setting the expiration predicates to true." (nov-entries-deleted 0) (info (gnus-get-info group)) (alist gnus-agent-article-alist) - (day (- (time-to-days (current-time)) + (day (- (time-to-days nil) (gnus-agent-find-parameter group 'agent-days-until-old))) (specials (if (and alist (not force)) @@ -3153,38 +3141,37 @@ FORCE is equivalent to setting the expiration predicates to true." (nov-file (concat dir ".overview")) (cnt 0) (completed -1) - dlist - type) - - ;; The normal article alist contains elements that look like - ;; (article# . fetch_date) I need to combine other - ;; information with this list. For example, a flag indicating - ;; that a particular article MUST BE KEPT. To do this, I'm - ;; going to transform the elements to look like (article# - ;; fetch_date keep_flag NOV_entry_position) Later, I'll reverse - ;; the process to generate the expired article alist. - - ;; Convert the alist elements to (article# fetch_date nil - ;; nil). - (setq dlist (mapcar (lambda (e) - (list (car e) (cdr e) nil nil)) alist)) - - ;; Convert the keep lists to elements that look like (article# - ;; nil keep_flag nil) then append it to the expanded dlist - ;; These statements are sorted by ascending precedence of the - ;; keep_flag. - (setq dlist (nconc dlist - (mapcar (lambda (e) - (list e nil 'unread nil)) - unreads))) - (setq dlist (nconc dlist - (mapcar (lambda (e) - (list e nil 'marked nil)) - marked))) - (setq dlist (nconc dlist - (mapcar (lambda (e) - (list e nil 'special nil)) - specials))) + type + + ;; The normal article alist contains elements that look like + ;; (article# . fetch_date) I need to combine other + ;; information with this list. For example, a flag indicating + ;; that a particular article MUST BE KEPT. To do this, I'm + ;; going to transform the elements to look like (article# + ;; fetch_date keep_flag NOV_entry_position) Later, I'll reverse + ;; the process to generate the expired article alist. + (dlist + (nconc + ;; Convert the alist elements to (article# fetch_date nil nil). + (mapcar (lambda (e) + (list (car e) (cdr e) nil nil)) + alist) + + ;; Convert the keep lists to elements that look like (article# + ;; nil keep_flag nil) then append it to the expanded dlist + ;; These statements are sorted by ascending precedence of the + ;; keep_flag. + (mapcar (lambda (e) + (list e nil 'unread nil)) + unreads) + + (mapcar (lambda (e) + (list e nil 'marked nil)) + marked) + + (mapcar (lambda (e) + (list e nil 'special nil)) + specials)))) (set-buffer overview) (erase-buffer) @@ -3352,10 +3339,11 @@ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) (ignore-errors ; Just being paranoid. (let* ((file-name (nnheader-concat dir (number-to-string article-number))) - (size (float (nth 7 (file-attributes file-name))))) - (incf bytes-freed size) - (incf size-files-deleted size) - (incf files-deleted) + (size (float (file-attribute-size + (file-attributes file-name))))) + (cl-incf bytes-freed size) + (cl-incf size-files-deleted size) + (cl-incf files-deleted) (delete-file file-name)) (push "expired cached article" actions)) (setf (nth 1 entry) nil) @@ -3368,13 +3356,13 @@ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) marker (- marker position-offset))) - (incf nov-entries-deleted) + (cl-incf nov-entries-deleted) (let* ((from (point-at-bol)) (to (progn (forward-line 1) (point))) (freed (- to from))) - (incf bytes-freed freed) - (incf position-offset freed) + (cl-incf bytes-freed freed) + (cl-incf position-offset freed) (delete-region from to))) ;; If considering all articles is set, I can only @@ -3392,7 +3380,7 @@ article alist" type) actions)) (when actions (gnus-agent-message 8 "gnus-agent-expire: %s:%d: %s" decoded article-number - (mapconcat 'identity actions ", "))))) + (mapconcat #'identity actions ", "))))) (t (gnus-agent-message 10 "gnus-agent-expire: %s:%d: Article kept as \ @@ -3431,9 +3419,9 @@ expiration tests failed." decoded article-number) (when (boundp 'gnus-agent-expire-stats) (let ((stats gnus-agent-expire-stats)) - (incf (nth 2 stats) bytes-freed) - (incf (nth 1 stats) files-deleted) - (incf (nth 0 stats) nov-entries-deleted))) + (cl-incf (nth 2 stats) bytes-freed) + (cl-incf (nth 1 stats) files-deleted) + (cl-incf (nth 0 stats) nov-entries-deleted))) (gnus-agent-update-files-total-fetched-for group (- size-files-deleted))))))) @@ -3476,9 +3464,7 @@ articles in every agentized group? ")) (count-lines (point-min) (point-max)))))) (dolist (expiring-group (gnus-groups-from-server gnus-command-method)) - (let* ((active - (gnus-gethash-safe expiring-group orig))) - + (let ((active (gethash expiring-group orig))) (when active (save-excursion (gnus-agent-expire-group-1 @@ -3508,83 +3494,80 @@ articles in every agentized group? ")) (defun gnus-agent-expire-unagentized-dirs () (when (and gnus-agent-expire-unagentized-dirs (boundp 'gnus-agent-expire-current-dirs)) - (let* ((keep (gnus-make-hashtable)) - (file-name-coding-system nnmail-pathname-coding-system)) - - (gnus-sethash gnus-agent-directory t keep) + (let ((file-name-coding-system nnmail-pathname-coding-system) + ;; Another hash table that could just be a list. + (keep (gnus-make-hashtable 20)) + to-remove) + (puthash gnus-agent-directory t keep) (dolist (dir gnus-agent-expire-current-dirs) (when (and (stringp dir) (file-directory-p dir)) - (while (not (gnus-gethash dir keep)) - (gnus-sethash dir t keep) + (while (not (gethash dir keep)) + (puthash dir t keep) (setq dir (file-name-directory (directory-file-name dir)))))) - (let* (to-remove - checker - (checker - (function - (lambda (d) - "Given a directory, check it and its subdirectories for - membership in the keep hash. If it isn't found, add - it to to-remove." - (let ((files (directory-files d)) - file) - (while (setq file (pop files)) - (cond ((equal file ".") ; Ignore self - nil) - ((equal file "..") ; Ignore parent - nil) - ((equal file ".overview") - ;; Directory must contain .overview to be - ;; agent's cache of a group. - (let ((d (file-name-as-directory d)) - r) - ;; Search ancestor's for last directory NOT - ;; found in keep hash. - (while (not (gnus-gethash - (setq d (file-name-directory d)) keep)) - (setq r d - d (directory-file-name d))) - ;; if ANY ancestor was NOT in keep hash and - ;; it's not already in to-remove, add it to - ;; to-remove. - (if (and r - (not (member r to-remove))) - (push r to-remove)))) - ((file-directory-p (setq file (nnheader-concat d file))) - (funcall checker file))))))))) - (funcall checker (expand-file-name gnus-agent-directory)) - - (when (and to-remove - (or gnus-expert-user - (gnus-y-or-n-p - "gnus-agent-expire has identified local directories that are\ + (cl-labels ((checker + (d) + ;; Given a directory, check it and its subdirectories + ;; for membership in the keep list. If it isn't found, + ;; add it to to-remove. + (let ((files (directory-files d)) + file) + (while (setq file (pop files)) + (cond ((equal file ".") ; Ignore self + nil) + ((equal file "..") ; Ignore parent + nil) + ((equal file ".overview") + ;; Directory must contain .overview to be + ;; agent's cache of a group. + (let ((d (file-name-as-directory d)) + r) + ;; Search ancestors for last directory NOT + ;; found in keep. + (while (not (gethash (setq d (file-name-directory d)) keep)) + (setq r d + d (directory-file-name d))) + ;; if ANY ancestor was NOT in keep hash and + ;; it's not already in to-remove, add it to + ;; to-remove. + (if (and r + (not (member r to-remove))) + (push r to-remove)))) + ((file-directory-p (setq file (nnheader-concat d file))) + (checker file))))))) + (checker (expand-file-name gnus-agent-directory))) + + (when (and to-remove + (or gnus-expert-user + (gnus-y-or-n-p + "gnus-agent-expire has identified local directories that are\ not currently required by any agentized group. Do you wish to consider\ deleting them?"))) - (while to-remove - (let ((dir (pop to-remove))) - (if (or gnus-expert-user - (gnus-y-or-n-p (format "Delete %s? " dir))) - (let* (delete-recursive - files f - (delete-recursive - (function - (lambda (f-or-d) - (ignore-errors - (if (file-directory-p f-or-d) - (condition-case nil - (delete-directory f-or-d) - (file-error - (setq files (directory-files f-or-d)) - (while files - (setq f (pop files)) - (or (member f '("." "..")) - (funcall delete-recursive - (nnheader-concat - f-or-d f)))) - (delete-directory f-or-d))) - (delete-file f-or-d))))))) - (funcall delete-recursive dir)))))))))) + (while to-remove + (let ((dir (pop to-remove))) + (if (or gnus-expert-user + (gnus-y-or-n-p (format "Delete %s? " dir))) + (let* (delete-recursive + files f + (delete-recursive + (function + (lambda (f-or-d) + (ignore-errors + (if (file-directory-p f-or-d) + (condition-case nil + (delete-directory f-or-d) + (file-error + (setq files (directory-files f-or-d)) + (while files + (setq f (pop files)) + (or (member f '("." "..")) + (funcall delete-recursive + (nnheader-concat + f-or-d f)))) + (delete-directory f-or-d))) + (delete-file f-or-d))))))) + (funcall delete-recursive dir))))))))) ;;;###autoload (defun gnus-agent-batch () @@ -3630,7 +3613,7 @@ If CACHED-HEADER is nil, articles are only excluded if the article itself has been fetched." ;; Logically equivalent to: (gnus-sorted-difference articles (mapcar - ;; 'car gnus-agent-article-alist)) + ;; #'car gnus-agent-article-alist)) ;; Functionally, I don't need to construct a temp list using mapcar. @@ -3805,7 +3788,7 @@ has been fetched." (buffer-read-only nil) (file-name-coding-system nnmail-pathname-coding-system)) (when (and (file-exists-p file) - (> (nth 7 (file-attributes file)) 0)) + (> (file-attribute-size (file-attributes file)) 0)) (erase-buffer) (gnus-kill-all-overlays) (let ((coding-system-for-read gnus-cache-coding-system)) @@ -3824,7 +3807,7 @@ has been fetched." ;; be expired later. (gnus-agent-load-alist group) (gnus-agent-save-alist group (list article) - (time-to-days (current-time)))))) + (time-to-days nil))))) (defun gnus-agent-regenerate-group (group &optional reread) "Regenerate GROUP. @@ -3936,7 +3919,7 @@ If REREAD is not nil, downloaded articles are marked as unread." (nnheader-insert-file-contents file) (nnheader-remove-body) (setq header (nnheader-parse-naked-head))) - (mail-header-set-number header (car downloaded)) + (setf (mail-header-number header) (car downloaded)) (if nov-arts (let ((key (concat "^" (int-to-string (car nov-arts)) "\t"))) @@ -3950,9 +3933,11 @@ If REREAD is not nil, downloaded articles are marked as unread." ;; This entry in the overview has been downloaded (push (cons (car downloaded) (time-to-days - (nth 5 (file-attributes - (concat dir (number-to-string - (car downloaded))))))) alist) + (file-attribute-modification-time + (file-attributes + (concat dir (number-to-string + (car downloaded))))))) + alist) (setq downloaded (cdr downloaded)) (setq nov-arts (cdr nov-arts))) (t @@ -4100,8 +4085,8 @@ agent has fetched." ;; if null, gnus-agent-group-pathname will calc method. (let* ((gnus-command-method method) (path (or path (gnus-agent-group-pathname group))) - (entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb) - (gnus-sethash path (make-list 3 0) + (entry (or (gethash path gnus-agent-total-fetched-hashtb) + (puthash path (make-list 3 0) gnus-agent-total-fetched-hashtb))) (file-name-coding-system nnmail-pathname-coding-system)) (when (file-exists-p path) @@ -4110,26 +4095,28 @@ agent has fetched." (let ((sum 0.0) file) (while (setq file (pop delta)) - (incf sum (float (or (nth 7 (file-attributes - (nnheader-concat - path - (if (numberp file) - (number-to-string file) - file)))) 0)))) + (cl-incf sum (float (or (file-attribute-size + (file-attributes + (nnheader-concat + path + (if (numberp file) + (number-to-string file) + file)))) + 0)))) (setq delta sum)) (let ((sum (- (nth 2 entry))) (info (directory-files-and-attributes path nil "^-?[0-9]+$" t)) file) (while (setq file (pop info)) - (incf sum (float (or (nth 8 file) 0)))) + (cl-incf sum (float (or (file-attribute-size (cdr file)) 0)))) (setq delta sum)))) (setq gnus-agent-need-update-total-fetched-for t) - (incf (nth 2 entry) delta)))))) + (cl-incf (nth 2 entry) delta)))))) (defun gnus-agent-update-view-total-fetched-for - (group agent-over &optional method path) + (group agent-over &optional method path) "Update, or set, the total disk space used by the .agentview and .overview files. These files are calculated separately as they can be modified." @@ -4139,15 +4126,15 @@ modified." ;; if null, gnus-agent-group-pathname will calc method. (let* ((gnus-command-method method) (path (or path (gnus-agent-group-pathname group))) - (entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb) - (gnus-sethash path (make-list 3 0) - gnus-agent-total-fetched-hashtb))) + (entry (or (gethash path gnus-agent-total-fetched-hashtb) + (puthash path (make-list 3 0) + gnus-agent-total-fetched-hashtb))) (file-name-coding-system nnmail-pathname-coding-system) - (size (or (nth 7 (file-attributes - (nnheader-concat - path (if agent-over - ".overview" - ".agentview")))) + (size (or (file-attribute-size (file-attributes + (nnheader-concat + path (if agent-over + ".overview" + ".agentview")))) 0))) (setq gnus-agent-need-update-total-fetched-for t) (setf (nth (if agent-over 1 0) entry) size))))) @@ -4156,12 +4143,13 @@ modified." "Get the total disk space used by the specified GROUP." (unless (equal group "dummy.group") (unless gnus-agent-total-fetched-hashtb - (setq gnus-agent-total-fetched-hashtb (gnus-make-hashtable 1024))) + (setq gnus-agent-total-fetched-hashtb + (gnus-make-hashtable 1000))) ;; if null, gnus-agent-group-pathname will calc method. (let* ((gnus-command-method method) (path (gnus-agent-group-pathname group)) - (entry (gnus-gethash path gnus-agent-total-fetched-hashtb))) + (entry (gethash path gnus-agent-total-fetched-hashtb))) (if entry (apply '+ entry) (let ((gnus-agent-inhibit-update-total-fetched-for (not no-inhibit))) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 4eb6249490e..8f5a313c618 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -24,8 +24,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defvar tool-bar-map) (defvar w3m-minor-mode-map) @@ -42,6 +41,7 @@ (require 'mm-uu) (require 'message) (require 'mouse) +(require 'seq) (autoload 'gnus-msg-mail "gnus-msg" nil t) (autoload 'gnus-button-mailto "gnus-msg") @@ -199,9 +199,9 @@ Possible values in this list are: `newsgroups' Newsgroup identical to Gnus group. `to-address' To identical to To-address. `to-list' To identical to To-list. - `cc-list' CC identical to To-list. - `followup-to' Followup-to identical to Newsgroups. - `reply-to' Reply-to identical to From. + `cc-list' Cc identical to To-list. + `followup-to' Followup-To identical to Newsgroups. + `reply-to' Reply-To identical to From. `date' Date less than four days old. `long-to' To and/or Cc longer than 1024 characters. `many-to' Multiple To and/or Cc." @@ -209,9 +209,9 @@ Possible values in this list are: (const :tag "Newsgroups identical to Gnus group." newsgroups) (const :tag "To identical to To-address." to-address) (const :tag "To identical to To-list." to-list) - (const :tag "CC identical to To-list." cc-list) - (const :tag "Followup-to identical to Newsgroups." followup-to) - (const :tag "Reply-to identical to From." reply-to) + (const :tag "Cc identical to To-list." cc-list) + (const :tag "Followup-To identical to Newsgroups." followup-to) + (const :tag "Reply-To identical to From." reply-to) (const :tag "Date less than four days old." date) (const :tag "To and/or Cc longer than 1024 characters." long-to) (const :tag "Multiple To and/or Cc headers." many-to)) @@ -279,7 +279,7 @@ This can also be a list of the above values." "String or function to be executed to display an X-Face header. If it is a string, the command will be executed in a sub-shell asynchronously. The compressed face will be piped to this command." - :type `(choice string + :type '(choice string (function-item gnus-display-x-face-in-from) function) :version "21.1" @@ -436,10 +436,10 @@ is the face used for highlighting." :on " On " :off " Off ") face))) :get (lambda (symbol) - (mapcar 'gnus-emphasis-custom-value-to-internal + (mapcar #'gnus-emphasis-custom-value-to-internal (default-value symbol))) :set (lambda (symbol value) - (set-default symbol (mapcar 'gnus-emphasis-custom-value-to-external + (set-default symbol (mapcar #'gnus-emphasis-custom-value-to-external value))) :group 'gnus-article-emphasis) @@ -761,9 +761,6 @@ Obsolete; use the face `gnus-signature' for customizations instead." "Face used for highlighting a signature in the article buffer." :group 'gnus-article-highlight :group 'gnus-article-signature) -;; backward-compatibility alias -(put 'gnus-signature-face 'face-alias 'gnus-signature) -(put 'gnus-signature-face 'obsolete-face "22.1") (defface gnus-header-from '((((class color) @@ -777,9 +774,6 @@ Obsolete; use the face `gnus-signature' for customizations instead." "Face used for displaying from headers." :group 'gnus-article-headers :group 'gnus-article-highlight) -;; backward-compatibility alias -(put 'gnus-header-from-face 'face-alias 'gnus-header-from) -(put 'gnus-header-from-face 'obsolete-face "22.1") (defface gnus-header-subject '((((class color) @@ -793,9 +787,6 @@ Obsolete; use the face `gnus-signature' for customizations instead." "Face used for displaying subject headers." :group 'gnus-article-headers :group 'gnus-article-highlight) -;; backward-compatibility alias -(put 'gnus-header-subject-face 'face-alias 'gnus-header-subject) -(put 'gnus-header-subject-face 'obsolete-face "22.1") (defface gnus-header-newsgroups '((((class color) @@ -811,9 +802,6 @@ In the default setup this face is only used for crossposted articles." :group 'gnus-article-headers :group 'gnus-article-highlight) -;; backward-compatibility alias -(put 'gnus-header-newsgroups-face 'face-alias 'gnus-header-newsgroups) -(put 'gnus-header-newsgroups-face 'obsolete-face "22.1") (defface gnus-header-name '((((class color) @@ -827,9 +815,6 @@ articles." "Face used for displaying header names." :group 'gnus-article-headers :group 'gnus-article-highlight) -;; backward-compatibility alias -(put 'gnus-header-name-face 'face-alias 'gnus-header-name) -(put 'gnus-header-name-face 'obsolete-face "22.1") (defface gnus-header-content '((((class color) @@ -842,9 +827,6 @@ articles." (:italic t))) "Face used for displaying header content." :group 'gnus-article-headers :group 'gnus-article-highlight) -;; backward-compatibility alias -(put 'gnus-header-content-face 'face-alias 'gnus-header-content) -(put 'gnus-header-content-face 'obsolete-face "22.1") (defcustom gnus-header-face-alist '(("From" nil gnus-header-from) @@ -1017,6 +999,7 @@ on parts -- for instance, adding Vcard info to a database." Valid formats are `ut' (Universal Time), `local' (local time zone), `english' (readable English), `lapsed' (elapsed time), `combined-lapsed' (both the original date and the elapsed time), +`combined-local-lapsed' (both the local time and the elapsed time), `original' (the original date header), `iso8601' (ISO8601 format), and `user-defined' (a user-defined format defined by the `gnus-article-time-format' variable). @@ -1032,6 +1015,7 @@ Some of these headers are updated automatically. See (const :tag "Readable English" english) (const :tag "Elapsed time" lapsed) (const :tag "Original and elapsed time" combined-lapsed) + (const :tag "Local and elapsed time" combined-local-lapsed) (const :tag "Original date header" original) (const :tag "ISO8601 format" iso8601) (const :tag "User-defined" user-defined))) @@ -1645,6 +1629,12 @@ resources when reading email groups (and therefore stops tracking), but allows loading external resources when reading from NNTP newsgroups and the like. +People controlling these external resources won't be able to tell +that any one person in particular has read the message (since +it's in a public venue, many people will end up loading that +resource), but they'll be able to tell that somebody from your IP +address has accessed the resource. + This can also be a function to be evaluated. If so, it will be called with the group name as the parameter, and should return a regexp." @@ -1826,7 +1816,7 @@ Initialized from `text-mode-syntax-table'.") (if (looking-at (car list)) (setq list nil) (setq list (cdr list)) - (incf i))) + (cl-incf i))) i)) (defun article-hide-headers (&optional _arg _delete) @@ -1851,14 +1841,14 @@ Initialized from `text-mode-syntax-table'.") (cond ((stringp gnus-ignored-headers) gnus-ignored-headers) ((listp gnus-ignored-headers) - (mapconcat 'identity + (mapconcat #'identity gnus-ignored-headers "\\|")))) visible (cond ((stringp gnus-visible-headers) gnus-visible-headers) ((and gnus-visible-headers (listp gnus-visible-headers)) - (mapconcat 'identity + (mapconcat #'identity gnus-visible-headers "\\|"))))) (set-buffer cur)) @@ -1966,7 +1956,7 @@ always hide." (when (and cc to-list (ignore-errors (gnus-string-equal - ;; only one address in CC + ;; only one address in Cc (nth 1 (mail-extract-address-components cc)) to-list))) (gnus-article-hide-header "cc")))) @@ -1989,11 +1979,11 @@ always hide." (sort (mapcar (lambda (x) (downcase (cadr x))) (mail-extract-address-components from t)) - 'string<) + #'string<) (sort (mapcar (lambda (x) (downcase (cadr x))) (mail-extract-address-components reply-to t)) - 'string<)))) + #'string<)))) (gnus-article-hide-header "reply-to"))))) ((eq elem 'date) (let ((date (with-current-buffer gnus-original-article-buffer @@ -2236,7 +2226,7 @@ unfolded." (dolist (elem gnus-article-image-alist) (gnus-delete-images (car elem)))))) -(autoload 'w3m-toggle-inline-images "w3m") +(declare-function w3m-toggle-inline-images "w3m") (defun gnus-article-show-images () "Show any images that are in the HTML-rendered article buffer. @@ -2246,10 +2236,12 @@ This only works if the article in question is HTML." (save-restriction (widen) (if (eq mm-text-html-renderer 'w3m) - (w3m-toggle-inline-images) + (progn + (require 'w3m) + (w3m-toggle-inline-images)) (dolist (region (gnus-find-text-property-region (point-min) (point-max) 'image-displayer)) - (destructuring-bind (start end function) region + (cl-destructuring-bind (start end function) region (funcall function (get-text-property start 'image-url) start end))))))) @@ -2415,7 +2407,7 @@ long lines if and only if arg is positive." (while faces (when (setq png (gnus-convert-face-to-png (pop faces))) (setq image - (apply 'gnus-create-image png 'png t + (apply #'gnus-create-image png 'png t (cdr (assq 'png gnus-face-properties-alist)))) (goto-char from) (when image @@ -2946,7 +2938,8 @@ message header will be added to the bodies of the \"text/html\" parts." (encode-coding-string title coding)) body content)) - (setq eheader (string-as-unibyte (buffer-string)) + (setq eheader (encode-coding-string + (buffer-string) 'utf-8) body content))) (erase-buffer) (mm-disable-multibyte) @@ -3029,9 +3022,6 @@ articles to verify whether you have read the message. As browser without eliminating these \"web bugs\" you should only use it for mails from trusted senders. -If you always want to display HTML parts in the browser, set -`mm-text-html-renderer' to nil. - This command creates temporary files to pass HTML contents including images if any to the browser, and deletes them when exiting the group \(if you want)." @@ -3540,10 +3530,28 @@ possible values." (put-text-property (match-beginning 1) (match-end 1) 'face eface))))))) +(defun article-make-date-combine-with-lapsed (date time type) + "Return type of date with lapsed time added." + (let ((date-string (article-make-date-line date type)) + (segments 3) + lapsed-string) + (while (and + time + (setq lapsed-string + (concat " (" (article-lapsed-string time segments) ")")) + (> (+ (length date-string) + (length lapsed-string)) + (+ fill-column 6)) + (> segments 0)) + (setq segments (1- segments))) + (if (> segments 0) + (concat date-string lapsed-string) + date-string))) + (defun article-make-date-line (date type) "Return a DATE line of TYPE." (unless (memq type '(local ut original user-defined iso8601 lapsed english - combined-lapsed)) + combined-lapsed combined-local-lapsed)) (error "Unknown conversion type: %s" type)) (condition-case () (let ((time (ignore-errors (date-to-time date)))) @@ -3553,18 +3561,11 @@ possible values." (concat "Date: " (message-make-date time))) ;; Convert to Universal Time. ((eq type 'ut) - (concat "Date: " - (substring - (message-make-date - (let* ((e (parse-time-string date)) - (tm (apply 'encode-time e)) - (ms (car tm)) - (ls (- (cadr tm) (car (current-time-zone time))))) - (cond ((< ls 0) (list (1- ms) (+ ls 65536))) - ((> ls 65535) (list (1+ ms) (- ls 65536))) - (t (list ms ls))))) - 0 -5) - "UT")) + (let ((system-time-locale "C")) + (format-time-string + "Date: %a, %d %b %Y %T UT" + (encode-time (parse-time-string date)) + t))) ;; Get the original date from the article. ((eq type 'original) (concat "Date: " (if (string-match "\n+$" date) @@ -3582,73 +3583,51 @@ possible values." (concat "Date: " (format-time-string format time))))) ;; ISO 8601. ((eq type 'iso8601) - (let ((tz (car (current-time-zone time)))) - (concat - "Date: " - (format-time-string "%Y%m%dT%H%M%S" time) - (format "%s%02d%02d" - (if (> tz 0) "+" "-") (/ (abs tz) 3600) - (/ (% (abs tz) 3600) 60))))) + (format-time-string "Date: %Y%m%dT%H%M%S%z" time)) ;; Do a lapsed format. ((eq type 'lapsed) (concat "Date: " (article-lapsed-string time))) ;; A combined date/lapsed format. ((eq type 'combined-lapsed) - (let ((date-string (article-make-date-line date 'original)) - (segments 3) - lapsed-string) - (while (and - time - (setq lapsed-string - (concat " (" (article-lapsed-string time segments) ")")) - (> (+ (length date-string) - (length lapsed-string)) - (+ fill-column 6)) - (> segments 0)) - (setq segments (1- segments))) - (if (> segments 0) - (concat date-string lapsed-string) - date-string))) + (article-make-date-combine-with-lapsed date time 'original)) + ;; A combined local/lapsed format. + ((eq type 'combined-local-lapsed) + (article-make-date-combine-with-lapsed date time 'local)) ;; Display the date in proper English ((eq type 'english) (let ((dtime (decode-time time))) (concat "Date: the " - (number-to-string (nth 3 dtime)) - (let ((digit (% (nth 3 dtime) 10))) + (number-to-string (decoded-time-day dtime)) + (let ((digit (% (decoded-time-day dtime) 10))) (cond - ((memq (nth 3 dtime) '(11 12 13)) "th") + ((memq (decoded-time-day dtime) '(11 12 13)) "th") ((= digit 1) "st") ((= digit 2) "nd") ((= digit 3) "rd") (t "th"))) " of " - (nth (1- (nth 4 dtime)) gnus-english-month-names) + (nth (1- (decoded-time-month dtime)) gnus-english-month-names) " " - (number-to-string (nth 5 dtime)) + (number-to-string (decoded-time-year dtime)) " at " - (format "%02d" (nth 2 dtime)) + (format "%02d" (decoded-time-hour dtime)) ":" - (format "%02d" (nth 1 dtime))))))) + (format "%02d" (decoded-time-minute dtime))))))) (foo (format "Date: %s (from Gnus)" date)))) (defun article-lapsed-string (time &optional max-segments) ;; If the date is seriously mangled, the timezone functions are ;; liable to bug out, so we ignore all errors. - (let* ((now (current-time)) - (real-time (time-subtract now time)) - (real-sec (and real-time - (+ (* (float (car real-time)) 65536) - (cadr real-time)))) - (sec (and real-time (abs real-sec))) + (let* ((real-time (time-since time)) + (real-sec (float-time real-time)) + (sec (abs real-sec)) (segments 0) num prev) (unless max-segments (setq max-segments (length article-time-units))) (cond - ((null real-time) - "Unknown") ((zerop sec) "Now") (t @@ -3764,7 +3743,7 @@ is to run." "Stop the Date timer." (interactive) (when article-lapsed-timer - (nnheader-cancel-timer article-lapsed-timer) + (cancel-timer article-lapsed-timer) (setq article-lapsed-timer nil))) (defun article-date-user (&optional highlight) @@ -4133,7 +4112,7 @@ and the raw article including all headers will be piped." (get 'gnus-summary-save-in-pipe :decode))) save-buffer default) (if article - (if (vectorp (gnus-summary-article-header article)) + (if (mail-header-p (gnus-summary-article-header article)) (save-current-buffer (gnus-summary-select-article decode decode nil article) (insert-buffer-substring @@ -4285,7 +4264,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is (forward-line)) (insert "\n-----BEGIN PGP SIGNATURE-----\n") (insert "Version: " (car items) "\n\n") - (insert (mapconcat 'identity (cddr items) "\n")) + (insert (mapconcat #'identity (cddr items) "\n")) (insert "\n-----END PGP SIGNATURE-----\n") (let ((mm-security-handle (list (format "multipart/signed")))) (mml2015-clean-buffer) @@ -4348,7 +4327,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is (with-current-buffer gnus-article-buffer (if interactive (call-interactively ',afunc) - (apply ',afunc args)))))))) + (apply #',afunc args)))))))) '(article-hide-headers article-verify-x-pgp-sig article-verify-cancel-lock @@ -4402,9 +4381,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is ;;; Gnus article mode ;;; -(put 'gnus-article-mode 'mode-class 'special) - -(set-keymap-parent gnus-article-mode-map widget-keymap) +(set-keymap-parent gnus-article-mode-map button-buffer-map) (gnus-define-keys gnus-article-mode-map " " gnus-article-goto-next-page @@ -4481,9 +4458,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is (defvar bookmark-make-record-function) (defvar shr-put-image-function) -(define-derived-mode gnus-article-mode fundamental-mode "Article" +(define-derived-mode gnus-article-mode gnus-mode "Article" "Major mode for displaying an article. - All normal editing commands are switched off. The following commands are available in addition to all summary mode @@ -4524,8 +4500,7 @@ commands: (setq cursor-in-non-selected-windows nil)) (gnus-set-default-directory) (buffer-disable-undo) - (setq buffer-read-only t - show-trailing-whitespace nil) + (setq show-trailing-whitespace nil) (mm-enable-multibyte)) (defun gnus-article-setup-buffer () @@ -4593,10 +4568,7 @@ commands: (current-buffer)))))) (defun gnus-article-stop-animations () - (dolist (timer (and (boundp 'timer-list) - timer-list)) - (when (eq (timer--function timer) 'image-animate-timeout) - (cancel-timer timer)))) + (cancel-function-timers 'image-animate-timeout)) (defun gnus-stop-downloads () (when (boundp 'url-queue) @@ -4691,7 +4663,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-summary-article-header gnus-current-article) gnus-article-current (cons gnus-newsgroup-name gnus-current-article)) - (unless (vectorp gnus-current-headers) + (unless (mail-header-p gnus-current-headers) (setq gnus-current-headers nil)) (gnus-summary-goto-subject gnus-current-article) (when (gnus-summary-show-thread) @@ -4725,6 +4697,11 @@ If ALL-HEADERS is non-nil, no headers are hidden." (forward-line -1)) (set-window-point (get-buffer-window (current-buffer)) (point)) (gnus-configure-windows 'article) + ;; Make sure the article begins with the top of the header. + (let ((window (get-buffer-window gnus-article-buffer))) + (when window + (with-current-buffer (window-buffer window) + (set-window-point window (point-min))))) (gnus-run-hooks 'gnus-article-prepare-hook) t)))))) @@ -4828,11 +4805,10 @@ If a prefix ARG is given, ask for confirmation." (interactive "P") (dolist (buf (gnus-buffers)) (with-current-buffer buf - (when (derived-mode-p 'gnus-sticky-article-mode) - (if (not arg) - (gnus-kill-buffer buf) - (when (yes-or-no-p (concat "Kill buffer " (buffer-name buf) "? ")) - (gnus-kill-buffer buf))))))) + (and (derived-mode-p 'gnus-sticky-article-mode) + (or (not arg) + (yes-or-no-p (format "Kill buffer %s? " buf))) + (gnus-kill-buffer buf))))) ;;; ;;; Gnus MIME viewing functions @@ -4898,6 +4874,7 @@ General format specifiers can also be used. See Info node (defvar gnus-mime-button-map (let ((map (make-sparse-keymap))) + (define-key map "\r" 'gnus-article-push-button) (define-key map [mouse-2] 'gnus-article-push-button) (define-key map [down-mouse-3] 'gnus-mime-button-menu) (dolist (c gnus-mime-button-commands) @@ -4912,7 +4889,9 @@ General format specifiers can also be used. See Info node gnus-mime-button-commands))) (defvar gnus-url-button-commands - '((gnus-article-copy-string "u" "Copy URL to kill ring"))) + '((gnus-article-copy-string "u" "Copy URL to kill ring") + (push-button "\r" "Push the button") + (push-button [mouse-2] "Push the button"))) (defvar gnus-url-button-map (let ((map (make-sparse-keymap))) @@ -5168,7 +5147,7 @@ Deleting parts may malfunction or destroy the article; continue? ")) "`----\n")) (setcdr data (cdr (mm-make-handle - nil `("text/plain" (charset . gnus-decoded)) nil nil + nil '("text/plain" (charset . gnus-decoded)) nil nil (list "attachment") (format "Deleted attachment (%s bytes)" bsize)))))) ;; (set-buffer gnus-summary-buffer) @@ -5228,7 +5207,7 @@ available media-types." (gnus-completing-read "View as MIME type" (if pred - (gnus-remove-if-not pred (mailcap-mime-types)) + (seq-filter pred (mailcap-mime-types)) (mailcap-mime-types)) nil nil nil (car default))))) @@ -5512,7 +5491,7 @@ If no internal viewer is available, use an external viewer." (defun gnus-mime-action-on-part (&optional action) "Do something with the MIME attachment at (point)." (interactive - (list (gnus-completing-read "Action" (mapcar 'car gnus-mime-action-alist) t))) + (list (gnus-completing-read "Action" (mapcar #'car gnus-mime-action-alist) t))) (gnus-article-check-buffer) (let ((action-pair (assoc action gnus-mime-action-alist))) (if action-pair @@ -5830,7 +5809,7 @@ all parts." ;; No subpart is displayed, so we find preferred one. (setq part (cdr (assq (mm-preferred-alternative - (nreverse (mapcar 'car handles))) + (nreverse (mapcar #'car handles))) handles)))) (if part (goto-char (1+ part)) @@ -5873,26 +5852,12 @@ all parts." ;; Exclude a newline. (1- (point)) (point))) - (when gnus-article-button-face - (overlay-put (make-overlay b e nil t) - 'face gnus-article-button-face)) - (widget-convert-button - 'link b e - :mime-handle handle - :action 'gnus-widget-press-button - :button-keymap gnus-mime-button-map - :help-echo - (lambda (widget) - (format - "%S: %s the MIME part; %S: more options" - 'mouse-2 - (if (mm-handle-displayed-p (widget-get widget :mime-handle)) - "hide" "show") - 'down-mouse-3))))) - -(defun gnus-widget-press-button (elems _el) - (goto-char (widget-get elems :from)) - (gnus-article-press-button)) + (make-text-button + b e + 'keymap gnus-mime-button-map + 'face gnus-article-button-face + 'help-echo + "mouse-2: toggle the MIME part; down-mouse-3: more options"))) (defvar gnus-displaying-mime nil) @@ -6024,11 +5989,11 @@ If nil, don't show those extra buttons." (defun gnus-mime-part-function (handles) (if (stringp (car handles)) - (mapcar 'gnus-mime-part-function (cdr handles)) + (mapcar #'gnus-mime-part-function (cdr handles)) (funcall gnus-article-mime-part-function handles))) (defun gnus-mime-display-mixed (handles) - (mapcar 'gnus-mime-display-part handles)) + (mapcar #'gnus-mime-display-part handles)) (defun gnus-mime-display-single (handle) (let ((type (mm-handle-media-type handle)) @@ -6175,10 +6140,9 @@ If nil, don't show those extra buttons." mouse-face ,gnus-article-mouse-face face ,gnus-article-button-face gnus-part ,id + button t article-type multipart rear-nonsticky t)) - (widget-convert-button 'link from (point) - :action 'gnus-widget-press-button) ;; Do the handles (while (setq handle (pop handles)) (add-text-properties @@ -6199,10 +6163,9 @@ If nil, don't show those extra buttons." mouse-face ,gnus-article-mouse-face face ,gnus-article-button-face gnus-part ,id + button t gnus-data ,handle rear-nonsticky t)) - (widget-convert-button 'link from (point) - :action 'gnus-widget-press-button) (insert " ")) (insert "\n\n")) (when preferred @@ -6696,7 +6659,7 @@ not have a face in `gnus-article-boring-faces'." (interactive "P") (gnus-article-check-buffer) (let ((nosaves - '("q" "Q" "c" "r" "\C-c\C-f" "m" "a" "f" "WDD" "WDW" + '("q" "Q" "r" "\C-c\C-f" "m" "a" "f" "WDD" "WDW" "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" "=" "^" "\M-^" "|")) (nosave-but-article @@ -6762,7 +6725,8 @@ not have a face in `gnus-article-boring-faces'." ;; We disable the pick minor mode commands. (setq func (let (gnus-pick-mode) (key-binding keys t))) - (when (get func 'disabled) + (when (and (symbolp func) + (get func 'disabled)) (error "Function %s disabled" func)) (if (and func (functionp func) @@ -7007,9 +6971,7 @@ If given a prefix, show the hidden text instead." ;; doesn't belong in this newsgroup (possibly), so we find its ;; message-id and request it by id instead of number. (when (and (numberp article) - gnus-summary-buffer - (get-buffer gnus-summary-buffer) - (gnus-buffer-exists-p gnus-summary-buffer)) + (gnus-buffer-live-p gnus-summary-buffer)) (with-current-buffer gnus-summary-buffer (let ((header (gnus-summary-article-header article))) (when (< article 0) @@ -7021,7 +6983,7 @@ If given a prefix, show the hidden text instead." (delq article gnus-newsgroup-sparse)) (setq article (mail-header-id header)) (setq sparse-header (gnus-read-header article))) - ((vectorp header) + ((mail-header-p header) ;; It's a real article. (setq article (mail-header-id header))) (t @@ -7032,7 +6994,7 @@ If given a prefix, show the hidden text instead." (let ((method (gnus-find-method-for-group gnus-newsgroup-name))) (when (and (eq (car method) 'nneething) - (vectorp header)) + (mail-header-p header)) (let ((dir (nneething-get-file-name (mail-header-id header)))) (when (and (stringp dir) @@ -7043,11 +7005,9 @@ If given a prefix, show the hidden text instead." (cond ;; Refuse to select canceled articles. ((and (numberp article) - gnus-summary-buffer - (get-buffer gnus-summary-buffer) - (gnus-buffer-exists-p gnus-summary-buffer) - (eq (cdr (with-current-buffer gnus-summary-buffer - (assq article gnus-newsgroup-reads))) + (gnus-buffer-live-p gnus-summary-buffer) + (eq (with-current-buffer gnus-summary-buffer + (cdr (assq article gnus-newsgroup-reads))) gnus-canceled-mark)) nil) ;; We first check `gnus-original-article-buffer'. @@ -7056,13 +7016,7 @@ If given a prefix, show the hidden text instead." (with-current-buffer gnus-original-article-buffer (and (equal (car gnus-original-article) group) (eq (cdr gnus-original-article) article)))) - ;; `insert-buffer-substring' would incorrectly use the - ;; equivalent of string-make-multibyte which amount to decoding - ;; with locale-coding-system, causing failure of - ;; subsequent decoding. - (insert (string-to-multibyte - (with-current-buffer gnus-original-article-buffer - (buffer-substring (point-min) (point-max))))) + (insert-buffer-substring gnus-original-article-buffer) 'article) ;; Check the backlog. ((and gnus-keep-backlog @@ -7376,27 +7330,9 @@ groups." ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>. -;;; Internal Variables: - -(defcustom gnus-button-url-regexp - (concat - "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|" - "nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)" - "\\(//[-a-z0-9_.]+:[0-9]*\\)?" - (let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]") - (punct "!?:;.,")) - (concat - "\\(?:" - ;; Match paired parentheses, e.g. in Wikipedia URLs: - ;; http://thread.gmane.org/47B4E3B2.3050402@gmail.com - "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" - "\\(?:" "[" chars punct "]+" "[" chars "]" "\\)?" - "\\|" - "[" chars punct "]+" "[" chars "]" - "\\)")) - "\\)") +(defcustom gnus-button-url-regexp browse-url-button-regexp "Regular expression that matches URLs." - :version "24.4" + :version "27.1" :group 'gnus-article-buttons :type 'regexp) @@ -7406,9 +7342,8 @@ groups." :group 'gnus-article-buttons :type 'regexp) -;; Regexp suggested by Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de> (defcustom gnus-button-valid-localpart-regexp - "[a-z0-9$%(*-=?[_][^<>\")!;:,{}\n\t @]*" + "[-a-z0-9$%(*+./=?[_][^<>\")!;:,{}\n\t @]*" "Regular expression that matches a localpart of mail addresses or MIDs." :version "22.1" :group 'gnus-article-buttons @@ -7466,10 +7401,10 @@ must return `mid', `mail', `invalid' or `ask'." (-2.0 . "^[0-9]") (-1.0 . "^[0-9][0-9]") ;; - ;; -3.0 /^[0-9][0-9a-fA-F]{2,2}/; - (-3.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]") - ;; -5.0 /^[0-9][0-9a-fA-F]{3,3}/; - (-5.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]") + ;; -3.0 /^[0-9][[:xdigit:]]{2,2}/; + (-3.0 . "^[0-9][[:xdigit:]][[:xdigit:]][^[:xdigit:]]") + ;; -5.0 /^[0-9][[:xdigit:]]{3,3}/; + (-5.0 . "^[0-9][[:xdigit:]][[:xdigit:]][[:xdigit:]][^[:xdigit:]]") ;; (-3.0 . "[0-9][0-9][0-9][0-9][0-9][^0-9].*@") ;; "[0-9]{5,}.*\@" (-3.0 . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][^0-9].*@") @@ -7804,7 +7739,7 @@ positives are possible." 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) ;; Raw URLs. (gnus-button-url-regexp - 0 (>= gnus-button-browse-level 0) browse-url 0) + 0 (>= gnus-button-browse-level 0) browse-url-button-open-url 0) ;; man pages ("\\b\\([a-z][a-z]+([1-9])\\)\\W" 0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3)) @@ -8077,7 +8012,7 @@ url is put as the `gnus-button-url' overlay property on the button." (match-beginning 1)) points))))) (match-beginning 2))) - (let (gnus-article-mouse-face widget-mouse-face) + (let (gnus-article-mouse-face) (while points (gnus-article-add-button (pop points) (pop points) 'gnus-button-push @@ -8086,7 +8021,7 @@ url is put as the `gnus-button-url' overlay property on the button." (let ((overlay (make-overlay start end))) (overlay-put overlay 'evaporate t) (overlay-put overlay 'gnus-button-url - (list (mapconcat 'identity (nreverse url) ""))) + (list (mapconcat #'identity (nreverse url) ""))) (when gnus-article-mouse-face (overlay-put overlay 'mouse-face gnus-article-mouse-face))) t) @@ -8126,18 +8061,19 @@ url is put as the `gnus-button-url' overlay property on the button." (defun gnus-article-add-button (from to fun &optional data text) "Create a button between FROM and TO with callback FUN and data DATA." - (when gnus-article-button-face - (overlay-put (make-overlay from to nil t) - 'face gnus-article-button-face)) (add-text-properties from to (nconc (and gnus-article-mouse-face (list 'mouse-face gnus-article-mouse-face)) - (list 'gnus-callback fun) + (list 'gnus-callback fun + 'button-data data + 'action fun + 'keymap gnus-url-button-map + 'category t + 'button t) (and data (list 'gnus-data data)))) - (widget-convert-button 'link from to :action 'gnus-widget-press-button - :help-echo (or text "Follow the link") - :keymap gnus-url-button-map)) + (when gnus-article-button-face + (add-face-text-property from to gnus-article-button-face t))) (defun gnus-article-copy-string () "Copy the string in the button to the kill ring." @@ -8238,7 +8174,7 @@ url is put as the `gnus-button-url' overlay property on the button." (defun gnus-button-handle-news (url) "Fetch a news URL." - (destructuring-bind (_scheme server port group message-id _articles) + (cl-destructuring-bind (_scheme server port group message-id _articles) (gnus-parse-news-url url) (cond (message-id @@ -8425,7 +8361,7 @@ url is put as the `gnus-button-url' overlay property on the button." (message-position-on-field (caar args))) (insert (replace-regexp-in-string "\r\n" "\n" - (mapconcat 'identity (reverse (cdar args)) ", ") nil t)) + (mapconcat #'identity (reverse (cdar args)) ", ") nil t)) (setq args (cdr args))) (if subject (message-goto-body) @@ -8465,13 +8401,8 @@ url is put as the `gnus-button-url' overlay property on the button." ;; Exclude a newline. (1- (point)) (point))) - (when gnus-article-button-face - (overlay-put (make-overlay b e nil t) - 'face gnus-article-button-face)) - (widget-convert-button - 'link b e - :action 'gnus-button-prev-page - :button-keymap gnus-prev-page-map))) + (make-text-button b e 'keymap gnus-prev-page-map + 'face gnus-article-button-face))) (defun gnus-button-next-page (&optional _args _more-args) "Go to the next page." @@ -8501,13 +8432,8 @@ url is put as the `gnus-button-url' overlay property on the button." ;; Exclude a newline. (1- (point)) (point))) - (when gnus-article-button-face - (overlay-put (make-overlay b e nil t) - 'face gnus-article-button-face)) - (widget-convert-button - 'link b e - :action 'gnus-button-next-page - :button-keymap gnus-next-page-map))) + (make-text-button b e 'keymap gnus-next-page-map + 'face gnus-article-button-face))) (defun gnus-article-button-next-page (_arg) "Go to the next page." @@ -8616,18 +8542,16 @@ For example: nil) (gnus-treat-condition (eq gnus-treat-condition val)) - ((and (listp val) - (stringp (car val))) - (apply 'gnus-or (mapcar `(lambda (s) - (string-match s ,(or gnus-newsgroup-name ""))) - val))) + ((stringp (car-safe val)) + (let ((name (or gnus-newsgroup-name ""))) + (seq-some (lambda (s) (string-match-p s name)) val))) ((listp val) (let ((pred (pop val))) (cond ((eq pred 'or) - (apply 'gnus-or (mapcar 'gnus-treat-predicate val))) + (apply #'gnus-or (mapcar #'gnus-treat-predicate val))) ((eq pred 'and) - (apply 'gnus-and (mapcar 'gnus-treat-predicate val))) + (apply #'gnus-and (mapcar #'gnus-treat-predicate val))) ((eq pred 'not) (not (gnus-treat-predicate (car val)))) ((eq pred 'typep) @@ -8655,7 +8579,7 @@ For example: (list (or gnus-article-encrypt-protocol (gnus-completing-read "Encrypt protocol" - (mapcar 'car gnus-article-encrypt-protocol-alist) + (mapcar #'car gnus-article-encrypt-protocol-alist) t)) current-prefix-arg)) ;; User might hit `K E' instead of `K e', so prompt once. @@ -8702,7 +8626,7 @@ For example: (message-remove-header "MIME-Version") (goto-char (point-max)) (setq point (point)) - (insert (apply 'concat headers)) + (insert (apply #'concat headers)) (widen) (narrow-to-region point (point-max)) (let ((message-options message-options)) @@ -8762,6 +8686,7 @@ For example: (defvar gnus-mime-security-button-map (let ((map (make-sparse-keymap))) + (define-key map "\r" 'gnus-article-push-button) (define-key map [mouse-2] 'gnus-article-push-button) (define-key map [down-mouse-3] 'gnus-mime-security-button-menu) (dolist (c gnus-mime-security-button-commands) @@ -8897,20 +8822,8 @@ For example: ;; Exclude a newline. (1- (point)) (point))) - (when gnus-article-button-face - (overlay-put (make-overlay b e nil t) - 'face gnus-article-button-face)) - (widget-convert-button - 'link b e - :mime-handle handle - :action 'gnus-widget-press-button - :button-keymap gnus-mime-security-button-map - :help-echo - (lambda (_widget) - (format - "%S: show detail; %S: more options" - 'mouse-2 - 'down-mouse-3))))) + (make-text-button b e 'keymap gnus-mime-security-button-map + 'face gnus-article-button-face))) (defun gnus-mime-display-security (handle) (save-restriction diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el index f256635b40b..57f667c5e50 100644 --- a/lisp/gnus/gnus-async.el +++ b/lisp/gnus/gnus-async.el @@ -1,4 +1,4 @@ -;;; gnus-async.el --- asynchronous support for Gnus +;;; gnus-async.el --- asynchronous support for Gnus -*- lexical-binding:t -*- ;; Copyright (C) 1996-2019 Free Software Foundation, Inc. @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-sum) @@ -38,7 +38,6 @@ "If non-nil, prefetch articles in groups that allow this. If a number, prefetch only that many articles forward; if t, prefetch as many articles as possible." - :group 'gnus-asynchronous :type '(choice (const :tag "off" nil) (const :tag "all" t) (integer :tag "some" 0))) @@ -46,7 +45,6 @@ if t, prefetch as many articles as possible." (defcustom gnus-asynchronous nil "If nil, inhibit all Gnus asynchronicity. If non-nil, let the other asynch variables be heeded." - :group 'gnus-asynchronous :type 'boolean) (defcustom gnus-prefetched-article-deletion-strategy '(read exit) @@ -55,28 +53,24 @@ Possible values in this list are `read', which means that articles are removed as they are read, and `exit', which means that all articles belonging to a group are removed on exit from that group." - :group 'gnus-asynchronous :type '(set (const read) (const exit))) (defcustom gnus-use-header-prefetch nil "If non-nil, prefetch the headers to the next group." - :group 'gnus-asynchronous :type 'boolean) -(defcustom gnus-async-prefetch-article-p 'gnus-async-unread-p +(defcustom gnus-async-prefetch-article-p #'gnus-async-unread-p "Function called to say whether an article should be prefetched or not. The function is called with one parameter -- the article data. It should return non-nil if the article is to be prefetched." - :group 'gnus-asynchronous :type 'function) -(defcustom gnus-async-post-fetch-function nil +(defcustom gnus-async-post-fetch-function #'ignore "Function called after an article has been prefetched. The function will be called narrowed to the region of the article that was fetched." - :version "24.1" - :group 'gnus-asynchronous - :type '(choice (const nil) function)) + :version "27.1" + :type 'function) ;;; Internal variables. @@ -84,7 +78,6 @@ that was fetched." (defvar gnus-async-article-alist nil) (defvar gnus-async-article-semaphore '(nil)) (defvar gnus-async-fetch-list nil) -(defvar gnus-async-hashtb nil) (defvar gnus-async-current-prefetch-group nil) (defvar gnus-async-current-prefetch-article nil) (defvar gnus-async-timer nil) @@ -110,15 +103,13 @@ that was fetched." (setcdr (symbol-value semaphore) nil)) (defmacro gnus-async-with-semaphore (&rest forms) + (declare (indent 0) (debug t)) `(unwind-protect (progn (gnus-async-get-semaphore 'gnus-async-article-semaphore) ,@forms) (gnus-async-release-semaphore 'gnus-async-article-semaphore))) -(put 'gnus-async-with-semaphore 'lisp-indent-function 0) -(put 'gnus-async-with-semaphore 'edebug-form-spec '(body)) - ;;; ;;; Article prefetch ;;; @@ -127,14 +118,11 @@ that was fetched." (defun gnus-async-close () (gnus-kill-buffer gnus-async-prefetch-article-buffer) (gnus-kill-buffer gnus-async-prefetch-headers-buffer) - (setq gnus-async-hashtb nil - gnus-async-article-alist nil + (setq gnus-async-article-alist nil gnus-async-header-prefetched nil)) (defun gnus-async-set-buffer () - (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t) - (unless gnus-async-hashtb - (setq gnus-async-hashtb (gnus-make-hashtable 1023)))) + (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t)) (defun gnus-async-halt-prefetch () "Stop prefetching." @@ -146,15 +134,22 @@ that was fetched." gnus-asynchronous (gnus-group-asynchronous-p group)) (with-current-buffer gnus-summary-buffer - (let ((next (caadr (gnus-data-find-list article)))) + (let ((next (cadr (gnus-data-find-list article)))) (when next (when gnus-async-timer (ignore-errors - (nnheader-cancel-timer 'gnus-async-timer))) + (cancel-timer 'gnus-async-timer))) (setq gnus-async-timer (run-with-idle-timer - 0.1 nil 'gnus-async-prefetch-article - group next summary))))))) + 0.1 nil + (lambda () + ;; When running from a timer, `C-g' is inhibited. + ;; But the prefetch action may (when there's a + ;; network problem or the like) hang (or take a + ;; long time), so allow quitting anyway. + (let ((inhibit-quit nil)) + (gnus-async-prefetch-article + group (gnus-data-number next) summary)))))))))) (defun gnus-async-prefetch-article (group article summary &optional next) "Possibly prefetch several articles starting with ARTICLE." @@ -183,7 +178,7 @@ that was fetched." d) (while (and (setq d (pop data)) (if (numberp n) - (natnump (decf n)) + (natnump (cl-decf n)) n)) (unless (or (gnus-async-prefetched-article-entry group (setq article (gnus-data-number d))) @@ -218,8 +213,8 @@ that was fetched." (defun gnus-make-async-article-function (group article mark summary next) "Return a callback function." - `(lambda (arg) - (gnus-async-article-callback arg ,group ,article ,mark ,summary ,next))) + (lambda (arg) + (gnus-async-article-callback arg group article mark summary next))) (defun gnus-async-article-callback (arg group article mark summary next) "Function called when an async article is done being fetched." @@ -242,13 +237,10 @@ that was fetched." (when gnus-async-post-fetch-function (funcall gnus-async-post-fetch-function summary)))) (gnus-async-with-semaphore - (setq - gnus-async-article-alist - (cons (list (intern (format "%s-%d" group article) - gnus-async-hashtb) - mark (point-max-marker) - group article) - gnus-async-article-alist)))) + (push (list (format "%s-%d" group article) + mark (point-max-marker) + group article) + gnus-async-article-alist))) (if (not (gnus-buffer-live-p summary)) (gnus-async-with-semaphore (setq gnus-async-fetch-list nil)) @@ -290,7 +282,7 @@ that was fetched." ;; should check time-since-last-output, which ;; needs to be done in nntp.el. (while (eq article gnus-async-current-prefetch-article) - (incf tries) + (cl-incf tries) (when (nntp-accept-process-output proc) (setq tries 0)) (when (and (not nntp-have-messaged) @@ -314,8 +306,7 @@ that was fetched." (set-marker (caddr entry) nil)) (gnus-async-with-semaphore (setq gnus-async-article-alist - (delq entry gnus-async-article-alist)) - (unintern (car entry) gnus-async-hashtb))) + (delete entry gnus-async-article-alist)))) (defun gnus-async-prefetch-remove-group (group) "Remove all articles belonging to GROUP from the prefetch buffer." @@ -331,9 +322,8 @@ that was fetched." "Return the entry for ARTICLE in GROUP if it has been prefetched." (let ((entry (save-excursion (gnus-async-set-buffer) - (assq (intern-soft (format "%s-%d" group article) - gnus-async-hashtb) - gnus-async-article-alist)))) + (assoc (format "%s-%d" group article) + gnus-async-article-alist)))) ;; Perhaps something has emptied the buffer? (if (and entry (= (cadr entry) (caddr entry))) @@ -342,7 +332,7 @@ that was fetched." (set-marker (cadr entry) nil) (set-marker (caddr entry) nil)) (setq gnus-async-article-alist - (delq entry gnus-async-article-alist)) + (delete entry gnus-async-article-alist)) nil) entry))) @@ -365,9 +355,9 @@ that was fetched." (erase-buffer) (let ((nntp-server-buffer (current-buffer)) (nnheader-callback-function - `(lambda (arg) + (lambda (_arg) (setq gnus-async-header-prefetched - ,(cons group unread))))) + (cons group unread))))) (gnus-retrieve-headers unread group gnus-fetch-old-headers)))))) (defun gnus-async-retrieve-fetched-headers (articles group) diff --git a/lisp/gnus/gnus-bcklg.el b/lisp/gnus/gnus-bcklg.el index c5c85289555..f478c39f370 100644 --- a/lisp/gnus/gnus-bcklg.el +++ b/lisp/gnus/gnus-bcklg.el @@ -22,19 +22,16 @@ ;;; Commentary: -;;; Code: +;; The backlog caches the text of a certain number of read articles in +;; a separate buffer, so they can be retrieved quickly if the user +;; opens them again. Also see `gnus-keep-backlog'. -(eval-when-compile (require 'cl)) +;;; Code: (require 'gnus) -;;; -;;; Buffering of read articles. -;;; - (defvar gnus-backlog-buffer " *Gnus Backlog*") -(defvar gnus-backlog-articles nil) -(defvar gnus-backlog-hashtb nil) +(defvar gnus-backlog-articles '()) (defun gnus-backlog-buffer () "Return the backlog buffer." @@ -44,58 +41,48 @@ (setq buffer-read-only t) (get-buffer gnus-backlog-buffer)))) -(defun gnus-backlog-setup () - "Initialize backlog variables." - (unless gnus-backlog-hashtb - (setq gnus-backlog-hashtb (gnus-make-hashtable 1024)))) - (gnus-add-shutdown 'gnus-backlog-shutdown 'gnus) (defun gnus-backlog-shutdown () "Clear all backlog variables and buffers." (interactive) - (when (get-buffer gnus-backlog-buffer) - (gnus-kill-buffer gnus-backlog-buffer)) - (setq gnus-backlog-hashtb nil - gnus-backlog-articles nil)) + (gnus-kill-buffer gnus-backlog-buffer) + (setq gnus-backlog-articles nil)) (defun gnus-backlog-enter-article (group number buffer) (when (and (numberp number) (not (gnus-virtual-group-p group))) - (gnus-backlog-setup) - (let ((ident (intern (concat group ":" (int-to-string number)) - gnus-backlog-hashtb)) + (let ((ident (format "%s:%d" group number)) b) - (if (memq ident gnus-backlog-articles) - () ; It's already kept. - ;; Remove the oldest article, if necessary. - (and (numberp gnus-keep-backlog) - (>= (length gnus-backlog-articles) gnus-keep-backlog) - (gnus-backlog-remove-oldest-article)) - (push ident gnus-backlog-articles) - ;; Insert the new article. - (with-current-buffer (gnus-backlog-buffer) - (let (buffer-read-only) - (goto-char (point-max)) - (unless (bolp) - (insert "\n")) - (setq b (point)) - (insert-buffer-substring buffer) - ;; Tag the beginning of the article with the ident. - (if (> (point-max) b) - (put-text-property b (1+ b) 'gnus-backlog ident) - (gnus-error 3 "Article %d is blank" number)))))))) + (unless (member ident gnus-backlog-articles) ; It's already kept. + ;; Remove the oldest article, if necessary. + (and (numberp gnus-keep-backlog) + (>= (length gnus-backlog-articles) gnus-keep-backlog) + (gnus-backlog-remove-oldest-article)) + (push ident gnus-backlog-articles) + ;; Insert the new article. + (with-current-buffer (gnus-backlog-buffer) + (let (buffer-read-only) + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (setq b (point)) + (insert-buffer-substring buffer) + ;; Tag the beginning of the article with the ident. + (if (> (point-max) b) + (put-text-property b (1+ b) 'gnus-backlog ident) + (gnus-error 3 "Article %d is blank" number)))))))) (defun gnus-backlog-remove-oldest-article () (with-current-buffer (gnus-backlog-buffer) (goto-char (point-min)) - (if (zerop (buffer-size)) - () ; The buffer is empty. + (unless (zerop (buffer-size)) ; The buffer is empty. (let ((ident (get-text-property (point) 'gnus-backlog)) buffer-read-only) ;; Remove the ident from the list of articles. (when ident - (setq gnus-backlog-articles (delq ident gnus-backlog-articles))) + (setq gnus-backlog-articles + (delete ident gnus-backlog-articles))) ;; Delete the article itself. (delete-region (point) (next-single-property-change @@ -104,42 +91,40 @@ (defun gnus-backlog-remove-article (group number) "Remove article NUMBER in GROUP from the backlog." (when (numberp number) - (gnus-backlog-setup) - (let ((ident (intern (concat group ":" (int-to-string number)) - gnus-backlog-hashtb)) - beg end) - (when (memq ident gnus-backlog-articles) + (let ((ident (format "%s:%d" group number)) + beg) + (when (member ident gnus-backlog-articles) ;; It was in the backlog. (with-current-buffer (gnus-backlog-buffer) - (let (buffer-read-only) - (when (setq beg (text-property-any - (point-min) (point-max) 'gnus-backlog - ident)) - ;; Find the end (i. e., the beginning of the next article). - (setq end - (next-single-property-change - (1+ beg) 'gnus-backlog (current-buffer) (point-max))) - (delete-region beg end) - ;; Return success. - t)) - (setq gnus-backlog-articles (delq ident gnus-backlog-articles))))))) + (save-excursion + (let (buffer-read-only) + (goto-char (point-min)) + (when (setq beg (gnus-text-property-search + 'gnus-backlog ident)) + ;; Find the end (i. e., the beginning of the next article). + (goto-char + (next-single-property-change + (1+ beg) 'gnus-backlog (current-buffer) (point-max))) + (delete-region beg (point)) + ;; Return success. + t))) + (setq gnus-backlog-articles + (delete ident gnus-backlog-articles))))))) (defun gnus-backlog-request-article (group number &optional buffer) (when (and (numberp number) (not (gnus-virtual-group-p group))) - (gnus-backlog-setup) - (let ((ident (intern (concat group ":" (int-to-string number)) - gnus-backlog-hashtb)) + (let ((ident (format "%s:%d" group number)) beg end) - (when (memq ident gnus-backlog-articles) + (when (member ident gnus-backlog-articles) ;; It was in the backlog. (with-current-buffer (gnus-backlog-buffer) - (if (not (setq beg (text-property-any - (point-min) (point-max) 'gnus-backlog - ident))) + (if (not (setq beg (gnus-text-property-search + 'gnus-backlog ident))) ;; It wasn't in the backlog after all. (ignore - (setq gnus-backlog-articles (delq ident gnus-backlog-articles))) + (setq gnus-backlog-articles + (delete ident gnus-backlog-articles))) ;; Find the end (i. e., the beginning of the next article). (setq end (next-single-property-change diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index a30ae38abb6..afe8a8a416c 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-sum) @@ -187,9 +187,9 @@ it's not cached." (setq lines-chars (nnheader-get-lines-and-char)) (nnheader-remove-body) (setq headers (nnheader-parse-naked-head)) - (mail-header-set-number headers number) - (mail-header-set-lines headers (car lines-chars)) - (mail-header-set-chars headers (cadr lines-chars)) + (setf (mail-header-number headers) number) + (setf (mail-header-lines headers) (car lines-chars)) + (setf (mail-header-chars headers) (cadr lines-chars)) (gnus-cache-change-buffer group) (set-buffer (cdr gnus-cache-buffer)) (goto-char (point-max)) @@ -272,7 +272,7 @@ it's not cached." (defun gnus-cache-possibly-alter-active (group active) "Alter the ACTIVE info for GROUP to reflect the articles in the cache." (when gnus-cache-active-hashtb - (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) + (let ((cache-active (gethash group gnus-cache-active-hashtb))) (when cache-active (when (< (car cache-active) (car active)) (setcar active (car cache-active))) @@ -522,7 +522,7 @@ system for example was used.") (gnus-delete-line))) (unless (setq gnus-newsgroup-cached (delq article gnus-newsgroup-cached)) - (gnus-sethash gnus-newsgroup-name nil gnus-cache-active-hashtb) + (remhash gnus-newsgroup-name gnus-cache-active-hashtb) (setq gnus-cache-active-altered t)) (gnus-summary-update-secondary-mark article) t))) @@ -542,8 +542,8 @@ system for example was used.") (progn (gnus-cache-update-active group (car articles) t) (gnus-cache-update-active group (car (last articles)))) - (when (gnus-gethash group gnus-cache-active-hashtb) - (gnus-sethash group nil gnus-cache-active-hashtb) + (when (gethash group gnus-cache-active-hashtb) + (remhash group gnus-cache-active-hashtb) (setq gnus-cache-active-altered t))) articles))) @@ -642,7 +642,8 @@ $ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache" "Read the cache active file." (gnus-make-directory gnus-cache-directory) (if (or (not (file-exists-p gnus-cache-active-file)) - (zerop (nth 7 (file-attributes gnus-cache-active-file))) + (zerop (file-attribute-size + (file-attributes gnus-cache-active-file))) force) ;; There is no active file, so we generate one. (gnus-cache-generate-active) @@ -665,13 +666,16 @@ $ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache" ;; Mark the active hashtb as unaltered. (setq gnus-cache-active-altered nil))) +;; FIXME: Why is there a `gnus-cache-possibly-alter-active', +;; `gnus-cache-possibly-update-active', and +;; `gnus-cache-update-active'? Do we really need all three? (defun gnus-cache-possibly-update-active (group active) "Update active info bounds of GROUP with ACTIVE if necessary. The update is performed if ACTIVE contains a higher or lower bound than the current." (let ((lower t) (higher t)) (if gnus-cache-active-hashtb - (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) + (let ((cache-active (gethash group gnus-cache-active-hashtb))) (when cache-active (unless (< (car active) (car cache-active)) (setq lower nil)) @@ -686,10 +690,10 @@ than the current." (defun gnus-cache-update-active (group number &optional low) "Update the upper bound of the active info of GROUP to NUMBER. If LOW, update the lower bound instead." - (let ((active (gnus-gethash group gnus-cache-active-hashtb))) + (let ((active (gethash group gnus-cache-active-hashtb))) (if (null active) ;; We just create a new active entry for this group. - (gnus-sethash group (cons number number) gnus-cache-active-hashtb) + (puthash group (cons number number) gnus-cache-active-hashtb) ;; Update the lower or upper bound. (if low (setcar active number) @@ -733,10 +737,10 @@ If LOW, update the lower bound instead." ;; FIXME: this is kind of a workaround. The active file should ;; be updated at the time articles are cached. It will make ;; `gnus-cache-unified-group-names' needless. - (gnus-sethash (or (cdr (assoc group gnus-cache-unified-group-names)) - group) - (cons (car nums) (gnus-last-element nums)) - gnus-cache-active-hashtb)) + (puthash (or (cdr (assoc group gnus-cache-unified-group-names)) + group) + (cons (car nums) (car (last nums))) + gnus-cache-active-hashtb)) ;; Go through all the other files. (dolist (file alphs) (when (and (file-directory-p file) @@ -797,13 +801,13 @@ supported." (unless gnus-cache-active-hashtb (gnus-cache-read-active)) (let* ((old-group-hash-value - (gnus-gethash old-group gnus-cache-active-hashtb)) + (gethash old-group gnus-cache-active-hashtb)) (new-group-hash-value - (gnus-gethash new-group gnus-cache-active-hashtb)) + (gethash new-group gnus-cache-active-hashtb)) (delta (or old-group-hash-value new-group-hash-value))) - (gnus-sethash new-group old-group-hash-value gnus-cache-active-hashtb) - (gnus-sethash old-group nil gnus-cache-active-hashtb) + (puthash new-group old-group-hash-value gnus-cache-active-hashtb) + (puthash old-group nil gnus-cache-active-hashtb) (if no-save (setq gnus-cache-active-altered delta) @@ -825,8 +829,8 @@ supported." (let ((no-save gnus-cache-active-hashtb)) (unless gnus-cache-active-hashtb (gnus-cache-read-active)) - (let* ((group-hash-value (gnus-gethash group gnus-cache-active-hashtb))) - (gnus-sethash group nil gnus-cache-active-hashtb) + (let* ((group-hash-value (gethash group gnus-cache-active-hashtb))) + (remhash group gnus-cache-active-hashtb) (if no-save (setq gnus-cache-active-altered group-hash-value) @@ -848,13 +852,13 @@ supported." (when gnus-cache-total-fetched-hashtb (gnus-cache-with-refreshed-group group - (let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb) - (gnus-sethash group (make-vector 2 0) - gnus-cache-total-fetched-hashtb))) + (let* ((entry (or (gethash group gnus-cache-total-fetched-hashtb) + (puthash group (make-vector 2 0) + gnus-cache-total-fetched-hashtb))) size) (if file - (setq size (or (nth 7 (file-attributes file)) 0)) + (setq size (or (file-attribute-size (file-attributes file)) 0)) (let* ((file-name-coding-system nnmail-pathname-coding-system) (files (directory-files (gnus-cache-file-name group "") t nil t)) @@ -862,22 +866,22 @@ supported." (setq size 0.0) (while (setq file (pop files)) (setq attrs (file-attributes file)) - (unless (nth 0 attrs) - (incf size (float (nth 7 attrs))))))) + (unless (file-attribute-type attrs) + (cl-incf size (float (file-attribute-size attrs))))))) (setq gnus-cache-need-update-total-fetched-for t) - (incf (nth 1 entry) (if subtract (- size) size)))))) + (cl-incf (nth 1 entry) (if subtract (- size) size)))))) (defun gnus-cache-update-overview-total-fetched-for (group file) (when gnus-cache-total-fetched-hashtb (gnus-cache-with-refreshed-group group - (let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb) - (gnus-sethash group (make-list 2 0) + (let* ((entry (or (gethash group gnus-cache-total-fetched-hashtb) + (puthash group (make-list 2 0) gnus-cache-total-fetched-hashtb))) (file-name-coding-system nnmail-pathname-coding-system) - (size (or (nth 7 (file-attributes + (size (or (file-attribute-size (file-attributes (or file (gnus-cache-file-name group ".overview")))) 0))) @@ -887,22 +891,21 @@ supported." (defun gnus-cache-rename-group-total-fetched-for (old-group new-group) "Record of disk space used by OLD-GROUP now associated with NEW-GROUP." (when gnus-cache-total-fetched-hashtb - (let ((entry (gnus-gethash old-group gnus-cache-total-fetched-hashtb))) - (gnus-sethash new-group entry gnus-cache-total-fetched-hashtb) - (gnus-sethash old-group nil gnus-cache-total-fetched-hashtb)))) + (let ((entry (gethash old-group gnus-cache-total-fetched-hashtb))) + (puthash new-group entry gnus-cache-total-fetched-hashtb) + (remhash old-group gnus-cache-total-fetched-hashtb)))) (defun gnus-cache-delete-group-total-fetched-for (group) "Delete record of disk space used by GROUP being deleted." (when gnus-cache-total-fetched-hashtb - (gnus-sethash group nil gnus-cache-total-fetched-hashtb))) + (remhash group gnus-cache-total-fetched-hashtb))) (defun gnus-cache-total-fetched-for (group &optional no-inhibit) "Get total disk space used by the cache for the specified GROUP." (unless (equal group "dummy.group") (unless gnus-cache-total-fetched-hashtb - (setq gnus-cache-total-fetched-hashtb (gnus-make-hashtable 1024))) - - (let* ((entry (gnus-gethash group gnus-cache-total-fetched-hashtb))) + (setq gnus-cache-total-fetched-hashtb (gnus-make-hashtable 1000))) + (let* ((entry (gethash group gnus-cache-total-fetched-hashtb))) (if entry (apply '+ entry) (let ((gnus-cache-inhibit-update-total-fetched-for (not no-inhibit))) diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el index d8b6df70bd4..7f0da2a0fa0 100644 --- a/lisp/gnus/gnus-cite.el +++ b/lisp/gnus/gnus-cite.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1995-2019 Free Software Foundation, Inc. -;; Author: Per Abhiddenware +;; Author: Per Abrahamsen <abraham@dina.kvl.dk> ;; This file is part of GNU Emacs. @@ -23,8 +23,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'gnus) (require 'gnus-range) (require 'gnus-art) @@ -136,9 +134,6 @@ the envelope From line." (defface gnus-cite-attribution '((t (:italic t))) "Face used for attribution lines." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-attribution-face 'face-alias 'gnus-cite-attribution) -(put 'gnus-cite-attribution-face 'obsolete-face "22.1") (defcustom gnus-cite-attribution-face 'gnus-cite-attribution "Face used for attribution lines. @@ -157,9 +152,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-1 'face-alias 'gnus-cite-1) -(put 'gnus-cite-face-1 'obsolete-face "22.1") (defface gnus-cite-2 '((((class color) (background dark)) @@ -171,9 +163,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-2 'face-alias 'gnus-cite-2) -(put 'gnus-cite-face-2 'obsolete-face "22.1") (defface gnus-cite-3 '((((class color) (background dark)) @@ -185,9 +174,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-3 'face-alias 'gnus-cite-3) -(put 'gnus-cite-face-3 'obsolete-face "22.1") (defface gnus-cite-4 '((((class color) (background dark)) @@ -199,9 +185,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-4 'face-alias 'gnus-cite-4) -(put 'gnus-cite-face-4 'obsolete-face "22.1") (defface gnus-cite-5 '((((class color) (background dark)) @@ -213,9 +196,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-5 'face-alias 'gnus-cite-5) -(put 'gnus-cite-face-5 'obsolete-face "22.1") (defface gnus-cite-6 '((((class color) (background dark)) @@ -227,9 +207,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-6 'face-alias 'gnus-cite-6) -(put 'gnus-cite-face-6 'obsolete-face "22.1") (defface gnus-cite-7 '((((class color) (background dark)) @@ -241,9 +218,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-7 'face-alias 'gnus-cite-7) -(put 'gnus-cite-face-7 'obsolete-face "22.1") (defface gnus-cite-8 '((((class color) (background dark)) @@ -255,9 +229,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-8 'face-alias 'gnus-cite-8) -(put 'gnus-cite-face-8 'obsolete-face "22.1") (defface gnus-cite-9 '((((class color) (background dark)) @@ -269,9 +240,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-9 'face-alias 'gnus-cite-9) -(put 'gnus-cite-face-9 'obsolete-face "22.1") (defface gnus-cite-10 '((((class color) (background dark)) @@ -283,9 +251,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-10 'face-alias 'gnus-cite-10) -(put 'gnus-cite-face-10 'obsolete-face "22.1") (defface gnus-cite-11 '((((class color) (background dark)) @@ -297,9 +262,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-11 'face-alias 'gnus-cite-11) -(put 'gnus-cite-face-11 'obsolete-face "22.1") (defcustom gnus-cite-face-list '(gnus-cite-1 gnus-cite-2 gnus-cite-3 gnus-cite-4 gnus-cite-5 gnus-cite-6 @@ -378,7 +340,7 @@ in a boring face, then the pages will be skipped." ;; TAG: Is a Supercite tag, if any. (defvar gnus-cited-opened-text-button-line-format-alist - `((?b (marker-position beg) ?d) + '((?b (marker-position beg) ?d) (?e (marker-position end) ?d) (?n (count-lines beg end) ?d) (?l (- end beg) ?d))) @@ -519,8 +481,13 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps (defun gnus-article-fill-cited-article (&optional width long-lines) "Do word wrapping in the current article. If WIDTH (the numerical prefix), use that text width when -filling. If LONG-LINES, only fill sections that have lines -longer than the frame width." +filling. + +If LONG-LINES, only fill sections that have lines longer than the +frame width. + +Sections that are heuristically interpreted as not being +text (i.e., computer code and the like) will not be folded." (interactive "P") (with-current-buffer gnus-article-buffer (let ((buffer-read-only nil) @@ -540,8 +507,6 @@ longer than the frame width." use-hard-newlines) (unless do-fill (setq do-fill (gnus-article-foldable-buffer (cdar marks)))) - ;; Note: the XEmacs version of `fill-region' inserts a newline - ;; unless the region ends with a newline. (when do-fill (if (not long-lines) (fill-region (point-min) (point-max)) @@ -660,7 +625,7 @@ always hide." (point) (progn (eval gnus-cited-closed-text-button-line-format-spec) (point)) - `gnus-article-toggle-cited-text + 'gnus-article-toggle-cited-text (list (cons beg end) start)) (point)) 'article-type 'annotation) @@ -710,7 +675,7 @@ means show, nil means toggle." gnus-cited-opened-text-button-line-format-spec gnus-cited-closed-text-button-line-format-spec)) (point)) - `gnus-article-toggle-cited-text + 'gnus-article-toggle-cited-text args) (point)) 'article-type 'annotation))))) @@ -1163,7 +1128,7 @@ Returns nil if there is no such line before LIMIT, t otherwise." (let ((cdepth (min (length (apply 'concat (split-string (match-string-no-properties 0) - "[ \t [:alnum:]]+"))) + "[\t [:alnum:]]+"))) gnus-message-max-citation-depth)) (mlist (make-list (* (1+ gnus-message-max-citation-depth) 2) nil)) (start (point-at-bol)) @@ -1198,7 +1163,7 @@ When enabled, it automatically turns on `font-lock-mode'." nil ;; init-value "" ;; lighter nil ;; keymap - (when (eq major-mode 'message-mode) ;FIXME: Use derived-mode-p. + (when (derived-mode-p 'message-mode) ;; FIXME: Use font-lock-add-keywords! (let ((defaults (car font-lock-defaults)) default keywords) diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index e6cf39c0525..485f815d9b9 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -28,7 +28,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'parse-time) (require 'nnimap) @@ -80,7 +79,7 @@ against the basename of files in said directory." (defcustom gnus-cloud-method nil "The IMAP select method used to store the cloud data. -See also `gnus-server-toggle-cloud-method-server' for an +See also `gnus-server-set-cloud-method-server' for an easy interactive way to set this from the Server buffer." :group 'gnus-cloud :type '(radio (const :tag "Not set" nil) @@ -229,7 +228,7 @@ easy interactive way to set this from the Server buffer." Use old data if FORCE-OLDER is not nil." (let* ((contents (plist-get elem :contents)) (date (or (plist-get elem :timestamp) "0")) - (now (gnus-cloud-timestamp (current-time))) + (now (gnus-cloud-timestamp nil)) (newer (string-lessp date now)) (group-info (gnus-get-info group))) (if (and contents @@ -340,7 +339,8 @@ Use old data if FORCE-OLDER is not nil." (format-time-string "%FT%T%z" time)) (defun gnus-cloud-file-new-p (file full) - (let ((timestamp (gnus-cloud-timestamp (nth 5 (file-attributes file)))) + (let ((timestamp (gnus-cloud-timestamp (file-attribute-modification-time + (file-attributes file)))) (old (cadr (assoc file gnus-cloud-file-timestamps)))) (when (or full (null old) @@ -368,6 +368,8 @@ Use old data if FORCE-OLDER is not nil." (interactive) (gnus-cloud-upload-data t)) +(autoload 'gnus-group-refresh-group "gnus-group") + (defun gnus-cloud-upload-data (&optional full) "Upload data (newsrc and files) to the Gnus Cloud. When FULL is t, upload everything, not just a difference from the last full." @@ -498,7 +500,7 @@ Otherwise, returns the Gnus Cloud data chunks." (gnus-method-to-server (gnus-find-method-for-group (gnus-info-group info)))) - (push `(:type :newsrc-data :name ,(gnus-info-group info) :contents ,info :timestamp ,(gnus-cloud-timestamp (current-time))) + (push `(:type :newsrc-data :name ,(gnus-info-group info) :contents ,info :timestamp ,(gnus-cloud-timestamp nil)) infos))) infos)) diff --git a/lisp/gnus/gnus-cus.el b/lisp/gnus/gnus-cus.el index 66fa3e0590f..fb8b300e350 100644 --- a/lisp/gnus/gnus-cus.el +++ b/lisp/gnus/gnus-cus.el @@ -253,7 +253,15 @@ DOC is a documentation string for the parameter.") (defconst gnus-extra-group-parameters '((uidvalidity (string :tag "IMAP uidvalidity") "\ -Server-assigned value attached to IMAP groups, used to maintain consistency.")) +Server-assigned value attached to IMAP groups, used to maintain consistency.") + (modseq (choice :tag "modseq" + (const :tag "None" nil) + (string :tag "Sequence number")) + "Modification seqence number") + (active (cons :tag "active" (integer :tag "min") (integer :tag "max")) + "active") + (permanent-flags (repeat :tag "Permanent Flags" (symbol :tag "Flag")) + "Permanent Flags")) "Alist of group parameters that are not also topic parameters. Each entry has the form (NAME TYPE DOC), where NAME is the parameter @@ -369,7 +377,7 @@ category.")) (unless (or topic (setq info (gnus-get-info group))) (error "Killed group; can't be edited")) ;; Ready. - (gnus-kill-buffer (gnus-get-buffer-create "*Gnus Customize*")) + (gnus-kill-buffer "*Gnus Customize*") (switch-to-buffer (gnus-get-buffer-create "*Gnus Customize*")) (gnus-custom-mode) (make-local-variable 'gnus-custom-group) @@ -406,7 +414,7 @@ category.")) ;; every duplicate ends up being displayed. So, rather than ;; display them, remove them from the list. - (let ((tmp (setq values (gnus-copy-sequence values))) + (let ((tmp (setq values (copy-tree values))) elem) (while (cdr tmp) (while (setq elem (assq (caar tmp) (cdr tmp))) @@ -1021,9 +1029,7 @@ articles in the thread. (cons 'agent-low-score gnus-agent-low-score) (cons 'agent-high-score gnus-agent-high-score)))) - (let ((old (get-buffer "*Gnus Agent Category Customize*"))) - (when old - (gnus-kill-buffer old))) + (gnus-kill-buffer "*Gnus Agent Category Customize*") (switch-to-buffer (gnus-get-buffer-create "*Gnus Agent Category Customize*")) @@ -1051,7 +1057,7 @@ articles in the thread. (when (get-buffer gnus-category-buffer) (switch-to-buffer (get-buffer gnus-category-buffer)) (gnus-category-list))) - "Done") + "Done") (widget-insert "\n Note: Empty fields default to the customizable global\ variables.\n\n") diff --git a/lisp/gnus/gnus-delay.el b/lisp/gnus/gnus-delay.el index b15187bcbc7..aabf23924a0 100644 --- a/lisp/gnus/gnus-delay.el +++ b/lisp/gnus/gnus-delay.el @@ -98,19 +98,15 @@ DELAY is a string, giving the length of the time. Possible values are: (setq hour (string-to-number (match-string 1 delay)) minute (string-to-number (match-string 2 delay))) ;; Use current time, except... - (setq deadline (apply 'vector (decode-time))) + (setq deadline (decode-time)) ;; ... for minute and hour. - (aset deadline 1 minute) - (aset deadline 2 hour) - ;; Convert to seconds. - (setq deadline (float-time (apply 'encode-time - (append deadline nil)))) + (setq deadline (apply #'encode-time (car deadline) minute hour + (nthcdr 3 deadline))) ;; If this time has passed already, add a day. - (when (< deadline (float-time)) - (setq deadline (+ 86400 deadline))) ; 86400 secs/day + (when (time-less-p deadline nil) + (setq deadline (time-add 86400 deadline))) ; 86400 secs/day ;; Convert seconds to date header. - (setq deadline (message-make-date - (seconds-to-time deadline)))) + (setq deadline (message-make-date deadline))) ((string-match "\\([0-9]+\\)\\s-*\\([mhdwMY]\\)" delay) (setq num (match-string 1 delay)) (setq unit (match-string 2 delay)) @@ -128,8 +124,7 @@ DELAY is a string, giving the length of the time. Possible values are: (setq delay (* num 60 60))) (t (setq delay (* num 60)))) - (setq deadline (message-make-date - (seconds-to-time (+ (float-time) delay))))) + (setq deadline (message-make-date (time-add nil delay)))) (t (error "Malformed delay `%s'" delay))) (message-add-header (format "%s: %s" gnus-delay-header deadline))) (set-buffer-modified-p t) @@ -164,11 +159,8 @@ DELAY is a string, giving the length of the time. Possible values are: nil t) (progn (setq deadline (nnheader-header-value)) - (setq deadline (apply 'encode-time - (parse-time-string deadline))) - (setq deadline (time-since deadline)) - (when (and (>= (nth 0 deadline) 0) - (>= (nth 1 deadline) 0)) + (setq deadline (encode-time (parse-time-string deadline))) + (unless (time-less-p nil deadline) (message "Sending delayed article %d" article) (gnus-draft-send article group) (message "Sending delayed article %d...done" article))) diff --git a/lisp/gnus/gnus-demon.el b/lisp/gnus/gnus-demon.el index 5709c50eb16..b26aaa15297 100644 --- a/lisp/gnus/gnus-demon.el +++ b/lisp/gnus/gnus-demon.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-int) @@ -93,7 +93,7 @@ Emacs has been idle for IDLE `gnus-demon-timestep's." (defun gnus-demon-idle-since () "Return the number of seconds since when Emacs is idle." - (float-time (or (current-idle-time) '(0 0 0)))) + (float-time (or (current-idle-time) 0))) (defun gnus-demon-run-callback (func &optional idle time special) "Run FUNC if Emacs has been idle for longer than IDLE seconds. @@ -101,7 +101,7 @@ If not, and a TIME is given, restart a new idle timer, so FUNC can be called at the next opportunity. Such a special idle run is marked with SPECIAL." (unless gnus-inhibit-demon - (block run-callback + (cl-block run-callback (when (eq idle t) (setq idle 0.001)) (cond (special @@ -111,13 +111,13 @@ marked with SPECIAL." func idle time)))) ((and idle (> idle (gnus-demon-idle-since))) (when time - (nnheader-cancel-timer (plist-get gnus-demon-timers func)) + (cancel-timer (plist-get gnus-demon-timers func)) (setq gnus-demon-timers (plist-put gnus-demon-timers func (run-with-idle-timer idle nil 'gnus-demon-run-callback func idle time t)))) - (return-from run-callback))) + (cl-return-from run-callback))) (with-local-quit (ignore-errors (funcall func)))))) @@ -176,27 +176,28 @@ marked with SPECIAL." (thenHour (elt thenParts 2)) (thenMin (elt thenParts 1)) ;; convert time as elements into number of seconds since EPOCH. - (then (encode-time 0 - thenMin - thenHour - ;; If THEN is earlier than NOW, make it - ;; same time tomorrow. Doc for encode-time - ;; says that this is OK. - (+ (elt nowParts 3) - (if (or (< thenHour (elt nowParts 2)) - (and (= thenHour (elt nowParts 2)) - (<= thenMin (elt nowParts 1)))) - 1 0)) - (elt nowParts 4) - (elt nowParts 5) - (elt nowParts 6) - (elt nowParts 7) - (elt nowParts 8))) - ;; calculate number of seconds between NOW and THEN - (diff (+ (* 65536 (- (car then) (car now))) - (- (cadr then) (cadr now))))) - ;; return number of timesteps in the number of seconds - (round (/ diff gnus-demon-timestep)))) + (then (encode-time + 0 + thenMin + thenHour + ;; If THEN is earlier than NOW, make it + ;; same time tomorrow. Doc for encode-time + ;; says that this is OK. + (+ (decoded-time-day nowParts) + (if (or (< thenHour (decoded-time-hour nowParts)) + (and (= thenHour + (decoded-time-hour nowParts)) + (<= thenMin + (decoded-time-minute nowParts)))) + 1 0)) + (decoded-time-month nowParts) + (decoded-time-year nowParts) + (decoded-time-weekday nowParts) + (decoded-time-dst nowParts) + (decoded-time-zone nowParts))) + (diff (float-time (time-subtract then now)))) + ;; Return number of timesteps in the number of seconds. + (round diff gnus-demon-timestep))) (gnus-add-shutdown 'gnus-demon-cancel 'gnus) @@ -204,7 +205,7 @@ marked with SPECIAL." "Cancel any Gnus daemons." (interactive) (dotimes (i (/ (length gnus-demon-timers) 2)) - (nnheader-cancel-timer (nth (1+ (* i 2)) gnus-demon-timers))) + (cancel-timer (nth (1+ (* i 2)) gnus-demon-timers))) (setq gnus-demon-timers nil)) (defun gnus-demon-add-disconnection () diff --git a/lisp/gnus/gnus-diary.el b/lisp/gnus/gnus-diary.el index 51e39958798..0e78f2b8992 100644 --- a/lisp/gnus/gnus-diary.el +++ b/lisp/gnus/gnus-diary.el @@ -2,8 +2,7 @@ ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. -;; Author: Didier Verna <didier@xemacs.org> -;; Maintainer: Didier Verna <didier@xemacs.org> +;; Author: Didier Verna <didier@didierverna.net> ;; Created: Tue Jul 20 10:42:55 1999 ;; Keywords: calendar mail news @@ -159,32 +158,29 @@ There are currently two built-in format functions: ;; Code partly stolen from article-make-date-line (let* ((extras (mail-header-extra header)) (sched (gnus-diary-header-schedule extras)) - (occur (nndiary-next-occurrence sched (current-time))) (now (current-time)) + (occur (nndiary-next-occurrence sched now)) (real-time (time-subtract occur now))) - (if (null real-time) - "?????" - (let* ((sec (+ (* (float (car real-time)) 65536) (cadr real-time))) - (past (< sec 0)) - delay) - (and past (setq sec (- sec))) - (unless (zerop sec) - ;; This is a bit convoluted, but basically we go through the time - ;; units for years, weeks, etc, and divide things to see whether - ;; that results in positive answers. - (let ((units `((year . ,(* 365.25 24 3600)) - (month . ,(* 31 24 3600)) - (week . ,(* 7 24 3600)) - (day . ,(* 24 3600)) - (hour . 3600) - (minute . 60))) - unit num) - (while (setq unit (pop units)) - (unless (zerop (setq num (ffloor (/ sec (cdr unit))))) - (setq delay (append delay `((,(floor num) . ,(car unit)))))) - (setq sec (- sec (* num (cdr unit))))))) - (funcall gnus-diary-delay-format-function past delay))) - )) + (let* ((sec (encode-time real-time 'integer)) + (past (< sec 0)) + delay) + (and past (setq sec (- sec))) + (unless (zerop sec) + ;; This is a bit convoluted, but basically we go through the time + ;; units for years, weeks, etc, and divide things to see whether + ;; that results in positive answers. + (let ((units `((year . ,(round (* 365.25 24 3600))) + (month . ,(* 31 24 3600)) + (week . ,(* 7 24 3600)) + (day . ,(* 24 3600)) + (hour . 3600) + (minute . 60))) + unit num) + (while (setq unit (pop units)) + (unless (zerop (setq num (floor sec (cdr unit)))) + (setq delay (append delay `((,num . ,(car unit)))))) + (setq sec (mod sec (cdr unit)))))) + (funcall gnus-diary-delay-format-function past delay)))) ;; #### NOTE: Gnus sometimes gives me a HEADER not corresponding to any ;; message, with all fields set to nil here. I don't know what it is for, and diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el index e1686e0f7c1..0616dc8fd5a 100644 --- a/lisp/gnus/gnus-draft.el +++ b/lisp/gnus/gnus-draft.el @@ -30,7 +30,6 @@ (require 'gnus-msg) (require 'nndraft) (require 'gnus-agent) -(eval-when-compile (require 'cl)) ;;; Draft minor mode @@ -95,14 +94,13 @@ (save-restriction (message-narrow-to-headers) (message-remove-header "date"))) - (let ((message-draft-headers - (delq 'Date (copy-sequence message-draft-headers)))) + (let ((message-draft-headers (remq 'Date message-draft-headers))) (save-buffer)) (let ((gnus-verbose-backends nil)) (gnus-request-expire-articles (list article) group t)) (push `((lambda () - (when (gnus-buffer-exists-p ,gnus-summary-buffer) + (when (gnus-buffer-live-p ,gnus-summary-buffer) (save-excursion (set-buffer ,gnus-summary-buffer) (gnus-cache-possibly-remove-article ,article nil nil nil t))))) diff --git a/lisp/gnus/gnus-dup.el b/lisp/gnus/gnus-dup.el index 8342ca86b67..4981614a17f 100644 --- a/lisp/gnus/gnus-dup.el +++ b/lisp/gnus/gnus-dup.el @@ -1,4 +1,4 @@ -;;; gnus-dup.el --- suppression of duplicate articles in Gnus +;;; gnus-dup.el --- suppression of duplicate articles in Gnus -*- lexical-binding: t -*- ;; Copyright (C) 1996-2019 Free Software Foundation, Inc. @@ -29,8 +29,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'gnus) (require 'gnus-art) @@ -46,7 +44,7 @@ seen in the same session." :type 'boolean) (defcustom gnus-duplicate-list-length 10000 - "The number of Message-IDs to keep in the duplicate suppression list." + "The maximum number of duplicate Message-IDs to keep track of." :group 'gnus-duplicate :type 'integer) @@ -57,10 +55,14 @@ seen in the same session." ;;; Internal variables -(defvar gnus-dup-list nil) -(defvar gnus-dup-hashtb nil) +(defvar gnus-dup-list nil + "List of seen message IDs, as strings.") + +(defvar gnus-dup-hashtb nil + "Hash table of seen message IDs, for fast lookup.") -(defvar gnus-dup-list-dirty nil) +(defvar gnus-dup-list-dirty nil + "Non-nil if `gnus-dup-list' needs to be saved.") ;;; ;;; Starting and stopping @@ -80,10 +82,10 @@ seen in the same session." (if gnus-save-duplicate-list (gnus-dup-read) (setq gnus-dup-list nil)) - (setq gnus-dup-hashtb (gnus-make-hashtable gnus-duplicate-list-length)) + (setq gnus-dup-hashtb (gnus-make-hashtable)) ;; Enter all Message-IDs into the hash table. - (let ((obarray gnus-dup-hashtb)) - (mapc 'intern gnus-dup-list))) + (dolist (g gnus-dup-list) + (puthash g t gnus-dup-hashtb))) (defun gnus-dup-read () "Read the duplicate suppression list." @@ -105,7 +107,7 @@ seen in the same session." (defun gnus-dup-enter-articles () "Enter articles from the current group for future duplicate suppression." - (unless gnus-dup-list + (unless gnus-dup-hashtb (gnus-dup-open)) (setq gnus-dup-list-dirty t) ; mark list for saving (let (msgid) @@ -118,29 +120,30 @@ seen in the same session." (not (= (gnus-data-mark datum) gnus-canceled-mark)) (setq msgid (mail-header-id (gnus-data-header datum))) (not (nnheader-fake-message-id-p msgid)) - (not (intern-soft msgid gnus-dup-hashtb))) + (not (gethash msgid gnus-dup-hashtb))) (push msgid gnus-dup-list) - (intern msgid gnus-dup-hashtb)))) - ;; Chop off excess Message-IDs from the list. - (let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list))) + (puthash msgid t gnus-dup-hashtb)))) + ;; Remove excess Message-IDs from the list and hash table. + (let* ((dups (cons nil gnus-dup-list)) + (end (nthcdr gnus-duplicate-list-length dups))) (when end - (mapc (lambda (id) (unintern id gnus-dup-hashtb)) (cdr end)) - (setcdr end nil)))) + (mapc (lambda (id) (remhash id gnus-dup-hashtb)) (cdr end)) + (setcdr end nil)) + (setq gnus-dup-list (cdr dups)))) (defun gnus-dup-suppress-articles () "Mark duplicate articles as read." - (unless gnus-dup-list + (unless gnus-dup-hashtb (gnus-dup-open)) (gnus-message 8 "Suppressing duplicates...") (let ((auto (and gnus-newsgroup-auto-expire (memq gnus-duplicate-mark gnus-auto-expirable-marks))) number) (dolist (header gnus-newsgroup-headers) - (when (and (intern-soft (mail-header-id header) gnus-dup-hashtb) - (gnus-summary-article-unread-p (mail-header-number header))) - (setq gnus-newsgroup-unreads - (delq (setq number (mail-header-number header)) - gnus-newsgroup-unreads)) + (when (and (gethash (mail-header-id header) gnus-dup-hashtb) + (setq number (mail-header-number header)) + (gnus-summary-article-unread-p number)) + (setq gnus-newsgroup-unreads (delq number gnus-newsgroup-unreads)) (if (not auto) (push (cons number gnus-duplicate-mark) gnus-newsgroup-reads) (push number gnus-newsgroup-expirable) @@ -149,12 +152,13 @@ seen in the same session." (defun gnus-dup-unsuppress-article (article) "Stop suppression of ARTICLE." - (let* ((header (gnus-data-header (gnus-data-find article))) - (id (when header (mail-header-id header)))) - (when id + (let (header id) + (when (and gnus-dup-hashtb + (setq header (gnus-data-header (gnus-data-find article))) + (setq id (mail-header-id header))) (setq gnus-dup-list-dirty t) (setq gnus-dup-list (delete id gnus-dup-list)) - (unintern id gnus-dup-hashtb)))) + (remhash id gnus-dup-hashtb)))) (provide 'gnus-dup) diff --git a/lisp/gnus/gnus-fun.el b/lisp/gnus/gnus-fun.el index d57180fe5ad..8b710512be8 100644 --- a/lisp/gnus/gnus-fun.el +++ b/lisp/gnus/gnus-fun.el @@ -24,9 +24,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - (require 'mm-util) (require 'gnus-util) (require 'gnus) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index bcff8621925..299ebdec50a 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -24,10 +24,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) -(defvar tool-bar-mode) - +(require 'cl-lib) (require 'gnus) (require 'gnus-start) (require 'nnmail) @@ -41,11 +38,14 @@ (eval-when-compile (require 'mm-url) + (require 'subr-x) (let ((features (cons 'gnus-group features))) (require 'gnus-sum)) (unless (boundp 'gnus-cache-active-hashtb) (defvar gnus-cache-active-hashtb nil))) +(defvar tool-bar-mode) + (autoload 'gnus-agent-total-fetched-for "gnus-agent") (autoload 'gnus-cache-total-fetched-for "gnus-cache") @@ -497,7 +497,7 @@ simple manner." (defvar gnus-tmp-number-of-unread) (defvar gnus-group-line-format-alist - `((?M gnus-tmp-marked-mark ?c) + '((?M gnus-tmp-marked-mark ?c) (?S gnus-tmp-subscribed ?c) (?L gnus-tmp-level ?d) (?N (cond ((eq number t) "*" ) @@ -545,7 +545,7 @@ simple manner." )) (defvar gnus-group-mode-line-format-alist - `((?S gnus-tmp-news-server ?s) + '((?S gnus-tmp-news-server ?s) (?M gnus-tmp-news-method ?s) (?u gnus-tmp-user-defined ?s) (?: gnus-tmp-colon ?s))) @@ -568,8 +568,6 @@ simple manner." ;;; Gnus group mode ;;; -(put 'gnus-group-mode 'mode-class 'special) - (gnus-define-keys gnus-group-mode-map " " gnus-group-read-group "=" gnus-group-select-group @@ -783,7 +781,7 @@ simple manner." (easy-menu-define gnus-group-reading-menu gnus-group-mode-map "" - `("Group" + '("Group" ["Read" gnus-group-read-group :included (not (gnus-topic-mode-p)) :active (gnus-group-group-name)] @@ -950,7 +948,7 @@ simple manner." (easy-menu-define gnus-group-misc-menu gnus-group-mode-map "" - `("Gnus" + '("Gnus" ["Send a mail" gnus-group-mail t] ["Send a message (mail or news)" gnus-group-post-news t] ["Create a local message" gnus-group-news t] @@ -1086,6 +1084,8 @@ See `gmm-tool-bar-from-list' for the format of the list." (defvar image-load-path) (defvar tool-bar-map) +(declare-function image-load-path-for-library "image" + (library image &optional path no-error)) (defun gnus-group-make-tool-bar (&optional force) "Make a group mode tool bar from `gnus-group-tool-bar'. @@ -1105,9 +1105,8 @@ When FORCE, rebuild the tool bar." (set (make-local-variable 'tool-bar-map) map)))) gnus-group-tool-bar-map) -(define-derived-mode gnus-group-mode fundamental-mode "Group" +(define-derived-mode gnus-group-mode gnus-mode "Group" "Major mode for reading news. - All normal editing commands are switched off. \\<gnus-group-mode-map> The group buffer lists (some of) the groups available. For instance, @@ -1130,8 +1129,7 @@ The following commands are available: (setq mode-line-process nil) (buffer-disable-undo) (setq truncate-lines t) - (setq buffer-read-only t - show-trailing-whitespace nil) + (setq show-trailing-whitespace nil) (gnus-set-default-directory) (gnus-update-format-specifications nil 'group 'group-mode) (gnus-update-group-mark-positions) @@ -1145,14 +1143,14 @@ The following commands are available: (let ((gnus-process-mark ?\200) (gnus-group-update-hook nil) (gnus-group-marked '("dummy.group")) - (gnus-active-hashtb (make-vector 10 0))) + (gnus-active-hashtb (gnus-make-hashtable 10))) (gnus-set-active "dummy.group" '(0 . 0)) (gnus-set-work-buffer) (gnus-group-insert-group-line "dummy.group" 0 nil 0 nil) (goto-char (point-min)) (setq gnus-group-mark-positions (list (cons 'process (and (search-forward - (string-to-multibyte "\200") nil t) + (string gnus-process-mark) nil t) (- (point) (point-min) 1)))))))) (defun gnus-mouse-pick-group (e) @@ -1189,6 +1187,9 @@ The following commands are available: (unless (derived-mode-p 'gnus-group-mode) (gnus-group-mode))) +;; FIXME: If we never have to coerce group names to unibyte now, how +;; much of this is necessary? How much encoding/decoding do we still +;; have to do? (defun gnus-group-name-charset (method group) (unless method (setq method (gnus-find-method-for-group group))) @@ -1270,20 +1271,14 @@ Also see the `gnus-group-use-permanent-levels' variable." ;; has disappeared in the new listing, try to find the next ;; one. If no next one can be found, just leave point at the ;; first newsgroup in the buffer. - (when (not (gnus-goto-char - (text-property-any - (point-min) (point-max) - 'gnus-group (gnus-intern-safe - group gnus-active-hashtb)))) - (let ((newsrc (cdddr (gnus-group-entry group)))) - (while (and newsrc - (not (gnus-goto-char - (text-property-any - (point-min) (point-max) 'gnus-group - (gnus-intern-safe - (caar newsrc) gnus-active-hashtb))))) - (setq newsrc (cdr newsrc))) - (unless newsrc + (when (not (gnus-text-property-search + 'gnus-group group nil 'goto)) + (let ((groups (cdr-safe (member group gnus-group-list)))) + (while (and groups + (not (gnus-text-property-search + 'gnus-group (car groups) 'forward 'goto))) + (setq groups (cdr groups))) + (unless groups (goto-char (point-max)) (forward-line -1))))))) ;; Adjust cursor point. @@ -1316,7 +1311,6 @@ If REGEXP is a function, list dead groups that the function returns non-nil; if it is a string, only list groups matching REGEXP." (set-buffer gnus-group-buffer) (let ((buffer-read-only nil) - (newsrc (cdr gnus-newsrc-alist)) (lowest (or lowest 1)) (not-in-list (and gnus-group-listed-groups (copy-sequence gnus-group-listed-groups))) @@ -1324,12 +1318,11 @@ if it is a string, only list groups matching REGEXP." (erase-buffer) (when (or (< lowest gnus-level-zombie) gnus-group-listed-groups) - ;; List living groups. - (while newsrc - (setq info (car newsrc) + ;; List living groups, according to order in `gnus-group-list'. + (dolist (g (cdr gnus-group-list)) + (setq info (gnus-get-info g) group (gnus-info-group info) params (gnus-info-params info) - newsrc (cdr newsrc) unread (gnus-group-unread group)) (when not-in-list (setq not-in-list (delete group not-in-list))) @@ -1359,6 +1352,8 @@ if it is a string, only list groups matching REGEXP." (and gnus-permanently-visible-groups (string-match gnus-permanently-visible-groups group)) + ;; Marked groups are always visible. + (member group gnus-group-marked) (memq 'visible params) (cdr (assq 'visible params))))))) (gnus-group-insert-group-line @@ -1394,39 +1389,35 @@ if it is a string, only list groups matching REGEXP." ;; List zombies and killed lists somewhat faster, which was ;; suggested by Jack Vinson <vinson@unagi.cis.upenn.edu>. It does ;; this by ignoring the group format specification altogether. - (let (group) - (if (> (length groups) gnus-group-listing-limit) - (while groups - (setq group (pop groups)) - (when (gnus-group-prepare-logic - group - (or (not regexp) - (and (stringp regexp) (string-match regexp group)) - (and (functionp regexp) (funcall regexp group)))) - (add-text-properties - (point) (prog1 (1+ (point)) - (insert " " mark " *: " - (gnus-group-decoded-name group) - "\n")) - (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) - 'gnus-unread t - 'gnus-level level)))) - (while groups - (setq group (pop groups)) + (if (nthcdr gnus-group-listing-limit groups) + (dolist (group groups) (when (gnus-group-prepare-logic group - (or (not regexp) - (and (stringp regexp) (string-match regexp group)) - (and (functionp regexp) (funcall regexp group)))) - (gnus-group-insert-group-line - group level nil - (let ((active (gnus-active group))) - (if active - (if (zerop (cdr active)) - 0 - (- (1+ (cdr active)) (car active))) - nil)) - (gnus-method-simplify (gnus-find-method-for-group group)))))))) + (cond ((not regexp)) + ((stringp regexp) (string-match-p regexp group)) + ((functionp regexp) (funcall regexp group)))) + (add-text-properties + (point) (prog1 (1+ (point)) + (insert " " mark " *: " + (gnus-group-decoded-name group) + "\n")) + (list 'gnus-group group + 'gnus-unread t + 'gnus-level level)))) + (dolist (group groups) + (when (gnus-group-prepare-logic + group + (cond ((not regexp)) + ((stringp regexp) (string-match-p regexp group)) + ((functionp regexp) (funcall regexp group)))) + (gnus-group-insert-group-line + group level nil + (let ((active (gnus-active group))) + (and active + (if (zerop (cdr active)) + 0 + (- (cdr active) (car active) -1)))) + (gnus-method-simplify (gnus-find-method-for-group group))))))) (defun gnus-group-update-group-line () "Update the current line in the group buffer." @@ -1439,7 +1430,7 @@ if it is a string, only list groups matching REGEXP." (not (gnus-ephemeral-group-p group)) (gnus-dribble-enter (concat "(gnus-group-set-info '" - (gnus-prin1-to-string (nth 2 entry)) + (gnus-prin1-to-string (nth 1 entry)) ")") (concat "^(gnus-group-set-info '(\"" (regexp-quote group) "\""))) (setq gnus-group-indentation (gnus-group-group-indentation)) @@ -1456,7 +1447,7 @@ if it is a string, only list groups matching REGEXP." (if entry (progn ;; (Un)subscribed group. - (setq info (nth 2 entry)) + (setq info (nth 1 entry)) (gnus-group-insert-group-line group (gnus-info-level info) (gnus-info-marks info) (or (car entry) t) (gnus-info-method info))) @@ -1473,7 +1464,7 @@ if it is a string, only list groups matching REGEXP." (gnus-method-simplify (gnus-find-method-for-group group)))))) (defun gnus-number-of-unseen-articles-in-group (group) - (let* ((info (nth 2 (gnus-group-entry group))) + (let* ((info (nth 1 (gnus-group-entry group))) (marked (gnus-info-marks info)) (seen (cdr (assq 'seen marked))) (active (gnus-active group))) @@ -1532,7 +1523,7 @@ if it is a string, only list groups matching REGEXP." (int-to-string (max 0 (- gnus-tmp-number-total number))) "*")) (gnus-tmp-subscribed - (cond ((<= gnus-tmp-level gnus-level-subscribed) ? ) + (cond ((<= gnus-tmp-level gnus-level-subscribed) ?\s) ((<= gnus-tmp-level gnus-level-unsubscribed) ?U) ((= gnus-tmp-level gnus-level-zombie) ?Z) (t ?K))) @@ -1545,13 +1536,13 @@ if it is a string, only list groups matching REGEXP." (gnus-tmp-newsgroup-description (if gnus-description-hashtb (or (gnus-group-name-decode - (gnus-gethash gnus-tmp-group gnus-description-hashtb) + (gethash gnus-tmp-group gnus-description-hashtb) group-name-charset) "") "")) (gnus-tmp-moderated (if (and gnus-moderated-hashtb - (gnus-gethash gnus-tmp-group gnus-moderated-hashtb)) - ?m ? )) + (gethash gnus-tmp-group gnus-moderated-hashtb)) + ?m ?\s)) (gnus-tmp-moderated-string (if (eq gnus-tmp-moderated ?m) "(m)" "")) (gnus-tmp-group-icon (gnus-group-get-icon gnus-tmp-group)) @@ -1565,18 +1556,18 @@ if it is a string, only list groups matching REGEXP." (if (and (numberp number) (zerop number) (cdr (assq 'tick gnus-tmp-marked))) - ?* ? )) + ?* ?\s)) (gnus-tmp-summary-live (if (and (not gnus-group-is-exiting-p) (gnus-buffer-live-p (gnus-summary-buffer-name gnus-tmp-group))) - ?* ? )) + ?* ?\s)) (gnus-tmp-process-marked (if (member gnus-tmp-group gnus-group-marked) - gnus-process-mark ? )) + gnus-process-mark ?\s)) (buffer-read-only nil) beg end - gnus-tmp-header) ; passed as parameter to user-funcs. + gnus-tmp-header) ; passed as parameter to user-funcs. (beginning-of-line) (setq beg (point)) (add-text-properties @@ -1586,7 +1577,7 @@ if it is a string, only list groups matching REGEXP." (let ((gnus-tmp-decoded-group (gnus-group-name-decode gnus-tmp-group group-name-charset))) (eval gnus-group-line-format-spec))) - `(gnus-group ,(gnus-intern-safe gnus-tmp-group gnus-active-hashtb) + `(gnus-group ,gnus-tmp-group gnus-unread ,(if (numberp number) (string-to-number gnus-tmp-number-of-unread) t) @@ -1620,7 +1611,7 @@ Some value are bound so the form can use them." (when list (let* ((entry (gnus-group-entry group)) (active (gnus-active group)) - (info (nth 2 entry)) + (info (nth 1 entry)) (method (inline (gnus-server-get-method group (gnus-info-method info)))) (marked (gnus-info-marks info)) @@ -1691,9 +1682,7 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated." ;; The buffer may be narrowed. (save-restriction (widen) - (let ((ident (gnus-intern-safe group gnus-active-hashtb)) - (loc (point-min)) - found buffer-read-only) + (let (found buffer-read-only) (unless info-unchanged ;; Enter the current status into the dribble buffer. (let ((entry (gnus-group-entry group))) @@ -1701,37 +1690,33 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated." (not (gnus-ephemeral-group-p group))) (gnus-dribble-enter (concat "(gnus-group-set-info '" - (gnus-prin1-to-string (nth 2 entry)) + (gnus-prin1-to-string (nth 1 entry)) ")") (concat "^(gnus-group-set-info '(\"" (regexp-quote group) "\""))))) - ;; Find all group instances. If topics are in use, each group - ;; may be listed in more than once. - (while (setq loc (text-property-any - loc (point-max) 'gnus-group ident)) + ;; Find all group instances. If topics are in use, groups + ;; may be listed more than once. + (goto-char (point-min)) + (while (gnus-text-property-search + 'gnus-group group 'forward 'goto) (setq found t) - (goto-char loc) (let ((gnus-group-indentation (gnus-group-group-indentation))) (gnus-delete-line) (gnus-group-insert-group-line-info group) (save-excursion (forward-line -1) - (gnus-run-hooks 'gnus-group-update-group-hook))) - (setq loc (1+ loc))) + (gnus-run-hooks 'gnus-group-update-group-hook)))) (unless (or found visible-only) ;; No such line in the buffer, find out where it's supposed to ;; go, and insert it there (or at the end of the buffer). (if gnus-goto-missing-group-function (funcall gnus-goto-missing-group-function group) - (let ((entry (cddr (gnus-group-entry group)))) - (while (and entry (car entry) + (let ((entry (cdr (member group gnus-group-list)))) + (goto-char (point-min)) + (while (and (car-safe entry) (not - (gnus-goto-char - (text-property-any - (point-min) (point-max) - 'gnus-group (gnus-intern-safe - (caar entry) - gnus-active-hashtb))))) + (gnus-text-property-search + 'gnus-group (car entry) 'forward 'goto))) (setq entry (cdr entry))) (or entry (goto-char (point-max))))) ;; Finally insert the line. @@ -1758,8 +1743,7 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated." gnus-tmp-header ;Dummy binding for user-defined formats ;; Get the resulting string. (modified - (and gnus-dribble-buffer - (buffer-name gnus-dribble-buffer) + (and (buffer-live-p gnus-dribble-buffer) (buffer-modified-p gnus-dribble-buffer) (with-current-buffer gnus-dribble-buffer (not (zerop (buffer-size)))))) @@ -1779,10 +1763,8 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated." (defun gnus-group-group-name () "Get the name of the newsgroup on the current line." (let ((group (get-text-property (point-at-bol) 'gnus-group))) - (when group - (if (stringp group) - group - (symbol-name group))))) + (cond ((stringp group) group) + (group (symbol-name group))))) (defun gnus-group-group-level () "Get the level of the newsgroup on the current line." @@ -1802,7 +1784,7 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated." (defun gnus-group-new-mail (group) (if (nnmail-new-mail-p (gnus-group-real-name group)) gnus-new-mail-mark - ? )) + ?\s)) (defun gnus-group-level (group) "Return the estimated level of GROUP." @@ -1892,13 +1874,13 @@ If FIRST-TOO, the current line is also eligible as a target." (if unmark (progn (setq gnus-group-marked (delete group gnus-group-marked)) - (insert-char ? 1 t)) + (insert-char ?\s 1 t)) (setq gnus-group-marked (cons group (delete group gnus-group-marked))) (insert-char gnus-process-mark 1 t))) (unless no-advance (gnus-group-next-group 1)) - (decf n)) + (cl-decf n)) (gnus-group-position-point) n)) @@ -2063,7 +2045,7 @@ that group." (unless group (error "No group on current line")) (setq marked (gnus-info-marks - (nth 2 (setq entry (gnus-group-entry group))))) + (nth 1 (setq entry (gnus-group-entry group))))) ;; This group might be a dead group. In that case we have to get ;; the number of unread articles from `gnus-active-hashtb'. (setq number @@ -2138,6 +2120,7 @@ be permanent." (let ((group (gnus-group-group-name))) (when group (gnus-group-decoded-name group))) + ;; FIXME: Use rx. (let ((regexp "[][\C-@-\t\v-*,/:-@\\^`{-\C-?]*\ \\(nn[a-z]+\\(?:\\+[^][\C-@-*,/:-@\\^`{-\C-?]+\\)?:\ [^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)*\ @@ -2176,34 +2159,39 @@ be permanent." (defun gnus-group-completing-read (&optional prompt collection require-match initial-input hist def) - "Read a group name with completion. Non-ASCII group names are allowed. -The arguments are the same as `completing-read' except that COLLECTION -and HIST default to `gnus-active-hashtb' and `gnus-group-history' -respectively if they are omitted. Regards COLLECTION as a hash table -if it is not a list." + "Read a group name with completion. +Non-ASCII group names are allowed. The arguments are the same as +`completing-read' except that COLLECTION and HIST default to +`gnus-active-hashtb' and `gnus-group-history' respectively if +they are omitted. Can handle COLLECTION as a list, hash table, +or vector." (or collection (setq collection gnus-active-hashtb)) - (let (choices group) - (if (listp collection) - (dolist (symbol collection) - (setq group (symbol-name symbol)) - (push (if (string-match "[^\000-\177]" group) - (gnus-group-decoded-name group) - group) - choices)) - (mapatoms (lambda (symbol) - (setq group (symbol-name symbol)) - (push (if (string-match "[^\000-\177]" group) - (gnus-group-decoded-name group) - group) - choices)) - collection)) - (setq group (gnus-completing-read (or prompt "Group") (nreverse choices) - require-match initial-input - (or hist 'gnus-group-history) - def)) - (unless (if (listp collection) - (member group (mapcar 'symbol-name collection)) - (symbol-value (intern-soft group collection))) + (let* ((choices + (mapcar + (lambda (g) + (if (string-match "[^\000-\177]" g) + (gnus-group-decoded-name g) + g)) + (cond ((listp collection) + collection) + ((vectorp collection) + (mapatoms #'symbol-name collection)) + ((hash-table-p collection) + (hash-table-keys collection))))) + (group + (gnus-completing-read (or prompt "Group") (reverse choices) + require-match initial-input + (or hist 'gnus-group-history) + def))) + (unless (cond ((and (listp collection) + (symbolp (car collection))) + (member group (mapcar 'symbol-name collection))) + ((listp collection) + (member group collection)) + ((vectorp collection) + (symbol-value (intern-soft group collection))) + ((hash-table-p collection) + (gethash group collection))) (setq group (encode-coding-string group (gnus-group-name-charset nil group)))) @@ -2281,7 +2269,8 @@ Return the name of the group if selection was successful." (nnheader-init-server-buffer) ;; Necessary because of funky inlining. (require 'gnus-cache) - (setq gnus-newsrc-hashtb (gnus-make-hashtable))) + (setq gnus-newsrc-hashtb (gnus-make-hashtable 100) + gnus-active-hashtb (gnus-make-hashtable 100))) ;; Transform the select method into a unique server. (when (stringp method) (setq method (gnus-server-to-method method))) @@ -2298,23 +2287,23 @@ Return the name of the group if selection was successful." (gnus-group-prefixed-name (gnus-group-real-name group) method)))) (gnus-set-active group nil) - (gnus-sethash + (puthash group - `(-1 nil (,group - ,gnus-level-default-subscribed nil nil ,method - ,(cons - (cons 'quit-config - (cond - (quit-config - quit-config) - ((assq gnus-current-window-configuration - gnus-buffer-configuration) - (cons gnus-summary-buffer - gnus-current-window-configuration)) - (t - (cons (current-buffer) - (current-window-configuration))))) - parameters))) + `(-1 (,group + ,gnus-level-default-subscribed nil nil ,method + ,(cons + (cons 'quit-config + (cond + (quit-config + quit-config) + ((assq gnus-current-window-configuration + gnus-buffer-configuration) + (cons gnus-summary-buffer + gnus-current-window-configuration)) + (t + (cons (current-buffer) + (current-window-configuration))))) + parameters))) gnus-newsrc-hashtb) (push method gnus-ephemeral-servers) (when (gnus-buffer-live-p gnus-group-buffer) @@ -2434,7 +2423,7 @@ Valid input formats include: (defcustom gnus-bug-group-download-format-alist '((emacs . "https://debbugs.gnu.org/cgi/bugreport.cgi?bug=%s;mboxmaint=yes;mboxstat=yes") (debian - . "http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=%s&mbox=yes;mboxmaint=yes")) + . "https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=%s&mbox=yes;mboxmaint=yes")) "Alist of symbols for bug trackers and the corresponding URL format string. The URL format string must contain a single \"%s\", specifying the bug number, and browsing the URL must return mbox output." @@ -2445,90 +2434,120 @@ the bug number, and browsing the URL must return mbox output." :version "24.1" :type '(repeat (cons (symbol) (string :tag "URL format string")))) +(autoload 'thing-at-point-looking-at "thingatpt") +(defvar bug-reference-bug-regexp) + +(defun gnus-group--read-bug-ids () + "Return a list of bug IDs read in the minibuffer." + (require 'bug-reference) + (let ((def (cond ((thing-at-point-looking-at bug-reference-bug-regexp 500) + (match-string 2)) + ((number-at-point))))) + ;; Pass DEF as the value of COLLECTION instead of DEF because: + ;; a) null input should not cause DEF to be returned and + ;; b) TAB and M-n still work this way. + (or (completing-read-multiple + (format "Bug IDs%s: " (if def (format " (default %s)" def) "")) + (and def (list (format "%s" def)))) + def))) + (defun gnus-read-ephemeral-bug-group (ids mbox-url &optional window-conf) - "Browse bug NUMBER as ephemeral group." - (interactive (list (read-string "Enter bug number: " - (thing-at-point 'word) nil) - ;; FIXME: Add completing-read from - ;; `gnus-emacs-bug-group-download-format' ... - (cdr (assoc 'emacs gnus-bug-group-download-format-alist)))) - (when (stringp ids) - (setq ids (string-to-number ids))) - (unless (listp ids) - (setq ids (list ids))) + "Browse bug reports with IDS in an ephemeral group. +IDS can be either a single bug ID (a number or string), or a list +thereof. MBOX-URL is a URL format string identifying the bug +tracker; see `gnus-bug-group-download-format-alist' for details. +Interactively, read multiple bug IDS in the minibuffer and +default to the MBOX-URL for the Emacs bug tracker. WINDOW-CONF +is the name of the Gnus window configuration to use when exiting +the ephemeral group." + (interactive + (list (gnus-group--read-bug-ids) + (alist-get 'emacs gnus-bug-group-download-format-alist))) + (or ids (user-error "No bug IDs specified")) + (setq ids (mapcar (lambda (id) (format "%s" id)) + (if (consp ids) ids (list ids)))) (let ((tmpfile (make-temp-file "gnus-temp-group-"))) - (let ((coding-system-for-write 'binary) - (coding-system-for-read 'binary)) - (with-temp-file tmpfile - (mm-disable-multibyte) - (dolist (id ids) - (let ((file (format "~/.emacs.d/debbugs-cache/%s" id))) - (if (and (not gnus-plugged) - (file-exists-p file)) - (insert-file-contents file) - (url-insert-file-contents (format mbox-url id) t)))) + (unwind-protect ;; Add the debbugs address so that we can respond to reports easily. - (let ((address - (format "%s@%s" (car ids) - (url-host (url-generic-parse-url mbox-url))))) - (goto-char (point-min)) - (while (re-search-forward (concat "^" message-unix-mail-delimiter) - nil t) - (narrow-to-region (point) - (if (search-forward "\n\n" nil t) - (1- (point)) - (point-max))) - (unless (string-match (concat "\\(?:\\`\\|[ ,<]\\)" - (regexp-quote address) - "\\(?:\\'\\|[ ,>]\\)") - (concat (message-fetch-field "to") " " - (message-fetch-field "cc"))) + (let* ((address (format "%s@%s" (car ids) + (url-host (url-generic-parse-url mbox-url)))) + (address-re (concat "\\(?:\\`\\|[ ,<]\\)" + (regexp-quote address) + "\\(?:\\'\\|[ ,>]\\)")) + (delim (concat "^" message-unix-mail-delimiter))) + (let ((coding-system-for-write 'binary) + (coding-system-for-read 'binary)) + (with-temp-file tmpfile + (mm-disable-multibyte) + (dolist (id ids) + (let ((file (concat "~/.emacs.d/debbugs-cache/" id))) + (if (and (not gnus-plugged) + (file-exists-p file)) + (insert-file-contents file) + ;; Pass non-nil VISIT to avoid errors with non-nil + ;; `url-automatic-caching' (bug#26063, bug#29008) + ;; and immediately unvisit. + ;; FIXME: This masks real errors! + (url-insert-file-contents (format mbox-url id) t) + (setq buffer-file-name nil)))) (goto-char (point-min)) - (if (re-search-forward "^To:" nil t) - (progn + ;; Throw an informative error early instead of passing nonsense + ;; to `gnus-group-read-ephemeral-group' (bug#36433). + (unless (save-excursion (re-search-forward delim nil t)) + (error "Invalid mbox format for bug IDs: %s" + (string-join ids ", "))) + (while (re-search-forward delim nil t) + (narrow-to-region (point) + (if (search-forward "\n\n" nil t) + (1- (point)) + (point-max))) + (unless (string-match-p address-re + (concat (message-fetch-field "to") " " + (message-fetch-field "cc"))) + (goto-char (point-min)) + (if (not (re-search-forward "^To:" nil t)) + (insert "To: " address "\n") (message-next-header) (skip-chars-backward "\t\n ") - (insert ", " address)) - (insert "To: " address "\n"))) - (goto-char (point-max)) - (widen))) - ;; `url-insert-file-contents' sets this because of the 2nd arg. - (setq buffer-file-name nil))) - (gnus-group-read-ephemeral-group - (format "nndoc+ephemeral:bug#%s" - (mapconcat 'number-to-string ids ",")) - `(nndoc ,tmpfile - (nndoc-article-type mbox)) - nil window-conf) - (delete-file tmpfile))) - -(defun gnus-read-ephemeral-debian-bug-group (number) - "Browse Debian bug NUMBER as ephemeral group." - (interactive (list (read-string "Enter bug number: " - (thing-at-point 'word) nil))) + (insert ", " address))) + (goto-char (point-max)) + (widen)))) + (gnus-group-read-ephemeral-group + (concat "nndoc+ephemeral:bug#" (string-join ids ",")) + `(nndoc ,tmpfile + (nndoc-article-type mbox)) + nil window-conf)) + (delete-file tmpfile)))) + +(defun gnus-read-ephemeral-debian-bug-group (ids &optional window-conf) + "Browse Debian bug reports with IDS in an ephemeral group. +The arguments have the same meaning as those of +`gnus-read-ephemeral-bug-group', which see." + (interactive (list (gnus-group--read-bug-ids))) (gnus-read-ephemeral-bug-group - number - (cdr (assoc 'debian gnus-bug-group-download-format-alist)))) + ids + (alist-get 'debian gnus-bug-group-download-format-alist) + window-conf)) (defvar debbugs-gnu-bug-number) ; debbugs-gnu +;;;###autoload (defun gnus-read-ephemeral-emacs-bug-group (ids &optional window-conf) - "Browse Emacs bugs IDS as an ephemeral group." - (interactive (list (string-to-number - (read-string "Enter bug number: " - (thing-at-point 'word) nil)))) - (when (stringp ids) - (setq ids (string-to-number ids))) - (unless (listp ids) - (setq ids (list ids))) + "Browse Emacs bug reports with IDS in an ephemeral group. +The arguments have the same meaning as those of +`gnus-read-ephemeral-bug-group', which see." + (interactive (list (gnus-group--read-bug-ids))) (gnus-read-ephemeral-bug-group ids - (cdr (assoc 'emacs gnus-bug-group-download-format-alist)) + (alist-get 'emacs gnus-bug-group-download-format-alist) window-conf) - (when (fboundp 'debbugs-gnu-summary-mode) + (when (and (require 'debbugs-gnu nil t) + (fboundp 'debbugs-gnu-summary-mode)) (with-current-buffer (window-buffer (selected-window)) (debbugs-gnu-summary-mode 1) - (set (make-local-variable 'debbugs-gnu-bug-number) (car ids))))) + (let ((id (or (car-safe ids) ids))) + (if (stringp id) (setq id (string-to-number id))) + (setq-local debbugs-gnu-bug-number id))))) (defun gnus-group-jump-to-group (group &optional prompt) "Jump to newsgroup GROUP. @@ -2548,65 +2567,64 @@ If PROMPT (the prefix) is a number, use the prompt specified in (when (equal group "") (error "Empty group name")) - (unless (gnus-ephemeral-group-p group) - ;; Either go to the line in the group buffer... - (unless (gnus-group-goto-group group) - ;; ... or insert the line. - (gnus-group-update-group group) - (gnus-group-goto-group group))) - ;; Adjust cursor point. - (gnus-group-position-point)) + (prog1 + (unless (gnus-ephemeral-group-p group) + ;; Either go to the line in the group buffer... + (unless (gnus-group-goto-group group) + ;; ... or insert the line. + (gnus-group-update-group group) + (gnus-group-goto-group group))) + ;; Adjust cursor point. + (gnus-group-position-point))) (defun gnus-group-goto-group (group &optional far test-marked) - "Goto to newsgroup GROUP. + "Go to newsgroup GROUP. If FAR, it is likely that the group is not on the current line. -If TEST-MARKED, the line must be marked." +If TEST-MARKED, the line must be marked. + +Return nil if GROUP is not found." (when group - (beginning-of-line) - (cond - ;; It's quite likely that we are on the right line, so - ;; we check the current line first. - ((and (not far) - (eq (get-text-property (point) 'gnus-group) - (gnus-intern-safe group gnus-active-hashtb)) - (or (not test-marked) (gnus-group-mark-line-p))) - (point)) - ;; Previous and next line are also likely, so we check them as well. - ((and (not far) - (save-excursion - (forward-line -1) - (and (eq (get-text-property (point) 'gnus-group) - (gnus-intern-safe group gnus-active-hashtb)) - (or (not test-marked) (gnus-group-mark-line-p))))) - (forward-line -1) - (point)) - ((and (not far) - (save-excursion - (forward-line 1) - (and (eq (get-text-property (point) 'gnus-group) - (gnus-intern-safe group gnus-active-hashtb)) - (or (not test-marked) (gnus-group-mark-line-p))))) - (forward-line 1) - (point)) - (test-marked - (goto-char (point-min)) - (let (found) - (while (and (not found) - (gnus-goto-char - (text-property-any - (point) (point-max) - 'gnus-group - (gnus-intern-safe group gnus-active-hashtb)))) - (if (gnus-group-mark-line-p) - (setq found t) - (forward-line 1))) - found)) - (t - ;; Search through the entire buffer. - (gnus-goto-char - (text-property-any - (point-min) (point-max) - 'gnus-group (gnus-intern-safe group gnus-active-hashtb))))))) + (let ((start (point))) + (beginning-of-line) + (cond + ;; It's quite likely that we are on the right line, so + ;; we check the current line first. + ((and (not far) + (equal (get-text-property (point) 'gnus-group) group) + (or (not test-marked) (gnus-group-mark-line-p))) + (point)) + ;; Previous and next line are also likely, so we check them as well. + ((and (not far) + (save-excursion + (forward-line -1) + (and (equal (get-text-property (point) 'gnus-group) group) + (or (not test-marked) (gnus-group-mark-line-p))))) + (forward-line -1) + (point)) + ((and (not far) + (save-excursion + (forward-line 1) + (and (equal (get-text-property (point) 'gnus-group) group) + (or (not test-marked) (gnus-group-mark-line-p))))) + (forward-line 1) + (point)) + (test-marked + (goto-char (point-min)) + (let (found) + (while (and (not found) + (gnus-text-property-search + 'gnus-group group 'forward 'goto)) + (if (gnus-group-mark-line-p) + (setq found t) + (forward-line 1))) + found)) + (t + ;; Search through the entire buffer. + (if (gnus-text-property-search + 'gnus-group group nil 'goto) + (point) + (goto-char start) + nil)))))) (defun gnus-group-next-group (n &optional silent) "Go to next N'th newsgroup. @@ -2771,9 +2789,7 @@ server." (gnus-group-change-level (setq info (list t nname gnus-level-default-subscribed nil nil meth)) gnus-level-default-subscribed gnus-level-killed - (and (gnus-group-group-name) - (gnus-group-entry (gnus-group-group-name))) - t) + (gnus-group-group-name) t) ;; Make it active. (gnus-set-active nname (cons 1 0)) (unless (gnus-ephemeral-group-p name) @@ -2833,6 +2849,7 @@ If FORCE (the prefix) is non-nil, all the articles in the group will be deleted. This is \"deleted\" as in \"removed forever from the face of the Earth\". There is no undo. The user will be prompted before doing the deletion. + Note that you also have to specify FORCE if you want the group to be removed from the server, even when it's empty." (interactive @@ -2844,12 +2861,11 @@ be removed from the server, even when it's empty." (error "This back end does not support group deletion")) (prog1 (let ((group-decoded (gnus-group-decoded-name group))) - (if (and (not no-prompt) - (not (gnus-yes-or-no-p - (format - "Do you really want to delete %s%s? " - group-decoded (if force " and all its contents" ""))))) - () ; Whew! + (when (or no-prompt + (gnus-yes-or-no-p + (format + "Do you really want to delete %s%s? " + group-decoded (if force " and all its contents" "")))) (gnus-message 6 "Deleting group %s..." group-decoded) (if (not (gnus-request-delete-group group force)) (gnus-error 3 "Couldn't delete group %s" group-decoded) @@ -2998,7 +3014,7 @@ and NEW-NAME will be prompted for." ;; Set the info. (if (not (and info new-group)) (gnus-group-set-info form (or new-group group) part) - (setq info (gnus-copy-sequence info)) + (setq info (copy-tree info)) (setcar info new-group) (unless (gnus-server-equal method "native") (unless (nthcdr 3 info) @@ -3021,7 +3037,7 @@ and NEW-NAME will be prompted for." ;; Don't use `caddr' here since macros within the `interactive' ;; form won't be expanded. (car (cddr entry))))) - (setq method (gnus-copy-sequence method)) + (setq method (copy-tree method)) (let (entry) (while (setq entry (memq (assq 'eval method) method)) (setcar entry (eval (cadar entry))))) @@ -3230,7 +3246,7 @@ mail messages or news articles in files that have numeric names." ;; Subscribe the new group after the group on the current line. (gnus-subscribe-group pgroup (gnus-group-group-name) method) (gnus-group-update-group pgroup) - (forward-line -1) + (forward-line) (gnus-group-position-point))) (defun gnus-group-enter-directory (dir) @@ -3313,21 +3329,31 @@ If REVERSE (the prefix), reverse the sorting order." (funcall gnus-group-sort-alist-function (gnus-make-sort-function func) reverse) (gnus-group-unmark-all-groups) + ;; Redisplay all groups according to the newly-sorted order of + ;; `gnus-group-list'. (gnus-group-list-groups) (gnus-dribble-touch)) (defun gnus-group-sort-flat (func reverse) - ;; We peel off the dummy group from the alist. + "Sort groups in a flat list using sorting function FUNC. +If REVERSE is non-nil, reverse the sort order. + +This function sets a new value for `gnus-group-list'; its return +value is disregarded." (when func - (when (equal (gnus-info-group (car gnus-newsrc-alist)) "dummy.group") - (pop gnus-newsrc-alist)) - ;; Do the sorting. - (setq gnus-newsrc-alist - (sort gnus-newsrc-alist func)) - (when reverse - (setq gnus-newsrc-alist (nreverse gnus-newsrc-alist))) - ;; Regenerate the hash table. - (gnus-make-hashtable-from-newsrc-alist))) + (let* ((groups (remove "dummy.group" gnus-group-list)) + (sorted-infos + (sort (mapcar (lambda (g) + (gnus-get-info g)) + groups) + func))) + (setq gnus-group-list + (mapcar (lambda (i) + (gnus-info-group i)) + sorted-infos)) + (when reverse + (setq gnus-group-list (nreverse gnus-group-list))) + (setq gnus-group-list (cons "dummy.group" gnus-group-list))))) (defun gnus-group-sort-groups-by-alphabet (&optional reverse) "Sort the group buffer alphabetically by group name. @@ -3390,27 +3416,26 @@ If REVERSE, sort in reverse order." (gnus-dribble-touch))) (defun gnus-group-sort-selected-flat (groups func reverse) - (let (entries infos) - ;; First find all the group entries for these groups. - (while groups - (push (nthcdr 2 (gnus-group-entry (pop groups))) - entries)) - ;; Then sort the infos. - (setq infos - (sort - (mapcar - (lambda (entry) (car entry)) - (setq entries (nreverse entries))) - func)) + "Sort only the selected GROUPS, using FUNC. +If REVERSE is non-nil, reverse the sorting." + (let ((infos (sort + (mapcar (lambda (g) + (gnus-get-info g)) + groups) + func)) + sorted-groups) (when reverse (setq infos (nreverse infos))) - ;; Go through all the infos and replace the old entries - ;; with the new infos. - (while infos - (setcar (car entries) (pop infos)) - (pop entries)) - ;; Update the hashtable. - (gnus-make-hashtable-from-newsrc-alist))) + (setq sorted-groups (mapcar (lambda (i) (gnus-info-group i)) infos)) + + ;; Find the original locations of GROUPS in `gnus-group-list', and + ;; replace each one, in order, with a group from SORTED-GROUPS. + (dolist (i (sort (mapcar (lambda (g) + (seq-position gnus-group-list g)) + groups) + #'<)) + (setf (nth i gnus-group-list) + (pop sorted-groups))))) (defun gnus-group-sort-selected-groups-by-alphabet (&optional n reverse) "Sort the group buffer alphabetically by group name. @@ -3553,7 +3578,7 @@ Obeys the process/prefix convention." (gnus-request-set-mark ,group ',action) (gnus-info-set-marks ',info ',(gnus-info-marks info) t) (gnus-info-set-read ',info ',(gnus-info-read info)) - (when (gnus-group-goto-group ,group) + (when (gnus-group-jump-to-group ,group) (gnus-get-unread-articles-in-group ',info ',(gnus-active group) t) (gnus-group-update-group-line)))) (setq action (mapcar (lambda (el) (list (nth 0 el) 'del (nth 2 el))) @@ -3623,7 +3648,7 @@ The return value is the number of articles that were marked as read, or nil if no action could be taken." (let* ((entry (gnus-group-entry group)) (num (car entry)) - (marks (gnus-info-marks (nth 2 entry))) + (marks (gnus-info-marks (nth 1 entry))) (unread (gnus-sequence-of-unread-articles group))) ;; Remove entries for this group. (nnmail-purge-split-history (gnus-group-real-name group)) @@ -3789,7 +3814,7 @@ group line." (newsrc ;; Toggle subscription flag. (gnus-group-change-level - newsrc (if level level (if (<= (gnus-info-level (nth 2 newsrc)) + newsrc (if level level (if (<= (gnus-info-level (nth 1 newsrc)) gnus-level-subscribed) (1+ gnus-level-subscribed) gnus-level-default-subscribed))) @@ -3805,8 +3830,7 @@ group line." (or (and (member group gnus-zombie-list) gnus-level-zombie) gnus-level-killed) - (when (gnus-group-group-name) - (gnus-group-entry (gnus-group-group-name)))) + (gnus-group-group-name)) (unless silent (gnus-group-update-group group))) (t (error "No such newsgroup: %s" group))) @@ -3877,10 +3901,12 @@ of groups killed." `(progn (gnus-group-goto-group ,(gnus-group-group-name)) (gnus-group-yank-group))) - (push (cons (car entry) (nth 2 entry)) + (push (cons (car entry) (nth 1 entry)) gnus-list-of-killed-groups)) (gnus-group-change-level (if entry entry group) gnus-level-killed (if entry nil level)) + ;; FIXME: Since the group has already been removed from + ;; `gnus-newsrc-hashtb', this check will always return nil. (when (numberp (gnus-group-unread group)) (gnus-request-update-group-status group 'unsubscribe)) (message "Killed group %s" (gnus-group-decoded-name group))) @@ -3898,7 +3924,7 @@ of groups killed." group gnus-level-killed 3)) (cond ((setq entry (gnus-group-entry group)) - (push (cons (car entry) (nth 2 entry)) + (push (cons (car entry) (nth 1 entry)) gnus-list-of-killed-groups) (setcdr (cdr entry) (cdddr entry))) ((member group gnus-zombie-list) @@ -3921,7 +3947,7 @@ yanked) a list of yanked groups is returned." (interactive "p") (setq arg (or arg 1)) (let (info group prev out) - (while (>= (decf arg) 0) + (while (>= (cl-decf arg) 0) (when (not (setq info (pop gnus-list-of-killed-groups))) (error "No more newsgroups to yank")) (push (setq group (nth 1 info)) out) @@ -3931,9 +3957,7 @@ yanked) a list of yanked groups is returned." ;; first newsgroup. (setq prev (gnus-group-group-name)) (gnus-group-change-level - info (gnus-info-level (cdr info)) gnus-level-killed - (and prev (gnus-group-entry prev)) - t) + info (gnus-info-level (cdr info)) gnus-level-killed prev t) (gnus-group-insert-group-line-info group) (gnus-request-update-group-status group 'subscribe) (gnus-undo-register @@ -4017,28 +4041,15 @@ entail asking the server for the groups." (gnus-agent gnus-plugged)); If we're actually plugged, store the active file in the agent. (gnus-read-active-file))) ;; Find all groups and sort them. - (let ((groups - (sort - (let (list) - (mapatoms - (lambda (sym) - (and (boundp sym) - (symbol-value sym) - (push (symbol-name sym) list))) - gnus-active-hashtb) - list) - 'string<)) - (buffer-read-only nil) - group) + (let ((buffer-read-only nil)) (erase-buffer) - (while groups - (setq group (pop groups)) + (dolist (group (sort (hash-table-keys gnus-active-hashtb) #'string<)) (add-text-properties (point) (prog1 (1+ (point)) (insert " *: " (gnus-group-decoded-name group) "\n")) - (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) + (list 'gnus-group group 'gnus-unread t 'gnus-level (inline (gnus-group-level group))))) (goto-char (point-min)))) @@ -4102,9 +4113,14 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." (gnus-group-remove-mark group) ;; Bypass any previous denials from the server. (gnus-remove-denial (setq method (gnus-find-method-for-group group))) - (if (or (and (not dont-scan) - (gnus-request-group-scan group (gnus-get-info group))) - (gnus-activate-group group (if dont-scan nil 'scan) nil method)) + (if (if (and (not dont-scan) + ;; Prefer request-group-scan if the backend supports it. + (gnus-check-backend-function 'request-group-scan group)) + (progn + ;; Ensure that the server is already open. + (gnus-activate-group group nil nil method) + (gnus-request-group-scan group (gnus-get-info group))) + (gnus-activate-group group (if dont-scan nil 'scan) nil method)) (let ((info (gnus-get-info group)) (active (gnus-active group))) (when info @@ -4117,6 +4133,7 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." method (gnus-group-real-name group) active)) (gnus-group-update-group group nil t)) (gnus-error 3 "%s error: %s" group (gnus-status-message group)))) + (gnus-run-hooks 'gnus-after-getting-new-news-hook) (when beg (goto-char beg)) (when gnus-goto-next-group-when-activating @@ -4132,17 +4149,17 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." desc) (when (and force gnus-description-hashtb) - (gnus-sethash mname nil gnus-description-hashtb)) + (remhash mname gnus-description-hashtb)) (unless group (error "No group name given")) (when (or (and gnus-description-hashtb ;; We check whether this group's method has been ;; queried for a description file. - (gnus-gethash mname gnus-description-hashtb)) + (gethash mname gnus-description-hashtb)) (setq desc (gnus-group-get-description group)) (gnus-read-descriptions-file method)) (gnus-message 1 "%s" - (or desc (gnus-gethash group gnus-description-hashtb) + (or desc (gethash group gnus-description-hashtb) "No description available"))))) ;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>. @@ -4154,24 +4171,19 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." (when (not (or gnus-description-hashtb (gnus-read-all-descriptions-files))) (error "Couldn't request descriptions file")) - (let ((buffer-read-only nil) - b groups) - (mapatoms - (lambda (group) - (push (symbol-name group) groups)) - gnus-description-hashtb) - (setq groups (sort groups 'string<)) + (let ((buffer-read-only nil)) (erase-buffer) - (dolist (group groups) - (setq b (point)) - (let ((charset (gnus-group-name-charset nil group))) + (dolist (group (sort (hash-table-keys gnus-description-hashtb) #'string<)) + (let ((b (point)) + (desc (gethash group gnus-description-hashtb)) + (charset (gnus-group-name-charset nil group))) (insert (format " *: %-20s %s\n" (gnus-group-name-decode group charset) - (gnus-group-name-decode group charset)))) - (add-text-properties - b (1+ b) (list 'gnus-group (intern group gnus-description-hashtb) - 'gnus-unread t 'gnus-marked nil - 'gnus-level (1+ gnus-level-subscribed)))) + (gnus-group-name-decode desc charset))) + (add-text-properties + b (1+ b) (list 'gnus-group group + 'gnus-unread t 'gnus-marked nil + 'gnus-level (1+ gnus-level-subscribed))))) (goto-char (point-min)) (gnus-group-position-point))) @@ -4183,20 +4195,16 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." (obuf (current-buffer)) groups des) ;; Go through all newsgroups that are known to Gnus. - (mapatoms - (lambda (group) - (and (symbol-name group) - (string-match regexp (symbol-name group)) - (symbol-value group) - (push (symbol-name group) groups))) + (maphash + (lambda (g-name _) + (and (string-match regexp g-name) + (push g-name groups))) gnus-active-hashtb) ;; Also go through all descriptions that are known to Gnus. (when search-description - (mapatoms - (lambda (group) - (and (string-match regexp (symbol-value group)) - (push (symbol-name group) groups))) - gnus-description-hashtb)) + (dolist (g-name (hash-table-keys gnus-description-hashtb)) + (when (string-match regexp g-name) + (push g-name groups)))) (if (not groups) (gnus-message 3 "No groups matched \"%s\"." regexp) ;; Print out all the groups. @@ -4212,8 +4220,8 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." (let ((charset (gnus-group-name-charset nil prev))) (insert (gnus-group-name-decode prev charset) "\n") (when (and gnus-description-hashtb - (setq des (gnus-gethash (car groups) - gnus-description-hashtb))) + (setq des (gethash (car groups) + gnus-description-hashtb))) (insert " " (gnus-group-name-decode des charset) "\n")))) (setq groups (cdr groups))) (goto-char (point-min)))) @@ -4367,6 +4375,9 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting." gnus-expert-user (gnus-y-or-n-p "Are you sure you want to quit reading news? ")) (gnus-run-hooks 'gnus-exit-gnus-hook) + ;; Check whether we have any unsaved Message buffers and offer to + ;; save them. + (gnus--abort-on-unsaved-message-buffers) ;; Offer to save data from non-quitted summary buffers. (gnus-offer-save-summaries) ;; Save the newsrc file(s). @@ -4378,6 +4389,16 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting." ;; Allow the user to do things after cleaning up. (gnus-run-hooks 'gnus-after-exiting-gnus-hook))) +(defun gnus--abort-on-unsaved-message-buffers () + (dolist (buffer (gnus-buffers)) + (with-current-buffer buffer + (when (and (derived-mode-p 'message-mode) + (buffer-modified-p) + (not (y-or-n-p + (format "Message buffer %s unsaved, continue exit? " + buffer)))) + (error "Gnus exit aborted due to unsaved buffer %s" buffer))))) + (defun gnus-group-quit () "Quit reading news without updating .newsrc.eld or .newsrc. The hook `gnus-exit-gnus-hook' is called before actually exiting." @@ -4443,7 +4464,7 @@ and the second element is the address." (let* ((entry (gnus-group-entry (or method-only-group (gnus-info-group info)))) (part-info info) - (info (if method-only-group (nth 2 entry) info)) + (info (if method-only-group (nth 1 entry) info)) method) (when method-only-group (unless entry @@ -4485,11 +4506,18 @@ and the second element is the address." ;; can do the update. (if entry (progn - (setcar (nthcdr 2 entry) info) + (setcar (nthcdr 1 entry) info) (when (and (not (eq (car entry) t)) (gnus-active (gnus-info-group info))) (setcar entry (length - (gnus-list-of-unread-articles (car info)))))) + (gnus-list-of-unread-articles (car info))))) + ;; The above `setcar' will only affect the hashtable, not + ;; the alist: update the alist separately. + (push info (cdr (setq gnus-newsrc-alist + (remove (assoc-string + (gnus-info-group info) + gnus-newsrc-alist) + gnus-newsrc-alist))))) (error "No such group: %s" (gnus-info-group info)))))) ;; Ad-hoc function for inserting data from a different newsrc.eld @@ -4553,8 +4581,7 @@ and the second element is the address." This function can be used in hooks like `gnus-select-group-hook' or `gnus-group-catchup-group-hook'." (when gnus-newsgroup-name - (let ((time (current-time))) - (setcdr (cdr time) nil) + (let ((time (encode-time nil 'integer))) (gnus-group-set-parameter gnus-newsgroup-name 'timestamp time)))) (defsubst gnus-group-timestamp (group) @@ -4563,11 +4590,11 @@ or `gnus-group-catchup-group-hook'." (defun gnus-group-timestamp-delta (group) "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number." - (let* ((time (or (gnus-group-timestamp group) - (list 0 0))) - (delta (time-subtract (current-time) time))) - (+ (* (nth 0 delta) 65536.0) - (nth 1 delta)))) + ;; FIXME: This should return a Lisp integer, not a Lisp float, + ;; since it is always an integer. + (let* ((time (or (gnus-group-timestamp group) 0)) + (delta (time-since time))) + (float-time delta))) (defun gnus-group-timestamp-string (group) "Return a string of the timestamp for GROUP." @@ -4595,11 +4622,11 @@ This command may read the active file." (assq 'cache marks))) lowest #'(lambda (group) - (or (gnus-gethash group - gnus-cache-active-hashtb) + (or (gethash group + gnus-cache-active-hashtb) ;; Cache active file might use "." ;; instead of ":". - (gnus-gethash + (gethash (mapconcat 'identity (split-string group ":") ".") @@ -4761,8 +4788,7 @@ Compacting group %s... (this may take a long time)" ;; Invalidate the "original article" buffer which might be out of date. ;; #### NOTE: Yes, this might be a bit rude, but since compaction ;; #### will not happen very often, I think this is acceptable. - (let ((original (get-buffer gnus-original-article-buffer))) - (and original (gnus-kill-buffer original))) + (gnus-kill-buffer gnus-original-article-buffer) ;; Update the group line to reflect new information (art number etc). (gnus-group-update-group-line)))) diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el index 964bda46c17..92d760f4bf7 100644 --- a/lisp/gnus/gnus-html.el +++ b/lisp/gnus/gnus-html.el @@ -28,8 +28,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'gnus-art) (eval-when-compile (require 'mm-decode)) @@ -86,7 +84,7 @@ fit these criteria." (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] 'widget-forward) + (define-key map [tab] 'button-forward) map)) (defun gnus-html-encode-url (url) @@ -99,11 +97,7 @@ fit these criteria." (not (file-exists-p (url-cache-create-filename url)))) (t (let ((cache-time (url-is-cached url))) (if cache-time - (time-less-p - (time-add - cache-time - ttl) - (current-time)) + (time-less-p (time-add cache-time ttl) nil) t))))) ;;;###autoload @@ -186,12 +180,10 @@ fit these criteria." 'image-displayer `(lambda (url start end) (gnus-html-display-image url start end ,alt-text)) + 'help-echo alt-text + 'button t + 'keymap gnus-html-image-map 'gnus-image (list url start end alt-text))) - (widget-convert-button - 'url-link start (point) - :help-echo alt-text - :keymap gnus-html-image-map - url) (if (string-match "\\`cid:" url) ;; URLs with cid: have their content stashed in other ;; parts of the MIME structure, so just insert them @@ -213,21 +205,15 @@ fit these criteria." (delete-region start end)) "*") 'cid)) - (widget-convert-button - 'link start end - :action 'gnus-html-insert-image - :help-echo url - :keymap gnus-html-image-map - :button-keymap gnus-html-image-map))) + (make-text-button start end + 'help-echo url + 'keymap gnus-html-image-map))) ;; Normal, external URL. (if (or inhibit-images (gnus-html-image-url-blocked-p url blocked-images)) - (widget-convert-button - 'link start end - :action 'gnus-html-insert-image - :help-echo url - :keymap gnus-html-image-map - :button-keymap gnus-html-image-map) + (make-text-button start end + 'help-echo url + 'keymap gnus-html-image-map) ;; Non-blocked url (let ((width (when (string-match "width=\"?\\([0-9]+\\)" parameters) @@ -450,11 +436,9 @@ Return a string with image data." (let ((image (gnus-rescale-image image (gnus-html-maximum-image-size)))) (delete-region start end) (gnus-put-image image alt-text 'external) - (widget-convert-button - 'url-link start (point) - :help-echo alt-text - :keymap gnus-html-displayed-image-map - url) + (make-text-button start (point) + 'help-echo alt-text + 'keymap gnus-html-displayed-image-map) (put-text-property start (point) 'gnus-alt-text alt-text) (when url (add-text-properties diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index e4ad2af0630..529cafe23e8 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -1,4 +1,4 @@ -;;; gnus-icalendar.el --- reply to iCalendar meeting requests +;;; gnus-icalendar.el --- reply to iCalendar meeting requests -*- lexical-binding:t -*- ;; Copyright (C) 2013-2019 Free Software Foundation, Inc. @@ -40,7 +40,7 @@ (require 'gnus-sum) (require 'gnus-art) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defun gnus-icalendar-find-if (pred seq) (catch 'found @@ -147,7 +147,7 @@ (icalendar--get-event-property-attributes event field) zone-map)) (dtdate-dec (icalendar--decode-isodatetime dtdate nil dtdate-zone))) - (apply 'encode-time dtdate-dec))) + (encode-time dtdate-dec))) (defun gnus-icalendar-event--find-attendee (ical name-or-email) (let* ((event (car (icalendar--all-events ical))) @@ -169,7 +169,7 @@ (defun gnus-icalendar-event--get-attendee-names (ical) (let* ((event (car (icalendar--all-events ical))) - (attendee-props (gnus-remove-if-not + (attendee-props (seq-filter (lambda (p) (eq (car p) 'ATTENDEE)) (caddr event)))) @@ -180,7 +180,7 @@ (or (plist-get (cadr prop) 'CN) (replace-regexp-in-string "^.*MAILTO:" "" (caddr prop)))) (attendees-by-type (type) - (gnus-remove-if-not + (seq-filter (lambda (p) (string= (attendee-role p) type)) attendee-props)) (attendee-names-by-type @@ -238,13 +238,13 @@ "\\\\n" "\n" (substring-no-properties value)))))) (accumulate-args (mapping) - (destructuring-bind (slot . ical-property) mapping + (cl-destructuring-bind (slot . ical-property) mapping (setq args (append (list (intern (concat ":" (symbol-name slot))) (map-property ical-property)) args))))) (mapc #'accumulate-args prop-map) - (apply 'make-instance event-class args)))) + (apply #'make-instance event-class args)))) (defun gnus-icalendar-event-from-buffer (buf &optional attendee-name-or-email) "Parse RFC5545 iCalendar in buffer BUF and return an event object. @@ -301,7 +301,8 @@ status will be retrieved from the first matching attendee record." ((string= key "DTSTAMP") (update-dtstamp)) ((member key '("ORGANIZER" "DTSTART" "DTEND" "LOCATION" "DURATION" "SEQUENCE" - "RECURRENCE-ID" "UID")) line) + "RECURRENCE-ID" "UID")) + line) (t nil)))) (when new-line (push new-line reply-event-lines)))))) @@ -352,9 +353,9 @@ on the IDENTITIES list." ;;; ;;; gnus-icalendar-org -;;; -;;; TODO: this is an optional feature, and it's only available with org-mode -;;; 7+, so will need to properly handle emacsen with no/outdated org-mode +;; +;; TODO: this is an optional feature, and it's only available with org-mode +;; 7+, so will need to properly handle emacsen with no/outdated org-mode (require 'org) (require 'org-capture) @@ -367,23 +368,19 @@ on the IDENTITIES list." (defcustom gnus-icalendar-org-capture-file nil "Target Org file for storing captured calendar events." - :type '(choice (const nil) file) - :group 'gnus-icalendar-org) + :type '(choice (const nil) file)) (defcustom gnus-icalendar-org-capture-headline nil "Target outline in `gnus-icalendar-org-capture-file' for storing captured events." - :type '(repeat string) - :group 'gnus-icalendar-org) + :type '(repeat string)) (defcustom gnus-icalendar-org-template-name "used by gnus-icalendar-org" "Org-mode template name." - :type '(string) - :group 'gnus-icalendar-org) + :type '(string)) (defcustom gnus-icalendar-org-template-key "#" "Org-mode template hotkey." - :type '(string) - :group 'gnus-icalendar-org) + :type '(string)) (defvar gnus-icalendar-org-enabled-p nil) @@ -413,13 +410,12 @@ Return nil for non-recurring EVENT." (end-time (format-time-string "%H:%M" end)) (end-at-midnight (string= end-time "00:00")) (start-end-date-diff - (/ (float-time (time-subtract - (org-time-string-to-time end-date) - (org-time-string-to-time start-date))) - 86400)) + (time-to-number-of-days (time-subtract + (org-time-string-to-time end-date) + (org-time-string-to-time start-date)))) (org-repeat (gnus-icalendar-event:org-repeat event)) (repeat (if org-repeat (concat " " org-repeat) "")) - (time-1-day '(0 86400))) + (time-1-day 86400)) ;; NOTE: special care is needed with appointments ending at midnight ;; (typically all-day events): the end time has to be changed to 23:59 to @@ -443,7 +439,7 @@ Return nil for non-recurring EVENT." ;; A 0:0 - A .:. -> A 0:0-.:. (default 1) ;; A 0:0 - A+n .:. -> A - A+n .:. ((and start-at-midnight - (plusp start-end-date-diff)) (format "<%s>--<%s %s>" start-date end-date end-time)) + (cl-plusp start-end-date-diff)) (format "<%s>--<%s %s>" start-date end-date end-time)) ;; default ;; A .:. - A .:. -> A .:.-.:. ;; A .:. - B .:. @@ -484,14 +480,13 @@ Return nil for non-recurring EVENT." (org-entry-put (point) (car prop) (cdr prop))) props)) - (when description - (save-restriction - (narrow-to-region (point) (point)) - (insert (gnus-icalendar-event:org-timestamp event) - "\n\n" - description) - (indent-region (point-min) (point-max) 2) - (fill-region (point-min) (point-max)))) + (save-restriction + (narrow-to-region (point) (point)) + (insert (gnus-icalendar-event:org-timestamp event) + "\n\n" + description) + (indent-region (point-min) (point-max) 2) + (fill-region (point-min) (point-max))) (buffer-string)))) @@ -655,10 +650,7 @@ is searched." (defun gnus-icalendar-show-org-agenda (event) (let* ((time-delta (time-subtract (gnus-icalendar-event:end-time event) (gnus-icalendar-event:start-time event))) - (duration-days (1+ (/ (+ (* (car time-delta) (expt 2 16)) - (cadr time-delta)) - 86400)))) - + (duration-days (1+ (floor (encode-time time-delta 'integer) 86400)))) (org-agenda-list nil (gnus-icalendar-event:start event) duration-days))) (cl-defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-request) reply-status) @@ -666,7 +658,7 @@ is searched." (gnus-icalendar--update-org-event event reply-status) (gnus-icalendar:org-event-save event reply-status))) -(cl-defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-cancel) reply-status) +(cl-defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-cancel) _reply-status) (when (gnus-icalendar-find-org-event-file event) (gnus-icalendar--cancel-org-event event))) @@ -689,8 +681,7 @@ is searched." (defcustom gnus-icalendar-reply-bufname "*CAL*" "Buffer used for building iCalendar invitation reply." - :type '(string) - :group 'gnus-icalendar) + :type '(string)) (defcustom gnus-icalendar-additional-identities nil "We need to know your identity to make replies to calendar requests work. @@ -706,17 +697,13 @@ Your identity is guessed automatically from the variables If you need even more aliases you can define them here. It really only makes sense to define names or email addresses." - :type '(repeat string) - :group 'gnus-icalendar) + :type '(repeat string)) -(make-variable-buffer-local - (defvar gnus-icalendar-reply-status nil)) +(defvar-local gnus-icalendar-reply-status nil) -(make-variable-buffer-local - (defvar gnus-icalendar-event nil)) +(defvar-local gnus-icalendar-event nil) -(make-variable-buffer-local - (defvar gnus-icalendar-handle nil)) +(defvar-local gnus-icalendar-handle nil) (defun gnus-icalendar-identities () "Return list of regexp-quoted names and email addresses belonging to the user. @@ -742,7 +729,8 @@ These will be used to retrieve the RSVP information from ical events." (cadr x)))) (with-slots (organizer summary description location recur uid - method rsvp participation-type) event + method rsvp participation-type) + event (let ((headers `(("Summary" ,summary) ("Location" ,(or location "")) ("Time" ,(gnus-icalendar-event:org-timestamp event)) @@ -789,9 +777,8 @@ These will be used to retrieve the RSVP information from ical events." ,callback keymap ,gnus-mime-button-map face ,gnus-article-button-face - gnus-data ,data)) - (widget-convert-button 'link start (point) - :action 'gnus-widget-press-button))) + button t + gnus-data ,data)))) (defun gnus-icalendar-send-buffer-by-mail (buffer-name subject) (let ((message-signature nil)) @@ -848,7 +835,7 @@ These will be used to retrieve the RSVP information from ical events." ("Tentative" gnus-icalendar-reply (,handle tentative ,event)) ("Decline" gnus-icalendar-reply (,handle declined ,event))))) -(cl-defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event-reply) handle) +(cl-defmethod gnus-icalendar-event:inline-reply-buttons ((_event gnus-icalendar-event-reply) _handle) "No buttons for REPLY events." nil) @@ -857,7 +844,7 @@ These will be used to retrieve the RSVP information from ical events." (gnus-icalendar--get-org-event-reply-status event)) "Not replied yet")) -(cl-defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event-reply)) +(cl-defmethod gnus-icalendar-event:inline-reply-status ((_event gnus-icalendar-event-reply)) "No reply status for REPLY events." nil) @@ -884,7 +871,7 @@ These will be used to retrieve the RSVP information from ical events." (when org-entry-exists-p `("Show Org Entry" gnus-icalendar--show-org-event ,event)))))) - +;;;###autoload (defun gnus-icalendar-mm-inline (handle) (let ((event (gnus-icalendar-event-from-handle handle (gnus-icalendar-identities)))) @@ -896,7 +883,7 @@ These will be used to retrieve the RSVP information from ical events." (buttons) (when buttons (mapc (lambda (x) - (apply 'gnus-icalendar-insert-button x) + (apply #'gnus-icalendar-insert-button x) (insert " ")) buttons) (insert "\n\n")))) @@ -977,6 +964,9 @@ These will be used to retrieve the RSVP information from ical events." (defvar gnus-mime-action-alist) ; gnus-art (defun gnus-icalendar-setup () + ;; FIXME: Get rid of this! + ;; The three add-to-list are now redundant (good), but I think the rest + ;; is still not automatically setup. (add-to-list 'mm-inlined-types "text/calendar") (add-to-list 'mm-automatic-display "text/calendar") (add-to-list 'mm-inline-media-tests '("text/calendar" gnus-icalendar-mm-inline identity)) @@ -991,7 +981,7 @@ These will be used to retrieve the RSVP information from ical events." (require 'gnus-art) (add-to-list 'gnus-mime-action-alist - (cons "save calendar event" 'gnus-icalendar-save-event) + (cons "save calendar event" #'gnus-icalendar-save-event) t)) (provide 'gnus-icalendar) diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index b4e9b625ca8..b27a8a18ebf 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'gnus) (require 'message) (require 'gnus-range) @@ -65,6 +63,8 @@ server denied." (const :tag "Deny server" denied) (const :tag "Unplug Agent" offline))) +;; Note: When this option is finally removed, also remove the entire +;; `gnus-start-news-server' function. (defcustom gnus-nntp-server nil "The name of the host running the NNTP server." :group 'gnus-server @@ -259,7 +259,8 @@ If it is down, start it up (again)." (insert (format-time-string "%H:%M:%S") (format " %.2fs %s %S\n" (if (numberp gnus-backend-trace-elapsed) - (- (float-time) gnus-backend-trace-elapsed) + (float-time + (time-since gnus-backend-trace-elapsed)) 0) type form)) (setq gnus-backend-trace-elapsed (float-time))))) diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el index 95ff5a81a8b..442d26cf4fb 100644 --- a/lisp/gnus/gnus-kill.el +++ b/lisp/gnus/gnus-kill.el @@ -25,17 +25,10 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'gnus) (require 'gnus-art) (require 'gnus-range) -(defcustom gnus-kill-file-mode-hook nil - "Hook for Gnus kill file mode." - :group 'gnus-score-kill - :type 'hook) - (defcustom gnus-kill-expiry-days 7 "Number of days before expiring unused kill file entries." :group 'gnus-score-kill @@ -357,8 +350,7 @@ Returns the number of articles marked as read." (let ((headers gnus-newsgroup-headers)) (if gnus-kill-killed (setq gnus-newsgroup-kill-headers - (mapcar (lambda (header) (mail-header-number header)) - headers)) + (mapcar #'mail-header-number headers)) (while headers (unless (gnus-member-of-range (mail-header-number (car headers)) @@ -607,8 +599,7 @@ marked as read or ticked are ignored." ((cond ((fboundp (setq function (intern-soft - (concat "mail-header-" (downcase field))))) - (setq function `(lambda (h) (,function h)))) + (concat "mail-header-" (downcase field)))))) ((when (setq extras (member (downcase field) (mapcar (lambda (header) diff --git a/lisp/gnus/gnus-logic.el b/lisp/gnus/gnus-logic.el index fa9d9306963..90f74205209 100644 --- a/lisp/gnus/gnus-logic.el +++ b/lisp/gnus/gnus-logic.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-score) @@ -162,9 +162,9 @@ (funcall type (or (aref gnus-advanced-headers index) 0) match))) (defun gnus-advanced-date (index match type) - (let ((date (apply 'encode-time (parse-time-string - (aref gnus-advanced-headers index)))) - (match (apply 'encode-time (parse-time-string match)))) + (let ((date (encode-time (parse-time-string + (aref gnus-advanced-headers index)))) + (match (encode-time (parse-time-string match)))) (cond ((eq type 'at) (equal date match)) diff --git a/lisp/gnus/gnus-ml.el b/lisp/gnus/gnus-ml.el index 8cca3d65b9a..488c01c21cd 100644 --- a/lisp/gnus/gnus-ml.el +++ b/lisp/gnus/gnus-ml.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2000-2019 Free Software Foundation, Inc. -;; Author: Julien Gilles <jgilles@free.fr> +;; Author: Julien Gilles <jgilles@free.fr> ;; Keywords: news, mail ;; This file is part of GNU Emacs. @@ -28,7 +28,6 @@ (require 'gnus) (require 'gnus-msg) -(eval-when-compile (require 'cl)) ;;; Mailing list minor mode diff --git a/lisp/gnus/gnus-mlspl.el b/lisp/gnus/gnus-mlspl.el index edc70667ba1..74e132b7a48 100644 --- a/lisp/gnus/gnus-mlspl.el +++ b/lisp/gnus/gnus-mlspl.el @@ -24,7 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'gnus) (require 'gnus-sum) (require 'gnus-group) @@ -49,7 +48,7 @@ group parameters. If AUTO-UPDATE is non-nil (prefix argument accepted, if called interactively), it makes sure nnmail-split-fancy is re-computed before getting new mail, by adding `gnus-group-split-update' to -`nnmail-pre-get-new-mail-hook'. +`gnus-get-top-new-news-hook'. A non-nil CATCH-ALL replaces the current value of `gnus-group-split-default-catch-all-group'. This variable is only used @@ -65,9 +64,14 @@ match any of the group-specified splitting rules. See (setq nnmail-split-methods 'nnmail-split-fancy) (when catch-all (setq gnus-group-split-default-catch-all-group catch-all)) - (gnus-group-split-update) - (when auto-update - (add-hook 'nnmail-pre-get-new-mail-hook 'gnus-group-split-update))) + (add-hook + (if auto-update + 'gnus-get-top-new-news-hook + ;; Split updating requires `gnus-newsrc-hashtb' to be + ;; initialized; the read newsrc hook is the only hook that comes + ;; after initialization, but before checking for new news. + 'gnus-read-newsrc-el-hook) + #'gnus-group-split-update)) ;;;###autoload (defun gnus-group-split-update (&optional catch-all) @@ -183,7 +187,8 @@ Calling (gnus-group-split-fancy nil nil \"mail.others\") returns: (to-list (cdr (assoc 'to-list params))) (extra-aliases (cdr (assoc 'extra-aliases params))) (split-regexp (cdr (assoc 'split-regexp params))) - (split-exclude (cdr (assoc 'split-exclude params)))) + (split-exclude (cdr (assoc 'split-exclude params))) + (match-list (cdr (assoc 'match-list params)))) (when (or to-address to-list extra-aliases split-regexp) ;; regexp-quote to-address, to-list and extra-aliases ;; and add them all to split-regexp @@ -203,16 +208,28 @@ Calling (gnus-group-split-fancy nil nil \"mail.others\") returns: "\\|") "\\)")) ;; Now create the new SPLIT - (push (append - (list 'any split-regexp) + (let ((split-regexp-with-list-ids + (replace-regexp-in-string "@" "[@.]" split-regexp t t)) + (exclude ;; Generate RESTRICTs for SPLIT-EXCLUDEs. (if (listp split-exclude) (apply #'append (mapcar (lambda (arg) (list '- arg)) split-exclude)) - (list '- split-exclude)) - (list group-clean)) - split) + (list '- split-exclude)))) + + (if match-list + ;; Match RFC2919 IDs or mail addresses + (push (append + (list 'list split-regexp-with-list-ids) + exclude + (list group-clean)) + split) + (push (append + (list 'any split-regexp) + exclude + (list group-clean)) + split))) ;; If it matches the empty string, it is a catch-all (when (string-match split-regexp "") (setq catch-all nil))))))))) diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index 5c5e7abd443..819936d935a 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -25,7 +25,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'message) @@ -110,11 +110,6 @@ the second with the current group name." :options '(message-remove-blank-cited-lines) :type 'hook) -(defcustom gnus-bug-create-help-buffer t - "Should we create the *Gnus Help Bug* buffer?" - :group 'gnus-message - :type 'boolean) - (defcustom gnus-posting-styles nil "Alist of styles to use when posting. See Info node `(gnus)Posting Styles'." @@ -158,9 +153,9 @@ if a regexp and matches the Gcc group name, attach files as external parts; if nil, attach files as normal parts." :version "22.1" :group 'gnus-message - :type '(choice (const nil :tag "None") - (const all :tag "Any") - (string :tag "Regexp"))) + :type '(choice (const :tag "None" nil) + (const :tag "Any" all) + regexp)) (defcustom gnus-gcc-self-resent-messages 'no-gcc-self "Like `gcc-self' group parameter, only for unmodified resent messages. @@ -232,7 +227,9 @@ List of charsets that are permitted to be unencoded.") "Files whose variables will be reported in `gnus-bug'." :version "22.1" :group 'gnus-message - :type '(repeat (string :tag "File"))) + :type '(repeat file)) + +(make-obsolete-variable 'gnus-debug-files "it is no longer used." "24.1") (defcustom gnus-debug-exclude-variables '(mm-mime-mule-charset-alist @@ -240,7 +237,10 @@ List of charsets that are permitted to be unencoded.") "Variables that should not be reported in `gnus-bug'." :version "22.1" :group 'gnus-message - :type '(repeat (symbol :tag "Variable"))) + :type '(repeat variable)) + +(make-obsolete-variable + 'gnus-debug-exclude-variables "it is no longer used." "24.1") (defcustom gnus-discouraged-post-methods '(nndraft nnml nnimap nnmaildir nnmh nnfolder nndir) @@ -340,33 +340,11 @@ only affect the Gcc copy, but not the original message." (defvar gnus-article-yanked-articles nil) (defvar gnus-message-buffer "*Mail Gnus*") (defvar gnus-article-copy nil) -(defvar gnus-check-before-posting nil) (defvar gnus-last-posting-server nil) (defvar gnus-message-group-art nil) (defvar gnus-msg-force-broken-reply-to nil) -(defconst gnus-bug-message - "Sending a bug report to the Gnus Towers. -======================================== - -The buffer below is a mail buffer. When you press `C-c C-c', it will -be sent to the Gnus Bug Exterminators. - -The thing near the bottom of the buffer is how the environment -settings will be included in the mail. Please do not delete that. -They will tell the Bug People what your environment is, so that it -will be easier to locate the bugs. - -If you have found a bug that makes Emacs go \"beep\", set -debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET') -and include the backtrace in your bug report. - -Please describe the bug in annoying, painstaking detail. - -Thank you for your help in stamping out bugs. -") - (autoload 'gnus-uu-post-news "gnus-uu" nil t) @@ -393,6 +371,7 @@ Thank you for your help in stamping out bugs. "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 @@ -535,7 +514,7 @@ instead." (progn (message "Gnus not running; using plain Message mode") (message-mail to subject other-headers continue - nil yank-action send-actions return-action)) + switch-action yank-action send-actions return-action)) (let ((buf (current-buffer)) ;; Don't use posting styles corresponding to any existing group. (group-name gnus-newsgroup-name) @@ -602,7 +581,7 @@ instead." (message-add-action `(progn (setq gnus-current-window-configuration ',winconf-name) - (when (gnus-buffer-exists-p ,buffer) + (when (gnus-buffer-live-p ,buffer) (set-window-configuration ,winconf))) 'exit 'postpone 'kill) (let ((to-be-marked (cond @@ -612,7 +591,7 @@ instead." (article (if (listp article) article (list article))) (t nil)))) (message-add-action - `(when (gnus-buffer-exists-p ,buffer) + `(when (gnus-buffer-live-p ,buffer) (with-current-buffer ,buffer ,(when to-be-marked (if (eq config 'forward) @@ -897,7 +876,7 @@ header line with the old Message-ID." (message-supersede) (push `((lambda () - (when (gnus-buffer-exists-p ,gnus-summary-buffer) + (when (gnus-buffer-live-p ,gnus-summary-buffer) (with-current-buffer ,gnus-summary-buffer (gnus-cache-possibly-remove-article ,article nil nil nil t) (gnus-summary-mark-as-read ,article gnus-canceled-mark))))) @@ -917,8 +896,7 @@ header line with the old Message-ID." (mm-enable-multibyte)) (let ((article-buffer (or article-buffer gnus-article-buffer)) end beg) - (if (not (and (get-buffer article-buffer) - (gnus-buffer-exists-p article-buffer))) + (if (not (gnus-buffer-live-p article-buffer)) (error "Can't find any article buffer") (with-current-buffer article-buffer (let ((gnus-newsgroup-charset (or gnus-article-charset @@ -1037,7 +1015,7 @@ header line with the old Message-ID." (gnus-inews-yank-articles yank)))))) (defun gnus-msg-treat-broken-reply-to (&optional force) - "Remove the Reply-to header if broken-reply-to." + "Remove the Reply-To header if broken-reply-to." (when (or force (gnus-group-find-parameter gnus-newsgroup-name 'broken-reply-to)) @@ -1113,11 +1091,11 @@ If SILENT, don't prompt the user." ((and (eq gnus-post-method 'current) (not (memq (car group-method) gnus-discouraged-post-methods)) (gnus-get-function group-method 'request-post t)) - (assert (not arg)) + (cl-assert (not arg)) group-method) ;; Use gnus-post-method. ((listp gnus-post-method) ;A method... - (assert (not (listp (car gnus-post-method)))) ;... not a list of methods. + (cl-assert (not (listp (car gnus-post-method)))) ;... not a list of methods. gnus-post-method) ;; Use the normal select method (nil or native). (t gnus-select-method)))) @@ -1268,23 +1246,35 @@ automatically." (defun gnus-summary-wide-reply-with-original (n) "Start composing a wide reply mail to the current message. -The original article will be yanked. +The original article(s) will be yanked. Uses the process/prefix convention." (interactive "P") (gnus-summary-reply-with-original n t)) (defun gnus-summary-very-wide-reply (&optional yank) - "Start composing a very wide reply mail to the current message. -If prefix argument YANK is non-nil, the original article is yanked -automatically." + "Start composing a very wide reply mail to a set of messages. + +Uses the process/prefix convention. + +The reply will include all From/Cc headers from the original +messages as the To/Cc headers. + +If prefix argument YANK is non-nil, the original article(s) will +be yanked automatically." (interactive (list (and current-prefix-arg (gnus-summary-work-articles 1)))) (gnus-summary-reply yank t (gnus-summary-work-articles yank))) (defun gnus-summary-very-wide-reply-with-original (n) - "Start composing a very wide reply mail to the current message. -The original article will be yanked." + "Start composing a very wide reply mail a set of messages. + +Uses the process/prefix convention. + +The reply will include all From/Cc headers from the original +messages as the To/Cc headers. + +The original article(s) will be yanked." (interactive "P") (gnus-summary-reply (gnus-summary-work-articles n) t (gnus-summary-work-articles n))) @@ -1482,7 +1472,7 @@ See `gnus-summary-mail-forward' for ARG." (not (member group (message-tokenize-header followup-to ", "))))) (if followup-to - (gnus-message 1 "Followup-to restricted") + (gnus-message 1 "Followup-To restricted") (gnus-message 1 "Not a crossposted article")) (set-buffer gnus-summary-buffer) (gnus-summary-reply-with-original 1) @@ -1519,44 +1509,13 @@ If YANK is non-nil, include the original article." (when yank (gnus-inews-yank-articles (list (cdr gnus-article-current))))))) -(defvar nntp-server-type) -(defun gnus-bug () - "Send a bug report to the Gnus maintainers." - (interactive) - (unless (gnus-alive-p) - (error "Gnus has been shut down")) - (gnus-setup-message (if (message-mail-user-agent) 'message 'bug) - (unless (message-mail-user-agent) - (when gnus-bug-create-help-buffer - (switch-to-buffer "*Gnus Help Bug*") - (erase-buffer) - (insert gnus-bug-message) - (goto-char (point-min))) - (message-pop-to-buffer "*Gnus Bug*")) - (let ((message-this-is-mail t)) - (message-setup `((To . ,gnus-maintainer) - (Subject . "") - (X-Debbugs-Package - . ,(format "%s" gnus-bug-package)) - (X-Debbugs-Version - . ,(format "%s" (gnus-continuum-version)))))) - (when gnus-bug-create-help-buffer - (push `(gnus-bug-kill-buffer) message-send-actions)) - (goto-char (point-min)) - (message-goto-body) - (insert "\n\n\n\n\n") - (insert (gnus-version) "\n" - (emacs-version) "\n") - (when (and (boundp 'nntp-server-type) - (stringp nntp-server-type)) - (insert nntp-server-type)) +(defun gnus-bug (subject) + "Send a bug report to the Emacs maintainers." + (interactive "sBug Subject: ") + (report-emacs-bug subject) + (save-excursion (goto-char (point-min)) - (search-forward "Subject: " nil t) - (message ""))) - -(defun gnus-bug-kill-buffer () - (when (get-buffer "*Gnus Help Bug*") - (kill-buffer "*Gnus Help Bug*"))) + (insert (format "X-Debbugs-Package: %s\n" gnus-bug-package)))) (defun gnus-summary-yank-message (buffer n) "Yank the current article into a composed message." @@ -2000,6 +1959,36 @@ this is a reply." (insert "From: " (message-make-from) "\n")))) nil 'local))))) +(defun gnus-summary-attach-article (n) + "Attach the current article(s) to an outgoing Message buffer. +If any current in-progress Message buffers exist, the articles +can be attached to them. If not, a new Message buffer is +created. + +This command uses the process/prefix convention, so if you +process-mark several articles, they will all be attached." + (interactive "P") + (let ((buffers (message-buffers)) + destination) + ;; Set up the destination mail composition buffer. + (if (and buffers + (y-or-n-p "Attach files to existing mail composition buffer? ")) + (setq destination + (if (= (length buffers) 1) + (get-buffer (car buffers)) + (gnus-completing-read "Attach to buffer" + buffers t nil nil (car buffers)))) + (gnus-summary-mail-other-window) + (setq destination (current-buffer))) + (gnus-summary-iterate n + (gnus-summary-select-article) + (set-buffer destination) + ;; Attach at the end of the buffer. + (save-excursion + (goto-char (point-max)) + (message-forward-make-body-mime gnus-original-article-buffer))) + (gnus-configure-windows 'message t))) + (provide 'gnus-msg) ;;; gnus-msg.el ends here diff --git a/lisp/gnus/gnus-picon.el b/lisp/gnus/gnus-picon.el index 7182e10cc63..18b46a1c12f 100644 --- a/lisp/gnus/gnus-picon.el +++ b/lisp/gnus/gnus-picon.el @@ -37,7 +37,7 @@ ;; ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-art) @@ -211,7 +211,7 @@ replacement is added." (gnus-article-goto-header header) (mail-header-narrow-to-field) - (case gnus-picon-style + (cl-case gnus-picon-style (right (when (= (length addresses) 1) (setq len (apply '+ (mapcar (lambda (x) diff --git a/lisp/gnus/gnus-range.el b/lisp/gnus/gnus-range.el index 2fc7e6d8143..b775def9a0d 100644 --- a/lisp/gnus/gnus-range.el +++ b/lisp/gnus/gnus-range.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - ;;; List and range functions (defsubst gnus-range-normalize (range) @@ -38,17 +36,9 @@ If RANGE is a single range, return (RANGE). Otherwise, return RANGE." (while (cdr list) (setq list (cdr list))) (car list)) +(make-obsolete 'gnus-last-element "use `car' of `last' instead." "27.1") -(defun gnus-copy-sequence (list) - "Do a complete, total copy of a list." - (let (out) - (while (consp list) - (if (consp (car list)) - (push (gnus-copy-sequence (pop list)) out) - (push (pop list) out))) - (if list - (nconc (nreverse out) list) - (nreverse out)))) +(define-obsolete-function-alias 'gnus-copy-sequence 'copy-tree "27.1") (defun gnus-set-difference (list1 list2) "Return a list of elements of LIST1 that do not appear in LIST2." @@ -455,7 +445,7 @@ modified." (if (or (null range1) (null range2)) range1 (let (out r1 r2 r1_min r1_max r2_min r2_max - (range2 (gnus-copy-sequence range2))) + (range2 (copy-tree range2))) (setq range1 (if (listp (cdr range1)) range1 (list range1)) range2 (sort (if (listp (cdr range2)) range2 (list range2)) (lambda (e1 e2) diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index 80d73b5c21a..e488858ebe0 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -76,7 +76,8 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) (require 'gnus) (require 'gnus-int) @@ -165,12 +166,7 @@ nnmairix groups are specifically excluded because they are ephemeral." (defvar gnus-registry-misc-menus nil) ; ugly way to keep the menus -(make-obsolete-variable 'gnus-registry-clean-empty nil "23.4") -(make-obsolete-variable 'gnus-registry-use-long-group-names nil "23.4") -(make-obsolete-variable 'gnus-registry-max-track-groups nil "23.4") -(make-obsolete-variable 'gnus-registry-entry-caching nil "23.4") -(make-obsolete-variable 'gnus-registry-trim-articles-without-groups nil "23.4") -;; FIXME it was simply deleted. +;; It was simply deleted. (make-obsolete-variable 'gnus-registry-max-pruned-entries nil "25.1") (defcustom gnus-registry-track-extra '(subject sender recipient) @@ -311,33 +307,40 @@ This is not required after changing `gnus-registry-cache-file'." (gnus-message 4 "Remaking the Gnus registry") (setq gnus-registry-db (gnus-registry-make-db)))) -(defun gnus-registry-load () - "Load the registry from the cache file." +(defun gnus-registry-load (&optional force) + "Load the registry from the cache file. +If the registry is already loaded, don't reload unless FORCE is +non-nil." (interactive) - (let ((file gnus-registry-cache-file)) - (condition-case nil - (gnus-registry-read file) - (file-error - ;; Fix previous mis-naming of the registry file. - (let ((old-file-name - (concat (file-name-sans-extension - gnus-registry-cache-file) - ".eioio"))) - (if (and (file-exists-p old-file-name) - (yes-or-no-p - (format "Rename registry file from %s to %s? " - old-file-name file))) - (progn - (gnus-registry-read old-file-name) - (setf (oref gnus-registry-db file) file) - (gnus-message 1 "Registry filename changed to %s" file)) - (gnus-registry-remake-db t)))) - (error - (gnus-message - 1 - "The Gnus registry could not be loaded from %s, creating a new one" - file) - (gnus-registry-remake-db t))))) + (when (or force + ;; The registry is loaded by both + ;; `gnus-registry-initialize' and the read-newsrc hook. + ;; Don't load twice. + (null (eieio-object-p gnus-registry-db))) + (let ((file gnus-registry-cache-file)) + (condition-case nil + (gnus-registry-read file) + (file-error + ;; Fix previous mis-naming of the registry file. + (let ((old-file-name + (concat (file-name-sans-extension + gnus-registry-cache-file) + ".eioio"))) + (if (and (file-exists-p old-file-name) + (yes-or-no-p + (format "Rename registry file from %s to %s? " + old-file-name file))) + (progn + (gnus-registry-read old-file-name) + (setf (oref gnus-registry-db file) file) + (gnus-message 1 "Registry filename changed to %s" file)) + (gnus-registry-remake-db t)))) + (error + (gnus-message + 1 + "The Gnus registry could not be loaded from %s, creating a new one" + file) + (gnus-registry-remake-db t)))))) (defun gnus-registry-read (file) "Do the actual reading of the registry persistence file." @@ -372,7 +375,7 @@ This is not required after changing `gnus-registry-cache-file'." (grouphashtb (registry-lookup-secondary db 'group)) (old-size (registry-size db))) (registry-reindex db) - (loop for k being the hash-keys of grouphashtb + (cl-loop for k being the hash-keys of grouphashtb using (hash-values v) when (gnus-registry-ignore-group-p k) do (registry-delete db v nil)) @@ -443,14 +446,14 @@ This is not required after changing `gnus-registry-cache-file'." (sender ,sender) (recipient ,@recipients) (subject ,subject))) - (when (second kv) - (let ((new (or (assq (first kv) entry) - (list (first kv))))) + (when (cadr kv) + (let ((new (or (assq (car kv) entry) + (list (car kv))))) (dolist (toadd (cdr kv)) (unless (member toadd new) (setq new (append new (list toadd))))) (setq entry (cons new - (assq-delete-all (first kv) entry)))))) + (assq-delete-all (car kv) entry)))))) (gnus-message 10 "Gnus registry: new entry for %s is %S" id entry) @@ -504,7 +507,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." :subject subject :log-agent "Gnus registry fancy splitting with parent"))) -(defun* gnus-registry--split-fancy-with-parent-internal +(cl-defun gnus-registry--split-fancy-with-parent-internal (&rest spec &key references refstr sender subject recipients log-agent &allow-other-keys) @@ -524,7 +527,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." log-agent refstr) (dolist (reference (nreverse references)) (gnus-message 9 "%s is looking up %s" log-agent reference) - (loop for group in (gnus-registry-get-id-key reference 'group) + (cl-loop for group in (gnus-registry-get-id-key reference 'group) when (gnus-registry-follow-group-p group) do (progn @@ -547,7 +550,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (gnus-registry-get-id-key reference 'group)) (registry-lookup-secondary-value db 'subject subject))))) (setq found - (loop for group in groups + (cl-loop for group in groups when (gnus-registry-follow-group-p group) do (gnus-message ;; warn more if gnus-registry-track-extra @@ -574,7 +577,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (gnus-registry-get-id-key reference 'group)) (registry-lookup-secondary-value db 'sender sender))))) (setq found - (loop for group in groups + (cl-loop for group in groups when (gnus-registry-follow-group-p group) do (gnus-message ;; warn more if gnus-registry-track-extra @@ -604,7 +607,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (registry-lookup-secondary-value db 'recipient recp))))) (setq found - (loop for group in groups + (cl-loop for group in groups when (gnus-registry-follow-group-p group) do (gnus-message ;; warn more if gnus-registry-track-extra @@ -640,7 +643,7 @@ possible. Uses `gnus-registry-split-strategy'." out chosen) ;; the strategy can be nil, in which case chosen is nil (setq chosen - (case gnus-registry-split-strategy + (cl-case gnus-registry-split-strategy ;; default, take only one-element lists into chosen ((nil) (and (= (length groups) 1) @@ -692,7 +695,7 @@ possible. Uses `gnus-registry-split-strategy'." 10 "%s: stripped group %s to %s" log-agent group short-name)) - (pushnew short-name out :test #'equal)) + (cl-pushnew short-name out :test #'equal)) ;; else... (gnus-message 7 @@ -803,11 +806,9 @@ Overrides existing keywords with FORCE set non-nil." ;; message field fetchers (defun gnus-registry-fetch-message-id-fast (article) - "Fetch the Message-ID quickly, using the internal gnus-data-list function." - (if (and (numberp article) - (assoc article (gnus-data-list nil))) - (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil)))) - nil)) + "Fetch the Message-ID quickly, using the internal `gnus-data-find' function." + (when-let* ((data (and (numberp article) (gnus-data-find article)))) + (mail-header-id (gnus-data-header data)))) (defun gnus-registry-extract-addresses (text) "Extract all the addresses in a normalized way from TEXT. @@ -834,31 +835,22 @@ Addresses without a name will say \"noname\"." nil)) (defun gnus-registry-fetch-simplified-message-subject-fast (article) - "Fetch the Subject quickly, using the internal gnus-data-list function." - (if (and (numberp article) - (assoc article (gnus-data-list nil))) - (gnus-string-remove-all-properties - (gnus-registry-simplify-subject - (mail-header-subject (gnus-data-header - (assoc article (gnus-data-list nil)))))) - nil)) + "Fetch the Subject quickly, using the internal `gnus-data-find' function." + (when-let* ((data (and (numberp article) (gnus-data-find article)))) + (gnus-string-remove-all-properties + (gnus-registry-simplify-subject + (mail-header-subject (gnus-data-header data)))))) (defun gnus-registry-fetch-sender-fast (article) - (gnus-registry-fetch-header-fast "from" article)) + (when-let* ((data (and (numberp article) (gnus-data-find article)))) + (mail-header-from (gnus-data-header data)))) (defun gnus-registry-fetch-recipients-fast (article) - (gnus-registry-sort-addresses - (or (ignore-errors (gnus-registry-fetch-header-fast "Cc" article)) "") - (or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) ""))) - -(defun gnus-registry-fetch-header-fast (article header) - "Fetch the HEADER quickly, using the internal gnus-data-list function." - (if (and (numberp article) - (assoc article (gnus-data-list nil))) - (gnus-string-remove-all-properties - (cdr (assq header (gnus-data-header - (assoc article (gnus-data-list nil)))))) - nil)) + (when-let* ((data (and (numberp article) (gnus-data-find article))) + (extra (mail-header-extra (gnus-data-header data)))) + (gnus-registry-sort-addresses + (or (cdr (assq 'Cc extra)) "") + (or (cdr (assq 'To extra)) "")))) ;; registry marks glue (defun gnus-registry-do-marks (type function) @@ -895,9 +887,7 @@ FUNCTION should take two parameters, a mark symbol and the cell value." (gnus-message 9 "Applying mark %s to %d articles" mark (length articles)) (dolist (article articles) - (gnus-summary-update-article - article - (assoc article (gnus-data-list nil)))))) + (gnus-summary-update-article article (gnus-data-find article))))) ;; This is ugly code, but I don't know how to do it better. (defun gnus-registry-install-shortcuts () @@ -1089,7 +1079,7 @@ only the last one's marks are returned." (expected (length old)) entry) (while (car-safe old) - (incf count) + (cl-incf count) ;; don't use progress reporters for backwards compatibility (when (and (< 0 expected) (= 0 (mod count 100))) @@ -1099,7 +1089,7 @@ only the last one's marks are returned." old (cdr-safe old)) (let* ((id (car-safe entry)) (rest (cdr-safe entry)) - (groups (loop for p in rest + (groups (cl-loop for p in rest when (stringp p) collect p)) extra-cell key val) @@ -1119,6 +1109,12 @@ only the last one's marks are returned." (gnus-registry-set-id-key id key val)))) (message "Import done, collected %d entries" count)))) +(defun gnus-registry-clear () + "Clear the registry." + (setq gnus-registry-db nil)) + +(gnus-add-shutdown 'gnus-registry-clear 'gnus) + ;;;###autoload (defun gnus-registry-initialize () "Initialize the Gnus registry." @@ -1235,7 +1231,7 @@ from your existing entries." (when extra (let ((db gnus-registry-db)) (registry-reindex db) - (loop for k being the hash-keys of (oref db data) + (cl-loop for k being the hash-keys of (oref db data) using (hash-value v) do (let ((newv (delq nil (mapcar #'(lambda (entry) (unless (member (car entry) extra) diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el index 0c17b5e2777..529cd8a337d 100644 --- a/lisp/gnus/gnus-salt.el +++ b/lisp/gnus/gnus-salt.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-sum) @@ -131,7 +131,7 @@ It accepts the same format specs that `gnus-summary-line-format' does." (defvar gnus-pick-line-number 1) (defun gnus-pick-line-number () "Return the current line number." - (incf gnus-pick-line-number)) + (cl-incf gnus-pick-line-number)) (defun gnus-pick-start-reading (&optional catch-up) "Start reading the picked articles. @@ -396,11 +396,6 @@ Two predefined functions are available: (function :tag "Other" nil)) :group 'gnus-summary-tree) -(defcustom gnus-tree-mode-hook nil - "Hook run in tree mode buffers." - :type 'hook - :group 'gnus-summary-tree) - ;;; Internal variables. (defvar gnus-tmp-name) @@ -411,7 +406,7 @@ Two predefined functions are available: (defvar gnus-tmp-subject) (defvar gnus-tree-line-format-alist - `((?n gnus-tmp-name ?s) + '((?n gnus-tmp-name ?s) (?f gnus-tmp-from ?s) (?N gnus-tmp-number ?d) (?\[ gnus-tmp-open-bracket ?c) @@ -445,8 +440,6 @@ Two predefined functions are available: 'undefined 'gnus-tree-read-summary-keys map) map)) -(put 'gnus-tree-mode 'mode-class 'special) - (defun gnus-tree-make-menu-bar () (unless (boundp 'gnus-tree-menu) (easy-menu-define @@ -454,7 +447,7 @@ Two predefined functions are available: '("Tree" ["Select article" gnus-tree-select-article t])))) -(define-derived-mode gnus-tree-mode fundamental-mode "Tree" +(define-derived-mode gnus-tree-mode gnus-mode "Tree" "Major mode for displaying thread trees." (gnus-set-format 'tree-mode) (gnus-set-format 'tree t) @@ -552,7 +545,7 @@ Two predefined functions are available: (not (one-window-p))) (let ((windows 0) tot-win-height) - (walk-windows (lambda (_window) (incf windows))) + (walk-windows (lambda (_window) (cl-incf windows))) (setq tot-win-height (- (frame-height) (* window-min-height (1- windows)) @@ -580,9 +573,9 @@ Two predefined functions are available: (header (if (vectorp header) header (progn (setq header (make-mail-header "*****")) - (mail-header-set-number header 0) - (mail-header-set-lines header 0) - (mail-header-set-chars header 0) + (setf (mail-header-number header) 0) + (setf (mail-header-lines header) 0) + (setf (mail-header-chars header) 0) header))) (gnus-tmp-from (mail-header-from header)) (gnus-tmp-subject (mail-header-subject header)) @@ -734,7 +727,7 @@ it in the environment specified by BINDINGS." (insert (make-string len ? ))))) (defsubst gnus-tree-forward-line (n) - (while (>= (decf n) 0) + (while (>= (cl-decf n) 0) (unless (zerop (forward-line 1)) (end-of-line) (insert "\n"))) @@ -784,7 +777,7 @@ it in the environment specified by BINDINGS." (progn (goto-char (point-min)) (end-of-line) - (incf gnus-tmp-indent)) + (cl-incf gnus-tmp-indent)) ;; Recurse downwards in all children of this article. (while thread (gnus-generate-vertical-tree diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index 4759a2864c6..72fcc641559 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -25,7 +25,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-sum) @@ -514,7 +514,7 @@ of the last successful match.") "f" gnus-score-edit-file "F" gnus-score-flush-cache "t" gnus-score-find-trace - "w" gnus-score-find-favourite-words) + "w" gnus-score-find-favorite-words) ;; Summary score file commands @@ -921,7 +921,7 @@ EXTRA is the possible non-standard header." (interactive (list (gnus-completing-read "Header" (mapcar 'car - (gnus-remove-if-not + (seq-filter (lambda (x) (fboundp (nth 2 x))) gnus-header-index)) t) @@ -1078,11 +1078,11 @@ EXTRA is the possible non-standard header." "Return the score of the current article. With prefix ARG, return the total score of the current (sub)thread." (interactive "P") - (gnus-message 1 "%s" (if arg - (gnus-thread-total-score - (gnus-id-to-thread - (mail-header-id (gnus-summary-article-header)))) - (gnus-summary-article-score)))) + (message "%s" (if arg + (gnus-thread-total-score + (gnus-id-to-thread + (mail-header-id (gnus-summary-article-header)))) + (gnus-summary-article-score)))) (defun gnus-score-change-score-file (file) "Change current score alist." @@ -1098,7 +1098,7 @@ EXTRA is the possible non-standard header." (if (not gnus-current-score-file) (error "No current score file") (let ((winconf (current-window-configuration))) - (when (buffer-name gnus-summary-buffer) + (when (buffer-live-p gnus-summary-buffer) (gnus-score-save)) (gnus-make-directory (file-name-directory file)) (setq gnus-score-edit-buffer (find-file-noselect file)) @@ -1126,7 +1126,7 @@ EXTRA is the possible non-standard header." (interactive (list (read-file-name "Edit score file: " gnus-kill-files-directory))) (gnus-make-directory (file-name-directory file)) - (when (buffer-name gnus-summary-buffer) + (when (buffer-live-p gnus-summary-buffer) (gnus-score-save)) (let ((winconf (current-window-configuration))) (setq gnus-score-edit-buffer (find-file-noselect file)) @@ -1238,7 +1238,7 @@ If FORMAT, also format the current score file." (or (not decay) (gnus-decay-scores alist decay))) (gnus-score-set 'touched '(t) alist) - (gnus-score-set 'decay (list (time-to-days (current-time))) alist)) + (gnus-score-set 'decay (list (time-to-days nil)) alist)) ;; We do not respect eval and files atoms from global score ;; files. (when (and files (not global)) @@ -1501,7 +1501,7 @@ If FORMAT, also format the current score file." (when (and gnus-summary-default-score scores) (let* ((entries gnus-header-index) - (now (date-to-day (current-time-string))) + (now (time-to-days nil)) (expire (and gnus-score-expiry-days (- now gnus-score-expiry-days))) (headers gnus-newsgroup-headers) @@ -1751,8 +1751,7 @@ score in `gnus-newsgroup-scored' by SCORE." (mm-display-inline handle) (goto-char (point-max)))))) - (let ( ;(mm-text-html-renderer 'w3m-standalone) - (handles (mm-dissect-buffer t))) + (let ((handles (mm-dissect-buffer t))) (save-excursion (article-goto-body) (delete-region (point) (point-max)) @@ -2235,8 +2234,7 @@ score in `gnus-newsgroup-scored' by SCORE." (let* ((score (or (nth 1 kill) gnus-score-interactive-default-score)) (date (nth 2 kill)) found) - (when (setq arts (intern-soft (nth 0 kill) hashtb)) - (setq arts (symbol-value arts)) + (when (setq arts (gethash (nth 0 kill) hashtb)) (setq found t) (if trace (while (setq art (pop arts)) @@ -2274,11 +2272,11 @@ score in `gnus-newsgroup-scored' by SCORE." (with-syntax-table gnus-adaptive-word-syntax-table (while (re-search-forward "\\b\\w+\\b" nil t) (setq val - (gnus-gethash + (gethash (setq word (downcase (buffer-substring (match-beginning 0) (match-end 0)))) hashtb)) - (gnus-sethash + (puthash word (append (get-text-property (point-at-eol) 'articles) val) hashtb))) @@ -2290,7 +2288,7 @@ score in `gnus-newsgroup-scored' by SCORE." ".")) gnus-default-ignored-adaptive-words))) (while ignored - (gnus-sethash (pop ignored) nil hashtb))))) + (remhash (pop ignored) hashtb))))) (defun gnus-score-string< (a1 a2) ;; Compare headers in articles A2 and A2. @@ -2318,7 +2316,7 @@ score in `gnus-newsgroup-scored' by SCORE." (when (or (not (listp gnus-newsgroup-adaptive)) (memq 'line gnus-newsgroup-adaptive)) (save-excursion - (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist)) + (let* ((malist (copy-tree gnus-adaptive-score-alist)) (alist malist) (date (current-time-string)) (data gnus-newsgroup-data) @@ -2343,9 +2341,7 @@ score in `gnus-newsgroup-scored' by SCORE." "references" (symbol-name (caar elem))) (cdar elem))) - (setcar (car elem) - `(lambda (h) - (,func h)))) + (setcar (car elem) func)) (setq elem (cdr elem))) (setq malist (cdr malist))) ;; Then we score away. @@ -2381,7 +2377,7 @@ score in `gnus-newsgroup-scored' by SCORE." (memq 'word gnus-newsgroup-adaptive)) (with-temp-buffer (let* ((hashtb (gnus-make-hashtable 1000)) - (date (date-to-day (current-time-string))) + (date (time-to-days nil)) (data gnus-newsgroup-data) word d score val) (with-syntax-table gnus-adaptive-word-syntax-table @@ -2401,8 +2397,8 @@ score in `gnus-newsgroup-scored' by SCORE." (goto-char (point-min)) (while (re-search-forward "\\b\\w+\\b" nil t) ;; Put the word and score into the hashtb. - (setq val (gnus-gethash (setq word (match-string 0)) - hashtb)) + (setq val (gethash (setq word (match-string 0)) + hashtb)) (when (or (not gnus-adaptive-word-length-limit) (> (length word) gnus-adaptive-word-length-limit)) @@ -2410,7 +2406,7 @@ score in `gnus-newsgroup-scored' by SCORE." (if (and gnus-adaptive-word-minimum (< val gnus-adaptive-word-minimum)) (setq val gnus-adaptive-word-minimum)) - (gnus-sethash word val hashtb))) + (puthash word val hashtb))) (erase-buffer)))) ;; Make all the ignorable words ignored. (let ((ignored (append gnus-ignored-adaptive-words @@ -2421,16 +2417,14 @@ score in `gnus-newsgroup-scored' by SCORE." ".")) gnus-default-ignored-adaptive-words))) (while ignored - (gnus-sethash (pop ignored) nil hashtb))) + (remhash (pop ignored) hashtb))) ;; Now we have all the words and scores, so we ;; add these rules to the ADAPT file. (set-buffer gnus-summary-buffer) - (mapatoms - (lambda (word) - (when (symbol-value word) - (gnus-summary-score-entry - "subject" (symbol-name word) 'w (symbol-value word) - date nil t))) + (maphash + (lambda (word val) + (gnus-summary-score-entry + "subject" word 'w val date nil t)) hashtb)))))) (defun gnus-score-edit-done () @@ -2517,7 +2511,7 @@ the score file and its full name, including the directory.") (set-buffer gnus-summary-buffer) (setq gnus-newsgroup-scored old-scored))) -(defun gnus-score-find-favourite-words () +(defun gnus-score-find-favorite-words () "List words used in scoring." (interactive) (let ((alists (gnus-score-load-files (gnus-all-score-files))) @@ -2553,6 +2547,9 @@ the score file and its full name, including the directory.") (pop rules)) (goto-char (point-min)) (gnus-configure-windows 'score-words)))) +(define-obsolete-function-alias + 'gnus-score-find-favourite-words + 'gnus-score-find-favorite-words "27.1") (defun gnus-summary-rescore () "Redo the entire scoring process in the current summary." @@ -2673,7 +2670,8 @@ the score file and its full name, including the directory.") (gnus-file-newer-than gnus-kill-files-directory (car gnus-score-file-list))) (setq gnus-score-file-list - (cons (nth 5 (file-attributes gnus-kill-files-directory)) + (cons (file-attribute-modification-time + (file-attributes gnus-kill-files-directory)) (nreverse (directory-files gnus-kill-files-directory t @@ -2731,8 +2729,10 @@ GROUP using BNews sys file syntax." (insert (car sfiles)) (goto-char (point-min)) ;; First remove the suffix itself. - (when (re-search-forward (concat "." score-regexp) nil t) - (replace-match "" t t) + (when (re-search-forward score-regexp nil t) + (unless (= (match-end 0) (match-beginning 0)) ; non-empty suffix + (replace-match "" t t) + (delete-char -1)) ; remove the "." before the suffix (goto-char (point-min)) (if (looking-at (regexp-quote kill-dir)) ;; If the file name was just "SCORE", `klen' is one character @@ -3060,7 +3060,7 @@ If ADAPT, return the home adaptive file instead." (defun gnus-decay-scores (alist day) "Decay non-permanent scores in ALIST." - (let ((times (- (time-to-days (current-time)) day)) + (let ((times (- (time-to-days nil) day)) kill entry updated score n) (unless (zerop times) ;Done decays today already? (while (setq entry (pop alist)) @@ -3072,7 +3072,7 @@ If ADAPT, return the home adaptive file instead." (setq score (or (nth 1 kill) gnus-score-interactive-default-score) n times) - (while (natnump (decf n)) + (while (natnump (cl-decf n)) (setq score (funcall gnus-decay-score-function score))) (setcdr kill (cons score (cdr (cdr kill))))))))) diff --git a/lisp/gnus/gnus-spec.el b/lisp/gnus/gnus-spec.el index d96e9f2aed7..47d722c9144 100644 --- a/lisp/gnus/gnus-spec.el +++ b/lisp/gnus/gnus-spec.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defvar gnus-newsrc-file-version) (require 'gnus) @@ -150,7 +150,7 @@ Return a list of updated types." (let ((buffer (intern (format "gnus-%s-buffer" type)))) (when (and (boundp buffer) (setq val (symbol-value buffer)) - (gnus-buffer-exists-p val)) + (gnus-buffer-live-p val)) (set-buffer val)) (setq new-format (symbol-value (intern (format "gnus-%s-line-format" type))))) @@ -271,9 +271,7 @@ Return a list of updated types." (insert " "))) (insert-char ? (max (- ,column (current-column)) 0)))))) -(defun gnus-correct-length (string) - "Return the correct width of STRING." - (apply #'+ (mapcar #'char-width string))) +(define-obsolete-function-alias 'gnus-correct-length 'string-width "27.1") (defun gnus-correct-substring (string start &optional end) (let ((wstart 0) @@ -285,15 +283,15 @@ Return a list of updated types." ;; Find the start position. (while (and (< seek length) (< wseek start)) - (incf wseek (char-width (aref string seek))) - (incf seek)) + (cl-incf wseek (char-width (aref string seek))) + (cl-incf seek)) (setq wstart seek) ;; Find the end position. (while (and (<= seek length) (or (not end) (<= wseek end))) - (incf wseek (char-width (aref string seek))) - (incf seek)) + (cl-incf wseek (char-width (aref string seek))) + (cl-incf seek)) (setq wend seek) (substring string wstart (1- wend)))) diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index f4464ad140c..972ff28e63f 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-start) @@ -36,11 +36,6 @@ (autoload 'gnus-group-make-nnir-group "nnir") -(defcustom gnus-server-mode-hook nil - "Hook run in `gnus-server-mode' buffers." - :group 'gnus-server - :type 'hook) - (defcustom gnus-server-exit-hook nil "Hook run when exiting the server buffer." :group 'gnus-server @@ -92,7 +87,7 @@ If nil, a faster, but more primitive, buffer is used instead." (defvar gnus-inserted-opened-servers nil) (defvar gnus-server-line-format-alist - `((?h gnus-tmp-how ?s) + '((?h gnus-tmp-how ?s) (?n gnus-tmp-name ?s) (?w gnus-tmp-where ?s) (?s gnus-tmp-status ?s) @@ -100,7 +95,7 @@ If nil, a faster, but more primitive, buffer is used instead." (?c gnus-tmp-cloud ?s))) (defvar gnus-server-mode-line-format-alist - `((?S gnus-tmp-news-server ?s) + '((?S gnus-tmp-news-server ?s) (?M gnus-tmp-news-method ?s) (?u gnus-tmp-user-defined ?s))) @@ -108,7 +103,7 @@ 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) +(defvar gnus-server-mode-map nil) (defcustom gnus-server-menu-hook nil "Hook run after the creation of the server mode menu." @@ -142,7 +137,7 @@ If nil, a faster, but more primitive, buffer is used instead." ["Offline" gnus-server-offline-server t] ["Deny" gnus-server-deny-server t] ["Toggle Cloud Sync for this server" gnus-server-toggle-cloud-server t] - ["Toggle Cloud Sync Host" gnus-server-toggle-cloud-method-server t] + ["Toggle Cloud Sync Host" gnus-server-set-cloud-method-server t] "---" ["Open All" gnus-server-open-all-servers t] ["Close All" gnus-server-close-all-servers t] @@ -150,11 +145,8 @@ If nil, a faster, but more primitive, buffer is used instead." (gnus-run-hooks 'gnus-server-menu-hook))) -(defvar gnus-server-mode-map nil) -(put 'gnus-server-mode 'mode-class 'special) - (unless gnus-server-mode-map - (setq gnus-server-mode-map (make-sparse-keymap)) + (setq gnus-server-mode-map (make-keymap)) (suppress-keymap gnus-server-mode-map) (gnus-define-keys gnus-server-mode-map @@ -189,7 +181,7 @@ If nil, a faster, but more primitive, buffer is used instead." "z" gnus-server-compact-server "i" gnus-server-toggle-cloud-server - "I" gnus-server-toggle-cloud-method-server + "I" gnus-server-set-cloud-method-server "\C-c\C-i" gnus-info-find-node "\C-c\C-b" gnus-bug)) @@ -200,9 +192,6 @@ If nil, a faster, but more primitive, buffer is used instead." (t (:bold t))) "Face used for displaying AGENTIZED servers" :group 'gnus-server-visual) -;; backward-compatibility alias -(put 'gnus-server-agent-face 'face-alias 'gnus-server-agent) -(put 'gnus-server-agent-face 'obsolete-face "22.1") (defface gnus-server-cloud '((((class color) (background light)) (:foreground "ForestGreen" :bold t)) @@ -224,9 +213,6 @@ If nil, a faster, but more primitive, buffer is used instead." (t (:bold t))) "Face used for displaying OPENED servers" :group 'gnus-server-visual) -;; backward-compatibility alias -(put 'gnus-server-opened-face 'face-alias 'gnus-server-opened) -(put 'gnus-server-opened-face 'obsolete-face "22.1") (defface gnus-server-closed '((((class color) (background light)) (:foreground "Steel Blue" :italic t)) @@ -235,9 +221,6 @@ If nil, a faster, but more primitive, buffer is used instead." (t (:italic t))) "Face used for displaying CLOSED servers" :group 'gnus-server-visual) -;; backward-compatibility alias -(put 'gnus-server-closed-face 'face-alias 'gnus-server-closed) -(put 'gnus-server-closed-face 'obsolete-face "22.1") (defface gnus-server-denied '((((class color) (background light)) (:foreground "Red" :bold t)) @@ -245,9 +228,6 @@ If nil, a faster, but more primitive, buffer is used instead." (t (:inverse-video t :bold t))) "Face used for displaying DENIED servers" :group 'gnus-server-visual) -;; backward-compatibility alias -(put 'gnus-server-denied-face 'face-alias 'gnus-server-denied) -(put 'gnus-server-denied-face 'obsolete-face "22.1") (defface gnus-server-offline '((((class color) (background light)) (:foreground "Orange" :bold t)) @@ -255,9 +235,6 @@ If nil, a faster, but more primitive, buffer is used instead." (t (:inverse-video t :bold t))) "Face used for displaying OFFLINE servers" :group 'gnus-server-visual) -;; backward-compatibility alias -(put 'gnus-server-offline-face 'face-alias 'gnus-server-offline) -(put 'gnus-server-offline-face 'obsolete-face "22.1") (defvar gnus-server-font-lock-keywords '(("(\\(agent\\))" 1 'gnus-server-agent) @@ -268,9 +245,8 @@ If nil, a faster, but more primitive, buffer is used instead." ("(\\(offline\\))" 1 'gnus-server-offline) ("(\\(denied\\))" 1 'gnus-server-denied))) -(defun gnus-server-mode () +(define-derived-mode gnus-server-mode gnus-mode "Server" "Major mode for listing and editing servers. - All normal editing commands are switched off. \\<gnus-server-mode-map> For more in-depth information on this mode, read the manual @@ -279,23 +255,16 @@ For more in-depth information on this mode, read the manual The following commands are available: \\{gnus-server-mode-map}" - ;; FIXME: Use define-derived-mode. - (interactive) (when (gnus-visual-p 'server-menu 'menu) (gnus-server-make-menu-bar)) - (kill-all-local-variables) (gnus-simplify-mode-line) - (setq major-mode 'gnus-server-mode) - (setq mode-name "Server") (gnus-set-default-directory) (setq mode-line-process nil) - (use-local-map gnus-server-mode-map) (buffer-disable-undo) (setq truncate-lines t) - (setq buffer-read-only t) (set (make-local-variable 'font-lock-defaults) - '(gnus-server-font-lock-keywords t)) - (gnus-run-mode-hooks 'gnus-server-mode-hook)) + '(gnus-server-font-lock-keywords t))) + (defun gnus-server-insert-server-line (name method) (let* ((gnus-tmp-name name) @@ -335,21 +304,15 @@ The following commands are available: (defun gnus-enter-server-buffer () "Set up the server buffer." - (gnus-server-setup-buffer) (gnus-configure-windows 'server) ;; Usually `gnus-configure-windows' will finish with the ;; `gnus-server-buffer' selected as the current buffer, but not always (I ;; bumped into it when starting from a dedicated *Group* frame, and ;; gnus-configure-windows opened *Server* into its own dedicated frame). - (with-current-buffer (get-buffer gnus-server-buffer) + (with-current-buffer (get-buffer-create gnus-server-buffer) + (gnus-server-mode) (gnus-server-prepare))) -(defun gnus-server-setup-buffer () - "Initialize the server buffer." - (unless (get-buffer gnus-server-buffer) - (with-current-buffer (gnus-get-buffer-create gnus-server-buffer) - (gnus-server-mode)))) - (defun gnus-server-prepare () (gnus-set-format 'server-mode) (gnus-set-format 'server t) @@ -452,7 +415,8 @@ The following commands are available: (if server (error "No such server: %s" server) (error "No server on the current line"))) (unless (assoc server gnus-server-alist) - (error "Read-only server %s" server)) + (error "Server %s must be deleted from your configuration files" + server)) (gnus-dribble-touch) (let ((buffer-read-only nil)) (gnus-delete-line)) @@ -608,7 +572,7 @@ The following commands are available: (error "%s already exists" to)) (unless (gnus-server-to-method from) (error "%s: no such server" from)) - (let ((to-entry (cons from (gnus-copy-sequence + (let ((to-entry (cons from (copy-tree (gnus-server-to-method from))))) (setcar to-entry to) (setcar (nthcdr 2 to-entry) to) @@ -642,7 +606,8 @@ The following commands are available: (unless server (error "No server on current line")) (unless (assoc server gnus-server-alist) - (error "This server can't be edited")) + (error "Server %s must be edited in your configuration files" + server)) (let ((info (cdr (assoc server gnus-server-alist)))) (gnus-close-server info) (gnus-edit-form @@ -661,8 +626,8 @@ The following commands are available: (let ((info (gnus-server-to-method server))) (gnus-edit-form info "Showing the server." - `(lambda (form) - (gnus-server-position-point)) + (lambda (form) + (gnus-server-position-point)) 'edit-server))) (defun gnus-server-scan-server (server) @@ -730,9 +695,7 @@ claim them." function (repeat function))) -(defvar gnus-browse-mode-hook nil) (defvar gnus-browse-mode-map nil) -(put 'gnus-browse-mode 'mode-class 'special) (unless gnus-browse-mode-map (setq gnus-browse-mode-map (make-keymap)) @@ -821,12 +784,11 @@ claim them." (while (not (eobp)) (ignore-errors (push (cons - (string-as-unibyte - (buffer-substring - (point) - (progn - (skip-chars-forward "^ \t") - (point)))) + (buffer-substring + (point) + (progn + (skip-chars-forward "^ \t") + (point))) (let ((last (read cur))) (cons (read cur) last))) groups)) @@ -834,19 +796,18 @@ claim them." (while (not (eobp)) (ignore-errors (push (cons - (string-as-unibyte - (if (eq (char-after) ?\") - (read cur) - (let ((p (point)) (name "")) - (skip-chars-forward "^ \t\\\\") - (setq name (buffer-substring p (point))) - (while (eq (char-after) ?\\) - (setq p (1+ (point))) - (forward-char 2) - (skip-chars-forward "^ \t\\\\") - (setq name (concat name (buffer-substring - p (point))))) - name))) + (if (eq (char-after) ?\") + (read cur) + (let ((p (point)) (name "")) + (skip-chars-forward "^ \t\\\\") + (setq name (buffer-substring p (point))) + (while (eq (char-after) ?\\) + (setq p (1+ (point))) + (forward-char 2) + (skip-chars-forward "^ \t\\\\") + (setq name (concat name (buffer-substring + p (point))))) + name)) (let ((last (read cur))) (cons (read cur) last))) groups)) @@ -912,9 +873,8 @@ claim them." (gnus-message 5 "Connecting to %s...done" (nth 1 method)) t)))) -(define-derived-mode gnus-browse-mode fundamental-mode "Browse Server" +(define-derived-mode gnus-browse-mode gnus-mode "Browse Server" "Major mode for browsing a foreign server. - All normal editing commands are switched off. \\<gnus-browse-mode-map> @@ -933,14 +893,17 @@ buffer. (setq mode-line-process nil) (buffer-disable-undo) (setq truncate-lines t) - (gnus-set-default-directory) - (setq buffer-read-only t)) + (gnus-set-default-directory)) (defun gnus-browse-read-group (&optional no-article number) "Enter the group at the current line. If NUMBER, fetch this number of articles." (interactive "P") - (let ((group (gnus-browse-group-name))) + (let* ((full-name (gnus-browse-group-name)) + (group (if (gnus-native-method-p + (gnus-find-method-for-group full-name)) + (gnus-group-short-name full-name) + full-name))) (if (or (not (gnus-get-info group)) (gnus-ephemeral-group-p group)) (unless (gnus-group-read-ephemeral-group @@ -982,7 +945,7 @@ how new groups will be entered into the group buffer." (not (eobp)) (gnus-browse-unsubscribe-group) (zerop (gnus-browse-next-group ward))) - (decf arg)) + (cl-decf arg)) (gnus-group-position-point) (when (/= 0 arg) (gnus-message 7 "No more newsgroups")) @@ -1123,11 +1086,10 @@ Requesting compaction of %s... (this may take a long time)" ;; Invalidate the original article buffer which might be out of date. ;; #### NOTE: Yes, this might be a bit rude, but since compaction ;; #### will not happen very often, I think this is acceptable. - (let ((original (get-buffer gnus-original-article-buffer))) - (and original (gnus-kill-buffer original)))))) + (gnus-kill-buffer gnus-original-article-buffer)))) (defun gnus-server-toggle-cloud-server () - "Make the server under point be replicated in the Emacs Cloud." + "Toggle whether the server under point is replicated in the Emacs Cloud." (interactive) (let ((server (gnus-server-server-name))) (unless server @@ -1147,7 +1109,7 @@ Requesting compaction of %s... (this may take a long time)" "Replication of %s in the cloud will stop") server))) -(defun gnus-server-toggle-cloud-method-server () +(defun gnus-server-set-cloud-method-server () "Set the server under point to host the Emacs Cloud." (interactive) (let ((server (gnus-server-server-name))) @@ -1157,7 +1119,7 @@ Requesting compaction of %s... (this may take a long time)" (error "The server under point can't host the Emacs Cloud")) (when (not (string-equal gnus-cloud-method server)) - (custom-set-variables '(gnus-cloud-method server)) + (customize-set-variable 'gnus-cloud-method server) ;; Note we can't use `Custom-save' here. (when (gnus-yes-or-no-p (format "The new cloud host server is %S now. Save it? " server)) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index a52cdbcbf2e..d726ee5aaba 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -36,8 +36,7 @@ (autoload 'gnus-agent-save-local "gnus-agent") (autoload 'gnus-agent-possibly-alter-active "gnus-agent") -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defvar gnus-agent-covered-methods) (defvar gnus-agent-file-loading-local) @@ -544,29 +543,21 @@ Can be used to turn version control on or off." (message "Descend hierarchy %s? ([y]nsq): " (substring prefix 1 (1- (length prefix))))) (cond ((= ans ?n) - (while (and groups - (setq group (car groups) - real-group (gnus-group-real-name group)) - (string-match prefix real-group)) - (push group gnus-killed-list) - (gnus-sethash group group gnus-killed-hashtb) - (setq groups (cdr groups))) + (dolist (g groups) + (when (string-match prefix (gnus-group-real-name g)) + (push g gnus-killed-list) + (puthash g t gnus-killed-hashtb))) (setq starts (cdr starts))) ((= ans ?s) - (while (and groups - (setq group (car groups) - real-group (gnus-group-real-name group)) - (string-match prefix real-group)) - (gnus-sethash group group gnus-killed-hashtb) - (gnus-subscribe-alphabetically (car groups)) - (setq groups (cdr groups))) + (dolist (g groups) + (when (string-match prefix (gnus-group-real-name g)) + (puthash g t gnus-killed-hashtb) + (gnus-subscribe-alphabetically g))) (setq starts (cdr starts))) ((= ans ?q) - (while groups - (setq group (car groups)) - (push group gnus-killed-list) - (gnus-sethash group group gnus-killed-hashtb) - (setq groups (cdr groups)))) + (dolist (g groups) + (push g gnus-killed-list) + (puthash g t gnus-killed-hashtb))) (t nil))) (message "Subscribe %s? ([n]yq)" (car groups)) (while (not (memq (setq ans (read-char-exclusive)) @@ -576,16 +567,14 @@ Can be used to turn version control on or off." (setq group (car groups)) (cond ((= ans ?y) (gnus-subscribe-alphabetically (car groups)) - (gnus-sethash group group gnus-killed-hashtb)) + (puthash group t gnus-killed-hashtb)) ((= ans ?q) - (while groups - (setq group (car groups)) - (push group gnus-killed-list) - (gnus-sethash group group gnus-killed-hashtb) - (setq groups (cdr groups)))) + (dolist (g groups) + (push g gnus-killed-list) + (puthash g t gnus-killed-hashtb))) (t (push group gnus-killed-list) - (gnus-sethash group group gnus-killed-hashtb))) + (puthash group t gnus-killed-hashtb))) (setq groups (cdr groups))))))) (defun gnus-subscribe-randomly (newsgroup) @@ -594,12 +583,9 @@ Can be used to turn version control on or off." (defun gnus-subscribe-alphabetically (newgroup) "Subscribe new NEWGROUP and insert it in alphabetical order." - (let ((groups (cdr gnus-newsrc-alist)) - before) - (while (and (not before) groups) - (if (string< newgroup (caar groups)) - (setq before (caar groups)) - (setq groups (cdr groups)))) + (let ((before (seq-find (lambda (group) + (string< newgroup group)) + (cdr gnus-group-list)))) (gnus-subscribe-newsgroup newgroup before))) (defun gnus-subscribe-hierarchically (newgroup) @@ -629,15 +615,15 @@ It is inserted in hierarchical newsgroup order if subscribed. If not, it is killed." (if (gnus-y-or-n-p (format "Subscribe new newsgroup %s? " group)) (gnus-subscribe-hierarchically group) - (push group gnus-killed-list))) + (gnus-subscribe-killed group))) (defun gnus-subscribe-zombies (group) "Make the new GROUP into a zombie group." - (push group gnus-zombie-list)) + (cl-pushnew group gnus-zombie-list :test #'equal)) (defun gnus-subscribe-killed (group) "Make the new GROUP a killed group." - (push group gnus-killed-list)) + (cl-pushnew group gnus-killed-list :test #'equal)) (defun gnus-subscribe-newsgroup (newsgroup &optional next) "Subscribe new NEWSGROUP. @@ -648,7 +634,7 @@ the first newsgroup." ;; We subscribe the group by changing its level to `subscribed'. (gnus-group-change-level newsgroup gnus-level-default-subscribed - gnus-level-killed (gnus-group-entry (or next "dummy.group"))) + gnus-level-killed (or next "dummy.group")) (gnus-request-update-group-status newsgroup 'subscribe) (gnus-message 5 "Subscribe newsgroup: %s" newsgroup) (run-hook-with-args 'gnus-subscribe-newsgroup-functions newsgroup) @@ -697,6 +683,7 @@ the first newsgroup." gnus-agent-file-loading-cache nil gnus-server-method-cache nil gnus-newsrc-alist nil + gnus-group-list nil gnus-newsrc-hashtb nil gnus-killed-list nil gnus-zombie-list nil @@ -733,11 +720,10 @@ the first newsgroup." ;; Kill Gnus buffers. (do-auto-save t) (dolist (buffer (gnus-buffers)) - (when (gnus-buffer-exists-p buffer) - (with-current-buffer buffer - (set-buffer-modified-p nil) - (when (local-variable-p 'kill-buffer-hook) - (setq kill-buffer-hook nil)))) + (with-current-buffer buffer + (set-buffer-modified-p nil) + (when (local-variable-p 'kill-buffer-hook) + (setq kill-buffer-hook nil))) (gnus-kill-buffer buffer)) ;; Remove Gnus frames. (gnus-kill-gnus-frames)) @@ -855,8 +841,7 @@ prompt the user for the name of an NNTP server to use." "Enter STRING into the dribble buffer. If REGEXP is given, lines that match it will be deleted." (when (and (not gnus-dribble-ignore) - gnus-dribble-buffer - (buffer-name gnus-dribble-buffer)) + (buffer-live-p gnus-dribble-buffer)) (let ((obuf (current-buffer))) (set-buffer gnus-dribble-buffer) (when regexp @@ -948,14 +933,13 @@ If REGEXP is given, lines that match it will be deleted." (set-buffer-modified-p nil))))) (defun gnus-dribble-save () - (when (and gnus-dribble-buffer - (buffer-name gnus-dribble-buffer)) + (when (buffer-live-p gnus-dribble-buffer) (with-current-buffer gnus-dribble-buffer (when (> (buffer-size) 0) (save-buffer))))) (defun gnus-dribble-clear () - (when (gnus-buffer-exists-p gnus-dribble-buffer) + (when (gnus-buffer-live-p gnus-dribble-buffer) (with-current-buffer gnus-dribble-buffer (erase-buffer) (set-buffer-modified-p nil) @@ -1019,7 +1003,7 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." (eq gnus-read-active-file 'some)) (gnus-update-active-hashtb-from-killed)) (unless gnus-active-hashtb - (setq gnus-active-hashtb (gnus-make-hashtable 4096))) + (setq gnus-active-hashtb (gnus-make-hashtable 4000))) ;; Initialize the cache. (when gnus-use-cache (gnus-cache-open)) @@ -1109,7 +1093,7 @@ for new groups, and subscribe the new groups as zombies." (gnus-ask-server-for-new-groups) ;; Go through the active hashtb and look for new groups. (let ((groups 0) - group new-newsgroups) + new-newsgroups) (gnus-message 5 "Looking for new newsgroups...") (unless gnus-have-read-active-file (gnus-read-active-file)) @@ -1118,30 +1102,26 @@ for new groups, and subscribe the new groups as zombies." (gnus-make-hashtable-from-killed)) ;; Go though every newsgroup in `gnus-active-hashtb' and compare ;; with `gnus-newsrc-hashtb' and `gnus-killed-hashtb'. - (mapatoms - (lambda (sym) - (if (or (null (setq group (symbol-name sym))) - (not (boundp sym)) - (null (symbol-value sym)) - (gnus-gethash group gnus-killed-hashtb) - (gnus-gethash group gnus-newsrc-hashtb)) - () - (let ((do-sub (gnus-matches-options-n group))) + (maphash + (lambda (g-name active) + (unless (or (gethash g-name gnus-killed-hashtb) + (gethash g-name gnus-newsrc-hashtb)) + (let ((do-sub (gnus-matches-options-n g-name))) (cond ((eq do-sub 'subscribe) (setq groups (1+ groups)) - (gnus-sethash group group gnus-killed-hashtb) + (puthash g-name t gnus-killed-hashtb) (gnus-call-subscribe-functions - gnus-subscribe-options-newsgroup-method group)) + gnus-subscribe-options-newsgroup-method g-name)) ((eq do-sub 'ignore) nil) (t (setq groups (1+ groups)) - (gnus-sethash group group gnus-killed-hashtb) + (puthash g-name t gnus-killed-hashtb) (if gnus-subscribe-hierarchical-interactive - (push group new-newsgroups) + (push g-name new-newsgroups) (gnus-call-subscribe-functions - gnus-subscribe-newsgroup-method group))))))) + gnus-subscribe-newsgroup-method g-name))))))) gnus-active-hashtb) (when new-newsgroups (gnus-subscribe-hierarchical-interactive new-newsgroups)) @@ -1214,36 +1194,32 @@ for new groups, and subscribe the new groups as zombies." ;; Enter all the new groups into a hashtable. (gnus-active-to-gnus-format method hashtb 'ignore)) ;; Now all new groups from `method' are in `hashtb'. - (mapatoms - (lambda (group-sym) - (if (or (null (setq group (symbol-name group-sym))) - (not (boundp group-sym)) - (null (symbol-value group-sym)) - (gnus-gethash group gnus-newsrc-hashtb) - (member group gnus-zombie-list) - (member group gnus-killed-list)) - ;; The group is already known. - () + (maphash + (lambda (g-name val) + (unless (or (null val) ; The group is already known. + (gethash g-name gnus-newsrc-hashtb) + (member g-name gnus-zombie-list) + (member g-name gnus-killed-list)) ;; Make this group active. - (when (symbol-value group-sym) - (gnus-set-active group (symbol-value group-sym))) + (when val + (gnus-set-active g-name val)) ;; Check whether we want it or not. - (let ((do-sub (gnus-matches-options-n group))) + (let ((do-sub (gnus-matches-options-n g-name))) (cond ((eq do-sub 'subscribe) - (incf groups) - (gnus-sethash group group gnus-killed-hashtb) + (cl-incf groups) + (puthash g-name group gnus-killed-hashtb) (gnus-call-subscribe-functions - gnus-subscribe-options-newsgroup-method group)) + gnus-subscribe-options-newsgroup-method g-name)) ((eq do-sub 'ignore) nil) (t - (incf groups) - (gnus-sethash group group gnus-killed-hashtb) + (cl-incf groups) + (puthash g-name group gnus-killed-hashtb) (if gnus-subscribe-hierarchical-interactive - (push group new-newsgroups) + (push g-name new-newsgroups) (gnus-call-subscribe-functions - gnus-subscribe-newsgroup-method group))))))) + gnus-subscribe-newsgroup-method g-name))))))) hashtb)) (when new-newsgroups (gnus-subscribe-hierarchical-interactive new-newsgroups))) @@ -1264,29 +1240,28 @@ for new groups, and subscribe the new groups as zombies." gnus-level-default-subscribed gnus-level-killed previous t) t) -;; `gnus-group-change-level' is the fundamental function for changing -;; subscription levels of newsgroups. This might mean just changing -;; from level 1 to 2, which is pretty trivial, from 2 to 6 or back -;; again, which subscribes/unsubscribes a group, which is equally -;; trivial. Changing from 1-7 to 8-9 means that you kill a group, and -;; from 8-9 to 1-7 means that you remove the group from the list of -;; killed (or zombie) groups and add them to the (kinda) subscribed -;; groups. And last but not least, moving from 8 to 9 and 9 to 8, -;; which is trivial. -;; ENTRY can either be a string (newsgroup name) or a list (if -;; FROMKILLED is t, it's a list on the format (NUM INFO-LIST), -;; otherwise it's a list in the format of the `gnus-newsrc-hashtb' -;; entries. -;; LEVEL is the new level of the group, OLDLEVEL is the old level and -;; PREVIOUS is the group (in hashtb entry format) to insert this group -;; after. + (defun gnus-group-change-level (entry level &optional oldlevel previous fromkilled) + "Change level of group ENTRY to LEVEL. +This is the fundamental function for changing subscription levels +of newsgroups. This might mean just changing from level 1 to 2, +which is pretty trivial, from 2 to 6 or back again, which +subscribes/unsubscribes a group, which is equally trivial. +Changing from 1-7 to 8-9 means that you kill a group, and from +8-9 to 1-7 means that you remove the group from the list of +killed (or zombie) groups and add them to the (kinda) subscribed +groups. And last but not least, moving from 8 to 9 and 9 to 8, +which is trivial. ENTRY can either be a string (newsgroup name) +or a list (if FROMKILLED is t, it's a list on the format (NUM +INFO-LIST), otherwise it's a list in the format of the +`gnus-newsrc-hashtb' entries. LEVEL is the new level of the +group, OLDLEVEL is the old level and PREVIOUS is the group (a +string name) to insert this group after." (let (group info active num) - ;; Glean what info we can from the arguments + ;; Glean what info we can from the arguments. (if (consp entry) - (if fromkilled (setq group (nth 1 entry)) - (setq group (car (nth 2 entry)))) + (setq group (if fromkilled (nth 1 entry) (car (nth 1 entry)))) (setq group entry)) (when (and (stringp entry) oldlevel @@ -1294,21 +1269,17 @@ for new groups, and subscribe the new groups as zombies." (setq entry (gnus-group-entry entry))) (if (and (not oldlevel) (consp entry)) - (setq oldlevel (gnus-info-level (nth 2 entry))) + (setq oldlevel (gnus-info-level (nth 1 entry))) (setq oldlevel (or oldlevel gnus-level-killed))) - (when (stringp previous) - (setq previous (gnus-group-entry previous))) - - (if (and (>= oldlevel gnus-level-zombie) - (gnus-group-entry group)) - ;; We are trying to subscribe a group that is already - ;; subscribed. - () ; Do nothing. - + ;; Group is already subscribed. + (unless (and (>= oldlevel gnus-level-zombie) + (gnus-group-entry group)) (unless (gnus-ephemeral-group-p group) (gnus-dribble-enter (format "(gnus-group-change-level %S %S %S %S %S)" - group level oldlevel (car (nth 2 previous)) fromkilled))) + group level oldlevel + (cadr (member previous gnus-group-list)) + fromkilled))) ;; Then we remove the newgroup from any old structures, if needed. ;; If the group was killed, we remove it from the killed or zombie @@ -1322,11 +1293,10 @@ for new groups, and subscribe the new groups as zombies." (t (when (and (>= level gnus-level-zombie) entry) - (gnus-sethash (car (nth 2 entry)) nil gnus-newsrc-hashtb) - (when (nth 3 entry) - (setcdr (gnus-group-entry (car (nth 3 entry))) - (cdr entry))) - (setcdr (cdr entry) (cdddr entry))))) + (remhash (car (nth 1 entry)) gnus-newsrc-hashtb) + (setq gnus-group-list (remove group gnus-group-list)) + (setq gnus-newsrc-alist (delq (assoc group gnus-newsrc-alist) + gnus-newsrc-alist))))) ;; Finally we enter (if needed) the list where it is supposed to ;; go, and change the subscription level. If it is to be killed, @@ -1334,12 +1304,13 @@ for new groups, and subscribe the new groups as zombies." (cond ((>= level gnus-level-zombie) ;; Remove from the hash table. - (gnus-sethash group nil gnus-newsrc-hashtb) + (remhash group gnus-newsrc-hashtb) + (setq gnus-group-list (remove group gnus-group-list)) (if (= level gnus-level-zombie) (push group gnus-zombie-list) (if (= oldlevel gnus-level-killed) ;; Remove from active hashtb. - (unintern group gnus-active-hashtb) + (remhash group gnus-active-hashtb) ;; Don't add it into killed-list if it was killed. (push group gnus-killed-list)))) (t @@ -1350,7 +1321,7 @@ for new groups, and subscribe the new groups as zombies." ;; It was alive, and it is going to stay alive, so we ;; just change the level and don't change any pointers or ;; hash table entries. - (setcar (cdaddr entry) level) + (setcar (cdadr entry) level) (if (listp entry) (setq info (cdr entry) num (car entry)) @@ -1365,23 +1336,18 @@ for new groups, and subscribe the new groups as zombies." (if method (setq info (list group level nil nil method)) (setq info (list group level nil))))) - (unless previous - (setq previous - (let ((p gnus-newsrc-alist)) - (while (cddr p) - (setq p (cdr p))) - p))) - (setq entry (cons info (cddr previous))) - (if (cdr previous) - (progn - (setcdr (cdr previous) entry) - (gnus-sethash group (cons num (cdr previous)) - gnus-newsrc-hashtb)) - (setcdr previous entry) - (gnus-sethash group (cons num previous) - gnus-newsrc-hashtb)) - (when (cdr entry) - (setcdr (gnus-group-entry (caadr entry)) entry)) + ;; Add group. The exact ordering only matters for + ;; `gnus-group-list', though we need to keep the dummy group + ;; at the head of `gnus-newsrc-alist'. + (push info (cdr gnus-newsrc-alist)) + (puthash group (list num info) gnus-newsrc-hashtb) + (when (stringp previous) + (setq previous (gnus-group-entry previous))) + (let* ((prev-idx (seq-position gnus-group-list (caadr previous))) + (idx (if prev-idx + (1+ prev-idx) + (length gnus-group-list)))) + (push group (nthcdr idx gnus-group-list))) (gnus-dribble-enter (format "(gnus-group-set-info '%S)" info) (concat "^(gnus-group-set-info '(\"" (regexp-quote group) "\""))))) @@ -1456,7 +1422,7 @@ newsgroup." (defun gnus-cache-possibly-alter-active (group active) "Alter the ACTIVE info for GROUP to reflect the articles in the cache." (when gnus-cache-active-hashtb - (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) + (let ((cache-active (gethash group gnus-cache-active-hashtb))) (when cache-active (when (< (car cache-active) (car active)) (setcar active (car cache-active))) @@ -1700,7 +1666,7 @@ backend check whether the group actually exists." ;; aren't equal (and that need extension; i.e., they are async). (let ((methods nil)) (dolist (elem type-cache) - (destructuring-bind (method method-type infos dummy) elem + (cl-destructuring-bind (method method-type infos dummy) elem (let ((gnus-opened-servers methods)) (when (and (gnus-similar-server-opened method) (gnus-check-backend-function @@ -1723,7 +1689,7 @@ backend check whether the group actually exists." ;; Clear out all the early methods. (dolist (elem type-cache) - (destructuring-bind (method method-type infos dummy) elem + (cl-destructuring-bind (method method-type infos dummy) elem (when (and method infos (gnus-check-backend-function @@ -1740,7 +1706,7 @@ backend check whether the group actually exists." (let ((done-methods nil) sanity-spec) (dolist (elem type-cache) - (destructuring-bind (method method-type infos dummy) elem + (cl-destructuring-bind (method method-type infos dummy) elem (setq sanity-spec (list (car method) (cadr method))) (when (and method infos (not (gnus-method-denied-p method))) @@ -1771,7 +1737,7 @@ backend check whether the group actually exists." ;; Do the rest of the retrieval. (dolist (elem type-cache) - (destructuring-bind (method method-type infos early-data) elem + (cl-destructuring-bind (method method-type infos early-data) elem (when (and method infos (not (gnus-method-denied-p method))) (let ((updatep (gnus-check-backend-function @@ -1795,11 +1761,11 @@ backend check whether the group actually exists." ;; are in the secondary select list. ((eq type 'secondary) (let ((i 2)) - (block nil - (dolist (smethod gnus-secondary-select-methods) + (cl-block nil + (cl-dolist (smethod gnus-secondary-select-methods) (when (equal method smethod) - (return i)) - (incf i)) + (cl-return i)) + (cl-incf i)) i))) ;; Just say that all foreign groups have the same rank. (t @@ -1838,19 +1804,25 @@ backend check whether the group actually exists." (dolist (info infos) (gnus-activate-group (gnus-info-group info) nil nil method t)))))) -;; Create a hash table out of the newsrc alist. The `car's of the -;; alist elements are used as keys. (defun gnus-make-hashtable-from-newsrc-alist () + "Create a hash table from `gnus-newsrc-alist'. +The keys are group names, and values are a cons of (unread info), +where unread is an integer count of calculated unread +messages (or nil), and info is a regular gnus info entry. + +The info element is shared with the same element of +`gnus-newrc-alist', so as to conserve space." (let ((alist gnus-newsrc-alist) (ohashtb gnus-newsrc-hashtb) - prev info method rest methods) - (setq gnus-newsrc-hashtb (gnus-make-hashtable (length alist))) + info method gname rest methods) + (setq gnus-newsrc-hashtb (gnus-make-hashtable (length alist)) + gnus-group-list nil) (setq alist - (setq prev (setq gnus-newsrc-alist - (if (equal (caar gnus-newsrc-alist) - "dummy.group") - gnus-newsrc-alist - (cons (list "dummy.group" 0 nil) alist))))) + (setq gnus-newsrc-alist + (if (equal (caar gnus-newsrc-alist) + "dummy.group") + gnus-newsrc-alist + (cons (list "dummy.group" 0 nil) alist)))) (while alist (setq info (car alist)) ;; Make the same select-methods identical Lisp objects. @@ -1859,17 +1831,18 @@ backend check whether the group actually exists." (gnus-info-set-method info (car rest)) (push method methods))) ;; Check for duplicates. - (if (gnus-gethash (car info) gnus-newsrc-hashtb) + (if (gethash (car info) gnus-newsrc-hashtb) ;; Remove this entry from the alist. - (setcdr prev (cddr prev)) - (gnus-sethash + (setcdr alist (cddr alist)) + (puthash (car info) ;; Preserve number of unread articles in groups. - (cons (and ohashtb (car (gnus-gethash (car info) ohashtb))) - prev) + (list (and ohashtb (car (gethash (car info) ohashtb))) + info) gnus-newsrc-hashtb) - (setq prev alist)) + (push (car info) gnus-group-list)) (setq alist (cdr alist))) + (setq gnus-group-list (nreverse gnus-group-list)) ;; Make the same select-methods in `gnus-server-alist' identical ;; as well. (while methods @@ -1884,10 +1857,10 @@ backend check whether the group actually exists." (setq gnus-killed-hashtb (gnus-make-hashtable (+ (length gnus-killed-list) (length gnus-zombie-list)))) - (while lists - (setq list (symbol-value (pop lists))) - (while list - (gnus-sethash (car list) (pop list) gnus-killed-hashtb))))) + (dolist (g (append gnus-killed-list gnus-zombie-list)) + ;; NOTE: We have lost the ordering that used to be kept in this + ;; variable. + (puthash g t gnus-killed-hashtb)))) (defun gnus-parse-active () "Parse active info in the nntp server buffer." @@ -1901,7 +1874,7 @@ backend check whether the group actually exists." (defun gnus-make-articles-unread (group articles) "Mark ARTICLES in GROUP as unread." - (let* ((info (nth 2 (or (gnus-group-entry group) + (let* ((info (nth 1 (or (gnus-group-entry group) (gnus-group-entry (gnus-group-real-name group))))) (ranges (gnus-info-read info)) @@ -1925,7 +1898,7 @@ backend check whether the group actually exists." "Mark ascending ARTICLES in GROUP as unread." (let* ((entry (or (gnus-group-entry group) (gnus-group-entry (gnus-group-real-name group)))) - (info (nth 2 entry)) + (info (nth 1 entry)) (ranges (gnus-info-read info)) (r ranges) modified) @@ -1988,17 +1961,11 @@ backend check whether the group actually exists." ;; Insert the change into the group buffer and the dribble file. (gnus-group-update-group group t)))) -;; Enter all dead groups into the hashtb. (defun gnus-update-active-hashtb-from-killed () - (let ((hashtb (setq gnus-active-hashtb (gnus-make-hashtable 4096))) - (lists (list gnus-killed-list gnus-zombie-list)) - killed) - (while lists - (setq killed (car lists)) - (while killed - (gnus-sethash (string-as-unibyte (car killed)) nil hashtb) - (setq killed (cdr killed))) - (setq lists (cdr lists))))) + (let ((hashtb (setq gnus-active-hashtb + (gnus-make-hashtable 4000)))) + (dolist (g (append gnus-killed-list gnus-zombie-list)) + (remhash g hashtb)))) (defun gnus-get-killed-groups () "Go through the active hashtb and mark all unknown groups as killed." @@ -2009,20 +1976,16 @@ backend check whether the group actually exists." (unless gnus-killed-hashtb (gnus-make-hashtable-from-killed)) ;; Go through all newsgroups that are known to Gnus - enlarge kill list. - (mapatoms - (lambda (sym) - (let ((groups 0) - (group (symbol-name sym))) - (if (or (null group) - (gnus-gethash group gnus-killed-hashtb) - (gnus-gethash group gnus-newsrc-hashtb)) - () - (let ((do-sub (gnus-matches-options-n group))) - (if (or (eq do-sub 'subscribe) (eq do-sub 'ignore)) - () + (maphash + (lambda (g-name active) + (let ((groups 0)) + (unless (or (gethash g-name gnus-killed-hashtb) + (gethash g-name gnus-newsrc-hashtb)) + (let ((do-sub (gnus-matches-options-n g-name))) + (unless (or (eq do-sub 'subscribe) (eq do-sub 'ignore)) (setq groups (1+ groups)) - (push group gnus-killed-list) - (gnus-sethash group group gnus-killed-hashtb)))))) + (push g-name gnus-killed-list) + (puthash g-name t gnus-killed-hashtb)))))) gnus-active-hashtb) (gnus-dribble-touch)) @@ -2135,11 +2098,13 @@ backend check whether the group actually exists." (not (equal method gnus-select-method))) gnus-active-hashtb (setq gnus-active-hashtb - (if (equal method gnus-select-method) - (gnus-make-hashtable - (count-lines (point-min) (point-max))) - (gnus-make-hashtable 4096)))))) + (gnus-make-hashtable + (if (equal method gnus-select-method) + (count-lines (point-min) (point-max)) + 4000)))))) group max min) + (unless gnus-moderated-hashtb + (setq gnus-moderated-hashtb (gnus-make-hashtable 100))) ;; Delete unnecessary lines. (goto-char (point-min)) (cond @@ -2149,12 +2114,6 @@ backend check whether the group actually exists." (delete-matching-lines (concat "^to\\.\\|" gnus-ignored-newsgroups)))) (goto-char (point-min)) - (unless (re-search-forward "[\\\"]" nil t) - ;; Make the group names readable as a lisp expression even if they - ;; contain special characters. - (goto-char (point-max)) - (while (re-search-backward "[][';?()#]" nil t) - (insert ?\\))) ;; Let the Gnus agent save the active file. (when (and gnus-agent real-active (gnus-online method)) @@ -2174,49 +2133,41 @@ backend check whether the group actually exists." (insert prefix) (zerop (forward-line 1))))))) ;; Store the active file in a hash table. - ;; Use a unibyte buffer in order to make `read' read non-ASCII - ;; group names (which have been encoded) as unibyte strings. - (mm-with-unibyte-buffer + + (with-temp-buffer (insert-buffer-substring cur) (setq cur (current-buffer)) (goto-char (point-min)) (while (not (eobp)) (condition-case () - (progn - (narrow-to-region (point) (point-at-eol)) - ;; group gets set to a symbol interned in the hash table - ;; (what a hack!!) - jwz - (setq group (let ((obarray hashtb)) (read cur))) - ;; ### The extended group name scheme makes - ;; the previous optimization strategy sort of pointless... - (when (stringp group) - (setq group (intern group hashtb))) - (if (and (numberp (setq max (read cur))) - (numberp (setq min (read cur))) - (progn - (skip-chars-forward " \t") - (not - (or (eq (char-after) ?=) - (eq (char-after) ?x) - (eq (char-after) ?j))))) - (progn - (set group (cons min max)) - ;; if group is moderated, stick in moderation table - (when (eq (char-after) ?m) - (unless gnus-moderated-hashtb - (setq gnus-moderated-hashtb (gnus-make-hashtable))) - (gnus-sethash (symbol-name group) t - gnus-moderated-hashtb))) - (set group nil))) + (if (and (stringp (progn + (setq group (read cur) + group + (cond ((numberp group) + (number-to-string group)) + ((symbolp group) + (encode-coding-string + (symbol-name group) + 'latin-1)) + ((stringp group) + group))))) + (numberp (setq max (read cur))) + (numberp (setq min (read cur))) + (null (progn + (skip-chars-forward " \t") + (memq (char-after) + '(?= ?x ?j))))) + (progn (puthash group (cons min max) hashtb) + ;; If group is moderated, stick it in the + ;; moderation cache. + (when (eq (char-after) ?m) + (puthash group t gnus-moderated-hashtb))) + (setq group nil)) (error - (and group - (symbolp group) - (set group nil)) (unless ignore-errors (gnus-message 3 "Warning - invalid active: %s" (buffer-substring (point-at-bol) (point-at-eol)))))) - (widen) (forward-line 1))))) (defun gnus-groups-to-gnus-format (method &optional hashtb real-active) @@ -2244,35 +2195,23 @@ backend check whether the group actually exists." (gnus-active-to-gnus-format method hashtb nil real-active)) (goto-char (point-min)) - ;; We split this into to separate loops, one with the prefix - ;; and one without to speed the reading up somewhat. - (if prefix - (let (min max opoint group) - (while (not (eobp)) - (condition-case () - (progn - (read cur) (read cur) - (setq min (read cur) - max (read cur) - opoint (point)) - (skip-chars-forward " \t") - (insert prefix) - (goto-char opoint) - (set (let ((obarray hashtb)) (read cur)) - (cons min max))) - (error (and group (symbolp group) (set group nil)))) - (forward-line 1))) - (let (min max group) - (while (not (eobp)) - (condition-case () - (when (eq (char-after) ?2) - (read cur) (read cur) - (setq min (read cur) - max (read cur)) - (set (setq group (let ((obarray hashtb)) (read cur))) - (cons min max))) - (error (and group (symbolp group) (set group nil)))) - (forward-line 1))))))) + (let (min max group) + (while (not (eobp)) + (condition-case () + (when (eq (char-after) ?2) + (read cur) (read cur) + (setq min (read cur) + max (read cur) + group (read cur) + group (if (numberp group) + (number-to-string group) + (symbol-name group))) + (puthash (if prefix + (concat prefix group) + group) + (cons min max) hashtb)) + (error (remhash group hashtb))) + (forward-line 1)))))) (defun gnus-read-newsrc-file (&optional force) "Read startup file. @@ -2456,10 +2395,6 @@ If FORCE is non-nil, the .newsrc file is read." (setq gnus-format-specs gnus-default-format-specs))) (when gnus-newsrc-assoc (setq gnus-newsrc-alist gnus-newsrc-assoc)))) - (dolist (elem gnus-newsrc-alist) - ;; Protect against broken .newsrc.el files. - (when (car elem) - (setcar elem (string-as-unibyte (car elem))))) (gnus-make-hashtable-from-newsrc-alist) (when (file-newer-than-file-p file ding-file) ;; Old format quick file @@ -2539,16 +2474,11 @@ If FORCE is non-nil, the .newsrc file is read." (setq gnus-newsrc-options-n nil) (unless gnus-active-hashtb - (setq gnus-active-hashtb (gnus-make-hashtable 4096))) + (setq gnus-active-hashtb (gnus-make-hashtable 4000))) (let ((buf (current-buffer)) (already-read (> (length gnus-newsrc-alist) 1)) - group subscribed options-symbol newsrc Options-symbol - symbol reads num1) + group subscribed newsrc reads num1) (goto-char (point-min)) - ;; We intern the symbol `options' in the active hashtb so that we - ;; can `eq' against it later. - (set (setq options-symbol (intern "options" gnus-active-hashtb)) nil) - (set (setq Options-symbol (intern "Options" gnus-active-hashtb)) nil) (while (not (eobp)) ;; We first read the first word on the line by narrowing and @@ -2559,15 +2489,16 @@ If FORCE is non-nil, the .newsrc file is read." (point) (progn (skip-chars-forward "^ \t!:\n") (point))) (goto-char (point-min)) - (setq symbol + (setq group (and (/= (point-min) (point-max)) - (let ((obarray gnus-active-hashtb)) (read buf)))) + (read buf)) + group (if (numberp group) + (number-to-string group) + (symbol-name group))) (widen) - ;; Now, the symbol we have read is either `options' or a group - ;; name. If it is an options line, we just add it to a string. (cond - ((or (eq symbol options-symbol) - (eq symbol Options-symbol)) + ;; It's possible that "group" is actually an options line. + ((string-equal (downcase group) "options") (setq gnus-newsrc-options ;; This concatting is quite inefficient, but since our ;; thorough studies show that approx 99.37% of all @@ -2581,19 +2512,13 @@ If FORCE is non-nil, the .newsrc file is read." (point-at-bol)) (point))))) (forward-line -1)) - (symbol - ;; Group names can be just numbers. - (when (numberp symbol) - (setq symbol (intern (int-to-string symbol) gnus-active-hashtb))) - (unless (boundp symbol) - (set symbol nil)) + (group ;; It was a group name. (setq subscribed (eq (char-after) ?:) - group (symbol-name symbol) reads nil) (if (eolp) ;; If the line ends here, this is clearly a buggy line, so - ;; we put point a the beginning of line and let the cond + ;; we put point at the beginning of line and let the cond ;; below do the error handling. (beginning-of-line) ;; We skip to the beginning of the ranges. @@ -2632,7 +2557,7 @@ If FORCE is non-nil, the .newsrc file is read." ;; It was just a simple number, so we add it to the ;; list of ranges. (push num1 reads)) - ;; If the next char in ?\n, then we have reached the end + ;; If the next char is ?\n, then we have reached the end ;; of the line and return nil. (not (eq (char-after) ?\n))) ((eq (char-after) ?\n) @@ -2661,7 +2586,8 @@ If FORCE is non-nil, the .newsrc file is read." (let ((info (gnus-get-info group)) level) (if info - ;; There is an entry for this file in the alist. + ;; There is an entry for this file in + ;; `gnus-newsrc-hashtb'. (progn (gnus-info-set-read info (nreverse reads)) ;; We update the level very gently. In fact, we @@ -2689,8 +2615,7 @@ If FORCE is non-nil, the .newsrc file is read." (setq newsrc (nreverse newsrc)) - (if (not already-read) - () + (unless already-read ;; We now have two newsrc lists - `newsrc', which is what we ;; have read from .newsrc, and `gnus-newsrc-alist', which is ;; what we've read from .newsrc.eld. We have to merge these @@ -2787,9 +2712,10 @@ If FORCE is non-nil, the .newsrc file is read." (defvar gnus-save-newsrc-file-last-timestamp nil) (defun gnus-save-newsrc-file (&optional force) - "Save .newsrc file." - ;; Note: We cannot save .newsrc file if all newsgroups are removed - ;; from the variable gnus-newsrc-alist. + "Save .newsrc file. +Use the group string names in `gnus-group-list' to pull info +values from `gnus-newsrc-hashtb', and write a new value of +`gnus-newsrc-alist'." (when (and (or gnus-newsrc-alist gnus-killed-list) gnus-current-startup-file) ;; Save agent range limits for the currently active method. @@ -2799,8 +2725,7 @@ If FORCE is non-nil, the .newsrc file is read." (save-excursion (if (and (or gnus-use-dribble-file gnus-slave) (not force) - (or (not gnus-dribble-buffer) - (not (buffer-name gnus-dribble-buffer)) + (or (not (buffer-live-p gnus-dribble-buffer)) (zerop (with-current-buffer gnus-dribble-buffer (buffer-size))))) (gnus-message 4 "(No changes need to be saved)") @@ -2829,78 +2754,89 @@ If FORCE is non-nil, the .newsrc file is read." (erase-buffer) (gnus-message 5 "Saving %s.eld..." gnus-current-startup-file) - ;; check timestamp of `gnus-current-startup-file'.eld against - ;; `gnus-save-newsrc-file-last-timestamp' - (let* ((checkfile (concat gnus-current-startup-file ".eld")) - (mtime (nth 5 (file-attributes checkfile)))) - (when (and gnus-save-newsrc-file-last-timestamp - (time-less-p gnus-save-newsrc-file-last-timestamp - mtime)) - (unless (y-or-n-p + ;; Check timestamp of `gnus-current-startup-file'.eld against + ;; `gnus-save-newsrc-file-last-timestamp'. + (if (let* ((checkfile (concat gnus-current-startup-file ".eld")) + (mtime (file-attribute-modification-time + (file-attributes checkfile)))) + (and gnus-save-newsrc-file-last-timestamp + (time-less-p gnus-save-newsrc-file-last-timestamp + mtime) + (not + (y-or-n-p (format "%s was updated externally after %s, save?" checkfile (format-time-string - "%c" - gnus-save-newsrc-file-last-timestamp))) - (error "Couldn't save %s: updated externally" checkfile)))) - - (if gnus-save-startup-file-via-temp-buffer + "%c" + gnus-save-newsrc-file-last-timestamp)))))) + (gnus-message + 4 "Didn't save %s: updated externally" + (concat gnus-current-startup-file ".eld")) + (if gnus-save-startup-file-via-temp-buffer + (let ((coding-system-for-write gnus-ding-file-coding-system) + (standard-output (current-buffer))) + (gnus-gnus-to-quick-newsrc-format) + (gnus-run-hooks 'gnus-save-quick-newsrc-hook) + (save-buffer) + (setq gnus-save-newsrc-file-last-timestamp + (file-attribute-modification-time + (file-attributes buffer-file-name)))) (let ((coding-system-for-write gnus-ding-file-coding-system) - (standard-output (current-buffer))) - (gnus-gnus-to-quick-newsrc-format) - (gnus-run-hooks 'gnus-save-quick-newsrc-hook) - (save-buffer) - (setq gnus-save-newsrc-file-last-timestamp - (nth 5 (file-attributes buffer-file-name)))) - (let ((coding-system-for-write gnus-ding-file-coding-system) - (version-control gnus-backup-startup-file) - (startup-file (concat gnus-current-startup-file ".eld")) - (working-dir (file-name-directory gnus-current-startup-file)) - working-file - (i -1)) - ;; Generate the name of a non-existent file. - (while (progn (setq working-file - (format - (if (and (eq system-type 'ms-dos) - (not (gnus-long-file-names))) - "%s#%d.tm#" ; MSDOS limits files to 8+3 - "%s#tmp#%d") - working-dir (setq i (1+ i)))) - (file-exists-p working-file))) - - (unwind-protect - (progn - (gnus-with-output-to-file working-file - (gnus-gnus-to-quick-newsrc-format) - (gnus-run-hooks 'gnus-save-quick-newsrc-hook)) - - ;; These bindings will mislead the current buffer - ;; into thinking that it is visiting the startup - ;; file. - (let ((buffer-backed-up nil) - (buffer-file-name startup-file) - (file-precious-flag t) - (setmodes (file-modes startup-file))) - ;; Backup the current version of the startup file. - (backup-buffer) - - ;; Replace the existing startup file with the temp file. - (rename-file working-file startup-file t) - (gnus-set-file-modes startup-file setmodes) - (setq gnus-save-newsrc-file-last-timestamp - (nth 5 (file-attributes startup-file))))) - (condition-case nil - (delete-file working-file) - (file-error nil))))) - - (gnus-kill-buffer (current-buffer)) - (gnus-message - 5 "Saving %s.eld...done" gnus-current-startup-file)) + (version-control gnus-backup-startup-file) + (startup-file (concat gnus-current-startup-file ".eld")) + (working-dir (file-name-directory gnus-current-startup-file)) + working-file + (i -1)) + ;; Generate the name of a non-existent file. + (while (progn (setq working-file + (format + (if (and (eq system-type 'ms-dos) + (not (gnus-long-file-names))) + "%s#%d.tm#" ; MSDOS limits files to 8+3 + "%s#tmp#%d") + working-dir (setq i (1+ i)))) + (file-exists-p working-file))) + + (unwind-protect + (progn + (gnus-with-output-to-file working-file + (gnus-gnus-to-quick-newsrc-format) + (gnus-run-hooks 'gnus-save-quick-newsrc-hook)) + + ;; These bindings will mislead the current buffer + ;; into thinking that it is visiting the startup + ;; file. + (let ((buffer-backed-up nil) + (buffer-file-name startup-file) + (file-precious-flag t) + (setmodes (file-modes startup-file))) + ;; Backup the current version of the startup file. + (backup-buffer) + + ;; Replace the existing startup file with the temp file. + (rename-file working-file startup-file t) + (gnus-set-file-modes startup-file setmodes) + (setq gnus-save-newsrc-file-last-timestamp + (file-attribute-modification-time + (file-attributes startup-file))))) + (condition-case nil + (delete-file working-file) + (file-error nil))))) + + (gnus-kill-buffer (current-buffer)) + (gnus-message + 5 "Saving %s.eld...done" gnus-current-startup-file))) (gnus-dribble-delete-file) (gnus-group-set-mode-line))))) (defun gnus-gnus-to-quick-newsrc-format (&optional minimal name &rest specific-variables) - "Print Gnus variables such as `gnus-newsrc-alist' in Lisp format." + "Print Gnus variables such as `gnus-newsrc-alist' in Lisp format. +Unless optional argument MINIMAL is non-nil, print human-readable +information in the header of the file, including the file +version. If NAME is present, print that as part of the header. + +Variables printed are either the variables specified in +SPECIFIC-VARIABLES, or those in `gnus-variable-list'." (princ (format ";; -*- mode:emacs-lisp; coding: %s; -*-\n" gnus-ding-file-coding-system)) (if name @@ -2934,9 +2870,18 @@ If FORCE is non-nil, the .newsrc file is read." ;; Remove the `gnus-killed-list' from the list of variables ;; to be saved, if required. (delq 'gnus-killed-list (copy-sequence gnus-variable-list))))) - ;; Peel off the "dummy" group. - (gnus-newsrc-alist (cdr gnus-newsrc-alist)) variable) + ;; A bit of a fake-out here: the original value of + ;; `gnus-newsrc-alist' isn't written to file, instead it is + ;; constructed at the last minute by combining the group + ;; ordering in `gnus-group-list' with the group infos from + ;; `gnus-newsrc-hashtb'. + (set (nth (seq-position gnus-variable-list 'gnus-newsrc-alist) + gnus-variable-list) + (mapcar (lambda (g) + (nth 1 (gethash g gnus-newsrc-hashtb))) + (delete "dummy.group" gnus-group-list))) + ;; Insert the variables into the file. (while variables (when (and (boundp (setq variable (pop variables))) @@ -2961,8 +2906,8 @@ If FORCE is non-nil, the .newsrc file is read." (interactive (list (gnus-y-or-n-p "write foreign groups too? "))) ;; Generate and save the .newsrc file. (with-current-buffer (create-file-buffer gnus-current-startup-file) - (let ((newsrc (cdr gnus-newsrc-alist)) - (standard-output (current-buffer)) + (let ((standard-output (current-buffer)) + (groups (delete "dummy.group" (copy-sequence gnus-group-list))) info ranges range method) (setq buffer-file-name gnus-current-startup-file) (setq default-directory (file-name-directory buffer-file-name)) @@ -2976,13 +2921,14 @@ If FORCE is non-nil, the .newsrc file is read." (when gnus-newsrc-options (insert gnus-newsrc-options)) ;; Write subscribed and unsubscribed. - (while (setq info (pop newsrc)) - ;; Don't write foreign groups to .newsrc. + (dolist (g-name groups) + (setq info (nth 1 (gnus-group-entry g-name))) + ;; Maybe don't write foreign groups to .newsrc. (when (or (null (setq method (gnus-info-method info))) (equal method "native") (inline (gnus-server-equal method gnus-select-method)) foreign-ok) - (insert (gnus-info-group info) + (insert g-name (if (> (gnus-info-level info) gnus-level-subscribed) "!" ":")) (when (setq ranges (gnus-info-read info)) @@ -3061,11 +3007,12 @@ If FORCE is non-nil, the .newsrc file is read." (with-current-buffer (gnus-get-buffer-create " *gnus slave*") (setq slave-files (sort (mapcar (lambda (file) - (list (nth 5 (file-attributes file)) file)) + (list (file-attribute-modification-time + (file-attributes file)) + file)) slave-files) (lambda (f1 f2) - (or (< (caar f1) (caar f2)) - (< (nth 1 (car f1)) (nth 1 (car f2))))))) + (time-less-p (car f1) (car f2))))) (while slave-files (erase-buffer) (setq file (nth 1 (car slave-files))) @@ -3109,10 +3056,10 @@ If FORCE is non-nil, the .newsrc file is read." ;; to avoid trying to re-read after a failed read. (unless gnus-description-hashtb (setq gnus-description-hashtb - (gnus-make-hashtable (length gnus-active-hashtb)))) + (gnus-make-hashtable (hash-table-size gnus-active-hashtb)))) ;; Mark this method's desc file as read. - (gnus-sethash (gnus-group-prefixed-name "" method) "Has read" - gnus-description-hashtb) + (puthash (gnus-group-prefixed-name "" method) "Has read" + gnus-description-hashtb) (gnus-message 5 "Reading descriptions file via %s..." (car method)) (cond @@ -3148,29 +3095,26 @@ If FORCE is non-nil, the .newsrc file is read." (zerop (forward-line 1))))))) (goto-char (point-min)) (while (not (eobp)) - ;; If we get an error, we set group to 0, which is not a - ;; symbol... (setq group (condition-case () - (let ((obarray gnus-description-hashtb)) - ;; Group is set to a symbol interned in this - ;; hash table. - (read nntp-server-buffer)) - (error 0))) + (read nntp-server-buffer) + (error nil))) (skip-chars-forward " \t") - ;; ... which leads to this line being effectively ignored. - (when (symbolp group) + (when group + (setq group (if (numberp group) + (number-to-string group) + (symbol-name group))) (let* ((str (buffer-substring (point) (progn (end-of-line) (point)))) - (name (symbol-name group)) (charset - (or (gnus-group-name-charset method name) - (gnus-parameter-charset name) + (or (gnus-group-name-charset method group) + (gnus-parameter-charset group) gnus-default-charset))) ;; Fixme: Don't decode in unibyte mode. + ;; Double fixme: We're not in unibyte mode, are we? (when (and str charset) (setq str (decode-coding-string str charset))) - (set group str))) + (puthash group str gnus-description-hashtb))) (forward-line 1)))) (gnus-message 5 "Reading descriptions file...done") t)))) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 99b970e323e..73f0eb39184 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -1,4 +1,4 @@ -;;; gnus-sum.el --- summary mode commands for Gnus +;;; gnus-sum.el --- summary mode commands for Gnus -*- lexical-binding:t -*- ;; Copyright (C) 1996-2019 Free Software Foundation, Inc. @@ -24,10 +24,39 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(require 'cl-lib) (defvar tool-bar-mode) +(defvar gnus-category-predicate-alist) +(defvar gnus-category-predicate-cache) +(defvar gnus-inhibit-article-treatments) +(defvar gnus-inhibit-demon) +(defvar gnus-tmp-article-number) +(defvar gnus-tmp-closing-bracket) +(defvar gnus-tmp-current) +(defvar gnus-tmp-dummy) +(defvar gnus-tmp-expirable) +(defvar gnus-tmp-from) +(defvar gnus-tmp-group-name) (defvar gnus-tmp-header) +(defvar gnus-tmp-indentation) +(defvar gnus-tmp-level) +(defvar gnus-tmp-lines) +(defvar gnus-tmp-name) +(defvar gnus-tmp-number) +(defvar gnus-tmp-opening-bracket) +(defvar gnus-tmp-process) +(defvar gnus-tmp-replied) +(defvar gnus-tmp-score) +(defvar gnus-tmp-score-char) +(defvar gnus-tmp-subject) +(defvar gnus-tmp-subject-or-nil) +(defvar gnus-tmp-thread) +(defvar gnus-tmp-unread) +(defvar gnus-tmp-unread-and-unselected) +(defvar gnus-tmp-unread-and-unticked) +(defvar gnus-tmp-user-defined) +(defvar gnus-use-article-prefetch) (require 'gnus) (require 'gnus-group) @@ -38,7 +67,11 @@ (require 'gnus-util) (require 'gmm-utils) (require 'mm-decode) +(require 'shr) +(require 'url) (require 'nnoo) +(eval-when-compile + (require 'subr-x)) (autoload 'gnus-summary-limit-include-cached "gnus-cache" nil t) (autoload 'gnus-cache-write-active "gnus-cache") @@ -214,7 +247,7 @@ fill in all gaps that Gnus manages to guess." (sexp :menu-tag "all" t))) (defcustom gnus-summary-thread-gathering-function - 'gnus-gather-threads-by-subject + #'gnus-gather-threads-by-subject "Function used for gathering loose threads. There are two pre-defined functions: `gnus-gather-threads-by-subject', which only takes Subjects into consideration; and @@ -510,7 +543,7 @@ this variable specifies group names." (cons :value ("" "") regexp (repeat string)) (sexp :value nil)))) -(defcustom gnus-move-group-prefix-function 'gnus-group-real-prefix +(defcustom gnus-move-group-prefix-function #'gnus-group-real-prefix "Function used to compute default prefix for article move/copy/etc prompts. The function should take one argument, a group name, and return a string with the suggested prefix." @@ -782,7 +815,7 @@ score file." :group 'gnus-score-default :type 'integer) -(defun gnus-widget-reversible-match (widget value) +(defun gnus-widget-reversible-match (_widget value) "Ignoring WIDGET, convert VALUE to internal form. VALUE should have the form `FOO' or `(not FOO)', where FOO is an symbol." ;; (debug value) @@ -792,7 +825,7 @@ VALUE should have the form `FOO' or `(not FOO)', where FOO is an symbol." (eq (nth 0 value) 'not) (symbolp (nth 1 value))))) -(defun gnus-widget-reversible-to-internal (widget value) +(defun gnus-widget-reversible-to-internal (_widget value) "Ignoring WIDGET, convert VALUE to internal form. VALUE should have the form `FOO' or `(not FOO)', where FOO is an atom. FOO is converted to (FOO nil) and (not FOO) is converted to (FOO t)." @@ -801,7 +834,7 @@ FOO is converted to (FOO nil) and (not FOO) is converted to (FOO t)." (list value nil) (list (nth 1 value) t))) -(defun gnus-widget-reversible-to-external (widget value) +(defun gnus-widget-reversible-to-external (_widget value) "Ignoring WIDGET, convert VALUE to external form. VALUE should have the form `(FOO nil)' or `(FOO t)', where FOO is an atom. \(FOO nil) is converted to FOO and (FOO t) is converted to (not FOO)." @@ -918,7 +951,7 @@ according to the value of `gnus-thread-sort-functions'." (function :tag "other")) (boolean :tag "Reverse order"))))) -(defcustom gnus-thread-score-function '+ +(defcustom gnus-thread-score-function #'+ "Function used for calculating the total score of a thread. The function is called with the scores of the article and each @@ -946,13 +979,6 @@ This variable is local to the summary buffers." :type '(choice (const :tag "off" nil) integer)) -(defcustom gnus-summary-mode-hook nil - "A hook for Gnus summary mode. -This hook is run before any variables are set in the summary buffer." - :options '(turn-on-gnus-mailing-list-mode gnus-pick-mode) - :group 'gnus-summary-various - :type 'hook) - (defcustom gnus-summary-menu-hook nil "Hook run after the creation of the summary mode menu." :group 'gnus-summary-visual @@ -992,10 +1018,9 @@ following hook: (add-hook gnus-select-group-hook (lambda () (mapcar (lambda (header) - (mail-header-set-subject - header - (gnus-simplify-subject - (mail-header-subject header) \\='re-only))) + (setf (mail-header-subject header) + (gnus-simplify-subject + (mail-header-subject header) \\='re-only))) gnus-newsgroup-headers)))" :group 'gnus-group-select :type 'hook) @@ -1149,11 +1174,11 @@ which it may alter in any way." function) :group 'gnus-summary) -(defvar gnus-decode-encoded-word-function 'mail-decode-encoded-word-string +(defvar gnus-decode-encoded-word-function #'mail-decode-encoded-word-string "Function used to decode a string with encoded words.") (defvar gnus-decode-encoded-address-function - 'mail-decode-encoded-address-string + #'mail-decode-encoded-address-string "Function used to decode addresses with encoded words.") (defcustom gnus-extra-headers '(To Cc Keywords Gcc Newsgroups X-GM-LABELS) @@ -1267,9 +1292,13 @@ For example: ((1 . cn-gb-2312) (2 . big5))." :type 'boolean :group 'gnus-summary-marks) -(defcustom gnus-alter-articles-to-read-function nil - "Function to be called to alter the list of articles to be selected." - :type '(choice (const nil) function) +(defcustom gnus-alter-articles-to-read-function + (lambda (_group article-list) article-list) + "Function to be called to alter the list of articles to be selected. +This option defaults to a lambda form that simply returns the +list of articles unchanged. Use `add-function' to set one or +more custom filter functions." + :type 'function :group 'gnus-summary) (defcustom gnus-orphan-score nil @@ -1347,7 +1376,7 @@ the normal Gnus MIME machinery." (defvar gnus-thread-indent-array nil) (defvar gnus-thread-indent-array-level gnus-thread-indent-level) -(defvar gnus-sort-gathered-threads-function 'gnus-thread-sort-by-number +(defvar gnus-sort-gathered-threads-function #'gnus-thread-sort-by-number "Function called to sort the articles within a thread after it has been gathered together.") (defvar gnus-summary-save-parts-type-history nil) @@ -1364,7 +1393,15 @@ the normal Gnus MIME machinery." (defvar gnus-current-crosspost-group nil) (defvar gnus-newsgroup-display nil) -(defvar gnus-newsgroup-dependencies nil) +(defvar gnus-newsgroup-dependencies nil + "A hash table holding dependencies between messages.") +;; Dependencies are held in a tree structure: a list with the root +;; message as car, and each immediate child a sublist (perhaps +;; containing further sublists). Each message is represented as a +;; vector of headers. Each message's list can be looked up in the +;; dependency table using the message's Message-ID as the key. The +;; root key is the string "none". + (defvar gnus-newsgroup-adaptive nil) (defvar gnus-summary-display-article-function nil) (defvar gnus-summary-highlight-line-function nil @@ -1378,7 +1415,8 @@ the normal Gnus MIME machinery." (?A (car (cdr (funcall gnus-extract-address-components gnus-tmp-from))) ?s) (?a (or (car (funcall gnus-extract-address-components gnus-tmp-from)) - gnus-tmp-from) ?s) + gnus-tmp-from) + ?s) (?F gnus-tmp-from ?s) (?x ,(macroexpand '(mail-header-xref gnus-tmp-header)) ?s) (?D ,(macroexpand '(mail-header-date gnus-tmp-header)) ?s) @@ -1390,12 +1428,15 @@ the normal Gnus MIME machinery." (?k (gnus-summary-line-message-size gnus-tmp-header) ?s) (?L gnus-tmp-lines ?s) (?Z (or (nnir-article-rsv (mail-header-number gnus-tmp-header)) - 0) ?d) + 0) + ?d) (?G (or (nnir-article-group (mail-header-number gnus-tmp-header)) - "") ?s) + "") + ?s) (?g (or (gnus-group-short-name (nnir-article-group (mail-header-number gnus-tmp-header))) - "") ?s) + "") + ?s) (?O gnus-tmp-downloaded ?c) (?I gnus-tmp-indentation ?s) (?T (if (= gnus-tmp-level 0) "" (make-string (frame-width) ? )) ?s) @@ -1406,32 +1447,35 @@ the normal Gnus MIME machinery." (?\< (make-string (max 0 (- 20 gnus-tmp-level)) ? ) ?s) (?i gnus-tmp-score ?d) (?z gnus-tmp-score-char ?c) - (?V (gnus-thread-total-score (and (boundp 'thread) (car thread))) ?d) + (?V (gnus-thread-total-score + (and (boundp 'gnus-tmp-thread) (car gnus-tmp-thread))) + ?d) (?U gnus-tmp-unread ?c) (?f (gnus-summary-from-or-to-or-newsgroups gnus-tmp-header gnus-tmp-from) ?s) (?t (gnus-summary-number-of-articles-in-thread - (and (boundp 'thread) (car thread)) gnus-tmp-level) + (and (boundp 'gnus-tmp-thread) (car gnus-tmp-thread)) gnus-tmp-level) ?d) (?e (gnus-summary-number-of-articles-in-thread - (and (boundp 'thread) (car thread)) gnus-tmp-level t) + (and (boundp 'gnus-tmp-thread) (car gnus-tmp-thread)) gnus-tmp-level t) ?c) (?u gnus-tmp-user-defined ?s) (?P (gnus-pick-line-number) ?d) (?B gnus-tmp-thread-tree-header-string ?s) (user-date (gnus-user-date - ,(macroexpand '(mail-header-date gnus-tmp-header))) ?s)) + ,(macroexpand '(mail-header-date gnus-tmp-header))) + ?s)) "An alist of format specifications that can appear in summary lines. These are paired with what variables they correspond with, along with the type of the variable (string, integer, character, etc).") (defvar gnus-summary-dummy-line-format-alist - `((?S gnus-tmp-subject ?s) + '((?S gnus-tmp-subject ?s) (?N gnus-tmp-number ?d) (?u gnus-tmp-user-defined ?s))) (defvar gnus-summary-mode-line-format-alist - `((?G gnus-tmp-group-name ?s) + '((?G gnus-tmp-group-name ?s) (?g (gnus-short-group-name gnus-tmp-group-name) ?s) (?p (gnus-group-real-name gnus-tmp-group-name) ?s) (?A gnus-tmp-article-number ?d) @@ -1665,7 +1709,9 @@ For example: (eval-when-compile ;; Bind features so that require will believe that gnus-sum has ;; already been loaded (avoids infinite recursion) + (with-no-warnings (defvar features)) ;Not just a local variable. (let ((features (cons 'gnus-sum features))) + ;; FIXME: Break this mutual dependency. (require 'gnus-art))) ;; MIME stuff. @@ -1772,7 +1818,7 @@ matter is removed. Additional things can be deleted by setting (setq modified-tick (buffer-modified-tick)) (cond ((listp regexp) - (mapc 'gnus-simplify-buffer-fuzzy-step regexp)) + (mapc #'gnus-simplify-buffer-fuzzy-step regexp)) (regexp (gnus-simplify-buffer-fuzzy-step regexp))) (gnus-simplify-buffer-fuzzy-step "^ *\\[[-+?*!][-+?*!]\\] *") @@ -1838,8 +1884,6 @@ increase the score of each group you read." ;;; Gnus summary mode ;;; -(put 'gnus-summary-mode 'mode-class 'special) - (defvar gnus-article-commands-menu) ;; Non-orthogonal keys @@ -1941,6 +1985,7 @@ increase the score of each group you read." "s" gnus-summary-isearch-article "\t" gnus-summary-widget-forward [backtab] gnus-summary-widget-backward + "w" gnus-summary-browse-url "t" gnus-summary-toggle-header "g" gnus-summary-show-article "l" gnus-summary-goto-last-article @@ -2107,6 +2152,7 @@ increase the score of each group you read." "s" gnus-summary-isearch-article "\t" gnus-summary-widget-forward [backtab] gnus-summary-widget-backward + "w" gnus-summary-browse-url "P" gnus-summary-print-article "S" gnus-sticky-article "M" gnus-mailing-list-insinuate @@ -2367,7 +2413,7 @@ increase the score of each group you read." ["Edit current score file" gnus-score-edit-current-scores t] ["Edit score file..." gnus-score-edit-file t] ["Trace score" gnus-score-find-trace t] - ["Find words" gnus-score-find-favourite-words t] + ["Find words" gnus-score-find-favorite-words t] ["Rescore buffer" gnus-summary-rescore t] ["Increase score..." gnus-summary-increase-score t] ["Lower score..." gnus-summary-lower-score t])))) @@ -2444,13 +2490,13 @@ increase the score of each group you read." (let ((command (intern (format "\ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) (fset command - `(lambda () - (interactive) - (let ((gnus-summary-show-article-charset-alist - '((1 . ,cs)))) - (gnus-summary-show-article 1)))) + (lambda () + (interactive) + (let ((gnus-summary-show-article-charset-alist + `((1 . ,cs)))) + (gnus-summary-show-article 1)))) `[,(symbol-name cs) ,command t])) - (sort (coding-system-list) 'string<))))) + (sort (coding-system-list) #'string<))))) ("Washing" ("Remove Blanks" ["Leading" gnus-article-strip-leading-blank-lines t] @@ -2600,7 +2646,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) (easy-menu-define gnus-summary-post-menu gnus-summary-mode-map "" - `("Post" + '("Post" ["Send a message (mail or news)" gnus-summary-post-news :help "Compose a new message (mail or news)"] ["Followup" gnus-summary-followup @@ -2626,6 +2672,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Resend message edit" gnus-summary-resend-message-edit t] ["Send bounced mail" gnus-summary-resend-bounced-mail t] ["Send a mail" gnus-summary-mail-other-window t] + ["Attach article to outgoing message" gnus-summary-attach-article t] ["Create a local message" gnus-summary-news-other-window t] ["Uuencode and post" gnus-uu-post-news :help "Post a uuencoded article"] @@ -2637,15 +2684,15 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) (interactive) (setq message-cite-function (if (eq message-cite-function - 'message-cite-original-without-signature) - 'message-cite-original - 'message-cite-original-without-signature))) + #'message-cite-original-without-signature) + #'message-cite-original + #'message-cite-original-without-signature))) :visible (memq message-cite-function '(message-cite-original-without-signature message-cite-original)) :style toggle :selected (eq message-cite-function - 'message-cite-original-without-signature) + #'message-cite-original-without-signature) :help "Strip signature from cited article when replying."])) (cond @@ -2660,7 +2707,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) (easy-menu-define gnus-summary-misc-menu gnus-summary-mode-map "" - `("Gnus" + '("Gnus" ("Mark Read" ["Mark as read" gnus-summary-mark-as-read-forward t] ["Mark same subject and select" @@ -2941,6 +2988,8 @@ See `gmm-tool-bar-from-list' for the format of the list." (defvar image-load-path) (defvar tool-bar-map) +(declare-function image-load-path-for-library "image" + (library image &optional path no-error)) (defun gnus-summary-make-tool-bar (&optional force) "Make a summary mode tool bar from `gnus-summary-tool-bar'. @@ -2985,7 +3034,7 @@ When FORCE, rebuild the tool bar." header) (list (apply - 'nconc + #'nconc (list (if (eq type 'lower) "Lower score" @@ -2996,7 +3045,7 @@ When FORCE, rebuild the tool bar." (setq outh (cons (apply - 'nconc + #'nconc (list (car header)) (let ((ts (cdr (assoc (nth 2 header) types))) outt) @@ -3004,7 +3053,7 @@ When FORCE, rebuild the tool bar." (setq outt (cons (apply - 'nconc + #'nconc (list (caar ts)) (let ((ps perms) outp) @@ -3045,10 +3094,13 @@ When FORCE, rebuild the tool bar." (defvar bidi-paragraph-direction) -(defun gnus-summary-mode (&optional group) - "Major mode for reading articles. +(defvar gnus-summary-mode-group nil + "Variable for communication with `gnus-summary-mode'. +Allows the `gnus-newsgroup-name' local variable to be set before +the summary mode hooks are run.") -All normal editing commands are switched off. +(define-derived-mode gnus-summary-mode gnus-mode "Summary" + "Major mode for reading articles. \\<gnus-summary-mode-map> Each line in this buffer represents one article. To read an article, you can, for instance, type `\\[gnus-summary-next-page]'. To move forwards @@ -3065,24 +3117,17 @@ buffer; read the info pages for more information (`\\[gnus-info-find-node]'). The following commands are available: \\{gnus-summary-mode-map}" - ;; FIXME: Use define-derived-mode. - (interactive) - (kill-all-local-variables) (let ((gnus-summary-local-variables gnus-newsgroup-variables)) (gnus-summary-make-local-variables)) (gnus-summary-make-local-variables) - (setq gnus-newsgroup-name group) + (setq gnus-newsgroup-name gnus-summary-mode-group) (when (gnus-visual-p 'summary-menu 'menu) (gnus-summary-make-menu-bar) (gnus-summary-make-tool-bar)) (gnus-make-thread-indent-array) (gnus-simplify-mode-line) - (setq major-mode 'gnus-summary-mode) - (setq mode-name "Summary") - (use-local-map gnus-summary-mode-map) (buffer-disable-undo) - (setq buffer-read-only t - show-trailing-whitespace nil + (setq show-trailing-whitespace nil truncate-lines t bidi-paragraph-direction 'left-to-right) (add-to-invisibility-spec '(gnus-sum . t)) @@ -3093,79 +3138,56 @@ The following commands are available: (make-local-variable 'gnus-summary-dummy-line-format) (make-local-variable 'gnus-summary-dummy-line-format-spec) (make-local-variable 'gnus-summary-mark-positions) - (add-hook 'pre-command-hook 'gnus-set-global-variables nil t) - (gnus-run-mode-hooks 'gnus-summary-mode-hook) - (turn-on-gnus-mailing-list-mode) + (make-local-variable 'gnus-article-buffer) + (make-local-variable 'gnus-article-current) + (make-local-variable 'gnus-original-article-buffer) + (add-hook 'pre-command-hook #'gnus-set-global-variables nil t) (mm-enable-multibyte) (set (make-local-variable 'bookmark-make-record-function) - 'gnus-summary-bookmark-make-record) - (gnus-update-format-specifications nil 'summary 'summary-mode 'summary-dummy) - (gnus-update-summary-mark-positions)) + #'gnus-summary-bookmark-make-record)) (defun gnus-summary-make-local-variables () "Make all the local summary buffer variables." - (let (global) - (dolist (local gnus-summary-local-variables) - (if (consp local) - (progn - (if (eq (cdr local) 'global) - ;; Copy the global value of the variable. - (setq global (symbol-value (car local))) - ;; Use the value from the list. - (setq global (eval (cdr local)))) - (set (make-local-variable (car local)) global)) - ;; Simple nil-valued local variable. - (set (make-local-variable local) nil))))) + (dolist (local gnus-summary-local-variables) + (if (consp local) + (let ((global (if (eq (cdr local) 'global) + ;; Copy the global value of the variable. + (symbol-value (car local)) + ;; Use the value from the list. + (eval (cdr local))))) + (set (make-local-variable (car local)) global)) + ;; Simple nil-valued local variable. + (set (make-local-variable local) nil)))) ;; Summary data functions. -(defmacro gnus-data-number (data) - `(car ,data)) - -(defmacro gnus-data-set-number (data number) - `(setcar ,data ,number)) - -(defmacro gnus-data-mark (data) - `(nth 1 ,data)) - -(defmacro gnus-data-set-mark (data mark) - `(setcar (nthcdr 1 ,data) ,mark)) - -(defmacro gnus-data-pos (data) - `(nth 2 ,data)) +(cl-defstruct (gnus-data + (:constructor nil) + (:constructor gnus-data-make (number mark pos header level)) + ;; In gnus-data-find-in, we rely on (car data) returning the + ;; number, because we use `assq' on a list of gnus-data. + (:type list)) + number mark pos header level) -(defmacro gnus-data-set-pos (data pos) - `(setcar (nthcdr 2 ,data) ,pos)) +(define-inline gnus-data-unread-p (data) + (inline-quote (= (gnus-data-mark ,data) gnus-unread-mark))) -(defmacro gnus-data-header (data) - `(nth 3 ,data)) +(define-inline gnus-data-read-p (data) + (inline-quote (/= (gnus-data-mark ,data) gnus-unread-mark))) -(defmacro gnus-data-set-header (data header) - `(setf (nth 3 ,data) ,header)) +(define-inline gnus-data-pseudo-p (data) + (inline-quote (consp (gnus-data-header ,data)))) -(defmacro gnus-data-level (data) - `(nth 4 ,data)) +(defalias 'gnus-data-find-in #'assq) -(defmacro gnus-data-unread-p (data) - `(= (nth 1 ,data) gnus-unread-mark)) - -(defmacro gnus-data-read-p (data) - `(/= (nth 1 ,data) gnus-unread-mark)) - -(defmacro gnus-data-pseudo-p (data) - `(consp (nth 3 ,data))) - -(defmacro gnus-data-find (number) - `(assq ,number gnus-newsgroup-data)) +(define-inline gnus-data-find (number) + (inline-quote (gnus-data-find-in ,number gnus-newsgroup-data))) (defmacro gnus-data-find-list (number &optional data) `(let ((bdata ,(or data 'gnus-newsgroup-data))) - (memq (assq ,number bdata) + (memq (gnus-data-find-in ,number bdata) bdata))) -(defmacro gnus-data-make (number mark pos header level) - `(list ,number ,mark ,pos ,header ,level)) - (defun gnus-data-enter (after-article number mark pos header level offset) (let ((data (gnus-data-find-list after-article))) (unless data @@ -3228,12 +3250,12 @@ The following commands are available: "Add OFFSET to the POS of all data entries in DATA." (setq gnus-newsgroup-data-reverse nil) (while data - (setcar (nthcdr 2 (car data)) (+ offset (nth 2 (car data)))) + (cl-incf (gnus-data-pos (car data)) offset) (setq data (cdr data)))) (defun gnus-summary-article-pseudo-p (article) "Say whether this article is a pseudo article or not." - (not (vectorp (gnus-data-header (gnus-data-find article))))) + (not (mail-header-p (gnus-data-header (gnus-data-find article))))) (defmacro gnus-summary-article-sparse-p (article) "Say whether this article is a sparse article or not." @@ -3255,9 +3277,10 @@ The following commands are available: (setq data (cdr data))) children)) -(defmacro gnus-summary-skip-intangible () +(defsubst gnus-summary-skip-intangible () + ;; FIXME: Does this really warrant a `defsubst'? "If the current article is intangible, then jump to a different article." - '(let ((to (get-text-property (point) 'gnus-intangible))) + (let ((to (get-text-property (point) 'gnus-intangible))) (and to (gnus-summary-goto-subject to)))) (defmacro gnus-summary-article-intangible-p () @@ -3266,19 +3289,20 @@ The following commands are available: ;; Some summary mode macros. -(defmacro gnus-summary-article-number () +(defsubst gnus-summary-article-number () "The article number of the article on the current line. If there isn't an article number here, then we return the current article number." - '(progn - (gnus-summary-skip-intangible) - (or (get-text-property (point) 'gnus-number) - (gnus-summary-last-subject)))) + (gnus-summary-skip-intangible) + (or (get-text-property (point) 'gnus-number) + (gnus-summary-last-subject))) -(defmacro gnus-summary-article-header (&optional number) +(define-inline gnus-summary-article-header (&optional number) "Return the header of article NUMBER." - `(gnus-data-header (gnus-data-find - ,(or number '(gnus-summary-article-number))))) + (inline-quote + (gnus-data-header (gnus-data-find + ,(or number + (inline-quote (gnus-summary-article-number))))))) (defmacro gnus-summary-thread-level (&optional number) "Return the level of thread that starts with article NUMBER." @@ -3298,17 +3322,17 @@ article number." `(gnus-data-pos (gnus-data-find ,(or number '(gnus-summary-article-number))))) -(defalias 'gnus-summary-subject-string 'gnus-summary-article-subject) -(defmacro gnus-summary-article-subject (&optional number) +(defalias 'gnus-summary-subject-string #'gnus-summary-article-subject) +(defsubst gnus-summary-article-subject (&optional number) + ;; FIXME: Does this really warrant a defsubst? "Return current subject string or nil if nothing." - `(let ((headers - ,(if number - `(gnus-data-header (assq ,number gnus-newsgroup-data)) - '(gnus-data-header (assq (gnus-summary-article-number) - gnus-newsgroup-data))))) - (and headers - (vectorp headers) - (mail-header-subject headers)))) + (let ((headers + (gnus-data-header + (gnus-data-find (or number + (gnus-summary-article-number)))))) + (and headers + (mail-header-p headers) + (mail-header-subject headers)))) (defmacro gnus-summary-article-score (&optional number) "Return current article score." @@ -3375,14 +3399,13 @@ marks of articles." (defmacro gnus-save-hidden-threads (&rest forms) "Save hidden threads, eval FORMS, and restore the hidden threads." + (declare (indent 0) (debug t)) (let ((config (make-symbol "config"))) `(let ((,config (gnus-hidden-threads-configuration))) (unwind-protect (save-excursion ,@forms) (gnus-restore-hidden-threads-configuration ,config))))) -(put 'gnus-save-hidden-threads 'lisp-indent-function 0) -(put 'gnus-save-hidden-threads 'edebug-form-spec '(body)) (defun gnus-data-compute-positions () "Compute the positions of all articles." @@ -3395,7 +3418,7 @@ marks of articles." (while data (while (get-text-property (point) 'gnus-intangible) (forward-line 1)) - (gnus-data-set-pos (car data) (+ (point) 3)) + (setf (gnus-data-pos (car data)) (+ (point) 3)) (setq data (cdr data)) (forward-line 1)))))) @@ -3471,14 +3494,16 @@ display only a single character." (current-buffer)))))) (defun gnus-summary-setup-buffer (group) - "Initialize summary buffer. -If the setup was successful, non-nil is returned." + "Initialize summary buffer for GROUP. +This function does all setup work that relies on the specific +value of GROUP, and puts the buffer in `gnus-summary-mode'. + +Returns non-nil if the setup was successful." (let ((buffer (gnus-summary-buffer-name group)) (dead-name (concat "*Dead Summary " (gnus-group-decoded-name group) "*"))) ;; If a dead summary buffer exists, we kill it. - (when (gnus-buffer-live-p dead-name) - (gnus-kill-buffer dead-name)) + (gnus-kill-buffer dead-name) (if (get-buffer buffer) (progn (set-buffer buffer) @@ -3486,13 +3511,15 @@ If the setup was successful, non-nil is returned." (not gnus-newsgroup-prepared)) (set-buffer (gnus-get-buffer-create buffer)) (setq gnus-summary-buffer (current-buffer)) - (gnus-summary-mode group) + (let ((gnus-summary-mode-group group)) + (gnus-summary-mode)) (when (gnus-group-quit-config group) (set (make-local-variable 'gnus-single-article-buffer) nil)) - (make-local-variable 'gnus-article-buffer) - (make-local-variable 'gnus-article-current) - (make-local-variable 'gnus-original-article-buffer) - (setq gnus-newsgroup-name group) + (turn-on-gnus-mailing-list-mode) + ;; These functions don't currently depend on GROUP, but might in + ;; the future. + (gnus-update-format-specifications nil 'summary 'summary-mode 'summary-dummy) + (gnus-update-summary-mark-positions) ;; Set any local variables in the group parameters. (gnus-summary-set-local-parameters gnus-newsgroup-name) t))) @@ -3517,13 +3544,12 @@ buffer that was in action when the last article was fetched." (score-file gnus-current-score-file) (default-charset gnus-newsgroup-charset) vlist) - (let ((locals gnus-newsgroup-variables)) - (while locals - (if (consp (car locals)) - (push (eval (caar locals)) vlist) - (push (eval (car locals)) vlist)) - (setq locals (cdr locals))) - (setq vlist (nreverse vlist))) + (dolist (local gnus-newsgroup-variables) + (push (eval (if (consp local) (car local) + local) + t) + vlist)) + (setq vlist (nreverse vlist)) (with-temp-buffer (setq gnus-newsgroup-name name gnus-newsgroup-marked marked @@ -3538,12 +3564,11 @@ buffer that was in action when the last article was fetched." gnus-reffed-article-number reffed gnus-current-score-file score-file gnus-newsgroup-charset default-charset) - (let ((locals gnus-newsgroup-variables)) - (while locals - (if (consp (car locals)) - (set (caar locals) (pop vlist)) - (set (car locals) (pop vlist))) - (setq locals (cdr locals)))))))) + (dolist (local gnus-newsgroup-variables) + (set (if (consp local) + (car local) + local) + (pop vlist))))))) (defun gnus-summary-article-unread-p (article) "Say whether ARTICLE is unread or not." @@ -3553,7 +3578,7 @@ buffer that was in action when the last article was fetched." "Return whether ARTICLE is the first article in the buffer." (if (not (setq article (or article (gnus-summary-article-number)))) nil - (eq article (caar gnus-newsgroup-data)))) + (eq article (gnus-data-number (car gnus-newsgroup-data))))) (defun gnus-summary-last-article-p (&optional article) "Return whether ARTICLE is the last article in the buffer." @@ -3562,6 +3587,12 @@ buffer that was in action when the last article was fetched." t (not (cdr (gnus-data-find-list article))))) +(defconst gnus--dummy-mail-header + (make-full-mail-header 0 "" "" "05 Apr 2001 23:33:09 +0400" "" "" 0 0 "" nil)) + +(defconst gnus--dummy-data-list + (list (gnus-data-make 0 nil nil gnus--dummy-mail-header nil))) + (defun gnus-make-thread-indent-array (&optional n) (when (or n (progn (setq n 200) nil) @@ -3577,7 +3608,7 @@ buffer that was in action when the last article was fetched." (defun gnus-update-summary-mark-positions () "Compute where the summary marks are to go." (save-excursion - (when (gnus-buffer-exists-p gnus-summary-buffer) + (when (gnus-buffer-live-p gnus-summary-buffer) (set-buffer gnus-summary-buffer)) (let ((spec gnus-summary-line-format-spec) pos) @@ -3589,11 +3620,13 @@ buffer that was in action when the last article was fetched." (gnus-score-over-mark ?Z) (gnus-undownloaded-mark ?Z) (gnus-summary-line-format-spec spec) + ;; Make sure `gnus-data-find' finds a dummy element + ;; so we don't call gnus-data-<field> accessors on nil. + (gnus-newsgroup-data gnus--dummy-data-list) (gnus-newsgroup-downloadable '(0)) - (header [0 "" "" "05 Apr 2001 23:33:09 +0400" "" "" 0 0 "" nil]) case-fold-search ignores) ;; Here, all marks are bound to Z. - (gnus-summary-insert-line header + (gnus-summary-insert-line gnus--dummy-mail-header 0 nil t gnus-tmp-unread t nil "" nil 1) (goto-char (point-min)) ;; Memorize the positions of the same characters as dummy marks. @@ -3607,7 +3640,7 @@ buffer that was in action when the last article was fetched." gnus-score-below-mark ?C gnus-score-over-mark ?C gnus-undownloaded-mark ?D) - (gnus-summary-insert-line header + (gnus-summary-insert-line gnus--dummy-mail-header 0 nil t gnus-tmp-unread t nil "" nil 1) ;; Ignore characters which aren't dummy marks. (dolist (p ignores) @@ -3631,19 +3664,23 @@ buffer that was in action when the last article was fetched." pos))) (setq gnus-summary-mark-positions pos)))) -(defun gnus-summary-insert-dummy-line (gnus-tmp-subject gnus-tmp-number) +(defun gnus-summary-insert-dummy-line (subject number) "Insert a dummy root in the summary buffer." (beginning-of-line) (add-text-properties - (point) (progn (eval gnus-summary-dummy-line-format-spec) (point)) - (list 'gnus-number gnus-tmp-number 'gnus-intangible gnus-tmp-number))) + (point) (let ((gnus-tmp-subject subject) + (gnus-tmp-number number)) + (eval gnus-summary-dummy-line-format-spec t) + (point)) + (list 'gnus-number number 'gnus-intangible number))) (defun gnus-summary-extract-address-component (from) (or (car (funcall gnus-extract-address-components from)) from)) -(defun gnus-summary-from-or-to-or-newsgroups (header gnus-tmp-from) - (let ((mail-parse-charset gnus-newsgroup-charset) +(defun gnus-summary-from-or-to-or-newsgroups (header from) + (let ((gnus-tmp-from from) + (mail-parse-charset gnus-newsgroup-charset) ;; Is it really necessary to do this next part for each summary line? ;; Luckily, doesn't seem to slow things down much. (mail-parse-ignored-charsets @@ -3670,25 +3707,31 @@ buffer that was in action when the last article was fetched." (and (memq 'Newsgroups gnus-extra-headers) (eq (car (gnus-find-method-for-group - gnus-newsgroup-name)) 'nntp) + gnus-newsgroup-name)) + 'nntp) (gnus-group-real-name gnus-newsgroup-name)))) (concat gnus-summary-newsgroup-prefix newsgroups))))) (bidi-string-mark-left-to-right (inline (gnus-summary-extract-address-component gnus-tmp-from)))))) -(defun gnus-summary-insert-line (gnus-tmp-header - gnus-tmp-level gnus-tmp-current - undownloaded gnus-tmp-unread gnus-tmp-replied - gnus-tmp-expirable gnus-tmp-subject-or-nil - &optional gnus-tmp-dummy gnus-tmp-score - gnus-tmp-process) - (if (>= gnus-tmp-level (length gnus-thread-indent-array)) +(defun gnus-summary-insert-line (header level current undownloaded + unread replied expirable subject-or-nil + &optional dummy score process) + (if (>= level (length gnus-thread-indent-array)) (gnus-make-thread-indent-array (max (* 2 (length gnus-thread-indent-array)) - gnus-tmp-level))) - (let* ((gnus-tmp-indentation (aref gnus-thread-indent-array gnus-tmp-level)) + level))) + (let* ((gnus-tmp-header header) + (gnus-tmp-level level) + (gnus-tmp-current current) + (gnus-tmp-unread unread) + (gnus-tmp-expirable expirable) + (gnus-tmp-subject-or-nil subject-or-nil) + (gnus-tmp-dummy dummy) + (gnus-tmp-process process) + (gnus-tmp-indentation (aref gnus-thread-indent-array gnus-tmp-level)) (gnus-tmp-lines (mail-header-lines gnus-tmp-header)) - (gnus-tmp-score (or gnus-tmp-score gnus-summary-default-score 0)) + (gnus-tmp-score (or score gnus-summary-default-score 0)) (gnus-tmp-score-char (if (or (null gnus-summary-default-score) (<= (abs (- gnus-tmp-score gnus-summary-default-score)) @@ -3701,7 +3744,7 @@ buffer that was in action when the last article was fetched." (cond (gnus-tmp-process gnus-process-mark) ((memq gnus-tmp-current gnus-newsgroup-cached) gnus-cached-mark) - (gnus-tmp-replied gnus-replied-mark) + (replied gnus-replied-mark) ((memq gnus-tmp-current gnus-newsgroup-forwarded) gnus-forwarded-mark) ((memq gnus-tmp-current gnus-newsgroup-saved) @@ -3736,9 +3779,9 @@ buffer that was in action when the last article was fetched." (setq gnus-tmp-name gnus-tmp-from)) (unless (numberp gnus-tmp-lines) (setq gnus-tmp-lines -1)) - (if (= gnus-tmp-lines -1) - (setq gnus-tmp-lines "?") - (setq gnus-tmp-lines (number-to-string gnus-tmp-lines))) + (setq gnus-tmp-lines (if (= gnus-tmp-lines -1) + "?" + (number-to-string gnus-tmp-lines))) (condition-case () (put-text-property (point) @@ -3796,18 +3839,18 @@ the thread are to be displayed." 1) ((and (consp thread) (cdr thread)) (apply - '+ 1 (mapcar - 'gnus-summary-number-of-articles-in-thread (cdr thread)))) + #'+ 1 (mapcar + #'gnus-summary-number-of-articles-in-thread (cdr thread)))) ((null thread) 1) ((memq (mail-header-number (car thread)) gnus-newsgroup-limit) 1) (t 0)))) (when (and level (zerop level) gnus-tmp-new-adopts) - (incf number - (apply '+ (mapcar - 'gnus-summary-number-of-articles-in-thread - gnus-tmp-new-adopts)))) + (cl-incf number + (apply #'+ (mapcar + #'gnus-summary-number-of-articles-in-thread + gnus-tmp-new-adopts)))) (if char (if (> number 1) gnus-not-empty-thread-mark gnus-empty-thread-mark) @@ -3857,20 +3900,20 @@ respectively." 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 (float-time (gnus-date-get-time messy-date))) - (now (float-time)) + (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 (- now messy-date)) + (let* ((difference (time-subtract now messy-date)) (templist gnus-user-date-format-alist) (top (eval (caar templist)))) - (while (if (numberp top) (< top difference) (not top)) + (while (if (numberp top) (time-less-p top difference) (not top)) (progn (setq templist (cdr templist)) (setq top (eval (caar templist))))) (if (stringp (cdr (car templist))) (setq my-format (cdr (car templist))))) - (format-time-string (eval my-format) (seconds-to-time messy-date))) + (format-time-string (eval my-format) messy-date)) (error " ? "))) (defun gnus-summary-set-local-parameters (group) @@ -3928,9 +3971,18 @@ If SELECT-ARTICLES, only select those articles from GROUP." (defun gnus-summary-read-group-1 (group show-all no-article kill-buffer no-display &optional select-articles) + "Display articles and threads in a Summary buffer for GROUP." + ;; This function calls `gnus-summary-setup-buffer' to create the + ;; buffer, put it in `gnus-summary-mode', and set local variables; + ;; `gnus-select-newsgroup' to update the group's active and marks + ;; from the server; and `gnus-summary-prepare' to actually insert + ;; lines for articles. The rest of the function is mostly concerned + ;; with limiting and positioning and windowing and other visual + ;; effects. + ;; Killed foreign groups can't be entered. ;; (when (and (not (gnus-group-native-p group)) - ;; (not (gnus-gethash group gnus-newsrc-hashtb))) + ;; (not (gethash group gnus-newsrc-hashtb))) ;; (error "Dead non-native groups can't be entered")) (gnus-message 7 "Retrieving newsgroup: %s..." (gnus-group-decoded-name group)) @@ -3993,7 +4045,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (spam-initialize)) ;; Save the active value in effect when the group was entered. (setq gnus-newsgroup-active - (gnus-copy-sequence + (copy-tree (gnus-active gnus-newsgroup-name))) (setq gnus-newsgroup-highest (cdr gnus-newsgroup-active)) ;; You can change the summary buffer in some way with this hook. @@ -4018,9 +4070,10 @@ If SELECT-ARTICLES, only select those articles from GROUP." (unless no-display (gnus-summary-prepare)) (when gnus-use-trees - (gnus-tree-open) + (gnus-tree-open) ;Autoloaded from gnus-salt. + (declare-function gnus-tree-highlight-article "gnus-salt" (article face)) (setq gnus-summary-highlight-line-function - 'gnus-tree-highlight-article)) + #'gnus-tree-highlight-article)) ;; If the summary buffer is empty, but there are some low-scored ;; articles or some excluded dormants, we include these in the ;; buffer. @@ -4160,7 +4213,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." "Gather threads by looking at Subject headers." (if (not gnus-summary-make-false-root) threads - (let ((hashtb (gnus-make-hashtable 1024)) + (let ((hashtb (gnus-make-hashtable 1000)) (prev threads) (result threads) subject hthread whole-subject) @@ -4169,7 +4222,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (setq whole-subject (mail-header-subject (caar threads))))) (when subject - (if (setq hthread (gnus-gethash subject hashtb)) + (if (setq hthread (gethash subject hashtb)) (progn ;; We enter a dummy root into the thread, if we ;; haven't done that already. @@ -4183,24 +4236,24 @@ If SELECT-ARTICLES, only select those articles from GROUP." (setcdr prev (cdr threads)) (setq threads prev)) ;; Enter this thread into the hash table. - (gnus-sethash subject - (if gnus-summary-make-false-root-always - (progn - ;; If you want a dummy root above all - ;; threads... - (setcar threads (list whole-subject - (car threads))) - threads) - threads) - hashtb))) + (puthash subject + (if gnus-summary-make-false-root-always + (progn + ;; If you want a dummy root above all + ;; threads... + (setcar threads (list whole-subject + (car threads))) + threads) + threads) + hashtb))) (setq prev threads) (setq threads (cdr threads))) result))) (defun gnus-gather-threads-by-references (threads) "Gather threads by looking at References headers." - (let ((idhashtb (gnus-make-hashtable 1024)) - (thhashtb (gnus-make-hashtable 1024)) + (let ((idhashtb (gnus-make-hashtable 1000)) + (thhashtb (gnus-make-hashtable 1000)) (prev threads) (result threads) ids references id gthread gid entered ref) @@ -4211,11 +4264,11 @@ If SELECT-ARTICLES, only select those articles from GROUP." entered nil) (while (setq ref (pop ids)) (setq ids (delete ref ids)) - (if (not (setq gid (gnus-gethash ref idhashtb))) + (if (not (setq gid (gethash ref idhashtb))) (progn - (gnus-sethash ref id idhashtb) - (gnus-sethash id threads thhashtb)) - (setq gthread (gnus-gethash gid thhashtb)) + (puthash ref id idhashtb) + (puthash id threads thhashtb)) + (setq gthread (gethash gid thhashtb)) (unless entered ;; We enter a dummy root into the thread, if we ;; haven't done that already. @@ -4227,7 +4280,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (setcdr (car gthread) (nconc (cdar gthread) (list (car threads))))) ;; Add it into the thread hash table. - (gnus-sethash id gthread thhashtb) + (puthash id gthread thhashtb) (setq entered t) ;; Remove it from the list of threads. (setcdr prev (cdr threads)) @@ -4260,12 +4313,12 @@ If SELECT-ARTICLES, only select those articles from GROUP." ;; We have found a loop. (let (ref-dep) (setcdr thread (delq (car th) (cdr thread))) - (if (boundp (setq ref-dep (intern "none" - gnus-newsgroup-dependencies))) - (setcdr (symbol-value ref-dep) - (nconc (cdr (symbol-value ref-dep)) + (if (setq ref-dep (gethash "none" + gnus-newsgroup-dependencies)) + (setcdr ref-dep + (nconc (cdr ref-dep) (list (car th)))) - (set ref-dep (list nil (car th)))) + (puthash ref-dep (list nil (car th)) gnus-newsgroup-dependencies)) (setq infloop 1 stack nil)) ;; Push all the subthreads onto the stack. @@ -4276,69 +4329,73 @@ If SELECT-ARTICLES, only select those articles from GROUP." "Go through the dependency hashtb and find the roots. Return all threads." (let (threads) (while (catch 'infloop - (mapatoms - (lambda (refs) + (maphash + (lambda (_id refs) ;; Deal with self-referencing References loops. - (when (and (car (symbol-value refs)) + (when (and (car refs) (not (zerop (apply - '+ + #'+ (mapcar (lambda (thread) (gnus-thread-loop-p - (car (symbol-value refs)) thread)) - (cdr (symbol-value refs))))))) + (car refs) thread)) + (cdr refs)))))) (setq threads nil) (throw 'infloop t)) - (unless (car (symbol-value refs)) + (unless (car refs) ;; These threads do not refer back to any other ;; articles, so they're roots. - (setq threads (append (cdr (symbol-value refs)) threads)))) + (setq threads (append (cdr refs) threads)))) gnus-newsgroup-dependencies))) threads)) ;; Build the thread tree. (defsubst gnus-dependencies-add-header (header dependencies force-new) "Enter HEADER into the DEPENDENCIES table if it is not already there. - If FORCE-NEW is not nil, enter HEADER into the DEPENDENCIES table even if it was already present. -If `gnus-summary-ignore-duplicates' is nil then duplicate Message-IDs -will not be entered in the DEPENDENCIES table. Otherwise duplicate -Message-IDs will be renamed to a unique Message-ID before being -entered. +If `gnus-summary-ignore-duplicates' is non-nil then duplicate +Message-IDs will not be entered in the DEPENDENCIES table. +Otherwise duplicate Message-IDs will be renamed to a unique +Message-ID before being entered. Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." (let* ((id (mail-header-id header)) - (id-dep (and id (intern id dependencies))) + ;; An "id-dep" is a list holding the vector headers of this + ;; message, plus equivalent "id-deps" for each immediate + ;; child message. + (id-dep (and id (gethash id dependencies))) parent-id ref ref-dep ref-header replaced) ;; Enter this `header' in the `dependencies' table. (cond - ((not id-dep) + ((null id) + ;; Omit this article altogether if there is no Message-ID. (setq header nil)) - ;; The first two cases do the normal part: enter a new `header' - ;; in the `dependencies' table. - ((not (boundp id-dep)) - (set id-dep (list header))) - ((null (car (symbol-value id-dep))) - (setcar (symbol-value id-dep) header)) - + ;; Enter a new id and `header' in the `dependencies' table. + ((null id-dep) + (setq id-dep (puthash id (list header) dependencies))) + ;; A child message has already added this id, just insert the header. + ((null (car id-dep)) + (setcar (gethash id dependencies) header) + (setq id-dep (gethash id dependencies))) ;; From here the `header' was already present in the ;; `dependencies' table. (force-new ;; Overrides an existing entry; ;; just set the header part of the entry. - (setcar (symbol-value id-dep) header) + (setcar (gethash id dependencies) header) (setq replaced t)) ;; Renames the existing `header' to a unique Message-ID. ((not gnus-summary-ignore-duplicates) ;; An article with this Message-ID has already been seen. ;; We rename the Message-ID. - (set (setq id-dep (intern (setq id (nnmail-message-id)) dependencies)) - (list header)) - (mail-header-set-id header id)) + (setq id-dep (puthash (setq id (nnmail-message-id)) + (list header) + dependencies)) + (setf (mail-header-id header) id)) ;; The last case ignores an existing entry, except it adds any ;; additional Xrefs (in case the two articles came from different @@ -4346,11 +4403,10 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." ;; Also sets `header' to nil meaning that the `dependencies' ;; table was *not* modified. (t - (mail-header-set-xref - (car (symbol-value id-dep)) - (concat (or (mail-header-xref (car (symbol-value id-dep))) - "") - (or (mail-header-xref header) ""))) + (setf (mail-header-xref (car id-dep)) + (concat (or (mail-header-xref (car id-dep)) + "") + (or (mail-header-xref header) ""))) (setq header nil))) (when (and header (not replaced)) @@ -4358,23 +4414,27 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." (setq parent-id (gnus-parent-id (mail-header-references header))) (setq ref parent-id) (while (and ref - (setq ref-dep (intern-soft ref dependencies)) - (boundp ref-dep) - (setq ref-header (car (symbol-value ref-dep)))) + (setq ref-dep (gethash ref dependencies)) + (setq ref-header (car-safe ref-dep))) (if (string= id ref) ;; Yuk! This is a reference loop. Make the article be a ;; root article. (progn - (mail-header-set-references (car (symbol-value id-dep)) "none") + (setf (mail-header-references (car id-dep)) "none") (setq ref nil) (setq parent-id nil)) (setq ref (gnus-parent-id (mail-header-references ref-header))))) - (setq ref-dep (intern (or parent-id "none") dependencies)) - (if (boundp ref-dep) - (setcdr (symbol-value ref-dep) - (nconc (cdr (symbol-value ref-dep)) - (list (symbol-value id-dep)))) - (set ref-dep (list nil (symbol-value id-dep))))) + (setq ref (or parent-id "none") + ref-dep (gethash ref dependencies)) + ;; Add `header' to its parent's list of children, creating that + ;; list if the parent isn't yet registered in the dependency + ;; table. + (if ref-dep + (setcdr (gethash ref dependencies) + (nconc (cdr ref-dep) + (list id-dep))) + (puthash ref (list nil id-dep) + dependencies))) header)) (defun gnus-extract-message-id-from-in-reply-to (string) @@ -4406,7 +4466,7 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." (setq end (1+ (point))) (when (search-backward "<" nil t) (setq new-child (buffer-substring (point) end)) - (push (list (incf generation) + (push (list (cl-incf generation) child (setq child new-child) subject date) relations))) @@ -4415,7 +4475,7 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." (erase-buffer))) (kill-buffer (current-buffer))) ;; Sort over trustworthiness. - (dolist (relation (sort relations 'car-less-than-car)) + (dolist (relation (sort relations #'car-less-than-car)) (when (gnus-dependencies-add-header (make-full-mail-header gnus-reffed-article-number @@ -4427,7 +4487,7 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." (push gnus-reffed-article-number gnus-newsgroup-sparse) (push (cons gnus-reffed-article-number gnus-sparse-mark) gnus-newsgroup-reads) - (decf gnus-reffed-article-number))) + (cl-decf gnus-reffed-article-number))) (gnus-message 7 "Making sparse threads...done"))) (defun gnus-build-old-threads () @@ -4436,16 +4496,15 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." ;; build complete threads - if the roots haven't been expired by the ;; server, that is. (let ((mail-parse-charset gnus-newsgroup-charset) - id heads) - (mapatoms - (lambda (refs) - (when (not (car (symbol-value refs))) - (setq heads (cdr (symbol-value refs))) + heads) + (maphash + (lambda (id refs) + (when (not (car refs)) + (setq heads (cdr refs)) (while heads (if (memq (mail-header-number (caar heads)) gnus-newsgroup-dormant) (setq heads (cdr heads)) - (setq id (symbol-name refs)) (while (and (setq id (gnus-build-get-header id)) (not (car (gnus-id-to-thread id))))) (setq heads nil))))) @@ -4461,7 +4520,6 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." ;; on the beginning of the line. (defsubst gnus-nov-parse-line (number dependencies &optional force-new) (let ((eol (point-at-eol)) - (buffer (current-buffer)) header references in-reply-to) ;; overview: [num subject from date id refs chars lines misc] @@ -4500,8 +4558,8 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." (when (and (string= references "") (setq in-reply-to (mail-header-extra header)) (setq in-reply-to (cdr (assq 'In-Reply-To in-reply-to)))) - (mail-header-set-references - header (gnus-extract-message-id-from-in-reply-to in-reply-to))) + (setf (mail-header-references header) + (gnus-extract-message-id-from-in-reply-to in-reply-to))) (when gnus-alter-header-function (funcall gnus-alter-header-function header)) @@ -4641,7 +4699,7 @@ the id of the parent article (if any)." (delq thread parent))) (if (gnus-summary-insert-subject id header) ;; Set the (possibly) new article number in the data structure. - (gnus-data-set-number data (gnus-id-to-article id)) + (setf (gnus-data-number data) (gnus-id-to-article id)) (setcar thread old) nil)))) @@ -4671,10 +4729,10 @@ If LINE, insert the rebuilt thread starting on line LINE." (push thr roots)) (setq thread (cdr thread))) ;; We now have all (unique) roots. - (if (= (length roots) 1) - ;; All the loose roots are now one solid root. - (setq thread (car roots)) - (setq thread (cons subject (gnus-sort-threads roots)))))) + (setq thread (if (= (length roots) 1) + ;; All the loose roots are now one solid root. + (car roots) + (cons subject (gnus-sort-threads roots)))))) (let (threads) ;; We then insert this thread into the summary buffer. (when line @@ -4684,6 +4742,7 @@ If LINE, insert the rebuilt thread starting on line LINE." (if gnus-show-threads (gnus-summary-prepare-threads (gnus-cut-threads (list thread))) (gnus-summary-prepare-unthreaded thread)) + ;; FIXME: Why is this `nreverse' safe? Don't we need `reverse' instead? (setq data (nreverse gnus-newsgroup-data)) (setq threads gnus-newsgroup-threads)) ;; We splice the new data into the data structure. @@ -4720,13 +4779,14 @@ If LINE, insert the rebuilt thread starting on line LINE." (setq parent (gnus-parent-id references))) (car (gnus-id-to-thread parent)) nil)) - (decf generation)) + (cl-decf generation)) (and (not (eq headers in-headers)) headers))) (defun gnus-id-to-thread (id) "Return the (sub-)thread where ID appears." - (gnus-gethash id gnus-newsgroup-dependencies)) + (when (hash-table-p gnus-newsgroup-dependencies) + (gethash id gnus-newsgroup-dependencies))) (defun gnus-id-to-article (id) "Return the article number of ID." @@ -4765,14 +4825,14 @@ If LINE, insert the rebuilt thread starting on line LINE." (defun gnus-articles-in-thread (thread) "Return the list of articles in THREAD." (cons (mail-header-number (car thread)) - (mapcan 'gnus-articles-in-thread (cdr thread)))) + (mapcan #'gnus-articles-in-thread (cdr thread)))) (defun gnus-remove-thread (id &optional dont-remove) "Remove the thread that has ID in it." (let (headers thread last-id) ;; First go up in this thread until we find the root. (setq last-id (gnus-root-id id) - headers (message-flatten-list (gnus-id-to-thread last-id))) + headers (flatten-tree (gnus-id-to-thread last-id))) ;; We have now found the real root of this thread. It might have ;; been gathered into some loose thread, so we have to search ;; through the threads to find the thread we wanted. @@ -4853,7 +4913,8 @@ If LINE, insert the rebuilt thread starting on line LINE." (and (cdr thread) (gnus-sort-subthreads-recursive (cdr thread) subthread-sort-func)))) - threads) func))) + threads) + func))) (defun gnus-sort-subthreads-recursive (threads func) ;; Responsible for sorting subthreads. @@ -4861,7 +4922,8 @@ If LINE, insert the rebuilt thread starting on line LINE." (cons (car thread) (and (cdr thread) (gnus-sort-subthreads-recursive (cdr thread) func)))) - threads) func)) + threads) + func)) (defun gnus-sort-threads-loop (threads func) (let* ((superthread (cons nil threads)) @@ -4915,8 +4977,16 @@ 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 :-) - (list 'byte-code "\10\211:\203\17\0\211@;\203\16\0A@@\207" - (vector thread) 2)) + (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-article-sort-by-number (h1 h2) "Sort articles by article number." @@ -4928,14 +4998,12 @@ using some other form will lead to serious barfage." (gnus-article-sort-by-number (gnus-thread-header h1) (gnus-thread-header h2))) -(defsubst gnus-article-sort-by-random (h1 h2) +(defsubst gnus-article-sort-by-random (_h1 _h2) "Sort articles randomly." (zerop (random 2))) -(defun gnus-thread-sort-by-random (h1 h2) - "Sort threads randomly." - (gnus-article-sort-by-random - (gnus-thread-header h1) (gnus-thread-header h2))) +(defalias 'gnus-thread-sort-by-random #'gnus-article-sort-by-random + "Sort threads randomly.") (defsubst gnus-article-sort-by-lines (h1 h2) "Sort articles by article Lines header." @@ -5051,7 +5119,7 @@ Unscored articles will be counted as having a score of zero." ((consp thread) (if (stringp (car thread)) (apply gnus-thread-score-function 0 - (mapcar 'gnus-thread-total-score-1 (cdr thread))) + (mapcar #'gnus-thread-total-score-1 (cdr thread))) (gnus-thread-total-score-1 thread))) (t (gnus-thread-total-score-1 (list thread))))) @@ -5066,9 +5134,9 @@ Unscored articles will be counted as having a score of zero." (defun gnus-thread-highest-number (thread) "Return the highest article number in THREAD." - (apply 'max (mapcar (lambda (header) + (apply #'max (mapcar (lambda (header) (mail-header-number header)) - (message-flatten-list thread)))) + (flatten-tree thread)))) (defun gnus-article-sort-by-most-recent-date (h1 h2) "Sort articles by number." @@ -5084,18 +5152,18 @@ Unscored articles will be counted as having a score of zero." ; quite a bit to use gnus-date-get-time, which caches the time value. (defun gnus-thread-latest-date (thread) "Return the highest article date in THREAD." - (apply 'max + (apply #'max (mapcar (lambda (header) (float-time (gnus-date-get-time (mail-header-date header)))) - (message-flatten-list thread)))) + (flatten-tree thread)))) (defun gnus-thread-total-score-1 (root) ;; This function find the total score of the thread below ROOT. (setq root (car root)) (apply gnus-thread-score-function (or (append - (mapcar 'gnus-thread-total-score + (mapcar #'gnus-thread-total-score (cdr (gnus-id-to-thread (mail-header-id root)))) (when (> (mail-header-number root) 0) (list (or (cdr (assq (mail-header-number root) @@ -5191,7 +5259,7 @@ or a straight list of headers." gnus-tmp-header gnus-tmp-unread gnus-tmp-downloaded gnus-tmp-replied gnus-tmp-subject-or-nil gnus-tmp-dummy gnus-tmp-indentation gnus-tmp-lines gnus-tmp-score - gnus-tmp-score-char gnus-tmp-from gnus-tmp-name + gnus-tmp-score-char gnus-tmp-from gnus-tmp-name gnus-tmp-thread gnus-tmp-number gnus-tmp-opening-bracket gnus-tmp-closing-bracket tree-stack) @@ -5429,7 +5497,7 @@ or a straight list of headers." (t (or gnus-sum-thread-tree-single-indent subject)))) (t - (concat (apply 'concat + (concat (apply #'concat (mapcar (lambda (item) (if (= item 1) gnus-sum-thread-tree-vertical @@ -5442,9 +5510,10 @@ or a straight list of headers." (setq gnus-tmp-name gnus-tmp-from)) (unless (numberp gnus-tmp-lines) (setq gnus-tmp-lines -1)) - (if (= gnus-tmp-lines -1) - (setq gnus-tmp-lines "?") - (setq gnus-tmp-lines (number-to-string gnus-tmp-lines))) + (setq gnus-tmp-lines (if (= gnus-tmp-lines -1) + "?" + (number-to-string gnus-tmp-lines))) + (setq gnus-tmp-thread thread) (put-text-property (point) (progn (eval gnus-summary-line-format-spec) (point)) @@ -5464,7 +5533,7 @@ or a straight list of headers." (nthcdr 1 thread)) stack)) (push (if (nth 1 thread) 1 0) tree-stack) - (incf gnus-tmp-level) + (cl-incf gnus-tmp-level) (setq threads (if thread-end nil (cdar thread))) (if gnus-summary-display-while-building (if building-count @@ -5523,7 +5592,7 @@ or a straight list of headers." "Get list identifier regexp for GROUP." (or (gnus-parameter-list-identifier group) (if (consp gnus-list-identifiers) - (mapconcat 'identity gnus-list-identifiers " *\\|") + (mapconcat #'identity gnus-list-identifiers " *\\|") gnus-list-identifiers))) (defun gnus-summary-remove-list-identifiers () @@ -5545,7 +5614,7 @@ or a straight list of headers." (setq subject (concat (substring subject 0 (match-beginning 1)) (substring subject (match-end 1))))) - (mail-header-set-subject header subject)))))) + (setf (mail-header-subject header) subject)))))) (defun gnus-fetch-headers (articles &optional limit force-new dependencies) "Fetch headers of ARTICLES." @@ -5579,7 +5648,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (if (eq (car (gnus-find-method-for-group group)) 'nnvirtual) t gnus-summary-ignore-duplicates)) - (info (nth 2 entry)) + (info (nth 1 entry)) charset articles fetched-articles cached) (unless (gnus-check-server @@ -5598,7 +5667,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (decode-coding-string group charset) (decode-coding-string (gnus-status-message group) charset)))) - (unless (gnus-request-group group t nil (gnus-get-info group)) + (unless (gnus-request-group group t nil info) (when (derived-mode-p 'gnus-summary-mode) (gnus-kill-buffer (current-buffer))) (error "Couldn't request group %s: %s" @@ -5624,11 +5693,11 @@ If SELECT-ARTICLES, only select those articles from GROUP." ((not (zerop (or (car-safe read-all) 0))) ;; The user entered the group with C-u SPC/RET, let's show ;; all articles. - 'gnus-not-ignore) + #'gnus-not-ignore) ((eq display 'all) - 'gnus-not-ignore) + #'gnus-not-ignore) ((arrayp display) - (gnus-summary-display-make-predicate (mapcar 'identity display))) + (gnus-summary-display-make-predicate (mapcar #'identity display))) ((numberp display) ;; The following is probably the "correct" solution, but ;; it makes Gnus fetch all headers and then limit the @@ -5636,9 +5705,8 @@ If SELECT-ARTICLES, only select those articles from GROUP." ;; select-articles parameter instead. -- Simon Josefsson ;; <jas@kth.se> ;; - ;; (gnus-byte-compile - ;; `(lambda () (> number ,(- (cdr (gnus-active group)) - ;; display))))) + ;; (let ((n (cdr (gnus-active group)))) + ;; (lambda () (> number (- n display)))) (setq select-articles (gnus-uncompress-range (cons (let ((tmp (- (cdr (gnus-active group)) display))) @@ -5702,8 +5770,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (setq gnus-newsgroup-limit (copy-sequence articles)) ;; Remove canceled articles from the list of unread articles. (setq fetched-articles - (mapcar (lambda (headers) (mail-header-number headers)) - gnus-newsgroup-headers)) + (mapcar #'mail-header-number gnus-newsgroup-headers)) (setq gnus-newsgroup-articles fetched-articles) (setq gnus-newsgroup-unreads (gnus-sorted-nintersection @@ -5738,7 +5805,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (mail-header-number (car gnus-newsgroup-headers)) gnus-newsgroup-end (mail-header-number - (gnus-last-element gnus-newsgroup-headers)))) + (car (last gnus-newsgroup-headers))))) ;; GROUP is successfully selected. (or gnus-newsgroup-headers t))))) @@ -5762,8 +5829,8 @@ If SELECT-ARTICLES, only select those articles from GROUP." (unseen . unseen)) gnus-article-mark-lists)) (push (cons (cdr elem) - (gnus-byte-compile ;Why bother? - `(lambda () (gnus-article-marked-p ',(cdr elem))))) + (let ((x (cdr elem))) + (lambda () (gnus-article-marked-p x)))) gnus-summary-display-cache))) (let ((gnus-category-predicate-alist gnus-summary-display-cache) (gnus-category-predicate-cache gnus-summary-display-cache)) @@ -5903,7 +5970,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." select (if (and (not (zerop scored)) (<= (abs select) scored)) (progn - (setq articles (sort scored-list '<)) + (setq articles (sort scored-list #'<)) (setq number (length articles))) (setq articles (copy-sequence articles))) @@ -5915,12 +5982,12 @@ If SELECT-ARTICLES, only select those articles from GROUP." (setq articles (nthcdr (- number select) articles)))) (setq gnus-newsgroup-unselected (gnus-sorted-difference gnus-newsgroup-unreads articles)) - (when gnus-alter-articles-to-read-function + (when (functionp gnus-alter-articles-to-read-function) (setq articles (sort (funcall gnus-alter-articles-to-read-function gnus-newsgroup-name articles) - '<))) + #'<))) articles))) (defun gnus-killed-articles (killed articles) @@ -5947,7 +6014,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (min (car active)) (max (cdr active)) (types gnus-article-mark-lists) - marks var articles article mark mark-type + var articles article mark mark-type bgn end) ;; Hack to avoid adjusting marks for imap. (when (eq (car (gnus-find-method-for-group (gnus-info-group info))) @@ -6066,7 +6133,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (setq list (gnus-range-add 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 (gnus-compress-sequence (set symbol (sort list #'<)) t))) (when (and (gnus-check-backend-function 'request-set-mark gnus-newsgroup-name) @@ -6077,12 +6144,12 @@ If SELECT-ARTICLES, only select those articles from GROUP." (del (gnus-list-range-intersection gnus-newsgroup-articles - (gnus-remove-from-range (gnus-copy-sequence old) list))) + (gnus-remove-from-range (copy-tree old) list))) (add (gnus-list-range-intersection gnus-newsgroup-articles (gnus-remove-from-range - (gnus-copy-sequence list) old)))) + (copy-tree list) old)))) (when add (push (list add 'add (list (cdr type))) delta-marks)) (when del @@ -6112,7 +6179,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (let ((i 5)) (while (and (> i 2) (not (nth i info))) - (when (nthcdr (decf i) info) + (when (nthcdr (cl-decf i) info) (setcdr (nthcdr i info) nil))))))) (defun gnus-set-mode-line (where) @@ -6149,7 +6216,7 @@ If WHERE is `summary', the summary mode line format will be used." gnus-tmp-unselected)))) (gnus-tmp-subject (if (and gnus-current-headers - (vectorp gnus-current-headers)) + (mail-header-p gnus-current-headers)) (gnus-mode-string-quote (mail-header-subject gnus-current-headers)) "")) @@ -6201,22 +6268,21 @@ The resulting hash table is returned, or nil if no Xrefs were found." (setq number (string-to-number (substring xrefs (match-beginning 2) (match-end 2)))) - (if (setq entry (gnus-gethash group xref-hashtb)) + (if (setq entry (gethash group xref-hashtb)) (setcdr entry (cons number (cdr entry))) - (gnus-sethash group (cons number nil) xref-hashtb))))) + (puthash group (cons number nil) xref-hashtb))))) (and start xref-hashtb))) (defun gnus-mark-xrefs-as-read (from-newsgroup headers unreads) "Look through all the headers and mark the Xrefs as read." (let ((virtual (gnus-virtual-group-p from-newsgroup)) - name info xref-hashtb idlist method nth4) + name info xref-hashtb method nth4) (with-current-buffer gnus-group-buffer (when (setq xref-hashtb (gnus-create-xref-hashtb from-newsgroup headers unreads)) - (mapatoms - (lambda (group) - (unless (string= from-newsgroup (setq name (symbol-name group))) - (setq idlist (symbol-value group)) + (maphash + (lambda (group idlist) + (unless (string= from-newsgroup group) ;; Dead groups are not updated. (and (prog1 (setq info (gnus-get-info name)) @@ -6242,7 +6308,7 @@ The resulting hash table is returned, or nil if no Xrefs were found." (defun gnus-compute-read-articles (group articles) (let* ((entry (gnus-group-entry group)) - (info (nth 2 entry)) + (info (nth 1 entry)) (active (gnus-active group)) ninfo) (when entry @@ -6273,13 +6339,13 @@ The resulting hash table is returned, or nil if no Xrefs were found." (setq ninfo (gnus-info-read info))) ;; Then we add the read articles to the range. (gnus-add-to-range - ninfo (setq articles (sort articles '<)))))) + ninfo (setq articles (sort articles #'<)))))) (defun gnus-group-make-articles-read (group articles) "Update the info of GROUP to say that ARTICLES are read." (let* ((num 0) (entry (gnus-group-entry group)) - (info (nth 2 entry)) + (info (nth 1 entry)) (active (gnus-active group)) (set-marks (gnus-method-option-p @@ -6304,6 +6370,7 @@ The resulting hash table is returned, or nil if no Xrefs were found." (when ,set-marks (gnus-request-set-mark ,group (list (list ',range 'del '(read))))) + (gnus-group-jump-to-group ,group) (gnus-group-update-group ,group t)))) ;; Add the read articles to the range. (gnus-info-set-read info range) @@ -6366,7 +6433,7 @@ The resulting hash table is returned, or nil if no Xrefs were found." ;; doesn't always go hand in hand. (setq header - (vector + (make-full-mail-header ;; Number. (prog1 (setq number (read cur)) @@ -6496,7 +6563,7 @@ Return a list of headers that match SEQUENCE (see `nntp-retrieve-headers')." ;; Get the Xref when the users reads the articles since most/some ;; NNTP servers do not include Xrefs when using XOVER. - (setq gnus-article-internal-prepare-hook '(gnus-article-get-xrefs)) + (setq gnus-article-internal-prepare-hook (list #'gnus-article-get-xrefs)) (let ((mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets) (cur nntp-server-buffer) @@ -6569,7 +6636,7 @@ This is meant to be called in `gnus-article-internal-prepare-hook'." (search-forward "\nXref:" nil t)) (goto-char (1+ (match-end 0))) (setq xref (buffer-substring (point) (point-at-eol))) - (mail-header-set-xref headers xref))))))) + (setf (mail-header-xref headers) xref))))))) (defun gnus-summary-insert-subject (id &optional old-header use-old-header) "Find article ID and insert the summary line for that article. @@ -6579,7 +6646,7 @@ If USE-OLD-HEADER is non-nil, then OLD-HEADER should be a header, and OLD-HEADER will be used when the summary line is inserted, too, instead of trying to fetch new headers." (let* ((line (and (numberp old-header) old-header)) - (old-header (and (vectorp old-header) old-header)) + (old-header (and (mail-header-p old-header) old-header)) (header (cond ((and old-header use-old-header) old-header) ((and (numberp id) @@ -6607,7 +6674,7 @@ too, instead of trying to fetch new headers." (let ((gnus-newsgroup-headers (list header))) (gnus-summary-remove-list-identifiers)) (when old-header - (mail-header-set-number header (mail-header-number old-header))) + (setf (mail-header-number header) (mail-header-number old-header))) (setq gnus-newsgroup-sparse (delq (setq number (mail-header-number header)) gnus-newsgroup-sparse)) @@ -6652,7 +6719,7 @@ current article will be taken into consideration." (if backward (gnus-summary-find-prev nil article) (gnus-summary-find-next nil article))) - (decf n))) + (cl-decf n))) (nreverse articles))) ((and (and transient-mark-mode mark-active) (mark)) (message "region active") @@ -6681,6 +6748,7 @@ current article will be taken into consideration." "Iterate over the process/prefixed articles and do FORMS. ARG is the interactive prefix given to the command. FORMS will be executed with point over the summary line of the articles." + (declare (indent 1) (debug t)) (let ((articles (make-symbol "gnus-summary-iterate-articles"))) `(let ((,articles (gnus-summary-work-articles ,arg))) (while ,articles @@ -6688,9 +6756,6 @@ executed with point over the summary line of the articles." ,@forms (pop ,articles))))) -(put 'gnus-summary-iterate 'lisp-indent-function 1) -(put 'gnus-summary-iterate 'edebug-form-spec '(form body)) - (defun gnus-summary-save-process-mark () "Push the current set of process marked articles on the stack." (interactive) @@ -6713,7 +6778,7 @@ executed with point over the summary line of the articles." (defun gnus-summary-process-mark-set (set) "Make SET into the current process marked articles." (gnus-summary-unmark-all-processable) - (mapc 'gnus-summary-set-process-mark set)) + (mapc #'gnus-summary-set-process-mark set)) ;;; Searching and stuff @@ -6819,7 +6884,7 @@ If EXCLUDE-GROUP, do not go to this group." (while arts (and (or (not unread) (gnus-data-unread-p (car arts))) - (vectorp (gnus-data-header (car arts))) + (mail-header-p (gnus-data-header (car arts))) (gnus-subject-equal simp-subject (mail-header-subject (gnus-data-header (car arts))) t) (setq result (car arts) @@ -7057,12 +7122,20 @@ buffer." (or (get-buffer-window gnus-article-buffer) (eq gnus-current-article (gnus-summary-article-number)) (gnus-summary-show-article)) - (gnus-configure-windows - (if gnus-widen-article-window - 'only-article - 'article) - t) - (select-window (get-buffer-window gnus-article-buffer)))) + (let ((point (with-current-buffer gnus-article-buffer + (point)))) + (gnus-configure-windows + (if gnus-widen-article-window + 'only-article + 'article) + t) + (select-window (get-buffer-window gnus-article-buffer)) + ;; If we've just selected the message, place point at the start of + ;; the body because that's probably where we want to be. + (if (not (= point (point-min))) + (goto-char point) + (article-goto-body) + (forward-char -1))))) (defun gnus-summary-universal-argument (arg) "Perform any operation on all articles that are process/prefixed." @@ -7087,7 +7160,7 @@ buffer." (gnus-summary-position-point)) (define-obsolete-function-alias - 'gnus-summary-toggle-truncation 'toggle-truncate-lines "26.1") + 'gnus-summary-toggle-truncation #'toggle-truncate-lines "26.1") (defun gnus-summary-find-for-reselect () "Return the number of an article to stay on across a reselect. @@ -7243,7 +7316,7 @@ If FORCE (the prefix), also save the .newsrc file(s)." (gnus-summary-update-info)) (gnus-close-group group) ;; Make sure where we were, and go to next newsgroup. - (when (buffer-live-p (get-buffer gnus-group-buffer)) + (when (gnus-buffer-live-p gnus-group-buffer) (set-buffer gnus-group-buffer)) (unless quit-config (gnus-group-jump-to-group group)) @@ -7275,12 +7348,13 @@ If FORCE (the prefix), also save the .newsrc file(s)." (if quit-config (gnus-handle-ephemeral-exit quit-config) (goto-char group-point) + (unless leave-hidden + (gnus-configure-windows 'group 'force)) ;; If gnus-group-buffer is already displayed, make sure we also move ;; the cursor in the window that displays it. (let ((win (get-buffer-window (current-buffer) 0))) - (if win (set-window-point win (point)))) - (unless leave-hidden - (gnus-configure-windows 'group 'force))) + (goto-char group-point) + (if win (set-window-point win (point))))) ;; If we have several article buffers, we kill them at exit. (unless single-article-buffer @@ -7344,7 +7418,7 @@ If FORCE (the prefix), also save the .newsrc file(s)." (setq gnus-newsgroup-name nil) (unless (gnus-ephemeral-group-p group) (gnus-group-update-group group nil t)) - (when (equal (gnus-group-group-name) group) + (when (gnus-group-goto-group group) (gnus-group-next-unread-group 1)) (gnus-article-stop-animations) (when quit-config @@ -7417,8 +7491,7 @@ The state which existed when entering the ephemeral is reset." (defun gnus-deaden-summary () "Make the current summary buffer into a dead summary buffer." ;; Kill any previous dead summary buffer. - (when (and gnus-dead-summary - (buffer-name gnus-dead-summary)) + (when (buffer-live-p gnus-dead-summary) (with-current-buffer gnus-dead-summary (when gnus-dead-summary-mode (kill-buffer (current-buffer))))) @@ -7436,7 +7509,7 @@ The state which existed when entering the ephemeral is reset." (defun gnus-kill-or-deaden-summary (buffer) "Kill or deaden the summary BUFFER." (save-excursion - (when (and (buffer-name buffer) + (when (and (buffer-live-p buffer) (not gnus-single-article-buffer)) (with-current-buffer buffer (gnus-kill-buffer gnus-article-buffer) @@ -7445,16 +7518,16 @@ The state which existed when entering the ephemeral is reset." ;; Kill the buffer. (gnus-kill-summary-on-exit (when (and gnus-use-trees - (gnus-buffer-exists-p buffer)) + (gnus-buffer-live-p buffer)) (with-current-buffer buffer (gnus-tree-close))) (gnus-kill-buffer buffer)) ;; Deaden the buffer. - ((gnus-buffer-exists-p buffer) + ((gnus-buffer-live-p buffer) (with-current-buffer buffer (gnus-deaden-summary)))))) -(defun gnus-summary-wake-up-the-dead (&rest args) +(defun gnus-summary-wake-up-the-dead (&rest _) "Wake up the dead summary buffer." (interactive) (gnus-dead-summary-mode -1) @@ -7521,7 +7594,7 @@ previous group instead." (and unreads (not (zerop unreads)))) (gnus-summary-read-group target-group nil no-article - (and (buffer-name current-buffer) current-buffer) + (and (buffer-live-p current-buffer) current-buffer) nil backward)) (setq entered t) (setq current-group target-group @@ -7647,7 +7720,7 @@ If FORCE, also allow jumping to articles not currently shown." force (gnus-summary-insert-subject article - (if (or (numberp force) (vectorp force)) force) + (if (or (numberp force) (mail-header-p force)) force) t) (setq data (gnus-data-find article))) (goto-char b) @@ -7680,15 +7753,21 @@ Given a prefix, will force an `article' buffer configuration." (gnus-article-setup-buffer)) (gnus-set-global-variables) (with-current-buffer gnus-article-buffer + ;; The buffer may be non-empty and even narrowed, so go back to + ;; a sane state. + (widen) + ;; We're going to erase the buffer anyway so do it now: it can save us from + ;; uselessly performing multibyte-conversion of the current content. + (let ((inhibit-read-only t)) (erase-buffer)) (setq gnus-article-charset gnus-newsgroup-charset) (setq gnus-article-ignored-charsets gnus-newsgroup-ignored-charsets) (mm-enable-multibyte)) (if (null article) nil (prog1 - (if gnus-summary-display-article-function - (funcall gnus-summary-display-article-function article all-header) - (gnus-article-prepare article all-header)) + (funcall (or gnus-summary-display-article-function + #'gnus-article-prepare) + article all-header) (gnus-run-hooks 'gnus-select-article-hook) (when (and gnus-current-article (not (zerop gnus-current-article))) @@ -7711,7 +7790,7 @@ be displayed." (unless (derived-mode-p 'gnus-summary-mode) (set-buffer gnus-summary-buffer)) (let ((article (or article (gnus-summary-article-number))) - (all-headers (not (not all-headers))) ;Must be t or nil. + (all-headers (and all-headers t)) ; Must be t or nil. gnus-summary-display-article-function) (and (not pseudo) (gnus-summary-article-pseudo-p article) @@ -7797,7 +7876,8 @@ If BACKWARD, the previous article is selected instead of the next." (cond ((or (not gnus-auto-select-next) (not cmd)) - (gnus-message 7 "No more%s articles" (if unread " unread" ""))) + (unless (eq gnus-auto-select-next 'quietly) + (gnus-message 6 "No more%s articles" (if unread " unread" "")))) ((or (eq gnus-auto-select-next 'quietly) (and (eq gnus-auto-select-next 'slightly-quietly) push) @@ -7806,10 +7886,11 @@ If BACKWARD, the previous article is selected instead of the next." ;; Select quietly. (if (gnus-ephemeral-group-p gnus-newsgroup-name) (gnus-summary-exit) - (gnus-message 7 "No more%s articles (%s)..." - (if unread " unread" "") - (if group (concat "selecting " group) - "exiting")) + (unless (eq gnus-auto-select-next 'quietly) + (gnus-message 6 "No more%s articles (%s)..." + (if unread " unread" "") + (if group (concat "selecting " group) + "exiting"))) (gnus-summary-next-group nil group backward))) (t (when (numberp last-input-event) @@ -7821,7 +7902,7 @@ If BACKWARD, the previous article is selected instead of the next." (gnus-summary-walk-group-buffer gnus-newsgroup-name cmd unread backward point)))))))) -(defun gnus-summary-walk-group-buffer (from-group cmd unread backward start) +(defun gnus-summary-walk-group-buffer (_from-group cmd unread backward start) (let ((keystrokes '((?\C-n (gnus-group-next-unread-group 1)) (?\C-p (gnus-group-prev-unread-group 1)))) (cursor-in-echo-area t) @@ -8115,7 +8196,7 @@ score higher than the default score." "Select the first unread subject that has a score over the default score." (interactive) (let ((data gnus-newsgroup-data) - article score) + article) (while (and (setq article (gnus-data-number (car data))) (or (gnus-data-read-p (car data)) (not (> (gnus-summary-article-score article) @@ -8141,7 +8222,7 @@ is a number, it is the line the article is to be displayed on." (list (gnus-completing-read "Article number or Message-ID" - (mapcar 'int-to-string gnus-newsgroup-limit)) + (mapcar #'int-to-string gnus-newsgroup-limit)) current-prefix-arg t)) (prog1 @@ -8193,8 +8274,7 @@ If given a prefix, remove all limits." (interactive "P") (when total (setq gnus-newsgroup-limits - (list (mapcar (lambda (h) (mail-header-number h)) - gnus-newsgroup-headers)))) + (list (mapcar #'mail-header-number gnus-newsgroup-headers)))) (unless gnus-newsgroup-limits (error "No limit to pop")) (prog1 @@ -8322,9 +8402,9 @@ in `nnmail-extra-headers'." (if (eq to t) from (mapcar (lambda (a) (car (memq a from))) to)) - (if (eq to t) - (mapcar (lambda (a) (car (memq a from))) cc) - (mapcar (lambda (a) (car (memq a from))) + (mapcar (lambda (a) (car (memq a from))) + (if (eq to t) + cc (mapcar (lambda (a) (car (memq a to))) cc)))) (nconc (if (eq to t) nil to) @@ -8385,7 +8465,7 @@ articles that are younger than AGE days." (cutoff (days-to-time age)) articles d date is-younger) (while (setq d (pop data)) - (when (and (vectorp (gnus-data-header d)) + (when (and (mail-header-p (gnus-data-header d)) (setq date (mail-header-date (gnus-data-header d)))) (setq is-younger (time-less-p (time-since (gnus-date-get-time date)) @@ -8406,7 +8486,7 @@ articles that are younger than AGE days." (if current-prefix-arg "Exclude extra header" "Limit extra header") - (mapcar 'symbol-name gnus-extra-headers) + (mapcar #'symbol-name gnus-extra-headers) t nil nil (symbol-name (car gnus-extra-headers)))))) (list header @@ -8528,7 +8608,7 @@ If UNREPLIED (the prefix), limit to unreplied articles." (gnus-summary-limit gnus-newsgroup-replied)) (gnus-summary-position-point)) -(defun gnus-summary-limit-exclude-marks (marks &optional reverse) +(defun gnus-summary-limit-exclude-marks (marks &optional _reverse) "Exclude articles that are marked with MARKS (e.g. \"DK\"). If REVERSE, limit the summary buffer to articles that are marked with MARKS. MARKS can either be a string of marks or a list of marks. @@ -8556,14 +8636,22 @@ Returns how many articles were removed." (gnus-summary-limit articles)) (gnus-summary-position-point))) -(defun gnus-summary-limit-to-score (score) - "Limit to articles with score at or above SCORE." - (interactive "NLimit to articles with score of at least: ") +(defun gnus-summary-limit-to-score (score &optional below) + "Limit to articles with score at or above SCORE. + +With a prefix argument, limit to articles with score at or below +SCORE." + (interactive (list (string-to-number + (read-string + (format "Limit to articles with score of at %s: " + (if current-prefix-arg "most" "least")))))) (let ((data gnus-newsgroup-data) - articles) + (compare (if (or below current-prefix-arg) #'<= #'>=)) + articles) (while data - (when (>= (gnus-summary-article-score (gnus-data-number (car data))) - score) + (when (funcall compare (gnus-summary-article-score + (gnus-data-number (car data))) + score) (push (gnus-data-number (car data)) articles)) (setq data (cdr data))) (prog1 @@ -8691,12 +8779,11 @@ fetched for this group." "Mark all unread excluded articles as read. If ALL, mark even excluded ticked and dormants as read." (interactive "P") - (setq gnus-newsgroup-limit (sort gnus-newsgroup-limit '<)) + (setq gnus-newsgroup-limit (sort gnus-newsgroup-limit #'<)) (let ((articles (gnus-sorted-ndifference (sort - (mapcar (lambda (h) (mail-header-number h)) - gnus-newsgroup-headers) - '<) + (mapcar #'mail-header-number gnus-newsgroup-headers) + #'<) gnus-newsgroup-limit)) article) (setq gnus-newsgroup-unreads @@ -8756,7 +8843,7 @@ If ALL, mark even excluded ticked and dormants as read." (let ((num 0)) (while threads (when (memq (mail-header-number (caar threads)) gnus-newsgroup-limit) - (incf num)) + (cl-incf num)) (pop threads)) (< num 2))) @@ -8811,7 +8898,7 @@ fetch-old-headers verbiage, and so on." ;; Most groups have nothing to remove. (unless (or gnus-inhibit-limiting (and (null gnus-newsgroup-dormant) - (eq gnus-newsgroup-display 'gnus-not-ignore) + (eq gnus-newsgroup-display #'gnus-not-ignore) (not (eq gnus-fetch-old-headers 'some)) (not (numberp gnus-fetch-old-headers)) (not (eq gnus-fetch-old-headers 'invisible)) @@ -8821,11 +8908,11 @@ fetch-old-headers verbiage, and so on." (null gnus-thread-expunge-below))) (push gnus-newsgroup-limit gnus-newsgroup-limits) (setq gnus-newsgroup-limit nil) - (mapatoms - (lambda (node) - (unless (car (symbol-value node)) + (maphash + (lambda (_id deps) + (unless (car deps) ;; These threads have no parents -- they are roots. - (let ((nodes (cdr (symbol-value node))) + (let ((nodes (cdr deps)) thread) (while nodes (if (and gnus-thread-expunge-below @@ -8852,7 +8939,7 @@ fetch-old-headers verbiage, and so on." (let* ((max-lisp-eval-depth (max 5000 max-lisp-eval-depth)) (children (if (cdr thread) - (apply '+ (mapcar 'gnus-summary-limit-children + (apply #'+ (mapcar #'gnus-summary-limit-children (cdr thread))) 0)) (number (mail-header-number (car thread))) @@ -8888,7 +8975,7 @@ fetch-old-headers verbiage, and so on." gnus-summary-expunge-below)) ;; We increase the expunge-tally here, but that has ;; nothing to do with the limits, really. - (incf gnus-newsgroup-expunged-tally) + (cl-incf gnus-newsgroup-expunged-tally) ;; We also mark as read here, if that's wanted. (when (and gnus-summary-mark-below (< score gnus-summary-mark-below)) @@ -8913,7 +9000,7 @@ fetch-old-headers verbiage, and so on." (defun gnus-expunge-thread (thread) "Mark all articles in THREAD as read." (let* ((number (mail-header-number (car thread)))) - (incf gnus-newsgroup-expunged-tally) + (cl-incf gnus-newsgroup-expunged-tally) ;; We also mark as read here, if that's wanted. (setq gnus-newsgroup-unreads (delq number gnus-newsgroup-unreads)) @@ -8922,7 +9009,7 @@ fetch-old-headers verbiage, and so on." (push (cons number gnus-low-score-mark) gnus-newsgroup-reads))) ;; Go recursively through all subthreads. - (mapcar 'gnus-expunge-thread (cdr thread))) + (mapcar #'gnus-expunge-thread (cdr thread))) ;; Summary article oriented commands @@ -8965,7 +9052,7 @@ The difference between N and the number of articles fetched is returned." (gnus-message 1 "No references in article %d" (gnus-summary-article-number)) (setq error t)) - (decf n)) + (cl-decf n)) (gnus-summary-position-point) n)) @@ -8981,7 +9068,7 @@ Return the number of articles fetched." (error "No References in the current article") ;; For each Message-ID in the References header... (while (string-match "<[^>]*>" ref) - (incf n) + (cl-incf n) ;; ... fetch that article. (gnus-summary-refer-article (prog1 (match-string 0 ref) @@ -9041,11 +9128,13 @@ non-numeric or nil fetch the number specified by the (refs (split-string (or (mail-header-references header) ""))) (gnus-parse-headers-hook - `(lambda () (goto-char (point-min)) - (keep-lines - (regexp-opt ',(append refs (list id subject))))))) + (let ((refs (append refs (list id subject)))) + (lambda () + (goto-char (point-min)) + (keep-lines (regexp-opt refs)))))) (gnus-fetch-headers (list last) (if (numberp limit) - (* 2 limit) limit) t)))) + (* 2 limit) limit) + t)))) article-ids new-unreads) (when (listp new-headers) (dolist (header new-headers) @@ -9321,25 +9410,103 @@ Obeys the standard process/prefix convention." (t (error "Couldn't select virtual nndoc group"))))) -(defun gnus-summary-widget-forward (arg) +(define-obsolete-function-alias 'gnus-summary-widget-forward + #'gnus-summary-button-forward "27.1") +(defun gnus-summary-button-forward (arg) "Move point to the next field or button in the article. With optional ARG, move across that many fields." (interactive "p") (gnus-summary-select-article) (gnus-configure-windows 'article) - (select-window (gnus-get-buffer-window gnus-article-buffer)) - (widget-forward arg)) - -(defun gnus-summary-widget-backward (arg) + (let ((win (or (gnus-get-buffer-window gnus-article-buffer t) + (error "No article window found")))) + (select-window win) + (select-frame-set-input-focus (window-frame win)) + (forward-button arg))) + +(define-obsolete-function-alias 'gnus-summary-widget-backward + #'gnus-summary-button-backward "27.1") +(defun gnus-summary-button-backward (arg) "Move point to the previous field or button in the article. With optional ARG, move across that many fields." (interactive "p") (gnus-summary-select-article) (gnus-configure-windows 'article) - (select-window (gnus-get-buffer-window gnus-article-buffer)) - (unless (widget-at (point)) - (goto-char (point-max))) - (widget-backward arg)) + (let ((win (or (gnus-get-buffer-window gnus-article-buffer t) + (error "No article window found")))) + (select-window win) + (select-frame-set-input-focus (window-frame win)) + (unless (button-at (point)) + (goto-char (point-max))) + (backward-button arg))) + +(defcustom gnus-collect-urls-primary-text "Link" + "The button text for the default link in `gnus-summary-browse-url'." + :version "27.1" + :type 'string + :group 'gnus-article-various) + +(defun gnus-collect-urls () + "Return the list of URLs in the buffer after (point). +The 1st element is the button named by `gnus-collect-urls-primary-text'." + (let ((pt (point)) urls primary) + (while (forward-button 1 nil nil t) + (setq pt (point)) + (when-let ((w (button-at pt)) + (u (or (button-get w 'shr-url) + (get-text-property pt 'gnus-string)))) + (when (string-match-p "\\`[[:alpha:]]+://" u) + (if (and gnus-collect-urls-primary-text (null primary) + (string= gnus-collect-urls-primary-text (button-label w))) + (setq primary u) + (push u urls))))) + (setq urls (nreverse urls)) + (when primary + (push primary urls)) + (delete-dups urls))) + +(defun gnus-shorten-url (url max) + "Return an excerpt from URL." + (if (<= (length url) max) + url + (let ((parsed (url-generic-parse-url url))) + (concat (url-host parsed) + "..." + (substring (url-filename parsed) + (- (length (url-filename parsed)) + (max (- max (length (url-host parsed))) 0))))))) + +(defun gnus-summary-browse-url (&optional external) + "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. + +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") + (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 "URL to browse (default %s): " + (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. @@ -9476,10 +9643,12 @@ Optional argument BACKWARD means do search for backward. This search includes all articles in the current group that Gnus has fetched headers for, whether they are displayed or not." (let ((articles nil) - ;; Can't eta-reduce because it's a macro. - (func `(lambda (h) (,(intern (concat "mail-header-" header)) h))) + (func (intern (concat "mail-header-" header))) (case-fold-search t)) (dolist (header gnus-newsgroup-headers) + ;; FIXME: when called from gnus-summary-limit-include-thread via + ;; gnus-summary-limit-include-matching-articles, `regexp' is a decoded + ;; string whereas the header isn't decoded. (when (string-match regexp (funcall func header)) (push (mail-header-number header) articles))) (nreverse articles))) @@ -9494,17 +9663,18 @@ be taken into consideration. If NOT-CASE-FOLD, case won't be folded in the comparisons. If NOT-MATCHING, return a list of all articles that not match REGEXP on HEADER." (let ((case-fold-search (not not-case-fold)) - articles d func) + articles func) (if (consp header) (if (eq (car header) 'extra) (setq func - `(lambda (h) - (or (cdr (assq ',(cdr header) (mail-header-extra h))) - ""))) + (let ((x (cdr header))) + (lambda (h) + (or (cdr (assq x (mail-header-extra h))) + "")))) (error "%s is an invalid header" header)) (unless (fboundp (intern (concat "mail-header-" header))) (error "%s is not a valid header" header)) - (setq func `(lambda (h) (,(intern (concat "mail-header-" header)) h)))) + (setq func (intern (concat "mail-header-" header)))) (dolist (d (if (eq backward 'all) gnus-newsgroup-data (gnus-data-find-list @@ -9512,7 +9682,7 @@ not match REGEXP on HEADER." (gnus-data-list backward)))) (when (and (or (not unread) ; We want all articles... (gnus-data-unread-p d)) ; Or just unreads. - (vectorp (gnus-data-header d)) ; It's not a pseudo. + (mail-header-p (gnus-data-header d)) ; It's not a pseudo. (if not-matching (not (string-match regexp @@ -9530,7 +9700,7 @@ article. If BACKWARD (the prefix) is non-nil, search backward instead." (list (let ((completion-ignore-case t)) (gnus-completing-read "Header name" - (mapcar 'symbol-name + (mapcar #'symbol-name (append '(Number Subject From Lines Date Message-ID Xref References Body) @@ -9614,6 +9784,10 @@ to save in." (gnus-summary-remove-process-mark article)) (ps-despool filename)) +(defvar ps-right-header) +(defvar ps-left-header) +(defvar shr-ignore-cache) + (defun gnus-print-buffer () (let ((ps-left-header (list @@ -9700,9 +9874,9 @@ C-u g', show the raw article." (insert ".\n") (let ((nntp-server-buffer (current-buffer))) (setq header (car (gnus-get-newsgroup-headers deps t)))))) - (gnus-data-set-header - (gnus-data-find (cdr gnus-article-current)) - header) + (setf (gnus-data-header + (gnus-data-find (cdr gnus-article-current))) + header) (gnus-summary-update-article-line (cdr gnus-article-current) header) (when (gnus-summary-goto-subject (cdr gnus-article-current) nil t) @@ -9839,7 +10013,7 @@ prefix specifies how many places to rotate each letter forward." ;; Create buttons and stuff... (gnus-treat-article nil)) -(defun gnus-summary-idna-message (&optional arg) +(defun gnus-summary-idna-message (&optional _arg) "Decode IDNA encoded domain names in the current articles. IDNA encoded domain names looks like `xn--bar'. If a string remain unencoded after running this function, it is likely an @@ -9847,7 +10021,7 @@ invalid IDNA string (`xn--bar' is invalid). You must have GNU Libidn (URL `https://www.gnu.org/software/libidn/') installed for this command to work." - (interactive "P") + (interactive) (gnus-summary-select-article) (let ((mail-header-separator "")) (gnus-eval-in-buffer-window gnus-article-buffer @@ -9859,9 +10033,9 @@ installed for this command to work." (replace-match (puny-decode-domain (match-string 1)))) (set-window-start (get-buffer-window (current-buffer)) start)))))) -(defun gnus-summary-morse-message (&optional arg) +(defun gnus-summary-morse-message (&optional _arg) "Morse decode the current article." - (interactive "P") + (interactive) (gnus-summary-select-article) (let ((mail-header-separator "")) (gnus-eval-in-buffer-window gnus-article-buffer @@ -9919,11 +10093,11 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (cond ((and (eq action 'move) (not (gnus-check-backend-function 'request-move-article gnus-newsgroup-name))) - (error "The current group does not support article moving")) + (user-error "The current group does not support article moving")) ((and (eq action 'crosspost) (not (gnus-check-backend-function 'request-replace-article gnus-newsgroup-name))) - (error "The current group does not support article editing"))) + (user-error "The current group does not support article editing"))) (let ((articles (gnus-summary-work-articles n)) (prefix (if (gnus-check-backend-function 'request-move-article gnus-newsgroup-name) @@ -9940,8 +10114,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (unless (assq action names) (error "Unknown action %s" action)) ;; Read the newsgroup name. - (when (and (not to-newsgroup) - (not select-method)) + (unless (or to-newsgroup select-method) (if (and gnus-move-split-methods (not (and (memq gnus-current-article articles) @@ -9986,6 +10159,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (or (car select-method) (gnus-group-decoded-name to-newsgroup)) articles) + ;; This `while' is not equivalent to a `dolist' (bug#33653#134). (while articles (setq article (pop articles)) ;; Set any marks that may have changed in the summary buffer. @@ -9996,8 +10170,9 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (cond ;; Move the article. ((eq action 'move) - ;; Remove this article from future suppression. - (gnus-dup-unsuppress-article article) + (when gnus-suppress-duplicates + ;; Remove this article from future suppression. + (gnus-dup-unsuppress-article article)) (let* ((from-method (gnus-find-method-for-group gnus-newsgroup-name)) (to-method (or select-method @@ -10039,7 +10214,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (setq xref (list (system-name)))) (setq new-xref (concat - (mapconcat 'identity + (mapconcat #'identity (delete "Xref:" (delete new-xref xref)) " ") " " new-xref)) @@ -10072,7 +10247,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (run-hook-with-args 'gnus-summary-article-delete-hook action (gnus-data-header - (assoc article (gnus-data-list nil))) + (gnus-data-find-in article (gnus-data-list nil))) gnus-newsgroup-name nil select-method))) (t @@ -10182,13 +10357,12 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." ;; run the move/copy/crosspost/respool hook (run-hook-with-args 'gnus-summary-article-move-hook action - (gnus-data-header - (assoc article (gnus-data-list nil))) + (gnus-data-header (gnus-data-find article)) gnus-newsgroup-name to-newsgroup select-method)) - ;;;!!!Why is this necessary? + ;;!!!Why is this necessary? (set-buffer gnus-summary-buffer) (when (eq action 'move) @@ -10198,7 +10372,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (push article articles-to-update-marks)) (save-excursion - (apply 'gnus-summary-remove-process-mark articles-to-update-marks)) + (apply #'gnus-summary-remove-process-mark articles-to-update-marks)) ;; Re-activate all groups that have been moved to. (with-current-buffer gnus-group-buffer (let ((gnus-group-marked to-groups)) @@ -10314,16 +10488,19 @@ latter case, they will be copied into the relevant groups." (unless (re-search-forward "^date:" nil t) (goto-char (point-max)) (setq atts (file-attributes file)) - (insert "Date: " (message-make-date (nth 5 atts)) "\n"))) + (insert "Date: " (message-make-date + (file-attribute-modification-time atts)) + "\n"))) ;; This doesn't look like an article, so we fudge some headers. (setq atts (file-attributes file) lines (count-lines (point-min) (point-max))) (insert "From: " (read-string "From: ") "\n" "Subject: " (read-string "Subject: ") "\n" - "Date: " (message-make-date (nth 5 atts)) "\n" + "Date: " (message-make-date + (file-attribute-modification-time atts)) "\n" "Message-ID: " (message-make-message-id) "\n" "Lines: " (int-to-string lines) "\n" - "Chars: " (int-to-string (nth 7 atts)) "\n\n")) + "Chars: " (int-to-string (file-attribute-size atts)) "\n\n")) (setq group-art (gnus-request-accept-article group nil t)) (kill-buffer (current-buffer))) (setq gnus-newsgroup-active (gnus-activate-group group)) @@ -10387,7 +10564,7 @@ This will be the case if the article has both been mailed and posted." (gnus-summary-update-info) (gnus-list-of-read-articles gnus-newsgroup-name)) (setq gnus-newsgroup-expirable - (sort gnus-newsgroup-expirable '<))) + (sort gnus-newsgroup-expirable #'<))) gnus-newsgroup-unexist)) (expiry-wait (if now 'immediate (gnus-group-find-parameter @@ -10423,7 +10600,7 @@ This will be the case if the article has both been mailed and posted." (run-hook-with-args 'gnus-summary-article-expire-hook 'delete - (gnus-data-header (assoc article (gnus-data-list nil))) + (gnus-data-header (gnus-data-find article)) gnus-newsgroup-name (cond ((stringp nnmail-expiry-target) nnmail-expiry-target) @@ -10466,7 +10643,7 @@ confirmation before the articles are deleted." (unless (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name)) (error "Couldn't open server")) ;; Compute the list of articles to delete. - (let ((articles (sort (copy-sequence (gnus-summary-work-articles n)) '<)) + (let ((articles (sort (copy-sequence (gnus-summary-work-articles n)) #'<)) (nnmail-expiry-target 'delete) not-deleted) (if (and gnus-novice-user @@ -10487,8 +10664,7 @@ confirmation before the articles are deleted." (unless (memq (car articles) not-deleted) (gnus-summary-mark-article (car articles) gnus-canceled-mark) (let* ((article (car articles)) - (ghead (gnus-data-header - (assoc article (gnus-data-list nil))))) + (ghead (gnus-data-header (gnus-data-find article)))) (run-hook-with-args 'gnus-summary-article-delete-hook 'delete ghead gnus-newsgroup-name nil nil))) @@ -10547,15 +10723,15 @@ groups." (setq raw t)) (gnus-article-edit-article (if raw 'ignore - `(lambda () - (let ((mbl mml-buffer-list)) - (setq mml-buffer-list nil) - (let ((rfc2047-quote-decoded-words-containing-tspecials t)) - (mime-to-mml ,'current-handles)) - (let ((mbl1 mml-buffer-list)) - (setq mml-buffer-list mbl) - (set (make-local-variable 'mml-buffer-list) mbl1)) - (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))) + (lambda () + (let ((mbl mml-buffer-list)) + (setq mml-buffer-list nil) + (let ((rfc2047-quote-decoded-words-containing-tspecials t)) + (mime-to-mml current-handles)) + (let ((mbl1 mml-buffer-list)) + (setq mml-buffer-list mbl) + (set (make-local-variable 'mml-buffer-list) mbl1)) + (add-hook 'kill-buffer-hook #'mml-destroy-buffers t t)))) `(lambda (no-highlight) (let ((mail-parse-charset ',gnus-newsgroup-charset) (message-options message-options) @@ -10575,7 +10751,7 @@ groups." (mml-to-mime) (mml-destroy-buffers) (remove-hook 'kill-buffer-hook - 'mml-destroy-buffers t) + #'mml-destroy-buffers t) (kill-local-variable 'mml-buffer-list))) (gnus-summary-edit-article-done ,(or (mail-header-references gnus-current-headers) "") @@ -10647,7 +10823,7 @@ groups." (let ((nntp-server-buffer (current-buffer))) (setq header (car (gnus-get-newsgroup-headers nil t)))) (with-current-buffer gnus-summary-buffer - (gnus-data-set-header (gnus-data-find article) header) + (setf (gnus-data-header (gnus-data-find article)) header) (gnus-summary-update-article-line article header) (if (gnus-summary-goto-subject article nil t) (gnus-summary-update-secondary-mark article))))))) @@ -10710,7 +10886,7 @@ groups." (unless silent (if groups (message "This message would go to %s" - (mapconcat 'car groups ", ")) + (mapconcat #'car groups ", ")) (message "This message would go to no groups")) groups))))) @@ -10839,8 +11015,8 @@ the actual number of articles unmarked is returned." (set var (cons article (symbol-value var))) (if (memq type '(processable cached replied forwarded recent saved)) (gnus-summary-update-secondary-mark article) - ;;; !!! This is bogus. We should find out what primary - ;;; !!! mark we want to set. + ;; !!! This is bogus. We should find out what primary + ;; !!! mark we want to set. (gnus-summary-update-mark gnus-del-mark 'unread))))) (defun gnus-summary-mark-as-expirable (n) @@ -11012,7 +11188,7 @@ If NO-EXPIRE, auto-expiry will be inhibited." t (if (<= article 0) (progn - (gnus-error 1 "Can't mark negative article numbers") + (gnus-error 1 "Gnus doesn't know the article number; can't mark") nil) (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked)) (setq gnus-newsgroup-spam-marked @@ -11041,7 +11217,7 @@ If NO-EXPIRE, auto-expiry will be inhibited." ;; See whether the article is to be put in the cache. (and gnus-use-cache - (vectorp (gnus-summary-article-header article)) + (mail-header-p (gnus-summary-article-header article)) (save-excursion (gnus-cache-possibly-enter-article gnus-newsgroup-name article @@ -11088,7 +11264,7 @@ If NO-EXPIRE, auto-expiry will be inhibited." ;; See whether the article is to be put in the cache. (and gnus-use-cache (not (= mark gnus-canceled-mark)) - (vectorp (gnus-summary-article-header article)) + (mail-header-p (gnus-summary-article-header article)) (save-excursion (gnus-cache-possibly-enter-article gnus-newsgroup-name article @@ -11143,7 +11319,7 @@ If NO-EXPIRE, auto-expiry will be inhibited." (re-search-backward "[\n\r]" (point-at-bol) 'move-to-limit) (when forward (when (looking-at "\r") - (incf forward)) + (cl-incf forward)) (when (<= (+ forward (point)) (point-max)) ;; Go to the right position on the line. (goto-char (+ forward (point))) @@ -11156,8 +11332,9 @@ If NO-EXPIRE, auto-expiry will be inhibited." (insert to-insert)) ;; Optionally update the marks by some user rule. (when (eq type 'unread) - (gnus-data-set-mark - (gnus-data-find (gnus-summary-article-number)) mark) + (setf (gnus-data-mark + (gnus-data-find (gnus-summary-article-number))) + mark) (gnus-summary-update-line (eq mark gnus-unread-mark))))))) (defun gnus-mark-article-as-read (article &optional mark) @@ -11184,7 +11361,7 @@ If NO-EXPIRE, auto-expiry will be inhibited." (let ((mark (or mark gnus-ticked-mark))) (if (<= article 0) (progn - (gnus-error 1 "Can't mark negative article numbers") + (gnus-error 1 "Gnus doesn't know the article number; can't mark") nil) (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked) gnus-newsgroup-spam-marked (delq article gnus-newsgroup-spam-marked) @@ -11518,6 +11695,7 @@ read." (defmacro gnus-with-article (article &rest forms) "Select ARTICLE and perform FORMS in the original article buffer. Then replace the article with the result." + (declare (indent 1) (debug t)) `(progn ;; We don't want the article to be marked as read. (let (gnus-mark-article-hook) @@ -11539,9 +11717,6 @@ Then replace the article with the result." (gnus-cache-update-article (car gnus-article-current) (cdr gnus-article-current))))) -(put 'gnus-with-article 'lisp-indent-function 1) -(put 'gnus-with-article 'edebug-form-spec '(form body)) - ;; Thread-based commands. (defun gnus-summary-articles-in-thread (&optional article) @@ -11708,9 +11883,8 @@ Returns nil if no thread was there to be shown." (defun gnus-map-articles (predicate articles) "Map PREDICATE over ARTICLES and return non-nil if any predicate is non-nil." - (apply 'gnus-or (mapcar predicate - (mapcar (lambda (number) - (gnus-summary-article-header number)) + (apply #'gnus-or (mapcar predicate + (mapcar #'gnus-summary-article-header articles)))) (defun gnus-summary-hide-all-threads (&optional predicate) @@ -11723,7 +11897,7 @@ will not be hidden." (let ((end nil) (count 0)) (while (not end) - (incf count) + (cl-incf count) (when (zerop (mod count 1000)) (message "Hiding all threads... %d" count)) (when (or (not predicate) @@ -11795,7 +11969,7 @@ If SILENT, don't output messages." (n (abs n))) (while (and (> n 0) (gnus-summary-go-to-next-thread backward)) - (decf n)) + (cl-decf n)) (unless silent (gnus-summary-position-point)) (when (and (not silent) (/= 0 n)) @@ -11969,10 +12143,10 @@ Argument REVERSE means reverse order." (interactive "P") (gnus-summary-sort 'marks reverse)) -(defun gnus-summary-sort-by-original (&optional reverse) +(defun gnus-summary-sort-by-original (&optional _reverse) "Sort the summary buffer using the default sorting method. Argument REVERSE means reverse order." - (interactive "P") + (interactive) (let* ((inhibit-read-only t) (gnus-summary-prepare-hook nil)) ;; We do the sorting by regenerating the threads. @@ -11982,26 +12156,29 @@ Argument REVERSE means reverse order." (defun gnus-summary-sort (predicate reverse) "Sort summary buffer by PREDICATE. REVERSE means reverse order." - (let* ((thread (intern (format "gnus-thread-sort-by-%s" predicate))) + (let* ((current (gnus-summary-article-number)) + (thread (intern (format "gnus-thread-sort-by-%s" predicate))) (article (intern (format "gnus-article-sort-by-%s" predicate))) (gnus-thread-sort-functions (if (not reverse) thread - `(lambda (t1 t2) - (,thread t2 t1)))) + (lambda (t1 t2) + (funcall thread t2 t1)))) (gnus-sort-gathered-threads-function gnus-thread-sort-functions) (gnus-article-sort-functions (if (not reverse) article - `(lambda (t1 t2) - (,article t2 t1)))) + (lambda (t1 t2) + (funcall article t2 t1)))) (inhibit-read-only t) (gnus-summary-prepare-hook nil)) ;; We do the sorting by regenerating the threads. (gnus-summary-prepare) ;; Hide subthreads if needed. - (gnus-summary-maybe-hide-threads))) + (gnus-summary-maybe-hide-threads) + ;; Restore point. + (gnus-summary-goto-subject current))) ;; Summary saving commands. @@ -12037,7 +12214,7 @@ performed." header file) (dolist (article articles) (setq header (gnus-summary-article-header article)) - (if (not (vectorp header)) + (if (not (mail-header-p header)) ;; This is a pseudo-article. (if (assq 'name header) (gnus-copy-file (cdr (assq 'name header))) @@ -12046,11 +12223,15 @@ performed." (save-window-excursion (gnus-summary-select-article decode decode nil article) (gnus-summary-goto-subject article)) - (with-current-buffer save-buffer - (erase-buffer) - (insert-buffer-substring (if decode - gnus-article-buffer - gnus-original-article-buffer))) + ;; The article may have expired. + (let ((art-buf (if decode + gnus-article-buffer + gnus-original-article-buffer))) + (when (zerop (buffer-size (get-buffer art-buf))) + (error "Couldn't select article %s" article)) + (with-current-buffer save-buffer + (erase-buffer) + (insert-buffer-substring art-buf))) (setq file (gnus-article-save save-buffer file num)) (gnus-summary-remove-process-mark article) (unless not-saved @@ -12255,12 +12436,11 @@ save those articles instead." (nreverse split-name))) (defun gnus-valid-move-group-p (group) - (and (symbolp group) - (boundp group) - (symbol-name group) - (symbol-value group) - (gnus-get-function (gnus-find-method-for-group - (symbol-name group)) 'request-accept-article t))) + (when (and (stringp group) + (null (string-empty-p group))) + (gnus-get-function (gnus-find-method-for-group + group) + 'request-accept-article t))) (defun gnus-read-move-group-name (prompt default articles prefix) "Read a group name." @@ -12271,17 +12451,20 @@ save those articles instead." (if (> (length articles) 1) (format "these %d articles" (length articles)) "this article"))) + (valid-names + (seq-filter #'gnus-valid-move-group-p + (hash-table-keys gnus-active-hashtb))) (to-newsgroup (cond ((null split-name) (gnus-group-completing-read prom - (gnus-remove-if-not 'gnus-valid-move-group-p gnus-active-hashtb t) + valid-names nil prefix nil default)) ((= 1 (length split-name)) (gnus-group-completing-read prom - (gnus-remove-if-not 'gnus-valid-move-group-p gnus-active-hashtb t) + valid-names nil prefix 'gnus-group-history (car split-name))) (t (gnus-completing-read @@ -12293,7 +12476,7 @@ save those articles instead." (string= to-newsgroup prefix)) (setq to-newsgroup default)) (unless to-newsgroup - (error "No group name entered")) + (user-error "No group name entered")) (setq encoded (encode-coding-string to-newsgroup (gnus-group-name-charset to-method to-newsgroup))) @@ -12305,7 +12488,7 @@ save those articles instead." (gnus-activate-group encoded nil nil to-method) (gnus-subscribe-group encoded)) (error "Couldn't create group %s" to-newsgroup))) - (error "No such group: %s" to-newsgroup)) + (user-error "No such group: %s" to-newsgroup)) encoded))) (defvar gnus-summary-save-parts-counter) @@ -12360,7 +12543,7 @@ If REVERSE, save parts that do not match TYPE." (cdr gnus-article-current) gnus-summary-save-parts-counter)))) dir))) - (incf gnus-summary-save-parts-counter) + (cl-incf gnus-summary-save-parts-counter) (unless (file-exists-p file) (mm-save-part-to-file handle file)))))) @@ -12376,7 +12559,7 @@ If REVERSE, save parts that do not match TYPE." ;; If all commands are to be bunched up on one line, we collect ;; them here. (unless gnus-view-pseudos-separately - (let ((ps (setq pslist (sort pslist 'gnus-pseudos<))) + (let ((ps (setq pslist (sort pslist #'gnus-pseudos<))) files action) (while ps (setq action (cdr (assq 'action (car ps)))) @@ -12393,7 +12576,7 @@ If REVERSE, save parts that do not match TYPE." (when (assq 'execute (car ps)) (setcdr (assq 'execute (car ps)) (funcall (if (string-match "%s" action) - 'format 'concat) + #'format #'concat) action (mapconcat (lambda (f) @@ -12531,9 +12714,9 @@ If REVERSE, save parts that do not match TYPE." ;; If we fetched by Message-ID and the article came from ;; a different group (or server), we fudge some bogus ;; article numbers for this article. - (mail-header-set-number header gnus-reffed-article-number)) + (setf (mail-header-number header) gnus-reffed-article-number)) (with-current-buffer gnus-summary-buffer - (decf gnus-reffed-article-number) + (cl-decf gnus-reffed-article-number) (gnus-remove-header (mail-header-number header)) (push header gnus-newsgroup-headers) (setq gnus-current-headers header) @@ -12603,14 +12786,21 @@ If REVERSE, save parts that do not match TYPE." (c cond) (list gnus-summary-highlight)) (while list - (setcdr c (cons (list (caar list) (list 'quote (cdar list))) - nil)) + (setcdr c `((,(caar list) ',(cdar list)))) (setq c (cdr c) list (cdr list))) - (gnus-byte-compile (list 'lambda nil cond)))))) + (gnus-byte-compile + `(lambda () + (with-no-warnings ;See docstring of gnus-summary-highlight. + (defvar score) (defvar default) (defvar default-high) + (defvar default-low) (defvar mark) (defvar uncached)) + ,cond)))))) (defun gnus-summary-highlight-line () "Highlight current line according to `gnus-summary-highlight'." + (with-no-warnings ;See docstring of gnus-summary-highlight. + (defvar score) (defvar default) (defvar default-high) (defvar default-low) + (defvar mark) (defvar uncached)) (let* ((beg (point-at-bol)) (article (or (gnus-summary-article-number) gnus-current-article)) (score (or (cdr (assq article @@ -12692,6 +12882,7 @@ UNREAD is a sorted list." `(progn (gnus-info-set-marks ',info ',(gnus-info-marks info) t) (gnus-info-set-read ',info ',(gnus-info-read info)) + (gnus-group-jump-to-group ,group) (gnus-get-unread-articles-in-group ',info (gnus-active ,group)) (gnus-group-update-group ,group t) @@ -12812,7 +13003,7 @@ treated as multipart/mixed." (defun gnus-summary-make-all-marking-commands () (define-key gnus-summary-mark-map "M" gnus-summary-generic-mark-map) (dolist (elem gnus-summary-marking-alist) - (apply 'gnus-summary-make-marking-command elem))) + (apply #'gnus-summary-make-marking-command elem))) (defun gnus-summary-make-marking-command (name mark keystroke) (let ((map (make-sparse-keymap))) @@ -12916,7 +13107,7 @@ returned." (mail-header-number (car gnus-newsgroup-headers)) gnus-newsgroup-end (mail-header-number - (gnus-last-element gnus-newsgroup-headers)))) + (car (last gnus-newsgroup-headers))))) (when gnus-use-scoring (gnus-possibly-score-headers)))) @@ -12926,7 +13117,7 @@ If ALL is non-nil, already read articles become readable. If ALL is a number, fetch this number of articles." (interactive "P") (prog1 - (let ((old (sort (mapcar 'car gnus-newsgroup-data) '<)) + (let ((old (sort (mapcar #'gnus-data-number gnus-newsgroup-data) #'<)) older len) (setq older ;; Some nntp servers lie about their active range. When @@ -12996,19 +13187,19 @@ If ALL is a number, fetch this number of articles." (defun gnus-summary-insert-new-articles () "Insert all new articles in this group." (interactive) - (let ((old (sort (mapcar 'car gnus-newsgroup-data) '<)) + (let ((old (sort (mapcar #'gnus-data-number gnus-newsgroup-data) #'<)) (old-high gnus-newsgroup-highest) (nnmail-fetched-sources (list t)) (new-active (gnus-activate-group gnus-newsgroup-name 'scan)) i new) (unless new-active (error "Couldn't fetch new data")) - (setq gnus-newsgroup-active (gnus-copy-sequence new-active)) + (setq gnus-newsgroup-active (copy-tree new-active)) (setq i (cdr gnus-newsgroup-active) gnus-newsgroup-highest i) (while (> i old-high) (push i new) - (decf i)) + (cl-decf i)) (if (not new) (message "No gnus is bad news") (gnus-summary-insert-articles new) diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index f7d1885fd6d..e2c728df8f4 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -25,12 +25,14 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-group) (require 'gnus-start) (require 'gnus-util) +(eval-when-compile + (require 'subr-x)) (defgroup gnus-topic nil "Group topics." @@ -85,7 +87,7 @@ See Info node `(gnus)Formatting Variables'." (defvar gnus-topic-inhibit-change-level nil) (defconst gnus-topic-line-format-alist - `((?n name ?s) + '((?n name ?s) (?v visible ?s) (?i indentation ?s) (?g number-of-groups ?d) @@ -99,8 +101,7 @@ See Info node `(gnus)Formatting Variables'." (defun gnus-group-topic-name () "The name of the topic on the current line." - (let ((topic (get-text-property (point-at-bol) 'gnus-topic))) - (and topic (symbol-name topic)))) + (get-text-property (point-at-bol) 'gnus-topic)) (defun gnus-group-topic-level () "The level of the topic on the current line." @@ -128,7 +129,7 @@ See Info node `(gnus)Formatting Variables'." number) (while entries (when (numberp (setq number (car (pop entries)))) - (incf total number))) + (cl-incf total number))) total)) (defun gnus-group-topic (group) @@ -144,8 +145,7 @@ See Info node `(gnus)Formatting Variables'." (defun gnus-topic-goto-topic (topic) (when topic - (gnus-goto-char (text-property-any (point-min) (point-max) - 'gnus-topic (intern topic))))) + (gnus-text-property-search 'gnus-topic topic nil 'goto))) (defun gnus-topic-jump-to-topic (topic) "Go to TOPIC." @@ -167,8 +167,7 @@ See Info node `(gnus)Formatting Variables'." (point) 'gnus-topic)) (get-text-property (max (1- (point)) (point-min)) 'gnus-topic)))))) - (when result - (symbol-name result)))) + result)) (defun gnus-current-topics (&optional topic) "Return a list of all current topics, lowest in hierarchy first. @@ -195,7 +194,7 @@ If RECURSIVE is t, return groups in its subtopics too." (while groups (when (setq group (pop groups)) (setq entry (gnus-group-entry group) - info (nth 2 entry) + info (nth 1 entry) params (gnus-info-params info) active (gnus-active group) unread (or (car entry) @@ -220,6 +219,8 @@ If RECURSIVE is t, return groups in its subtopics too." ;; Check for permanent visibility. (and gnus-permanently-visible-groups (string-match gnus-permanently-visible-groups group)) + ;; Marked groups are always visible. + (member group gnus-group-marked) (memq 'visible params) (cdr (assq 'visible params))) ;; Add this group to the list of visible groups. @@ -302,7 +303,7 @@ If RECURSIVE is t, return groups in its subtopics too." (while (and (not (zerop num)) (setq topic (funcall way topic))) (when (gnus-topic-goto-topic topic) - (decf num))) + (cl-decf num))) (unless (zerop num) (goto-char (point-max))) num)) @@ -458,9 +459,9 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." (unless gnus-killed-hashtb (gnus-make-hashtable-from-killed)) (gnus-group-prepare-flat-list-dead - (gnus-remove-if (lambda (group) + (seq-remove (lambda (group) (or (gnus-group-entry group) - (gnus-gethash group gnus-killed-hashtb))) + (gethash group gnus-killed-hashtb))) not-in-list) gnus-level-killed ?K regexp))) @@ -508,7 +509,7 @@ articles in the topic and its subtopics." info entry end active tick) ;; Insert any sub-topics. (while topicl - (incf unread + (cl-incf unread (gnus-topic-prepare-topic (pop topicl) (1+ level) list-level predicate (not visiblep) lowest regexp))) @@ -534,7 +535,7 @@ articles in the topic and its subtopics." (funcall regexp entry)) ((null regexp) t) (t nil)))) - (setq info (nth 2 entry)) + (setq info (nth 1 entry)) (gnus-group-prepare-logic (gnus-info-group info) (and (or (not gnus-group-listed-groups) @@ -555,14 +556,14 @@ articles in the topic and its subtopics." (car active)) nil) ;; Living groups. - (when (setq info (nth 2 entry)) + (when (setq info (nth 1 entry)) (gnus-group-insert-group-line (gnus-info-group info) (gnus-info-level info) (gnus-info-marks info) (car entry) (gnus-info-method info))))) (when (and (listp entry) (numberp (car entry))) - (incf unread (car entry))) + (cl-incf unread (car entry))) (when (listp entry) (setq tick t)))) (goto-char beg) @@ -644,7 +645,7 @@ articles in the topic and its subtopics." (point) (prog1 (1+ (point)) (eval gnus-topic-line-format-spec)) - (list 'gnus-topic (intern name) + (list 'gnus-topic name 'gnus-topic-level level 'gnus-topic-unread unread 'gnus-active active-topic @@ -728,10 +729,10 @@ articles in the topic and its subtopics." (cdr gnus-group-list-mode))) entry) (while children - (incf unread (gnus-topic-unread (caar (pop children))))) + (cl-incf unread (gnus-topic-unread (caar (pop children))))) (while (setq entry (pop entries)) (when (numberp (car entry)) - (incf unread (car entry)))) + (cl-incf unread (car entry)))) (gnus-topic-insert-topic-line topic t t (car (gnus-topic-find-topology topic)) nil unread))) @@ -772,10 +773,10 @@ articles in the topic and its subtopics." (if reads (setq unread (- (gnus-group-topic-unread) reads)) (while children - (incf unread (gnus-topic-unread (caar (pop children))))) + (cl-incf unread (gnus-topic-unread (caar (pop children))))) (while (setq entry (pop entries)) (when (numberp (car entry)) - (incf unread (car entry))))) + (cl-incf unread (car entry))))) (setq old-unread (gnus-group-topic-unread)) ;; Insert the topic line. (gnus-topic-insert-topic-line @@ -842,10 +843,9 @@ articles in the topic and its subtopics." ;; they belong to some topic. (let* ((tgroups (apply 'append (mapcar 'cdr gnus-topic-alist))) (entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist))) - (newsrc (cdr gnus-newsrc-alist)) - group) - (while newsrc - (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups) + (groups (cdr gnus-group-list))) + (dolist (group groups) + (unless (member group tgroups) (setcdr entry (list group)) (setq entry (cdr entry))))) ;; Go through all topics and make sure they contain only living groups. @@ -886,7 +886,7 @@ articles in the topic and its subtopics." (while (setq group (pop topic)) (when (and (or (gnus-active group) (gnus-info-method (gnus-get-info group))) - (not (gnus-gethash group gnus-killed-hashtb))) + (not (gethash group gnus-killed-hashtb))) (push group filtered-topic))) (push (cons topic-name (nreverse filtered-topic)) result))) (setq gnus-topic-alist (nreverse result)))) @@ -896,7 +896,7 @@ articles in the topic and its subtopics." (with-current-buffer gnus-group-buffer (let ((inhibit-read-only t)) (unless gnus-topic-inhibit-change-level - (gnus-group-goto-group (or (car (nth 2 previous)) group)) + (gnus-group-goto-group (or (car (nth 1 previous)) group)) (when (and gnus-topic-mode gnus-topic-alist (not gnus-topic-inhibit-change-level)) @@ -954,7 +954,7 @@ articles in the topic and its subtopics." (if (not group) (if (not (memq 'gnus-topic props)) (goto-char (point-max)) - (let ((topic (symbol-name (cadr (memq 'gnus-topic props))))) + (let ((topic (cadr (memq 'gnus-topic props)))) (or (gnus-topic-goto-topic topic) (gnus-topic-goto-topic (gnus-topic-next-topic topic))))) (if (gnus-group-goto-group group) @@ -990,12 +990,8 @@ articles in the topic and its subtopics." ;; First we make sure that we have really read the active file. (when (or force (not gnus-topic-active-alist)) - (let (groups) - ;; Get a list of all groups available. - (mapatoms (lambda (g) (when (symbol-value g) - (push (symbol-name g) groups))) - gnus-active-hashtb) - (setq groups (sort groups 'string<)) + ;; Get a list of all groups available. + (let ((groups (sort (hash-table-keys gnus-active-hashtb) #'string<))) ;; Init the variables. (setq gnus-topic-active-topology (list (list "" 'visible))) (setq gnus-topic-active-alist nil) @@ -1200,7 +1196,7 @@ If performed over a topic line, toggle folding the topic." (save-excursion (gnus-message 5 "Expiring groups in %s..." topic) (let ((gnus-group-marked - (mapcar (lambda (entry) (car (nth 2 entry))) + (mapcar (lambda (entry) (car (nth 1 entry))) (gnus-topic-find-groups topic gnus-level-killed t nil t)))) (gnus-group-expire-articles nil)) @@ -1214,7 +1210,7 @@ Also see `gnus-group-catchup'." (call-interactively 'gnus-group-catchup-current) (save-excursion (let* ((groups - (mapcar (lambda (entry) (car (nth 2 entry))) + (mapcar (lambda (entry) (car (nth 1 entry))) (gnus-topic-find-groups topic gnus-level-killed t nil t))) (inhibit-read-only t) @@ -1447,7 +1443,7 @@ If NON-RECURSIVE (which is the prefix) is t, don't mark its subtopics." (not non-recursive)))) (while groups (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) - (gnus-info-group (nth 2 (pop groups))))))))) + (gnus-info-group (nth 1 (pop groups))))))))) (defun gnus-topic-unmark-topic (topic &optional _dummy non-recursive) "Remove the process mark from all groups in the TOPIC. diff --git a/lisp/gnus/gnus-undo.el b/lisp/gnus/gnus-undo.el index c5c920e2ea2..179679a8298 100644 --- a/lisp/gnus/gnus-undo.el +++ b/lisp/gnus/gnus-undo.el @@ -43,8 +43,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'gnus-util) (require 'gnus) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index ae8cd45672e..9ccdb83865c 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -32,16 +32,17 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) +(require 'seq) (require 'time-date) +(require 'text-property-search) (defcustom gnus-completing-read-function 'gnus-emacs-completing-read "Function use to do completing read." :version "24.1" :group 'gnus-meta - :type `(radio (function-item + :type '(radio (function-item :doc "Use Emacs standard `completing-read' function." gnus-emacs-completing-read) (function-item @@ -105,22 +106,9 @@ This is a compatibility function for different Emacsen." (put 'gnus-eval-in-buffer-window 'lisp-indent-function 1) (put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body)) -(defmacro gnus-intern-safe (string hashtable) - "Get hash value. Arguments are STRING and HASHTABLE." - `(let ((symbol (intern ,string ,hashtable))) - (or (boundp symbol) - (set symbol nil)) - symbol)) - (defsubst gnus-goto-char (point) (and point (goto-char point))) -(defmacro gnus-buffer-exists-p (buffer) - `(let ((buffer ,buffer)) - (when buffer - (funcall (if (stringp buffer) 'get-buffer 'buffer-name) - buffer)))) - (defun gnus-delete-first (elt list) "Delete by side effect the first occurrence of ELT as a member of LIST." (if (equal (car list) elt) @@ -142,7 +130,7 @@ This is a compatibility function for different Emacsen." "Extract address components from a From header. Given an RFC-822 (or later) address FROM, extract name and address. Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). Much more simple -solution than `mail-extract-address-components', which works much better, but +solution than `mail-header-parse-address', which works much better, but is slower." (let (name address) ;; First find the address - the thing with the @ in it. This may @@ -200,6 +188,36 @@ is slower." (search-forward ":" eol t) (point))))) +(defun gnus-text-property-search (prop value &optional forward-only goto end) + "Search current buffer for text property PROP with VALUE. +Behaves like a combination of `text-property-any' and +`text-property-search-forward'. Searches for the beginning of a +text property `equal' to VALUE. Returns the value of point at +the beginning of the matching text property span. + +If FORWARD-ONLY is non-nil, only search forward from point. + +If GOTO is non-nil, move point to the beginning of that span +instead. + +If END is non-nil, use the end of the span instead." + (let* ((start (point)) + (found (progn + (unless forward-only + (goto-char (point-min))) + (text-property-search-forward + prop value #'equal))) + (target (when found + (if end + (prop-match-end found) + (prop-match-beginning found))))) + (when target + (if goto + (goto-char target) + (prog1 + target + (goto-char start)))))) + (declare-function gnus-find-method-for-group "gnus" (group &optional info)) (declare-function gnus-group-name-decode "gnus-group" (string charset)) (declare-function gnus-group-name-charset "gnus-group" (method group)) @@ -278,10 +296,7 @@ Symbols are also allowed; their print names are used instead." ;;; Time functions. (defun gnus-file-newer-than (file date) - (let ((fdate (nth 5 (file-attributes file)))) - (or (> (car fdate) (car date)) - (and (= (car fdate) (car date)) - (> (nth 1 fdate) (nth 1 date)))))) + (time-less-p date (file-attribute-modification-time (file-attributes file)))) ;;; Keymap macros. @@ -344,20 +359,26 @@ Symbols are also allowed; their print names are used instead." (defun gnus-seconds-today () "Return the number of seconds passed today." (let ((now (decode-time))) - (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)))) + (+ (decoded-time-second now) + (* (decoded-time-minute now) 60) + (* (decoded-time-hour now) 3600)))) (defun gnus-seconds-month () "Return the number of seconds passed this month." (let ((now (decode-time))) - (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) - (* (- (car (nthcdr 3 now)) 1) 3600 24)))) + (+ (decoded-time-second now) + (* (decoded-time-minute now) 60) + (* (decoded-time-hour now) 3600) + (* (- (decoded-time-day now) 1) 3600 24)))) (defun gnus-seconds-year () "Return the number of seconds passed this year." (let* ((current (current-time)) (now (decode-time current)) (days (format-time-string "%j" current))) - (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) + (+ (decoded-time-second now) + (* (decoded-time-minute now) 60) + (* (decoded-time-hour now) 3600) (* (- (string-to-number days) 1) 3600 24)))) (defmacro gnus-date-get-time (date) @@ -394,22 +415,9 @@ Cache the result as a text property stored in DATE." "Quote all \"%\"'s in STRING." (replace-regexp-in-string "%" "%%" string)) -;; Make a hash table (default and minimum size is 256). -;; Optional argument HASHSIZE specifies the table size. -(defun gnus-make-hashtable (&optional hashsize) - (make-vector (if hashsize (max (gnus-create-hash-size hashsize) 256) 256) 0)) - -;; Make a number that is suitable for hashing; bigger than MIN and -;; equal to some 2^x. Many machines (such as sparcs) do not have a -;; hardware modulo operation, so they implement it in software. On -;; many sparcs over 50% of the time to intern is spent in the modulo. -;; Yes, it's slower than actually computing the hash from the string! -;; So we use powers of 2 so people can optimize the modulo to a mask. -(defun gnus-create-hash-size (min) - (let ((i 1)) - (while (< i min) - (setq i (* 2 i))) - i)) +(defsubst gnus-make-hashtable (&optional size) + "Make a hash table of SIZE, testing on `equal'." + (make-hash-table :size (or size 300) :test #'equal)) (defcustom gnus-verbose 6 "Integer that says how verbose Gnus should be. @@ -554,8 +562,12 @@ If N, return the Nth ancestor instead." (match-string 1 references)))))) (defsubst gnus-buffer-live-p (buffer) - "Say whether BUFFER is alive or not." - (and buffer (buffer-live-p (get-buffer buffer)))) + "If BUFFER names a live buffer, return its object; else nil." + (and buffer (buffer-live-p (setq buffer (get-buffer buffer))) + buffer)) + +(define-obsolete-function-alias 'gnus-buffer-exists-p + 'gnus-buffer-live-p "27.1") (defun gnus-horizontal-recenter () "Recenter the current buffer horizontally." @@ -1117,41 +1129,9 @@ ARG is passed to the first function." (with-current-buffer gnus-group-buffer (eq major-mode 'gnus-group-mode)))) -(defun gnus-remove-if (predicate sequence &optional hash-table-p) - "Return a copy of SEQUENCE with all items satisfying PREDICATE removed. -SEQUENCE should be a list, a vector, or a string. Returns always a list. -If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table." - (let (out) - (if hash-table-p - (mapatoms (lambda (symbol) - (unless (funcall predicate symbol) - (push symbol out))) - sequence) - (unless (listp sequence) - (setq sequence (append sequence nil))) - (while sequence - (unless (funcall predicate (car sequence)) - (push (car sequence) out)) - (setq sequence (cdr sequence)))) - (nreverse out))) - -(defun gnus-remove-if-not (predicate sequence &optional hash-table-p) - "Return a copy of SEQUENCE with all items not satisfying PREDICATE removed. -SEQUENCE should be a list, a vector, or a string. Returns always a list. -If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table." - (let (out) - (if hash-table-p - (mapatoms (lambda (symbol) - (when (funcall predicate symbol) - (push symbol out))) - sequence) - (unless (listp sequence) - (setq sequence (append sequence nil))) - (while sequence - (when (funcall predicate (car sequence)) - (push (car sequence) out)) - (setq sequence (cdr sequence)))) - (nreverse out))) +(define-obsolete-function-alias 'gnus-remove-if 'seq-remove "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." @@ -1185,20 +1165,13 @@ If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table." (eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t) (text-property-any b e 'gnus-undeletable t))) -(defun gnus-or (&rest elems) - "Return non-nil if any of the elements are non-nil." - (catch 'found - (while elems - (when (pop elems) - (throw 'found t))))) - -(defun gnus-and (&rest elems) - "Return non-nil if all of the elements are non-nil." - (catch 'found - (while elems - (unless (pop elems) - (throw 'found nil))) - t)) +(defun gnus-or (&rest elements) + "Return non-nil if any one of ELEMENTS is non-nil." + (seq-drop-while #'null elements)) + +(defun gnus-and (&rest elements) + "Return non-nil if all ELEMENTS are non-nil." + (not (memq nil elements))) ;; gnus.el requires mm-util. (declare-function mm-disable-multibyte "mm-util") @@ -1210,18 +1183,16 @@ If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table." ;; The buffer should be in the unibyte mode because group names ;; are ASCII text or encoded non-ASCII text (i.e., unibyte). (mm-disable-multibyte) - (mapatoms - (lambda (sym) - (when (and sym - (boundp sym) - (symbol-value sym)) - (insert (format "%S %d %d y\n" + (maphash + (lambda (group active) + (when active + (insert (format "%s %d %d y\n" (if full-names - sym - (intern (gnus-group-real-name (symbol-name sym)))) - (or (cdr (symbol-value sym)) - (car (symbol-value sym))) - (car (symbol-value sym)))))) + group + (gnus-group-real-name group)) + (or (cdr active) + (car active)) + (car active))))) hashtb) (goto-char (point-max)) (while (search-backward "\\." nil t) @@ -1440,7 +1411,7 @@ SPEC is a predicate specifier that contains stuff like `or', `and', (symbol-value history) collection)) filtered-choices) (dolist (x choices) - (setq filtered-choices (adjoin x filtered-choices))) + (setq filtered-choices (cl-adjoin x filtered-choices))) (nreverse filtered-choices)))))) (unwind-protect (progn @@ -1467,7 +1438,7 @@ SPEC is a predicate specifier that contains stuff like `or', `and', (defun gnus-cache-file-contents (file variable function) "Cache the contents of FILE in VARIABLE. The contents come from FUNCTION." - (let ((time (nth 5 (file-attributes file))) + (let ((time (file-attribute-modification-time (file-attributes file))) contents value) (if (or (null (setq value (symbol-value variable))) (not (equal (car value) file)) @@ -1648,8 +1619,7 @@ empty directories from OLD-PATH." "Rescale IMAGE to SIZE if possible. SIZE is in format (WIDTH . HEIGHT). Return a new image. Sizes are in pixels." - (if (or (not (fboundp 'imagemagick-types)) - (not (get-buffer-window (current-buffer)))) + (if (not (fboundp 'imagemagick-types)) image (let ((new-width (car size)) (new-height (cdr size))) diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el index 9907bb5cf5b..253ee24f32c 100644 --- a/lisp/gnus/gnus-uu.el +++ b/lisp/gnus/gnus-uu.el @@ -26,7 +26,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-art) @@ -2047,7 +2047,7 @@ If no file has been included, the user will be asked for a file." (setq length (count-lines (point-min) (point-max))) (setq parts (/ length gnus-uu-post-length)) (unless (< (% length gnus-uu-post-length) 4) - (incf parts))) + (cl-incf parts))) (when gnus-uu-post-separate-description (forward-line -1)) @@ -2106,7 +2106,7 @@ If no file has been included, the user will be asked for a file." (insert-buffer-substring uubuf beg end) (insert beg-line "\n") (setq beg end) - (incf i) + (cl-incf i) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$") nil t) diff --git a/lisp/gnus/gnus-vm.el b/lisp/gnus/gnus-vm.el index 98a362f6426..6042365c74f 100644 --- a/lisp/gnus/gnus-vm.el +++ b/lisp/gnus/gnus-vm.el @@ -34,12 +34,6 @@ (require 'gnus) (require 'gnus-msg) -(eval-when-compile - (require 'cl)) - -(autoload 'vm-mode "vm") -(autoload 'vm-save-message "vm") - (defvar gnus-vm-inhibit-window-system nil "Inhibit loading `win-vm' if using a window-system. Has to be set before gnus-vm is loaded.") @@ -49,6 +43,8 @@ Has to be set before gnus-vm is loaded.") (when window-system (require 'win-vm)))) +(declare-function vm-mode "ext:vm" (&optional read-only)) + (defun gnus-vm-make-folder (&optional buffer) (require 'vm) (let ((article (or buffer (current-buffer))) @@ -81,6 +77,8 @@ save those articles instead." (let ((gnus-default-article-saver 'gnus-summary-save-in-vm)) (gnus-summary-save-article arg))) +(declare-function vm-save-message "ext:vm-save" (folder &optional count)) + (defun gnus-summary-save-in-vm (&optional folder) (interactive) (require 'vm) diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el index 4df6b039a4c..e6906e99bb2 100644 --- a/lisp/gnus/gnus-win.el +++ b/lisp/gnus/gnus-win.el @@ -24,10 +24,11 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-util) +(require 'seq) (defgroup gnus-windows nil "Window configuration." @@ -269,7 +270,7 @@ See the Gnus manual for an explanation of the syntax used.") (error "Invalid buffer type: %s" type)) (let ((buf (gnus-get-buffer-create (gnus-window-to-buffer-helper buffer)))) - (when (buffer-name buf) + (when (buffer-live-p buf) (cond ((eq buf (window-buffer (selected-window))) (set-buffer buf)) @@ -284,7 +285,7 @@ See the Gnus manual for an explanation of the syntax used.") ;; from a hard-dedicated frame, it creates (and ;; configures) a new frame, leaving the dedicated frame alone. (pop-to-buffer buf)) - (t (switch-to-buffer buf))))) + (t (pop-to-buffer-same-window buf))))) (when (memq 'frame-focus split) (setq gnus-window-frame-focus window)) ;; We return the window if it has the `point' spec. @@ -312,7 +313,7 @@ See the Gnus manual for an explanation of the syntax used.") ;; Select the frame in question and do more splits there. (select-frame frame) (setq fresult (or (gnus-configure-frame (elt subs i)) fresult)) - (incf i)) + (cl-incf i)) ;; Select the frame that has the selected buffer. (when fresult (select-frame (window-frame fresult))))) @@ -344,7 +345,7 @@ See the Gnus manual for an explanation of the syntax used.") ((eq type 'vertical) (setq s (max s window-min-height)))) (setcar (cdar comp-subs) s) - (incf total s))) + (cl-incf total s))) ;; Take care of the "1.0" spec. (if rest (setcar (cdr rest) (- len total)) @@ -429,20 +430,13 @@ See the Gnus manual for an explanation of the syntax used.") (defun gnus-delete-windows-in-gnusey-frames () "Do a `delete-other-windows' in all frames that have Gnus windows." (let ((buffers (gnus-buffers))) - (mapcar - (lambda (frame) - (unless (eq (cdr (assq 'minibuffer - (frame-parameters frame))) - 'only) - (select-frame frame) - (let (do-delete) - (walk-windows - (lambda (window) - (when (memq (window-buffer window) buffers) - (setq do-delete t)))) - (when do-delete - (delete-other-windows))))) - (frame-list)))) + (dolist (frame (frame-list)) + (unless (eq (frame-parameter frame 'minibuffer) 'only) + (select-frame frame) + (when (get-window-with-predicate + (lambda (window) + (memq (window-buffer window) buffers))) + (delete-other-windows)))))) (defun gnus-all-windows-visible-p (split) "Say whether all buffers in SPLIT are currently visible. @@ -490,11 +484,10 @@ should have point." (nth 1 (window-edges window))) (defun gnus-remove-some-windows () - (let ((buffers (gnus-buffers)) - buf bufs lowest-buf lowest) + (let (bufs lowest-buf lowest) (save-excursion ;; Remove windows on all known Gnus buffers. - (while (setq buf (pop buffers)) + (dolist (buf (gnus-buffers)) (when (get-buffer-window buf) (push buf bufs) (pop-to-buffer buf) @@ -505,19 +498,19 @@ should have point." (when lowest-buf (pop-to-buffer lowest-buf) (set-buffer nntp-server-buffer)) - (mapcar (lambda (b) (delete-windows-on b t)) - (delq lowest-buf bufs))))) + (dolist (b (delq lowest-buf bufs)) + (delete-windows-on b t))))) (defun gnus-get-buffer-window (buffer &optional frame) - (cond ((and (null gnus-use-frames-on-any-display) - (memq frame '(t 0 visible))) - (car - (let ((frames (frames-on-display-list))) - (gnus-remove-if (lambda (win) (not (memq (window-frame win) - frames))) - (get-buffer-window-list buffer nil frame))))) - (t - (get-buffer-window buffer frame)))) + "Return a window currently displaying BUFFER, or nil if none. +Like `get-buffer-window', but respecting +`gnus-use-frames-on-any-display'." + (if (and (not gnus-use-frames-on-any-display) + (memq frame '(t 0 visible))) + (let ((frames (frames-on-display-list))) + (seq-find (lambda (win) (memq (window-frame win) frames)) + (get-buffer-window-list buffer nil frame))) + (get-buffer-window buffer frame))) (provide 'gnus-win) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 4437ee972e2..9ee7db9e203 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -1,4 +1,4 @@ -;;; gnus.el --- a newsreader for GNU Emacs +;;; gnus.el --- a newsreader for GNU Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1987-1990, 1993-1998, 2000-2019 Free Software ;; Foundation, Inc. @@ -29,10 +29,12 @@ (run-hooks 'gnus-load-hook) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib) + (require 'subr-x)) (require 'wid-edit) (require 'mm-util) (require 'nnheader) +(require 'seq) ;; These are defined afterwards with gnus-define-group-parameter (defvar gnus-ham-process-destinations) @@ -335,21 +337,6 @@ be set in `.emacs' instead." ;; We define these group faces here to avoid the display ;; update forced when creating new faces. -(defface gnus-group-news-1 - '((((class color) - (background dark)) - (:foreground "PaleTurquoise" :bold t)) - (((class color) - (background light)) - (:foreground "ForestGreen" :bold t)) - (t - ())) - "Level 1 newsgroup face." - :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-1-face 'face-alias 'gnus-group-news-1) -(put 'gnus-group-news-1-face 'obsolete-face "22.1") - (defface gnus-group-news-1-empty '((((class color) (background dark)) @@ -361,24 +348,11 @@ be set in `.emacs' instead." ())) "Level 1 empty newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-1-empty-face 'face-alias 'gnus-group-news-1-empty) -(put 'gnus-group-news-1-empty-face 'obsolete-face "22.1") -(defface gnus-group-news-2 - '((((class color) - (background dark)) - (:foreground "turquoise" :bold t)) - (((class color) - (background light)) - (:foreground "CadetBlue4" :bold t)) - (t - ())) - "Level 2 newsgroup face." +(defface gnus-group-news-1 + '((t (:inherit gnus-group-news-1-empty :bold t))) + "Level 1 newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-2-face 'face-alias 'gnus-group-news-2) -(put 'gnus-group-news-2-face 'obsolete-face "22.1") (defface gnus-group-news-2-empty '((((class color) @@ -391,24 +365,11 @@ be set in `.emacs' instead." ())) "Level 2 empty newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-2-empty-face 'face-alias 'gnus-group-news-2-empty) -(put 'gnus-group-news-2-empty-face 'obsolete-face "22.1") -(defface gnus-group-news-3 - '((((class color) - (background dark)) - (:bold t)) - (((class color) - (background light)) - (:bold t)) - (t - ())) - "Level 3 newsgroup face." +(defface gnus-group-news-2 + '((t (:inherit gnus-group-news-2-empty :bold t))) + "Level 2 newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-3-face 'face-alias 'gnus-group-news-3) -(put 'gnus-group-news-3-face 'obsolete-face "22.1") (defface gnus-group-news-3-empty '((((class color) @@ -421,24 +382,11 @@ be set in `.emacs' instead." ())) "Level 3 empty newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-3-empty-face 'face-alias 'gnus-group-news-3-empty) -(put 'gnus-group-news-3-empty-face 'obsolete-face "22.1") -(defface gnus-group-news-4 - '((((class color) - (background dark)) - (:bold t)) - (((class color) - (background light)) - (:bold t)) - (t - ())) - "Level 4 newsgroup face." +(defface gnus-group-news-3 + '((t (:inherit gnus-group-news-3-empty :bold t))) + "Level 3 newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-4-face 'face-alias 'gnus-group-news-4) -(put 'gnus-group-news-4-face 'obsolete-face "22.1") (defface gnus-group-news-4-empty '((((class color) @@ -451,24 +399,11 @@ be set in `.emacs' instead." ())) "Level 4 empty newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-4-empty-face 'face-alias 'gnus-group-news-4-empty) -(put 'gnus-group-news-4-empty-face 'obsolete-face "22.1") -(defface gnus-group-news-5 - '((((class color) - (background dark)) - (:bold t)) - (((class color) - (background light)) - (:bold t)) - (t - ())) - "Level 5 newsgroup face." +(defface gnus-group-news-4 + '((t (:inherit gnus-group-news-4-empty :bold t))) + "Level 4 newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-5-face 'face-alias 'gnus-group-news-5) -(put 'gnus-group-news-5-face 'obsolete-face "22.1") (defface gnus-group-news-5-empty '((((class color) @@ -481,24 +416,11 @@ be set in `.emacs' instead." ())) "Level 5 empty newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-5-empty-face 'face-alias 'gnus-group-news-5-empty) -(put 'gnus-group-news-5-empty-face 'obsolete-face "22.1") -(defface gnus-group-news-6 - '((((class color) - (background dark)) - (:bold t)) - (((class color) - (background light)) - (:bold t)) - (t - ())) - "Level 6 newsgroup face." +(defface gnus-group-news-5 + '((t (:inherit gnus-group-news-5-empty :bold t))) + "Level 5 newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-6-face 'face-alias 'gnus-group-news-6) -(put 'gnus-group-news-6-face 'obsolete-face "22.1") (defface gnus-group-news-6-empty '((((class color) @@ -511,24 +433,11 @@ be set in `.emacs' instead." ())) "Level 6 empty newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-6-empty-face 'face-alias 'gnus-group-news-6-empty) -(put 'gnus-group-news-6-empty-face 'obsolete-face "22.1") -(defface gnus-group-news-low - '((((class color) - (background dark)) - (:foreground "DarkTurquoise" :bold t)) - (((class color) - (background light)) - (:foreground "DarkGreen" :bold t)) - (t - ())) - "Low level newsgroup face." +(defface gnus-group-news-6 + '((t (:inherit gnus-group-news-6-empty :bold t))) + "Level 6 newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-low-face 'face-alias 'gnus-group-news-low) -(put 'gnus-group-news-low-face 'obsolete-face "22.1") (defface gnus-group-news-low-empty '((((class color) @@ -541,24 +450,11 @@ be set in `.emacs' instead." ())) "Low level empty newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-low-empty-face 'face-alias 'gnus-group-news-low-empty) -(put 'gnus-group-news-low-empty-face 'obsolete-face "22.1") -(defface gnus-group-mail-1 - '((((class color) - (background dark)) - (:foreground "#e1ffe1" :bold t)) - (((class color) - (background light)) - (:foreground "DeepPink3" :bold t)) - (t - (:bold t))) - "Level 1 mailgroup face." +(defface gnus-group-news-low + '((t (:inherit gnus-group-news-low-empty :bold t))) + "Low level newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-mail-1-face 'face-alias 'gnus-group-mail-1) -(put 'gnus-group-mail-1-face 'obsolete-face "22.1") (defface gnus-group-mail-1-empty '((((class color) @@ -568,27 +464,14 @@ be set in `.emacs' instead." (background light)) (:foreground "DeepPink3")) (t - (:italic t :bold t))) + (:italic t))) "Level 1 empty mailgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-mail-1-empty-face 'face-alias 'gnus-group-mail-1-empty) -(put 'gnus-group-mail-1-empty-face 'obsolete-face "22.1") -(defface gnus-group-mail-2 - '((((class color) - (background dark)) - (:foreground "DarkSeaGreen1" :bold t)) - (((class color) - (background light)) - (:foreground "HotPink3" :bold t)) - (t - (:bold t))) - "Level 2 mailgroup face." +(defface gnus-group-mail-1 + '((t (:inherit gnus-group-mail-1-empty :bold t))) + "Level 1 mailgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-mail-2-face 'face-alias 'gnus-group-mail-2) -(put 'gnus-group-mail-2-face 'obsolete-face "22.1") (defface gnus-group-mail-2-empty '((((class color) @@ -598,27 +481,14 @@ be set in `.emacs' instead." (background light)) (:foreground "HotPink3")) (t - (:bold t))) + (:italic t))) "Level 2 empty mailgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-mail-2-empty-face 'face-alias 'gnus-group-mail-2-empty) -(put 'gnus-group-mail-2-empty-face 'obsolete-face "22.1") -(defface gnus-group-mail-3 - '((((class color) - (background dark)) - (:foreground "aquamarine1" :bold t)) - (((class color) - (background light)) - (:foreground "magenta4" :bold t)) - (t - (:bold t))) - "Level 3 mailgroup face." +(defface gnus-group-mail-2 + '((t (:inherit gnus-group-mail-2-empty :bold t))) + "Level 2 mailgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-mail-3-face 'face-alias 'gnus-group-mail-3) -(put 'gnus-group-mail-3-face 'obsolete-face "22.1") (defface gnus-group-mail-3-empty '((((class color) @@ -631,24 +501,11 @@ be set in `.emacs' instead." ())) "Level 3 empty mailgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-mail-3-empty-face 'face-alias 'gnus-group-mail-3-empty) -(put 'gnus-group-mail-3-empty-face 'obsolete-face "22.1") -(defface gnus-group-mail-low - '((((class color) - (background dark)) - (:foreground "aquamarine2" :bold t)) - (((class color) - (background light)) - (:foreground "DeepPink4" :bold t)) - (t - (:bold t))) - "Low level mailgroup face." +(defface gnus-group-mail-3 + '((t (:inherit gnus-group-mail-3-empty :bold t))) + "Level 3 mailgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-mail-low-face 'face-alias 'gnus-group-mail-low) -(put 'gnus-group-mail-low-face 'obsolete-face "22.1") (defface gnus-group-mail-low-empty '((((class color) @@ -661,57 +518,23 @@ be set in `.emacs' instead." (:bold t))) "Low level empty mailgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-mail-low-empty-face 'face-alias 'gnus-group-mail-low-empty) -(put 'gnus-group-mail-low-empty-face 'obsolete-face "22.1") + +(defface gnus-group-mail-low + '((t (:inherit gnus-group-mail-low-empty :bold t))) + "Low level mailgroup face." + :group 'gnus-group) ;; Summary mode faces. (defface gnus-summary-selected '((t (:underline t))) "Face used for selected articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-selected-face 'face-alias 'gnus-summary-selected) -(put 'gnus-summary-selected-face 'obsolete-face "22.1") (defface gnus-summary-cancelled '((((class color)) (:foreground "yellow" :background "black"))) "Face used for canceled articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-cancelled-face 'face-alias 'gnus-summary-cancelled) -(put 'gnus-summary-cancelled-face 'obsolete-face "22.1") - -(defface gnus-summary-high-ticked - '((((class color) - (background dark)) - (:foreground "pink" :bold t)) - (((class color) - (background light)) - (:foreground "firebrick" :bold t)) - (t - (:bold t))) - "Face used for high interest ticked articles." - :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-high-ticked-face 'face-alias 'gnus-summary-high-ticked) -(put 'gnus-summary-high-ticked-face 'obsolete-face "22.1") - -(defface gnus-summary-low-ticked - '((((class color) - (background dark)) - (:foreground "pink" :italic t)) - (((class color) - (background light)) - (:foreground "firebrick" :italic t)) - (t - (:italic t))) - "Face used for low interest ticked articles." - :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-low-ticked-face 'face-alias 'gnus-summary-low-ticked) -(put 'gnus-summary-low-ticked-face 'obsolete-face "22.1") (defface gnus-summary-normal-ticked '((((class color) @@ -724,39 +547,16 @@ be set in `.emacs' instead." ())) "Face used for normal interest ticked articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-normal-ticked-face 'face-alias 'gnus-summary-normal-ticked) -(put 'gnus-summary-normal-ticked-face 'obsolete-face "22.1") -(defface gnus-summary-high-ancient - '((((class color) - (background dark)) - (:foreground "SkyBlue" :bold t)) - (((class color) - (background light)) - (:foreground "RoyalBlue" :bold t)) - (t - (:bold t))) - "Face used for high interest ancient articles." +(defface gnus-summary-high-ticked + '((t (:inherit gnus-summary-normal-ticked :bold t))) + "Face used for high interest ticked articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-high-ancient-face 'face-alias 'gnus-summary-high-ancient) -(put 'gnus-summary-high-ancient-face 'obsolete-face "22.1") -(defface gnus-summary-low-ancient - '((((class color) - (background dark)) - (:foreground "SkyBlue" :italic t)) - (((class color) - (background light)) - (:foreground "RoyalBlue" :italic t)) - (t - (:italic t))) - "Face used for low interest ancient articles." +(defface gnus-summary-low-ticked + '((t (:inherit gnus-summary-normal-ticked :italic t))) + "Face used for low interest ticked articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-low-ancient-face 'face-alias 'gnus-summary-low-ancient) -(put 'gnus-summary-low-ancient-face 'obsolete-face "22.1") (defface gnus-summary-normal-ancient '((((class color) @@ -769,35 +569,16 @@ be set in `.emacs' instead." ())) "Face used for normal interest ancient articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-normal-ancient-face 'face-alias 'gnus-summary-normal-ancient) -(put 'gnus-summary-normal-ancient-face 'obsolete-face "22.1") -(defface gnus-summary-high-undownloaded - '((((class color) - (background light)) - (:bold t :foreground "cyan4")) - (((class color) (background dark)) - (:bold t :foreground "LightGray")) - (t (:inverse-video t :bold t))) - "Face used for high interest uncached articles." +(defface gnus-summary-high-ancient + '((t (:inherit gnus-summary-normal-ancient :bold t))) + "Face used for high interest ancient articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-high-undownloaded-face 'face-alias 'gnus-summary-high-undownloaded) -(put 'gnus-summary-high-undownloaded-face 'obsolete-face "22.1") -(defface gnus-summary-low-undownloaded - '((((class color) - (background light)) - (:italic t :foreground "cyan4" :bold nil)) - (((class color) (background dark)) - (:italic t :foreground "LightGray" :bold nil)) - (t (:inverse-video t :italic t))) - "Face used for low interest uncached articles." +(defface gnus-summary-low-ancient + '((t (:inherit gnus-summary-normal-ancient :italic t))) + "Face used for low interest ancient articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-low-undownloaded-face 'face-alias 'gnus-summary-low-undownloaded) -(put 'gnus-summary-low-undownloaded-face 'obsolete-face "22.1") (defface gnus-summary-normal-undownloaded '((((class color) @@ -808,70 +589,32 @@ be set in `.emacs' instead." (t (:inverse-video t))) "Face used for normal interest uncached articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-normal-undownloaded-face 'face-alias 'gnus-summary-normal-undownloaded) -(put 'gnus-summary-normal-undownloaded-face 'obsolete-face "22.1") -(defface gnus-summary-high-unread - '((t - (:bold t))) - "Face used for high interest unread articles." +(defface gnus-summary-high-undownloaded + '((t (:inherit gnus-summary-normal-undownloaded :bold t))) + "Face used for high interest uncached articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-high-unread-face 'face-alias 'gnus-summary-high-unread) -(put 'gnus-summary-high-unread-face 'obsolete-face "22.1") -(defface gnus-summary-low-unread - '((t - (:italic t))) - "Face used for low interest unread articles." +(defface gnus-summary-low-undownloaded + '((t (:inherit gnus-summary-normal-undownloaded :italic t))) + "Face used for low interest uncached articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-low-unread-face 'face-alias 'gnus-summary-low-unread) -(put 'gnus-summary-low-unread-face 'obsolete-face "22.1") (defface gnus-summary-normal-unread '((t ())) "Face used for normal interest unread articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-normal-unread-face 'face-alias 'gnus-summary-normal-unread) -(put 'gnus-summary-normal-unread-face 'obsolete-face "22.1") -(defface gnus-summary-high-read - '((((class color) - (background dark)) - (:foreground "PaleGreen" - :bold t)) - (((class color) - (background light)) - (:foreground "DarkGreen" - :bold t)) - (t - (:bold t))) - "Face used for high interest read articles." +(defface gnus-summary-high-unread + '((t (:inherit gnus-summary-normal-unread :bold t))) + "Face used for high interest unread articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-high-read-face 'face-alias 'gnus-summary-high-read) -(put 'gnus-summary-high-read-face 'obsolete-face "22.1") -(defface gnus-summary-low-read - '((((class color) - (background dark)) - (:foreground "PaleGreen" - :italic t)) - (((class color) - (background light)) - (:foreground "DarkGreen" - :italic t)) - (t - (:italic t))) - "Face used for low interest read articles." +(defface gnus-summary-low-unread + '((t (:inherit gnus-summary-normal-unread :italic t))) + "Face used for low interest unread articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-low-read-face 'face-alias 'gnus-summary-low-read) -(put 'gnus-summary-low-read-face 'obsolete-face "22.1") (defface gnus-summary-normal-read '((((class color) @@ -884,10 +627,23 @@ be set in `.emacs' instead." ())) "Face used for normal interest read articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-normal-read-face 'face-alias 'gnus-summary-normal-read) -(put 'gnus-summary-normal-read-face 'obsolete-face "22.1") +(defface gnus-summary-high-read + '((t (:inherit gnus-summary-normal-read :bold t))) + "Face used for high interest read articles." + :group 'gnus-summary) + +(defface gnus-summary-low-read + '((t (:inherit gnus-summary-normal-read :italic t))) + "Face used for low interest read articles." + :group 'gnus-summary) + +;;; Base gnus-mode + +(define-derived-mode gnus-mode special-mode nil + "Base mode from which all other gnus modes derive. +This does nothing but derive from `special-mode', and should not +be used directly.") ;;; ;;; Gnus buffers @@ -909,26 +665,15 @@ be set in `.emacs' instead." (defmacro gnus-kill-buffer (buffer) "Kill BUFFER and remove from the list of Gnus buffers." `(let ((buf ,buffer)) - (when (gnus-buffer-exists-p buf) + (when (gnus-buffer-live-p buf) (kill-buffer buf) (gnus-prune-buffers)))) -(defun gnus-prune-buffers () - (dolist (buf gnus-buffers) - (unless (buffer-live-p buf) - (setq gnus-buffers (delete buf gnus-buffers))))) - (defun gnus-buffers () "Return a list of live Gnus buffers." - (while (and gnus-buffers - (not (buffer-name (car gnus-buffers)))) - (pop gnus-buffers)) - (let ((buffers gnus-buffers)) - (while (cdr buffers) - (if (buffer-name (cadr buffers)) - (pop buffers) - (setcdr buffers (cddr buffers))))) - gnus-buffers) + (setq gnus-buffers (seq-filter #'buffer-live-p gnus-buffers))) + +(defalias 'gnus-prune-buffers #'gnus-buffers) ;;; Splash screen. @@ -946,9 +691,6 @@ be set in `.emacs' instead." ())) "Face for the splash screen." :group 'gnus-start) -;; backward-compatibility alias -(put 'gnus-splash-face 'face-alias 'gnus-splash) -(put 'gnus-splash-face 'obsolete-face "22.1") (defun gnus-splash () (save-excursion @@ -1006,6 +748,7 @@ be set in `.emacs' instead." (cdr (assq gnus-logo-color-style gnus-logo-color-alist)) "Colors used for the Gnus logo.") +(defvar image-load-path) (declare-function image-size "image.c" (spec &optional pixels frame)) (defun gnus-group-startup-message (&optional x y) @@ -1106,12 +849,11 @@ be set in `.emacs' instead." (cons (car list) (list :type type :data data))) list))) -(eval-when (load) - (let ((command (format "%s" this-command))) - (when (string-match "gnus" command) - (if (string-match "gnus-other-frame" command) - (gnus-get-buffer-create gnus-group-buffer) - (gnus-splash))))) +(let ((command (format "%s" this-command))) + (when (string-match "gnus" command) + (if (eq 'gnus-other-frame this-command) + (gnus-get-buffer-create gnus-group-buffer) + (gnus-splash)))) ;;; Do the rest. @@ -2479,7 +2221,7 @@ Disabling the agent may result in noticeable loss of performance." :group 'gnus-agent :type 'boolean) -(defcustom gnus-other-frame-function 'gnus +(defcustom gnus-other-frame-function #'gnus "Function called by the command `gnus-other-frame' when starting Gnus." :group 'gnus-start :type '(choice (function-item gnus) @@ -2487,7 +2229,9 @@ Disabling the agent may result in noticeable loss of performance." (function-item gnus-slave) (function-item gnus-slave-no-server))) -(defcustom gnus-other-frame-resume-function 'gnus-group-get-new-news +(declare-function gnus-group-get-new-news "gnus-group") + +(defcustom gnus-other-frame-resume-function #'gnus-group-get-new-news "Function called by the command `gnus-other-frame' when resuming Gnus." :version "24.4" :group 'gnus-start @@ -2555,7 +2299,7 @@ a string, be sure to use a valid format, see RFC 2616." ) (defvar gnus-agent-target-move-group-header "X-Gnus-Agent-Move-To") (defvar gnus-draft-meta-information-header "X-Draft-From") -(defvar gnus-group-get-parameter-function 'gnus-group-get-parameter) +(defvar gnus-group-get-parameter-function #'gnus-group-get-parameter) (defvar gnus-original-article-buffer " *Original Article*") (defvar gnus-newsgroup-name nil) (defvar gnus-ephemeral-servers nil) @@ -2592,7 +2336,9 @@ a string, be sure to use a valid format, see RFC 2616." (defvar gnus-group-history nil) (defvar gnus-server-alist nil - "List of available servers.") + "Servers created by Gnus, or via the server buffer. +Servers defined in the user's config files do not appear here. +This variable is persisted in the user's .newsrc.eld file.") (defcustom gnus-cache-directory (nnheader-concat gnus-directory "cache/") @@ -2697,28 +2443,37 @@ such as a mark that says whether an article is stored in the cache gnus-registry.el will populate this if it's loaded.") (defvar gnus-newsrc-hashtb nil - "Hashtable of `gnus-newsrc-alist'.") + "Hash table of `gnus-newsrc-alist'.") + +(defvar gnus-group-list nil + "Ordered list of group names as strings. +This variable only exists to provide easy access to the ordering +of `gnus-newsrc-alist'.") (defvar gnus-killed-list nil "List of killed newsgroups.") (defvar gnus-killed-hashtb nil - "Hash table equivalent of `gnus-killed-list'.") + "Hash table equivalent of `gnus-killed-list'. +This is a hash table purely for the fast membership test: values +are always t.") (defvar gnus-zombie-list nil "List of almost dead newsgroups.") (defvar gnus-description-hashtb nil - "Descriptions of newsgroups.") + "Hash table mapping group names to their descriptions.") (defvar gnus-list-of-killed-groups nil "List of newsgroups that have recently been killed by the user.") (defvar gnus-active-hashtb nil - "Hashtable of active articles.") + "Hash table mapping group names to their active entry.") (defvar gnus-moderated-hashtb nil - "Hashtable of moderated newsgroups.") + "Hash table of moderated groups. +This is a hash table purely for the fast membership test: values +are always t.") ;; Save window configuration. (defvar gnus-prev-winconf nil) @@ -2755,7 +2510,6 @@ gnus-registry.el will populate this if it's loaded.") (nthcdr 3 package) (cdr package))))) '(("info" :interactive t Info-goto-node) - ("pp" pp-to-string) ("qp" quoted-printable-decode-region quoted-printable-decode-string) ("ps-print" ps-print-preprint) ("message" :interactive t @@ -2863,8 +2617,8 @@ gnus-registry.el will populate this if it's loaded.") gnus-list-of-unread-articles gnus-list-of-read-articles gnus-offer-save-summaries gnus-make-thread-indent-array gnus-summary-exit gnus-update-read-articles gnus-summary-last-subject - (gnus-summary-skip-intangible macro) (gnus-summary-article-number macro) - (gnus-data-header macro) (gnus-data-find macro)) + gnus-summary-skip-intangible gnus-summary-article-number + gnus-data-header gnus-data-find) ("gnus-group" gnus-group-insert-group-line gnus-group-quit gnus-group-list-groups gnus-group-first-unread-group gnus-group-set-mode-line gnus-group-set-info gnus-group-save-newsrc @@ -2902,7 +2656,6 @@ gnus-registry.el will populate this if it's loaded.") gnus-check-reasonable-setup) ("gnus-dup" gnus-dup-suppress-articles gnus-dup-unsuppress-article gnus-dup-enter-articles) - ("gnus-range" gnus-copy-sequence) ("gnus-eform" gnus-edit-form) ("gnus-logic" gnus-score-advanced) ("gnus-undo" gnus-undo-mode gnus-undo-register) @@ -3016,7 +2769,7 @@ See Info node `(gnus)Formatting Variables'." (defun gnus-suppress-keymap (keymap) (suppress-keymap keymap) - (let ((keys `([delete] "\177" "\M-u"))) ;[mouse-2] + (let ((keys '([delete] "\177" "\M-u"))) ;[mouse-2] (while keys (define-key keymap (pop keys) 'undefined)))) @@ -3046,36 +2799,21 @@ See Info node `(gnus)Formatting Variables'." (defun gnus-header-from (header) (mail-header-from header)) -(defmacro gnus-gethash (string hashtable) - "Get hash value of STRING in HASHTABLE." - `(symbol-value (intern-soft ,string ,hashtable))) - -(defmacro gnus-gethash-safe (string hashtable) - "Get hash value of STRING in HASHTABLE. -Return nil if not defined." - `(let ((sym (intern-soft ,string ,hashtable))) - (and (boundp sym) (symbol-value sym)))) - -(defmacro gnus-sethash (string value hashtable) - "Set hash value. Arguments are STRING, VALUE, and HASHTABLE." - `(set (intern ,string ,hashtable) ,value)) -(put 'gnus-sethash 'edebug-form-spec '(form form form)) - (defmacro gnus-group-unread (group) "Get the currently computed number of unread articles in GROUP." - `(car (gnus-gethash ,group gnus-newsrc-hashtb))) + `(car (gethash ,group gnus-newsrc-hashtb))) (defmacro gnus-group-entry (group) "Get the newsrc entry for GROUP." - `(gnus-gethash ,group gnus-newsrc-hashtb)) + `(gethash ,group gnus-newsrc-hashtb)) (defmacro gnus-active (group) "Get active info on GROUP." - `(gnus-gethash ,group gnus-active-hashtb)) + `(gethash ,group gnus-active-hashtb)) (defmacro gnus-set-active (group active) "Set GROUP's active info." - `(gnus-sethash ,group ,active gnus-active-hashtb)) + `(puthash ,group ,active gnus-active-hashtb)) ;; Info access macros. @@ -3139,11 +2877,11 @@ Return nil if not defined." (setcar rank (cons (car rank) ,score))))) (defmacro gnus-get-info (group) - `(nth 2 (gnus-gethash ,group gnus-newsrc-hashtb))) + `(nth 1 (gethash ,group gnus-newsrc-hashtb))) (defun gnus-set-info (group info) - (setcar (nthcdr 2 (gnus-gethash group gnus-newsrc-hashtb)) - info)) + (setcdr (gethash group gnus-newsrc-hashtb) + (list info))) ;;; @@ -3179,9 +2917,9 @@ with a `subscribed' parameter." (or (gnus-group-fast-parameter group 'to-address) (gnus-group-fast-parameter group 'to-list)))) (when address - (add-to-list 'addresses address)))) + (cl-pushnew address addresses :test #'equal)))) (when addresses - (list (mapconcat 'regexp-quote addresses "\\|"))))) + (list (mapconcat #'regexp-quote addresses "\\|"))))) (defmacro gnus-string-or (&rest strings) "Return the first element of STRINGS that is a non-blank string. @@ -3234,6 +2972,8 @@ If ARG, insert string at point." minor least) (format "%d.%02d%02d" major minor least)))))) +(defvar gnus-info-buffer) + (defun gnus-info-find-node (&optional nodename) "Find Info documentation of Gnus." (interactive) @@ -3253,7 +2993,7 @@ If ARG, insert string at point." (defvar gnus-current-prefix-symbols nil "List of current prefix symbols.") -(defun gnus-interactive (string &optional params) +(defun gnus-interactive (string) "Return a list that can be fed to `interactive'. See `interactive' for full documentation. @@ -3345,9 +3085,9 @@ g -- Group name." (setq out (delq 'gnus-prefix-nil out)) (nreverse out))) -(defun gnus-symbolic-argument (&optional arg) +(defun gnus-symbolic-argument () "Read a symbolic argument and a command, and then execute command." - (interactive "P") + (interactive) (let* ((in-command (this-command-keys)) (command in-command) gnus-current-prefix-symbols @@ -3392,7 +3132,7 @@ that that variable is buffer-local to the summary buffers." t) ;is news of course. ((not (gnus-member-of-valid 'post-mail group)) ;Non-combined. nil) ;must be mail then. - ((vectorp article) ;Has header info. + ((mail-header-p article) ;Has header info. (eq (gnus-request-type group (mail-header-id article)) 'news)) ((null article) ;Hasn't header info (eq (gnus-request-type group) 'news)) ;(unknown ==> mail) @@ -3429,7 +3169,7 @@ that that variable is buffer-local to the summary buffers." (defun gnus-kill-ephemeral-group (group) "Remove ephemeral GROUP from relevant structures." - (gnus-sethash group nil gnus-newsrc-hashtb)) + (remhash group gnus-newsrc-hashtb)) (defun gnus-simplify-mode-line () "Make mode lines a bit simpler." @@ -3463,16 +3203,15 @@ that that variable is buffer-local to the summary buffers." (throw 'server-name (car name-method)))) gnus-server-method-cache)) - (mapc - (lambda (server-alist) - (mapc (lambda (name-method) - (when (gnus-methods-equal-p (cdr name-method) method) - (unless (member name-method gnus-server-method-cache) - (push name-method gnus-server-method-cache)) - (throw 'server-name (car name-method)))) - server-alist)) - (list gnus-server-alist - gnus-predefined-server-alist)) + (dolist (server-alist + (list gnus-server-alist + gnus-predefined-server-alist)) + (mapc (lambda (name-method) + (when (gnus-methods-equal-p (cdr name-method) method) + (unless (member name-method gnus-server-method-cache) + (push name-method gnus-server-method-cache)) + (throw 'server-name (car name-method)))) + server-alist)) (let* ((name (if (member (cadr method) '(nil "")) (format "%s" (car method)) @@ -3574,26 +3313,26 @@ that that variable is buffer-local to the summary buffers." (let ((p1 (copy-sequence (cddr m1))) (p2 (copy-sequence (cddr m2))) e1 e2) - (block nil + (cl-block nil (while (setq e1 (pop p1)) (unless (setq e2 (assq (car e1) p2)) ;; The parameter doesn't exist in p2. - (return nil)) + (cl-return nil)) (setq p2 (delq e2 p2)) (unless (equal e1 e2) (if (not (and (stringp (cadr e1)) (stringp (cadr e2)))) - (return nil) + (cl-return nil) ;; Special-case string parameter comparison so that we ;; can uniquify them. (let ((s1 (cadr e1)) (s2 (cadr e2))) - (when (string-match "/$" s1) + (when (string-match "/\\'" s1) (setq s1 (directory-file-name s1))) - (when (string-match "/$" s2) + (when (string-match "/\\'" s2) (setq s2 (directory-file-name s2))) (unless (equal s1 s2) - (return nil)))))) + (cl-return nil)))))) ;; If p2 now is empty, they were equal. (null p2)))) @@ -3888,9 +3627,8 @@ If SYMBOL, return the value of that symbol in the group parameters. If you call this function inside a loop, consider using the faster `gnus-group-fast-parameter' instead." - (with-current-buffer (if (buffer-live-p (get-buffer gnus-group-buffer)) - gnus-group-buffer - (current-buffer)) + (with-current-buffer (or (gnus-buffer-live-p gnus-group-buffer) + (current-buffer)) (if symbol (gnus-group-fast-parameter group symbol allow-list) (nconc @@ -3981,8 +3719,7 @@ If SCORE is nil, add 1 to the score of GROUP." "Collapse GROUP name LEVELS. Select methods are stripped and any remote host name is stripped down to just the host name." - (let* ((name "") - (foreign "") + (let* ((foreign "") (depth 0) (skip 1) (levels (or levels @@ -3997,7 +3734,7 @@ just the host name." ;; otherwise collapse to select method. (let* ((colon (string-match ":" group)) (server (and colon (substring group 0 colon))) - (plus (and server (string-match "+" server)))) + (plus (and server (string-match "\\+" server)))) (when server (if plus (setq foreign (substring server (+ 1 plus) @@ -4024,13 +3761,13 @@ just the host name." gsep ".")) (setq levels (- glen levels)) (dolist (g glist) - (push (if (>= (decf levels) 0) + (push (if (>= (cl-decf levels) 0) (if (zerop (length g)) "" (substring g 0 1)) g) res)) - (concat foreign (mapconcat 'identity (nreverse res) gsep)))))) + (concat foreign (mapconcat #'identity (nreverse res) gsep)))))) (defun gnus-narrow-to-body () "Narrow to the body of an article." @@ -4272,7 +4009,7 @@ Allow completion over sensible values." gnus-server-alist)) (method (gnus-completing-read - prompt (mapcar 'car servers) + prompt (mapcar #'car servers) t nil 'gnus-method-history))) (cond ((equal method "") @@ -4385,13 +4122,13 @@ current display is used." (progn (switch-to-buffer gnus-group-buffer) (funcall gnus-other-frame-resume-function arg)) (funcall gnus-other-frame-function arg) - (add-hook 'gnus-exit-gnus-hook 'gnus-delete-gnus-frame) + (add-hook 'gnus-exit-gnus-hook #'gnus-delete-gnus-frame) ;; One might argue that `gnus-delete-gnus-frame' should not be called ;; from `gnus-suspend-gnus-hook', but, on the other hand, one might ;; argue that it should. No matter what you think, for the sake of ;; those who want it to be called from it, please keep (defun ;; gnus-delete-gnus-frame) even if you remove the next `add-hook'. - (add-hook 'gnus-suspend-gnus-hook 'gnus-delete-gnus-frame))))) + (add-hook 'gnus-suspend-gnus-hook #'gnus-delete-gnus-frame))))) ;;;###autoload (defun gnus (&optional arg dont-connect slave) diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index 7251286f9b7..69ecde30275 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -26,12 +26,11 @@ (require 'format-spec) (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'imap)) (autoload 'auth-source-search "auth-source") (autoload 'pop3-movemail "pop3") (autoload 'pop3-get-message-count "pop3") -(autoload 'nnheader-cancel-timer "nnheader") (require 'mm-util) (require 'message) ;; for `message-directory' @@ -439,7 +438,7 @@ the `mail-source-keyword-map' variable." ;; the msname is the mail-source parameter (dolist (msname '(:server :user :port)) ;; the asname is the auth-source parameter - (let* ((asname (case msname + (let* ((asname (cl-case msname (:server :host) ; auth-source uses :host (t msname))) ;; this is the mail-source default @@ -602,7 +601,8 @@ If CONFIRM is non-nil, ask for confirmation before removing a file." (let* ((ffile (car files)) (bfile (replace-regexp-in-string "\\`.*/\\([^/]+\\)\\'" "\\1" ffile)) - (filetime (nth 5 (file-attributes ffile)))) + (filetime (file-attribute-modification-time + (file-attributes ffile)))) (setq files (cdr files)) (when (and (> (time-to-number-of-days (time-subtract now filetime)) diff) @@ -618,7 +618,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (defun mail-source-callback (callback info) "Call CALLBACK on the mail file. Pass INFO on to CALLBACK." (if (or (not (file-exists-p mail-source-crash-box)) - (zerop (nth 7 (file-attributes mail-source-crash-box)))) + (zerop (file-attribute-size + (file-attributes mail-source-crash-box)))) (progn (when (file-exists-p mail-source-crash-box) (delete-file mail-source-crash-box)) @@ -645,9 +646,9 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) ;; Don't check for old incoming files more than once per day to ;; save a lot of file accesses. (when (or (null mail-source-incoming-last-checked-time) - (> (float-time - (time-since mail-source-incoming-last-checked-time)) - (* 24 60 60))) + (time-less-p + (* 24 60 60) + (time-since mail-source-incoming-last-checked-time))) (setq mail-source-incoming-last-checked-time (current-time)) (mail-source-delete-old-incoming mail-source-delete-incoming @@ -670,7 +671,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) ((not (file-exists-p from)) ;; There is no inbox. (setq to nil)) - ((zerop (nth 7 (file-attributes from))) + ((zerop (file-attribute-size (file-attributes from))) ;; Empty file. (setq to nil)) (t @@ -721,8 +722,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (buffer-string) result)) (error "%s" (buffer-string))) (setq to nil))))))) - (when (and errors - (buffer-name errors)) + (when (buffer-live-p errors) (kill-buffer errors)) ;; Return whether we moved successfully or not. to))) @@ -790,7 +790,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (when (and (file-regular-p file) (funcall predicate file) (mail-source-movemail file mail-source-crash-box)) - (incf found (mail-source-callback callback file)) + (cl-incf found (mail-source-callback callback file)) (mail-source-run-script postscript (format-spec-make ?t path)) (mail-source-delete-crash-box))) found))) @@ -987,9 +987,9 @@ This only works when `display-time' is enabled." (> (prefix-numeric-value arg) 0)))) (setq mail-source-report-new-mail on) (and mail-source-report-new-mail-timer - (nnheader-cancel-timer mail-source-report-new-mail-timer)) + (cancel-timer mail-source-report-new-mail-timer)) (and mail-source-report-new-mail-idle-timer - (nnheader-cancel-timer mail-source-report-new-mail-idle-timer)) + (cancel-timer mail-source-report-new-mail-idle-timer)) (setq mail-source-report-new-mail-timer nil) (setq mail-source-report-new-mail-idle-timer nil) (if on @@ -1045,7 +1045,7 @@ This only works when `display-time' is enabled." (insert "\001\001\001\001\n")) (delete-file file) nil)))) - (incf found (mail-source-callback callback file)) + (cl-incf found (mail-source-callback callback file)) (mail-source-delete-crash-box))))) found))) @@ -1120,7 +1120,7 @@ This only works when `display-time' is enabled." (replace-match ">From ")) (goto-char (point-max)))) (nnheader-ms-strip-cr)) - (incf found (mail-source-callback callback server)) + (cl-incf found (mail-source-callback callback server)) (mail-source-delete-crash-box) (when (and remove fetchflag) (setq remove (nreverse remove)) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index d260bdb2a2c..30c5f7cbda0 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -28,9 +28,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - +(require 'cl-lib) (require 'mailheader) (require 'gmm-utils) (require 'mail-utils) @@ -158,7 +156,7 @@ If this variable is nil, no such courtesy message will be added." :group 'message-interface :type 'regexp) -(defcustom message-from-style mail-from-style +(defcustom message-from-style 'angles "Specifies how \"From\" headers look. If nil, they contain just the return address like: @@ -170,12 +168,16 @@ If `angles', they look like: Otherwise, most addresses look like `angles', but they look like `parens' if `angles' would need quoting and `parens' would not." - :version "23.2" + :version "27.1" :type '(choice (const :tag "simple" nil) (const parens) (const angles) (const default)) :group 'message-headers) +(make-obsolete-variable + 'message-from-style + "Only the `angles' value is valid according to RFC2822" "27.1") + (defcustom message-insert-canlock t "Whether to insert a Cancel-Lock header in news postings." @@ -550,10 +552,15 @@ The provided functions are: (function-item message-forward-subject-name-subject) (repeat :tag "List of functions" function))) -(defcustom message-forward-as-mime t +(defcustom message-forward-as-mime nil "Non-nil means forward messages as an inline/rfc822 MIME section. -Otherwise, directly inline the old message in the forwarded message." - :version "21.1" +Otherwise, directly inline the old message in the forwarded +message. + +When forwarding as MIME, certain MIME-related headers in the +forwarded message may be removed/altered to ensure that the +resulting mail is syntactically valid." + :version "27.1" :group 'message-forwarding :link '(custom-manual "(message)Forwarding") :type 'boolean) @@ -605,6 +612,9 @@ Done before generating the new subject of a forward." (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus" "All headers that match this regexp will be deleted when forwarding a message. +This variable is only consulted when forwarding \"normally\", not +when forwarding as MIME or the like. + This may also be a list of regexps." :version "21.1" :group 'message-forwarding @@ -615,11 +625,12 @@ This may also be a list of regexps." (widget-editable-list-match widget value))) regexp)) -(defcustom message-forward-included-headers nil +(defcustom message-forward-included-headers + '("^From:" "^Subject:" "^Date:" "^To:" "^Cc:") "If non-nil, delete non-matching headers when forwarding a message. Only headers that match this regexp will be included. This variable should be a regexp or a list of regexps." - :version "25.1" + :version "27.1" :group 'message-forwarding :type '(repeat :value-to-internal (lambda (widget value) (custom-split-regexp-maybe value)) @@ -655,30 +666,29 @@ variable should be a regexp or a list of regexps." (defun message-send-mail-function () "Return suitable value for the variable `message-send-mail-function'." - (cond ((and (require 'sendmail) - (boundp 'sendmail-program) - sendmail-program - (executable-find sendmail-program)) - 'message-send-mail-with-sendmail) - ((and (locate-library "smtpmail") - (boundp 'smtpmail-default-smtp-server) - smtpmail-default-smtp-server) - 'message-smtpmail-send-it) - ((locate-library "mailclient") - 'message-send-mail-with-mailclient) + (declare (obsolete nil "27.1")) + (require 'sendmail) + (defvar sendmail-program) + (cond ((executable-find sendmail-program) + #'message-send-mail-with-sendmail) + ((bound-and-true-p 'smtpmail-default-smtp-server) + #'message-smtpmail-send-it) (t - (error "Don't know how to send mail. Please customize `message-send-mail-function'")))) + #'message-send-mail-with-mailclient))) (defun message-default-send-mail-function () - (cond ((eq send-mail-function 'smtpmail-send-it) 'message-smtpmail-send-it) - ((eq send-mail-function 'feedmail-send-it) 'feedmail-send-it) - ((eq send-mail-function 'sendmail-query-once) 'sendmail-query-once) - ((eq send-mail-function 'mailclient-send-it) - 'message-send-mail-with-mailclient) - (t (message-send-mail-function)))) + (cond ((eq send-mail-function #'feedmail-send-it) #'feedmail-send-it) + ((eq send-mail-function #'sendmail-query-once) #'sendmail-query-once) + ((eq send-mail-function #'sendmail-send-it) + #'message-send-mail-with-sendmail) + (t #'message-use-send-mail-function))) + +(defun message--default-send-mail-function () + "Use the setting of `send-mail-function' if applicable." + (funcall (message-default-send-mail-function))) ;; Useful to set in site-init.el -(defcustom message-send-mail-function (message-default-send-mail-function) +(defcustom message-send-mail-function #'message--default-send-mail-function "Function to call to send the current buffer as mail. The headers should be delimited by a line whose contents match the variable `mail-header-separator'. @@ -691,7 +701,9 @@ default is system dependent and determined by the function `message-send-mail-function'. See also `send-mail-function'." - :type '(radio (function-item message-send-mail-with-sendmail) + :type '(radio (function-item message--default-send-mail-function + :tag "Use send-mail-function") + (function-item message-send-mail-with-sendmail) (function-item message-send-mail-with-mh) (function-item message-send-mail-with-qmail) (function-item message-smtpmail-send-it) @@ -701,8 +713,8 @@ See also `send-mail-function'." :tag "Use Mailclient package") (function :tag "Other")) :group 'message-sending - :version "23.2" - :initialize 'custom-initialize-default + :version "27.1" + :initialize #'custom-initialize-default :link '(custom-manual "(message)Mail Variables") :group 'message-mail) @@ -823,7 +835,10 @@ symbol `never', the posting is not allowed. If it is the symbol (const never) (const ask))) -(defcustom message-sendmail-f-is-evil nil +(defcustom message-sendmail-f-is-evil + (if (boundp 'mail-specify-envelope-from) + (not mail-specify-envelope-from) + nil) "Non-nil means don't add \"-f username\" to the sendmail command line. Doing so would be even more evil than leaving it out." :group 'message-sending @@ -1067,13 +1082,15 @@ point and mark around the citation text as modified." (defcustom message-signature mail-signature "String to be inserted at the end of the message buffer. -If t, the `message-signature-file' file will be inserted instead. -If a function, the result from the function will be used instead. -If a form, the result from the form will be used instead." +If nil, don't insert a signature. +If t, insert `message-signature-file'. +If a function or form, insert its result. +See `mail-signature' for the recommended format of a signature." :version "23.2" - :type '(choice string (const :tag "Contents of signature file" t) - function - sexp) + :type '(choice string + (const :tag "None" nil) + (const :tag "Contents of signature file" t) + function sexp) :risky t :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) @@ -1241,13 +1258,13 @@ called and its result is inserted." ;; Ease the transition from mail-mode to message-mode. See bugs#4431, 5555. (concat (if (and (boundp 'mail-default-reply-to) (stringp mail-default-reply-to)) - (format "Reply-to: %s\n" mail-default-reply-to)) + (format "Reply-To: %s\n" mail-default-reply-to)) (if (and (boundp 'mail-self-blind) mail-self-blind) - (format "BCC: %s\n" user-mail-address)) + (format "Bcc: %s\n" user-mail-address)) (if (and (boundp 'mail-archive-file-name) (stringp mail-archive-file-name)) - (format "FCC: %s\n" mail-archive-file-name)) + (format "Fcc: %s\n" mail-archive-file-name)) mail-default-headers) "A string of header lines to be inserted in outgoing mails." :version "23.2" @@ -1277,7 +1294,7 @@ called and its result is inserted." ;; According to RFC 822 and its successors, the field name must ;; consist of printable US-ASCII characters other than colon, ;; i.e., decimal 33-56 and 59-126. - '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:")) + '(looking-at "[ \t]\\|[][!\"#$%&'()*+,./0-9;<=>?@A-Z\\^_`a-z{|}~-]+:")) "Set this non-nil if the system's mailer runs the header and body together. \(This problem exists on Sunos 4 when sendmail is run in remote mode.) The value should be an expression to test whether the problem will @@ -1340,7 +1357,8 @@ If nil, Message won't auto-save." :link '(custom-manual "(message)Various Message Variables") :type '(choice directory (const :tag "Don't auto-save" nil))) -(defcustom message-default-charset (and (not (mm-multibyte-p)) 'iso-8859-1) +(defcustom message-default-charset (and (not enable-multibyte-characters) + 'iso-8859-1) "Default charset used in non-MULE Emacsen. If nil, you might be asked to input the charset." :version "21.1" @@ -1435,8 +1453,6 @@ starting with `not' and followed by regexps." :bold t :italic t)) "Face used for displaying To headers." :group 'message-faces) -(define-obsolete-face-alias 'message-header-to-face - 'message-header-to "22.1") (defface message-header-cc '((((class color) @@ -1449,8 +1465,6 @@ starting with `not' and followed by regexps." :bold t)) "Face used for displaying Cc headers." :group 'message-faces) -(define-obsolete-face-alias 'message-header-cc-face - 'message-header-cc "22.1") (defface message-header-subject '((((class color) @@ -1463,8 +1477,6 @@ starting with `not' and followed by regexps." :bold t)) "Face used for displaying Subject headers." :group 'message-faces) -(define-obsolete-face-alias 'message-header-subject-face - 'message-header-subject "22.1") (defface message-header-newsgroups '((((class color) @@ -1477,8 +1489,6 @@ starting with `not' and followed by regexps." :bold t :italic t)) "Face used for displaying Newsgroups headers." :group 'message-faces) -(define-obsolete-face-alias 'message-header-newsgroups-face - 'message-header-newsgroups "22.1") (defface message-header-other '((((class color) @@ -1491,8 +1501,6 @@ starting with `not' and followed by regexps." :bold t :italic t)) "Face used for displaying other headers." :group 'message-faces) -(define-obsolete-face-alias 'message-header-other-face - 'message-header-other "22.1") (defface message-header-name '((((class color) @@ -1505,8 +1513,6 @@ starting with `not' and followed by regexps." :bold t)) "Face used for displaying header names." :group 'message-faces) -(define-obsolete-face-alias 'message-header-name-face - 'message-header-name "22.1") (defface message-header-xheader '((((class color) @@ -1519,8 +1525,6 @@ starting with `not' and followed by regexps." :bold t)) "Face used for displaying X-Header headers." :group 'message-faces) -(define-obsolete-face-alias 'message-header-xheader-face - 'message-header-xheader "22.1") (defface message-separator '((((class color) @@ -1533,8 +1537,6 @@ starting with `not' and followed by regexps." :bold t)) "Face used for displaying the separator." :group 'message-faces) -(define-obsolete-face-alias 'message-separator-face - 'message-separator "22.1") (defface message-cited-text '((((class color) @@ -1547,8 +1549,6 @@ starting with `not' and followed by regexps." :bold t)) "Face used for displaying cited text names." :group 'message-faces) -(define-obsolete-face-alias 'message-cited-text-face - 'message-cited-text "22.1") (defface message-mml '((((class color) @@ -1561,66 +1561,65 @@ starting with `not' and followed by regexps." :bold t)) "Face used for displaying MML." :group 'message-faces) -(define-obsolete-face-alias 'message-mml-face - 'message-mml "22.1") -(defun message-font-lock-make-header-matcher (regexp) - (let ((form - `(lambda (limit) - (let ((start (point))) - (save-restriction - (widen) - (goto-char (point-min)) - (if (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") - nil t) - (setq limit (min limit (match-beginning 0)))) - (goto-char start)) - (and (< start limit) - (re-search-forward ,regexp limit t)))))) - (if (featurep 'bytecomp) - (byte-compile form) - form))) +(defun message-match-to-eoh (_limit) + (let ((start (point))) + (rfc822-goto-eoh) + ;; Typical situation: some temporary change causes the header to be + ;; incorrect, so EOH comes earlier than intended: the last lines of the + ;; intended headers are now not considered part of the header any more, + ;; so they don't have the multiline property set. When the change is + ;; completed and the header has its correct shape again, the lack of the + ;; multiline property means we won't rehighlight the last lines of + ;; the header. + (if (< (point) start) + nil ;No header within start..limit. + ;; Here we disregard LIMIT so that we may extend the area again. + (set-match-data (list start (point))) + (point)))) (defvar message-font-lock-keywords (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?")) - `((,(message-font-lock-make-header-matcher - (concat "^\\([Tt]o:\\)" content)) - (1 'message-header-name) - (2 'message-header-to nil t)) - (,(message-font-lock-make-header-matcher - (concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content)) - (1 'message-header-name) - (2 'message-header-cc nil t)) - (,(message-font-lock-make-header-matcher - (concat "^\\([Ss]ubject:\\)" content)) - (1 'message-header-name) - (2 'message-header-subject nil t)) - (,(message-font-lock-make-header-matcher - (concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)) - (1 'message-header-name) - (2 'message-header-newsgroups nil t)) - (,(message-font-lock-make-header-matcher - (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content)) - (1 'message-header-name) - (2 'message-header-xheader)) - (,(message-font-lock-make-header-matcher - (concat "^\\([A-Z][^: \n\t]+:\\)" content)) - (1 'message-header-name) - (2 'message-header-other nil t)) - ,@(if (and mail-header-separator - (not (equal mail-header-separator ""))) - `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") - 1 'message-separator)) - nil) - ((lambda (limit) - (re-search-forward (concat "^\\(" - message-cite-prefix-regexp - "\\).*") - limit t)) - (0 'message-cited-text)) - ("<#/?\\(multipart\\|part\\|external\\|mml\\|secure\\)[^>]*>" - (0 'message-mml)))) + `((message-match-to-eoh + (,(concat "^\\([Tt]o:\\)" content) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'message-header-name) + (2 'message-header-to nil t)) + (,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'message-header-name) + (2 'message-header-cc nil t)) + (,(concat "^\\([Ss]ubject:\\)" content) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'message-header-name) + (2 'message-header-subject nil t)) + (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'message-header-name) + (2 'message-header-newsgroups nil t)) + (,(concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'message-header-name) + (2 'message-header-xheader)) + (,(concat "^\\([A-Z][^: \n\t]+:\\)" content) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'message-header-name) + (2 'message-header-other nil t))) + (,(lambda (limit) + (and mail-header-separator + (not (equal mail-header-separator "")) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$") + limit t))) + 0 'message-separator) + (,(lambda (limit) + (re-search-forward (concat "^\\(?:" + message-cite-prefix-regexp + "\\).*") + limit t)) + 0 'message-cited-text) + ("<#/?\\(?:multipart\\|part\\|external\\|mml\\|secure\\)[^>]*>" + 0 'message-mml))) "Additional expressions to highlight in Message mode.") (defvar message-face-alist @@ -1773,6 +1772,7 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." ;;; Internal variables. +(defvar message-inhibit-body-encoding nil) (defvar message-sending-message "Sending...") (defvar message-buffer-list nil) (defvar message-this-is-news nil) @@ -1861,7 +1861,7 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." "Alist of header names/filler functions.") (defvar message-header-format-alist - `((From) + '((From) (Newsgroups) (To) (Cc) @@ -1924,10 +1924,10 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." "Ask QUESTION, displaying remaining args in a temporary buffer if SHOW." `(message-talkative-question 'y-or-n-p ,question ,show ,@text)) -(defmacro message-delete-line (&optional n) +(defsubst message-delete-line (&optional n) "Delete the current line (and the next N lines)." - `(delete-region (progn (beginning-of-line) (point)) - (progn (forward-line ,(or n 1)) (point)))) + (delete-region (progn (beginning-of-line) (point)) + (progn (forward-line (or n 1)) (point)))) (defun message-mark-active-p () "Non-nil means the mark and region are currently active in this buffer." @@ -1991,6 +1991,8 @@ is used by default." (defun message-fetch-field (header &optional not-all) "The same as `mail-fetch-field', only remove all newlines. +Surrounding whitespace is also removed. + The buffer is expected to be narrowed to just the header of the message; see `message-narrow-to-headers-or-head'." (let* ((inhibit-point-motion-hooks t) @@ -1998,7 +2000,9 @@ see `message-narrow-to-headers-or-head'." (when value (while (string-match "\n[\t ]+" value) (setq value (replace-match " " t t value))) - value))) + ;; If the initial or final line is blank (just a newline), then + ;; we have initial or trailing white space; remove it. + (string-trim value)))) (defun message-field-value (header &optional not-all) "The same as `message-fetch-field', only narrow to the headers first." @@ -2039,14 +2043,11 @@ see `message-narrow-to-headers-or-head'." (defmacro message-with-reply-buffer (&rest forms) "Evaluate FORMS in the reply buffer, if it exists." - `(when (and (bufferp message-reply-buffer) - (buffer-name message-reply-buffer)) + (declare (indent 0) (debug t)) + `(when (buffer-live-p message-reply-buffer) (with-current-buffer message-reply-buffer ,@forms))) -(put 'message-with-reply-buffer 'lisp-indent-function 0) -(put 'message-with-reply-buffer 'edebug-form-spec '(body)) - (defun message-fetch-reply-field (header) "Fetch field HEADER from the message we're replying to." (message-with-reply-buffer @@ -2060,8 +2061,9 @@ see `message-narrow-to-headers-or-head'." (let ((regexp (if (stringp gnus-list-identifiers) gnus-list-identifiers (mapconcat 'identity gnus-list-identifiers " *\\|")))) - (if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp - " *\\)\\)+\\(Re: +\\)?\\)") subject) + (if (and (not (equal regexp "")) + (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp + " *\\)\\)+\\(Re: +\\)?\\)") subject)) (concat (substring subject 0 (match-beginning 1)) (or (match-string 3 subject) (match-string 5 subject)) @@ -2435,7 +2437,7 @@ Return the number of headers removed." (looking-at "[!-9;-~]+:")) (looking-at regexp)) (progn - (incf number) + (cl-incf number) (when first (setq last t)) (delete-region @@ -2460,10 +2462,10 @@ Return the number of headers removed." (save-excursion (goto-char (point-min)) (while (re-search-forward regexp nil t) - (incf count))) + (cl-incf count))) (while (> count 1) (message-remove-header header nil t) - (decf count)))) + (cl-decf count)))) (defun message-narrow-to-headers () "Narrow the buffer to the head of the message." @@ -2606,6 +2608,36 @@ PGG manual, depending on the value of `mml2015-use'." (t 'message))))) +(defun message-all-recipients () + "Return a list of all recipients in the message, looking at TO, Cc and Bcc. + +Each recipient is in the format of `mail-extract-address-components'." + (mapcan (lambda (header) + (let ((header-value (message-fetch-field header))) + (and + header-value + (mail-extract-address-components header-value t)))) + '("To" "Cc" "Bcc"))) + +(defun message-all-epg-keys-available-p () + "Return non-nil if the pgp keyring has a public key for each recipient." + (require 'epa) + (let ((context (epg-make-context epa-protocol))) + (catch 'break + (dolist (recipient (message-all-recipients)) + (let ((recipient-email (cadr recipient))) + (when (and recipient-email (not (epg-list-keys context recipient-email))) + (throw 'break nil)))) + t))) + +(defun message-sign-encrypt-if-all-keys-available () + "Add MML tag to encrypt message when there is a key for each recipient. + +Consider adding this function to `message-send-hook' to +systematically send encrypted emails when possible." + (when (message-all-epg-keys-available-p) + (mml-secure-message-sign-encrypt))) + ;;; @@ -2694,7 +2726,7 @@ PGG manual, depending on the value of `mml2015-use'." (easy-menu-define message-mode-menu message-mode-map "Message Menu." - `("Message" + '("Message" ["Yank Original" message-yank-original message-reply-buffer] ["Fill Yanked Message" message-fill-yanked-message t] ["Insert Signature" message-insert-signature t] @@ -2728,7 +2760,7 @@ PGG manual, depending on the value of `mml2015-use'." (easy-menu-define message-mode-field-menu message-mode-map "" - `("Field" + '("Field" ["To" message-goto-to t] ["From" message-goto-from t] ["Subject" message-goto-subject t] @@ -2843,8 +2875,7 @@ See also `message-forbidden-properties'." (message-display-abbrev)) (when (and message-strip-special-text-properties (message-tamago-not-in-use-p begin)) - (let ((buffer-read-only nil) - (inhibit-read-only t)) + (let ((inhibit-read-only t)) (remove-text-properties begin end message-forbidden-properties)))) (defvar message-smileys '(":-)" ":)" @@ -2874,42 +2905,9 @@ See also `message-forbidden-properties'." ;;;###autoload (define-derived-mode message-mode text-mode "Message" "Major mode for editing mail and news to be sent. -Like Text Mode but with these additional commands:\\<message-mode-map> -C-c C-s `message-send' (send the message) C-c C-c `message-send-and-exit' -C-c C-d Postpone sending the message C-c C-k Kill the message -C-c C-f move to a header field (and create it if there isn't): - C-c C-f C-t move to To C-c C-f C-s move to Subject - C-c C-f C-c move to Cc C-c C-f C-b move to Bcc - C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To - C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups - C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution - C-c C-f C-o move to From (\"Originator\") - C-c C-f C-f move to Followup-To - C-c C-f C-m move to Mail-Followup-To - C-c C-f C-e move to Expires - C-c C-f C-i cycle through Importance values - C-c C-f s change subject and append \"(was: <Old Subject>)\" - C-c C-f x crossposting with FollowUp-To header and note in body - C-c C-f t replace To: header with contents of Cc: or Bcc: - C-c C-f a Insert X-No-Archive: header and a note in the body -C-c C-t `message-insert-to' (add a To header to a news followup) -C-c C-l `message-to-list-only' (removes all but list address in to/cc) -C-c C-n `message-insert-newsgroups' (add a Newsgroup header to a news reply) -C-c C-b `message-goto-body' (move to beginning of message text). -C-c C-i `message-goto-signature' (move to the beginning of the signature). -C-c C-w `message-insert-signature' (insert `message-signature-file' file). -C-c C-y `message-yank-original' (insert current message, if any). -C-c C-q `message-fill-yanked-message' (fill what was yanked). -C-c C-e `message-elide-region' (elide the text between point and mark). -C-c C-v `message-delete-not-region' (remove the text outside the region). -C-c C-z `message-kill-to-signature' (kill the text up to the signature). -C-c C-r `message-caesar-buffer-body' (rot13 the message body). -C-c C-a `mml-attach-file' (attach a file as MIME). -C-c C-u `message-insert-or-toggle-importance' (insert or cycle importance). -C-c M-n `message-insert-disposition-notification-to' (request receipt). -C-c M-m `message-mark-inserted-region' (mark region with enclosing tags). -C-c M-f `message-mark-insert-file' (insert file marked with enclosing tags). -M-RET `message-newline-and-reformat' (break the line and reformat)." +Like `text-mode', but with these additional commands: + +\\{message-mode-map}" (set (make-local-variable 'message-reply-buffer) nil) (set (make-local-variable 'message-inserted-headers) nil) (set (make-local-variable 'message-send-actions) nil) @@ -2951,7 +2949,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (easy-menu-add message-mode-menu message-mode-map) (easy-menu-add message-mode-field-menu message-mode-map) ;; Mmmm... Forbidden properties... - (add-hook 'after-change-functions 'message-strip-forbidden-properties + (add-hook 'after-change-functions #'message-strip-forbidden-properties nil 'local) ;; Allow mail alias things. (cond @@ -2959,7 +2957,9 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (mail-abbrevs-setup)) ((message-mail-alias-type-p 'ecomplete) (ecomplete-setup))) - (add-hook 'completion-at-point-functions 'message-completion-function nil t) + ;; 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 #'message-completion-function nil t) (unless buffer-file-name (message-set-auto-save-file-name)) (unless (buffer-base-buffer) @@ -3093,17 +3093,15 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (push-mark) (message-position-on-field "Summary" "Subject")) -(defun message-goto-body () - "Move point to the beginning of the message body." - (interactive) - (when (and (called-interactively-p 'any) - (looking-at "[ \t]*\n")) +(define-obsolete-function-alias 'message-goto-body-1 'message-goto-body "27.1") +(defun message-goto-body (&optional interactive) + "Move point to the beginning of the message body. +Returns point." + (interactive "p") + (when interactive + (when (looking-at "[ \t]*\n") (expand-abbrev)) - (push-mark) - (message-goto-body-1)) - -(defun message-goto-body-1 () - "Go to the body and return point." + (push-mark)) (goto-char (point-min)) (or (search-forward (concat "\n" mail-header-separator "\n") nil t) ;; If the message is mangled, find the end of the headers the @@ -3122,12 +3120,12 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." "Return t if point is in the message body." (>= (point) (save-excursion - (message-goto-body-1)))) + (message-goto-body)))) -(defun message-goto-eoh () +(defun message-goto-eoh (&optional interactive) "Move point to the end of the headers." - (interactive) - (message-goto-body) + (interactive "p") + (message-goto-body interactive) (forward-line -1)) (defun message-goto-signature () @@ -3218,13 +3216,13 @@ or in the synonym headers, defined by `message-header-synonyms'." (dolist (header headers) (let* ((header-name (symbol-name (car header))) (new-header (cdr header)) - (synonyms (loop for synonym in message-header-synonyms - when (memq (car header) synonym) return synonym)) + (synonyms (cl-loop for synonym in message-header-synonyms + when (memq (car header) synonym) return synonym)) (old-header - (loop for synonym in synonyms - for old-header = (mail-fetch-field (symbol-name synonym)) - when (and old-header (string-match new-header old-header)) - return synonym))) + (cl-loop for synonym in synonyms + for old-header = (mail-fetch-field (symbol-name synonym)) + when (and old-header (string-match new-header old-header)) + return synonym))) (if old-header (message "already have `%s' in `%s'" new-header old-header) (when (and (message-position-on-field header-name) @@ -3237,8 +3235,7 @@ or in the synonym headers, defined by `message-header-synonyms'." "Widen the reply to include maximum recipients." (interactive) (let ((follow-to - (and (bufferp message-reply-buffer) - (buffer-name message-reply-buffer) + (and (buffer-live-p message-reply-buffer) (with-current-buffer message-reply-buffer (message-get-reply-headers t))))) (save-excursion @@ -3544,7 +3541,7 @@ Note that this should not be used in newsgroups." (message-remove-header "Disposition-Notification-To")) (message-goto-eoh) (insert (format "Disposition-Notification-To: %s\n" - (or (message-field-value "Reply-to") + (or (message-field-value "Reply-To") (message-field-value "From") (message-make-from)))))) @@ -3585,7 +3582,7 @@ text was killed." "Create a rot table with offset N." (let ((i -1) (table (make-string 256 0))) - (while (< (incf i) 256) + (while (< (cl-incf i) 256) (aset table i i)) (concat (substring table 0 ?A) @@ -3753,13 +3750,13 @@ To use this automatically, you may add this function to (goto-char (mark t)) (insert-before-markers ?\n) (goto-char pt)))) - (case message-cite-reply-position - (above + (pcase message-cite-reply-position + ('above (message-goto-body) (insert body-text) (insert (if (bolp) "\n" "\n\n")) (message-goto-body)) - (below + ('below (message-goto-signature))) ;; Add a `message-setup-very-last-hook' here? ;; Add `gnus-article-highlight-citation' here? @@ -3827,13 +3824,14 @@ This function uses `mail-citation-hook' if that is non-nil." (narrow-to-region start end) (message-narrow-to-head-1) (setq x-no-archive (message-fetch-field "x-no-archive")) - (vector 0 - (or (message-fetch-field "subject") "none") - (or (message-fetch-field "from") "nobody") - (message-fetch-field "date") - (message-fetch-field "message-id" t) - (message-fetch-field "references") - 0 0 "")))) + (make-full-mail-header + 0 + (or (message-fetch-field "subject") "none") + (or (message-fetch-field "from") "nobody") + (message-fetch-field "date") + (message-fetch-field "message-id" t) + (message-fetch-field "references") + 0 0 "")))) (mml-quote-region start end) (when strip-signature ;; Allow undoing. @@ -4034,7 +4032,7 @@ It should typically alter the sending method in some way or other." (let ((buf (current-buffer)) (actions message-exit-actions)) (when (and (message-send arg) - (buffer-name buf)) + (buffer-live-p buf)) (message-bury buf) (if message-kill-buffer-on-exit (kill-buffer buf)) @@ -4178,13 +4176,11 @@ It should typically alter the sending method in some way or other." (defmacro message-check (type &rest forms) "Eval FORMS if TYPE is to be checked." + (declare (indent 1) (debug t)) `(or (message-check-element ,type) (save-excursion ,@forms))) -(put 'message-check 'lisp-indent-function 1) -(put 'message-check 'edebug-form-spec '(form body)) - (defun message-text-with-property (prop &optional start end reverse) "Return a list of start and end positions where the text has PROP. START and END bound the search, they default to `point-min' and @@ -4277,7 +4273,7 @@ conformance." (point-max)))) (setq char (char-after))) (when (or (< char 128) - (and (mm-multibyte-p) + (and enable-multibyte-characters (memq (char-charset char) '(eight-bit-control eight-bit-graphic ;; Emacs 23, Bug#1770: @@ -4309,7 +4305,7 @@ conformance." (while (not (eobp)) (when (let ((char (char-after))) (or (< char 128) - (and (mm-multibyte-p) + (and enable-multibyte-characters ;; FIXME: Wrong for Emacs 23 (unicode) and for ;; things like undecodable utf-8 (in Emacs 21?). ;; Should at least use find-coding-systems-region. @@ -4382,7 +4378,7 @@ This function could be useful in `message-setup-hook'." (if (string= encoded bog) "" (format " (%s)" encoded)))))) - (error "Bogus address")))))))) + (user-error "Bogus address")))))))) (custom-add-option 'message-setup-hook 'message-check-recipients) @@ -4485,6 +4481,49 @@ This function could be useful in `message-setup-hook'." (declare-function hashcash-wait-async "hashcash" (&optional buffer)) +(defun message--check-continuation-headers () + (message-check 'continuation-headers + (goto-char (point-min)) + (while (re-search-forward "^[^ \t\n][^ \t\n:]*[ \t\n]" nil t) + (goto-char (match-beginning 0)) + (if (y-or-n-p "Fix continuation lines? ") + (insert " ") + (forward-line 1) + (unless (y-or-n-p "Send anyway? ") + (error "Failed to send the message")))))) + +(defun message--send-mail-maybe-partially () + (if (or (not message-send-mail-partially-limit) + (< (buffer-size) message-send-mail-partially-limit) + (not (message-y-or-n-p + "The message size is too large, split? " + t + "\ +The message size, " + (/ (buffer-size) 1000) "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 " + (/ message-send-mail-partially-limit 1000) + "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 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 + (funcall message-send-mail-real-function) + (message-multi-smtp-send-mail))) + (message-send-mail-partially))) + (defun message-send-mail (&optional _) (require 'mail-utils) (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp")) @@ -4536,17 +4575,7 @@ This function could be useful in `message-setup-hook'." (if news nil message-deletable-headers))) (message-generate-headers headers)) ;; Check continuation headers. - (message-check 'continuation-headers - (goto-char (point-min)) - (while (re-search-forward "^[^ \t\n][^ \t\n:]*[ \t\n]" nil t) - (goto-char (match-beginning 0)) - (if (y-or-n-p "Fix continuation lines? ") - (insert " ") - (forward-line 1) - (unless (y-or-n-p "Send anyway? ") - (error "Failed to send the message"))))) - ;; Fold too-long header lines. They should be no longer than - ;; 998 octets long. + (message--check-continuation-headers) (message--fold-long-headers) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) @@ -4568,8 +4597,7 @@ This function could be useful in `message-setup-hook'." (message-generate-headers '(Lines))) ;; Remove some headers. (message-remove-header message-ignored-mail-headers t) - (let ((mail-parse-charset message-default-charset)) - (mail-encode-encoded-word-buffer))) + (mail-encode-encoded-word-buffer)) (goto-char (point-max)) ;; require one newline at the end. (or (= (preceding-char) ?\n) @@ -4603,41 +4631,14 @@ This function could be useful in `message-setup-hook'." (message-insert-courtesy-copy (with-current-buffer mailbuf message-courtesy-message))) - ;; Let's make sure we encoded all the body. - (assert (save-excursion - (goto-char (point-min)) - (not (re-search-forward "[^\000-\377]" nil t)))) + ;; If this was set, `sendmail-program' takes care of encoding. + (unless message-inhibit-body-encoding + ;; Let's make sure we encoded all the body. + (cl-assert (save-excursion + (goto-char (point-min)) + (not (re-search-forward "[^\000-\377]" nil t))))) (mm-disable-multibyte) - (if (or (not message-send-mail-partially-limit) - (< (buffer-size) message-send-mail-partially-limit) - (not (message-y-or-n-p - "The message size is too large, split? " - t - "\ -The message size, " - (/ (buffer-size) 1000) "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 " - (/ message-send-mail-partially-limit 1000) - "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 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 - (funcall message-send-mail-real-function) - (message-multi-smtp-send-mail))) - (message-send-mail-partially)) + (message--send-mail-maybe-partially) (setq options message-options)) (kill-buffer tembuf)) (set-buffer mailbuf) @@ -4645,10 +4646,12 @@ If you always want Gnus to send messages in one piece, set (push 'mail message-sent-message-via))) (defun message--fold-long-headers () + "Fold too-long header lines. +Each line should be no more than 79 characters long." (goto-char (point-min)) (while (not (eobp)) (when (and (looking-at "[^:]+:") - (> (- (line-end-position) (point)) 998)) + (> (- (line-end-position) (point)) 79)) (mail-header-fold-field)) (forward-line 1))) @@ -4671,9 +4674,11 @@ that instead." (message-send-mail-with-sendmail)) ((equal (car method) "smtp") (require 'smtpmail) - (let ((smtpmail-smtp-server (nth 1 method)) - (smtpmail-smtp-service (nth 2 method)) - (smtpmail-smtp-user (or (nth 3 method) smtpmail-smtp-user))) + (let* ((smtpmail-smtp-server (nth 1 method)) + (service (nth 2 method)) + (port (string-to-number service)) + (smtpmail-smtp-service (if (> port 0) port service)) + (smtpmail-smtp-user (or (nth 3 method) smtpmail-smtp-user))) (message-smtpmail-send-it))) (t (error "Unknown method %s" method)))))) @@ -4746,7 +4751,7 @@ that instead." (if (not (zerop (buffer-size))) (error "Sending...failed to %s" (buffer-string)))))) - (when (bufferp errbuf) + (when (buffer-live-p errbuf) (kill-buffer errbuf))))) (defun message-send-mail-with-qmail () @@ -4760,7 +4765,7 @@ to find out how to use this." (replace-match "\n") (run-hooks 'message-send-mail-hook) ;; send the message - (case + (pcase (let ((coding-system-for-write message-send-coding-system)) (apply 'call-process-region (point-min) (point-max) @@ -4791,7 +4796,7 @@ to find out how to use this." (100 (error "qmail-inject reported permanent failure")) (111 (error "qmail-inject reported transient failure")) ;; should never happen - (t (error "qmail-inject reported unknown failure")))) + (_ (error "qmail-inject reported unknown failure")))) (defvar mh-previous-window-config) @@ -4813,24 +4818,25 @@ to find out how to use this." ;; Pass it on to mh. (mh-send-letter))) +(defun message-use-send-mail-function () + (run-hooks 'message-send-mail-hook) + (funcall send-mail-function)) + (defun message-smtpmail-send-it () "Send the prepared message buffer with `smtpmail-send-it'. The only difference from `smtpmail-send-it' is that this command evaluates `message-send-mail-hook' just before sending a message. It is useful if your ISP requires the POP-before-SMTP authentication. See the Gnus manual for details." + (declare (obsolete message-use-send-mail-function "27.1")) (run-hooks 'message-send-mail-hook) - ;; Change header-delimiter to be what smtpmail expects. - (goto-char (point-min)) - (when (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (replace-match "\n")) (smtpmail-send-it)) (defun message-send-mail-with-mailclient () "Send the prepared message buffer with `mailclient-send-it'. The only difference from `mailclient-send-it' is that this command evaluates `message-send-mail-hook' just before sending a message." + (declare (obsolete message-use-send-mail-function "27.1")) (run-hooks 'message-send-mail-hook) (mailclient-send-it)) @@ -4940,8 +4946,7 @@ Otherwise, generate and save a value for `canlock-password' first." (message-generate-headers '(Lines))) ;; Remove some headers. (message-remove-header message-ignored-news-headers t) - (let ((mail-parse-charset message-default-charset)) - (mail-encode-encoded-word-buffer))) + (mail-encode-encoded-word-buffer)) (goto-char (point-max)) ;; require one newline at the end. (or (= (preceding-char) ?\n) @@ -5165,19 +5170,8 @@ Otherwise, generate and save a value for `canlock-password' first." "Really post to %s unknown group%s: %s? " (if (= (length errors) 1) "this" "these") (if (= (length errors) 1) "" "s") - (mapconcat 'identity errors ", "))))))) - ;; Check continuation headers. - (message-check 'continuation-headers - (goto-char (point-min)) - (let ((do-posting t)) - (while (re-search-forward "^[^ \t\n][^ \t\n:]*[ \t\n]" nil t) - (goto-char (match-beginning 0)) - (if (y-or-n-p "Fix continuation lines? ") - (insert " ") - (forward-line 1) - (unless (y-or-n-p "Send anyway? ") - (setq do-posting nil)))) - do-posting)) + (mapconcat #'identity errors ", "))))))) + (progn (message--check-continuation-headers) t) ;; Check the Newsgroups & Followup-To headers for syntax errors. (message-check 'valid-newsgroups (let ((case-fold-search t) @@ -5314,7 +5308,9 @@ Otherwise, generate and save a value for `canlock-password' first." ;; Check for control characters. (message-check 'control-chars (if (re-search-forward - (string-to-multibyte "[\000-\007\013\015-\032\034-\037\200-\237]") + (eval-when-compile + (decode-coding-string "[\000-\007\013\015-\032\034-\037\200-\237]" + 'binary)) nil t) (y-or-n-p "The article contains control characters. Really post? ") @@ -5330,7 +5326,7 @@ Otherwise, generate and save a value for `canlock-password' first." (message-check 'new-text (or (not message-checksum) - (not (eq (message-checksum) message-checksum)) + (not (equal (message-checksum) message-checksum)) (if (message-gnksa-enable-p 'quoted-text-only) (y-or-n-p "It looks like no new text has been added. Really post? ") @@ -5375,6 +5371,17 @@ Otherwise, generate and save a value for `canlock-password' first." (message "Denied posting -- only quoted text.") nil))))))) +(defun message--rotate-fixnum-left (n) + "Rotate the fixnum N left by one bit in a fixnum word. +The result is a fixnum." + (logior (if (natnump n) 0 1) + (ash (cond ((< (ash most-positive-fixnum -1) n) + (logior n most-negative-fixnum)) + ((< n (ash most-negative-fixnum -1)) + (logand n most-positive-fixnum)) + (n)) + 1))) + (defun message-checksum () "Return a \"checksum\" for the current buffer." (let ((sum 0)) @@ -5384,7 +5391,7 @@ Otherwise, generate and save a value for `canlock-password' first." (concat "^" (regexp-quote mail-header-separator) "$")) (while (not (eobp)) (when (not (looking-at "[ \t\n]")) - (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1) + (setq sum (logxor (message--rotate-fixnum-left sum) (char-after)))) (forward-char 1))) sum)) @@ -5406,8 +5413,7 @@ Otherwise, generate and save a value for `canlock-password' first." (while (setq file (message-fetch-field "fcc" t)) (push file list) (message-remove-header "fcc" nil t)) - (let ((mail-parse-charset message-default-charset) - (rfc2047-header-encoding-alist + (let ((rfc2047-header-encoding-alist (cons '("Newsgroups" . default) rfc2047-header-encoding-alist))) (mail-encode-encoded-word-buffer))) @@ -5416,7 +5422,7 @@ Otherwise, generate and save a value for `canlock-password' first." (concat "^" (regexp-quote mail-header-separator) "$") nil t) (replace-match "" t t )) - ;; Process FCC operations. + ;; Process Fcc operations. (while list (setq file (pop list)) (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file) @@ -5504,9 +5510,9 @@ If NOW, use that time instead." In posting styles use `(\"Expires\" (make-expires-date 30))'." (let* ((cur (decode-time)) - (nday (+ days (nth 3 cur)))) - (setf (nth 3 cur) nday) - (message-make-date (apply 'encode-time cur)))) + (nday (+ days (decoded-time-day cur)))) + (setf (decoded-time-day cur) nday) + (message-make-date (encode-time cur)))) (defun message-make-message-id () "Make a unique Message-ID." @@ -5539,7 +5545,7 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." ;; Instead we use this randomly inited counter. (setq message-unique-id-char (% (1+ (or message-unique-id-char - (logand (random most-positive-fixnum) (1- (lsh 1 20))))) + (random (ash 1 20)))) ;; (current-time) returns 16-bit ints, ;; and 2^16*25 just fits into 4 digits i base 36. (* 25 25))) @@ -5554,9 +5560,9 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." user) (message-number-base36 (user-uid) -1)) (message-number-base36 (+ (car tm) - (lsh (% message-unique-id-char 25) 16)) 4) + (ash (% message-unique-id-char 25) 16)) 4) (message-number-base36 (+ (nth 1 tm) - (lsh (/ message-unique-id-char 25) 16)) 4) + (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. @@ -5840,10 +5846,10 @@ subscribed address (and not the additional To and Cc header contents)." message-subscribed-address-functions)))) (save-match-data (let ((list - (loop for recipient in recipients - when (loop for regexp in mft-regexps - thereis (string-match regexp recipient)) - return recipient))) + (cl-loop for recipient in recipients + when (cl-loop for regexp in mft-regexps + thereis (string-match regexp recipient)) + return recipient))) (when list (if only-show-subscribed list @@ -6192,7 +6198,7 @@ they are." (when (> count maxcount) (let ((surplus (- count maxcount))) (message-shorten-1 refs cut surplus) - (decf count surplus))) + (cl-decf count surplus))) ;; When sending via news, make sure the total folded length will ;; be less than 998 characters. This is to cater to broken INN @@ -6372,8 +6378,7 @@ moved to the beginning " (defun message-pop-to-buffer (name &optional switch-function) "Pop to buffer NAME, and warn if it already exists and is modified." (let ((buffer (get-buffer name))) - (if (and buffer - (buffer-name buffer)) + (if (buffer-live-p buffer) (let ((window (get-buffer-window buffer 0))) (if window ;; Raise the frame already displaying the message buffer. @@ -6404,7 +6409,7 @@ moved to the beginning " (>= (length message-buffer-list) message-max-buffers)) ;; Kill the oldest buffer -- unless it has been changed. (let ((buffer (pop message-buffer-list))) - (when (and (buffer-name buffer) + (when (and (buffer-live-p buffer) (not (buffer-modified-p buffer))) (kill-buffer buffer)))) ;; Rename the buffer. @@ -6717,9 +6722,9 @@ The function is called with one parameter, a cons cell ..." ;; Gmane renames "To". Look at "Original-To", too, if it is present in ;; message-header-synonyms. (setq to (or (message-fetch-field "to") - (and (loop for synonym in message-header-synonyms - when (memq 'Original-To synonym) - return t) + (and (cl-loop for synonym in message-header-synonyms + when (memq 'Original-To synonym) + return t) (message-fetch-field "original-to"))) cc (message-fetch-field "cc") extra (when message-extra-wide-headers @@ -6857,6 +6862,9 @@ want to get rid of this query permanently."))) (setq recipients (delq recip recipients)))))))) (setq recipients (message-prune-recipients recipients)) + (setq recipients + (cl-loop for (id . address) in recipients + collect (cons id (message--alter-repeat-address address)))) ;; Build the header alist. Allow the user to be asked whether ;; or not to reply to all recipients in a wide reply. @@ -6887,6 +6895,15 @@ want to get rid of this query permanently."))) (setq recipients (delq recipient recipients)))))))) recipients) +(defun message--alter-repeat-address (address) + "Transform an address on the form \"\"foo@bar.com\"\" <foo@bar.com>\". +The first bit will be elided if a match is made." + (let ((bits (gnus-extract-address-components address))) + (if (equal (car bits) (cadr bits)) + (car bits) + ;; Return the original address if we don't have repetition. + address))) + (defcustom message-simplify-subject-functions '(message-strip-list-identifiers message-strip-subject-re @@ -6904,21 +6921,12 @@ Useful functions to put in this list include: :type '(repeat function)) (defun message-simplify-subject (subject &optional functions) - "Return simplified SUBJECT." - (unless functions - ;; Simplify fully: - (setq functions message-simplify-subject-functions)) - (when (and (memq 'message-strip-list-identifiers functions) - gnus-list-identifiers) - (setq subject (message-strip-list-identifiers subject))) - (when (memq 'message-strip-subject-re functions) - (setq subject (concat "Re: " (message-strip-subject-re subject)))) - (when (and (memq 'message-strip-subject-trailing-was functions) - message-subject-trailing-was-query) - (setq subject (message-strip-subject-trailing-was subject))) - (when (memq 'message-strip-subject-encoded-words functions) - (setq subject (message-strip-subject-encoded-words subject))) - subject) + "Return simplified SUBJECT. +Do so by calling each one-argument function in the list of functions +specified by FUNCTIONS, if non-nil, or by the variable +`message-simplify-subject-functions' otherwise." + (dolist (fun (or functions message-simplify-subject-functions) subject) + (setq subject (funcall fun subject)))) ;;;###autoload (defun message-reply (&optional to-address wide switch-function) @@ -6951,7 +6959,7 @@ Useful functions to put in this list include: subject (or (message-fetch-field "subject") "none")) ;; Strip list identifiers, "Re: ", and "was:" - (setq subject (message-simplify-subject subject)) + (setq subject (concat "Re: " (message-simplify-subject subject))) (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) (string-match "<[^>]+>" gnus-warning)) @@ -6970,8 +6978,8 @@ Useful functions to put in this list include: (if wide to-address nil)) switch-function)) (setq message-reply-headers - (vector 0 (cdr (assq 'Subject headers)) - from date message-id references 0 0 "")) + (make-full-mail-header 0 (cdr (assq 'Subject headers)) + from date message-id references 0 0 "")) (message-setup headers cur)))) ;;;###autoload @@ -7022,13 +7030,14 @@ If TO-NEWSGROUPS, use that as the new Newsgroups line." (string-match "world" distribution))) (setq distribution nil)) ;; Strip list identifiers, "Re: ", and "was:" - (setq subject (message-simplify-subject subject)) + (setq subject (concat "Re: " (message-simplify-subject subject))) (widen)) (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) (setq message-reply-headers - (vector 0 subject from date message-id references 0 0 "")) + (make-full-mail-header + 0 subject from date message-id references 0 0 "")) (message-setup `((Subject . ,subject) @@ -7367,9 +7376,7 @@ Optional DIGEST will use digest to forward." (unless (multibyte-string-p contents) (error "Attempt to insert unibyte string from the buffer \"%s\"\ to the multibyte buffer \"%s\"" - (if (bufferp forward-buffer) - (buffer-name forward-buffer) - forward-buffer) + forward-buffer (buffer-name))) (insert (mm-with-multibyte-buffer (insert contents) @@ -7401,7 +7408,8 @@ Optional DIGEST will use digest to forward." (when message-forward-included-headers (message-remove-header (if (listp message-forward-included-headers) - (regexp-opt message-forward-included-headers) + (mapconcat #'identity (cons "^$" message-forward-included-headers) + "\\|") message-forward-included-headers) t nil t))))) @@ -7420,7 +7428,7 @@ Optional DIGEST will use digest to forward." ;; Consider there is no illegible text. (add-text-properties b (point) - `(no-illegible-text t rear-nonsticky t start-open t)))) + '(no-illegible-text t rear-nonsticky t start-open t)))) (defun message-forward-make-body-mml (forward-buffer) (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n") @@ -7430,9 +7438,7 @@ Optional DIGEST will use digest to forward." (unless (multibyte-string-p contents) (error "Attempt to insert unibyte string from the buffer \"%s\"\ to the multibyte buffer \"%s\"" - (if (bufferp forward-buffer) - (buffer-name forward-buffer) - forward-buffer) + forward-buffer (buffer-name))) (insert (mm-with-multibyte-buffer (insert contents) @@ -7578,8 +7584,6 @@ is for the internal use." (setq rmail-insert-mime-forwarded-message-function 'message-forward-rmail-make-body)) -(defvar message-inhibit-body-encoding nil) - ;;;###autoload (defun message-resend (address) "Resend the current article to ADDRESS." @@ -7812,8 +7816,8 @@ Pre-defined symbols include `message-tool-bar-gnome' and (repeat :tag "User defined list" gmm-tool-bar-item) (symbol)) :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'message-tool-bar-update + :initialize #'custom-initialize-default + :set #'message-tool-bar-update :group 'message) (defcustom message-tool-bar-gnome @@ -7837,8 +7841,8 @@ Pre-defined symbols include `message-tool-bar-gnome' and 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 + :initialize #'custom-initialize-default + :set #'message-tool-bar-update :group 'message) (defcustom message-tool-bar-retro @@ -7857,8 +7861,8 @@ See `gmm-tool-bar-from-list' for details on the format of the list." 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 + :initialize #'custom-initialize-default + :set #'message-tool-bar-update :group 'message) (defcustom message-tool-bar-zap-list @@ -7870,11 +7874,13 @@ 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 + :initialize #'custom-initialize-default + :set #'message-tool-bar-update :group 'message) (defvar image-load-path) +(declare-function image-load-path-for-library "image" + (library image &optional path no-error)) (defun message-make-tool-bar (&optional force) "Make a message mode tool bar from `message-tool-bar-list'. @@ -7901,6 +7907,7 @@ When FORCE, rebuild the tool bar." :type 'regexp) (defcustom message-completion-alist + ;; FIXME: Make it possible to use the standard completion UI. (list (cons message-newgroups-header-regexp 'message-expand-group) '("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name) '("^\\(Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):" @@ -7973,18 +7980,11 @@ regular text mode tabbing command." (skip-chars-backward "^, \t\n") (point)))) (completion-ignore-case t) (e (progn (skip-chars-forward "^,\t\n ") (point))) - group collection) - (when (and (boundp 'gnus-active-hashtb) - gnus-active-hashtb) - (mapatoms - (lambda (symbol) - (setq group (symbol-name symbol)) - (push (if (string-match "[^\000-\177]" group) - (gnus-group-decoded-name group) - group) - collection)) - gnus-active-hashtb)) - (completion-in-region b e collection))) + (collection (when (and (boundp 'gnus-active-hashtb) + gnus-active-hashtb) + (hash-table-keys gnus-active-hashtb)))) + (when collection + (completion-in-region b e collection)))) (defun message-expand-name () (cond ((and (memq 'eudc message-expand-name-databases) @@ -8009,7 +8009,7 @@ regular text mode tabbing command." If SHOW is non-nil, the arguments TEXT... are displayed in a temp buffer. The following arguments may contain lists of values." (if (and show - (setq text (message-flatten-list text))) + (setq text (flatten-tree text))) (save-window-excursion (with-output-to-temp-buffer " *MESSAGE information message*" (with-current-buffer " *MESSAGE information message*" @@ -8019,15 +8019,7 @@ The following arguments may contain lists of values." (funcall ask question)) (funcall ask question))) -(defun message-flatten-list (list) - "Return a new, flat list that contains all elements of LIST. - -\(message-flatten-list \\='(1 (2 3 (4 5 (6))) 7)) -=> (1 2 3 4 5 6 7)" - (cond ((consp list) - (apply 'append (mapcar 'message-flatten-list list))) - (list - (list list)))) +(define-obsolete-function-alias 'message-flatten-list #'flatten-tree "27.1") (defun message-generate-new-buffer-clone-locals (name &optional varstr) "Create and return a buffer with name based on NAME using `generate-new-buffer'. @@ -8065,9 +8057,7 @@ regexp VARSTR." (defun message-encode-message-body () (unless message-inhibit-body-encoding - (let ((mail-parse-charset (or mail-parse-charset - message-default-charset)) - (case-fold-search t) + (let ((case-fold-search t) lines content-type-p) (message-goto-body) (save-restriction @@ -8123,12 +8113,19 @@ From headers in the original article." (emails (message-tokenize-header (mail-strip-quoted-names - (mapconcat 'message-fetch-reply-field fields ",")))) - (email (cond ((functionp message-alternative-emails) - (car (cl-remove-if-not message-alternative-emails emails))) - (t (loop for email in emails - if (string-match-p message-alternative-emails email) - return email))))) + (mapconcat + #'identity + (cl-loop for field in fields + for value = (message-fetch-reply-field field) + when value + collect value) + ",")))) + (email + (cond ((functionp message-alternative-emails) + (car (cl-remove-if-not message-alternative-emails emails))) + (t (cl-loop for email in emails + if (string-match-p message-alternative-emails email) + return email))))) (unless (or (not email) (equal email user-mail-address)) (message-remove-header "From") (goto-char (point-max)) @@ -8224,16 +8221,19 @@ From headers in the original article." (autoload 'ecomplete-display-matches "ecomplete") +(defun message--in-tocc-p () + (and (memq (char-after (point-at-bol)) '(?C ?T ?\t ? )) + (message-point-in-header-p) + (save-excursion + (beginning-of-line) + (while (and (memq (char-after) '(?\t ? )) + (zerop (forward-line -1)))) + (looking-at "To:\\|Cc:")))) + (defun message-display-abbrev (&optional choose) "Display the next possible abbrev for the text before point." (interactive (list t)) - (when (and (memq (char-after (point-at-bol)) '(?C ?T ?\t ? )) - (message-point-in-header-p) - (save-excursion - (beginning-of-line) - (while (and (memq (char-after) '(?\t ? )) - (zerop (forward-line -1)))) - (looking-at "To:\\|Cc:"))) + (when (message--in-tocc-p) (let* ((end (point)) (start (save-excursion (and (re-search-backward "[\n\t ]" nil t) @@ -8246,6 +8246,20 @@ From headers in the original article." (delete-region start end) (insert match))))) +(defun message-ecomplete-capf () + "Return completion data for email addresses in Ecomplete. +Meant for use on `completion-at-point-functions'." + (when (and (bound-and-true-p ecomplete-database) + (fboundp 'ecomplete-completion-table) + (message--in-tocc-p)) + (let ((end (save-excursion + (skip-chars-forward "^, \t\n") + (point))) + (start (save-excursion + (skip-chars-backward "^, \t\n") + (point)))) + `(,start ,end ,(ecomplete-completion-table 'mail))))) + ;; To send pre-formatted letters like the example below, you can use ;; `message-send-form-letter': ;; --8<---------------cut here---------------start------------->8--- @@ -8353,6 +8367,9 @@ even if NEW-VALUE is empty." (message-position-on-field header)) (insert new-value)))) +(make-obsolete-variable + 'message-recipients-without-full-name + "Recipients are simplified by default" "27.1") (defcustom message-recipients-without-full-name (list "ding@gnus.org" "bugs@gnus.org" @@ -8368,6 +8385,7 @@ Used in `message-simplify-recipients'." :version "23.1" ;; No Gnus :group 'message-headers) +(make-obsolete 'message-simplify-recipients nil "27.1") (defun message-simplify-recipients () (interactive) (dolist (hdr '("Cc" "To")) diff --git a/lisp/gnus/mm-bodies.el b/lisp/gnus/mm-bodies.el index 298127a3f44..e1e1a12cc59 100644 --- a/lisp/gnus/mm-bodies.el +++ b/lisp/gnus/mm-bodies.el @@ -262,7 +262,7 @@ decoding. If it is nil, default to `mail-parse-charset'." (setq coding-system (mm-charset-to-coding-system mail-parse-charset))) (when (and charset coding-system - (mm-multibyte-p) + enable-multibyte-characters (or (not (eq coding-system 'ascii)) (setq coding-system mail-parse-charset))) (decode-coding-region (point-min) (point-max) coding-system)) @@ -289,7 +289,7 @@ decoding. If it is nil, default to `mail-parse-charset'." (setq coding-system (mm-charset-to-coding-system mail-parse-charset))) (when (and charset coding-system - (mm-multibyte-p) + enable-multibyte-characters (or (not (eq coding-system 'ascii)) (setq coding-system mail-parse-charset))) (decode-coding-string string coding-system))) diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 33cb797bf69..cba9633b539 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -1,4 +1,4 @@ -;;; mm-decode.el --- Functions for decoding MIME things +;;; mm-decode.el --- Functions for decoding MIME things -*- lexical-binding:t -*- ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. @@ -25,7 +25,7 @@ (require 'mail-parse) (require 'mm-bodies) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (autoload 'gnus-map-function "gnus-util") @@ -118,8 +118,7 @@ ((executable-find "w3m") 'gnus-w3m) ((executable-find "links") 'links) ((executable-find "lynx") 'lynx) - ((locate-library "html2text") 'html2text) - (t nil)) + ((locate-library "html2text") 'html2text)) "Render of HTML contents. It is one of defined renderer types, or a rendering function. The defined renderer types are: @@ -129,9 +128,8 @@ The defined renderer types are: `w3m-standalone': use plain w3m; `links': use links; `lynx': use lynx; -`html2text': use html2text; -nil : use external viewer (default web browser)." - :version "24.1" +`html2text': use html2text." + :version "27.1" :type '(choice (const shr) (const gnus-w3m) (const w3m :tag "emacs-w3m") @@ -139,7 +137,6 @@ nil : use external viewer (default web browser)." (const links) (const lynx) (const html2text) - (const nil :tag "External viewer") (function)) :group 'mime-display) @@ -193,45 +190,45 @@ before the external MIME handler is invoked." :group 'mime-display) (defcustom mm-inline-media-tests - '(("image/p?jpeg" + `(("image/p?jpeg" mm-inline-image - (lambda (handle) + ,(lambda (handle) (mm-valid-and-fit-image-p 'jpeg handle))) ("image/png" mm-inline-image - (lambda (handle) + ,(lambda (handle) (mm-valid-and-fit-image-p 'png handle))) ("image/gif" mm-inline-image - (lambda (handle) + ,(lambda (handle) (mm-valid-and-fit-image-p 'gif handle))) ("image/tiff" mm-inline-image - (lambda (handle) + ,(lambda (handle) (mm-valid-and-fit-image-p 'tiff handle))) ("image/xbm" mm-inline-image - (lambda (handle) + ,(lambda (handle) (mm-valid-and-fit-image-p 'xbm handle))) ("image/x-xbitmap" mm-inline-image - (lambda (handle) + ,(lambda (handle) (mm-valid-and-fit-image-p 'xbm handle))) ("image/xpm" mm-inline-image - (lambda (handle) + ,(lambda (handle) (mm-valid-and-fit-image-p 'xpm handle))) ("image/x-xpixmap" mm-inline-image - (lambda (handle) + ,(lambda (handle) (mm-valid-and-fit-image-p 'xpm handle))) ("image/bmp" mm-inline-image - (lambda (handle) + ,(lambda (handle) (mm-valid-and-fit-image-p 'bmp handle))) ("image/x-portable-bitmap" mm-inline-image - (lambda (handle) + ,(lambda (handle) (mm-valid-and-fit-image-p 'pbm handle))) ("text/plain" mm-inline-text identity) ("text/enriched" mm-inline-text identity) @@ -239,6 +236,7 @@ before the external MIME handler is invoked." ("text/x-patch" mm-display-patch-inline identity) ;; In case mime.types uses x-diff (as does Debian's mime-support-3.40). ("text/x-diff" mm-display-patch-inline identity) + ("application/x-patch" mm-display-patch-inline identity) ("application/emacs-lisp" mm-display-elisp-inline identity) ("application/x-emacs-lisp" mm-display-elisp-inline identity) ("application/x-shellscript" mm-display-shell-script-inline identity) @@ -249,13 +247,14 @@ before the external MIME handler is invoked." ("text/x-org" mm-display-org-inline identity) ("text/html" mm-inline-text-html - (lambda (handle) + ,(lambda (_handle) mm-text-html-renderer)) ("text/x-vcard" mm-inline-text-vcard - (lambda (handle) + ,(lambda (_handle) (or (featurep 'vcard) (locate-library "vcard")))) + ("text/calendar" gnus-icalendar-mm-inline identity) ("message/delivery-status" mm-inline-text identity) ("message/rfc822" mm-inline-message identity) ("message/partial" mm-inline-partial identity) @@ -263,15 +262,6 @@ before the external MIME handler is invoked." ("text/.*" mm-inline-text identity) ("application/x-.?tar\\(-.*\\)?" mm-archive-dissect-and-inline identity) ("application/zip" mm-archive-dissect-and-inline identity) - ("audio/wav" mm-inline-audio - (lambda (handle) - (and (or (featurep 'nas-sound) (featurep 'native-sound)) - (device-sound-enabled-p)))) - ("audio/au" - mm-inline-audio - (lambda (handle) - (and (or (featurep 'nas-sound) (featurep 'native-sound)) - (device-sound-enabled-p)))) ("application/pgp-signature" ignore identity) ("application/x-pkcs7-signature" ignore identity) ("application/pkcs7-signature" ignore identity) @@ -282,7 +272,7 @@ before the external MIME handler is invoked." ("multipart/related" ignore identity) ("image/.*" mm-inline-image - (lambda (handle) + ,(lambda (handle) (and (mm-valid-image-format-p 'imagemagick) (mm-with-unibyte-buffer (mm-insert-part handle) @@ -305,8 +295,9 @@ before the external MIME handler is invoked." (defcustom mm-inlined-types '("image/.*" "text/.*" "message/delivery-status" "message/rfc822" - "message/partial" "message/external-body" "application/emacs-lisp" - "application/x-emacs-lisp" + "message/partial" "message/external-body" + "application/x-patch" + "application/emacs-lisp" "application/x-emacs-lisp" "application/pgp-signature" "application/x-pkcs7-signature" "application/pkcs7-signature" "application/x-pkcs7-mime" "application/pkcs7-mime" @@ -323,15 +314,18 @@ type inline." (defcustom mm-keep-viewer-alive-types '("application/postscript" "application/msword" "application/vnd.ms-excel" - "application/pdf" "application/x-dvi") - "List of media types for which the external viewer will not be killed -when selecting a different article." - :version "22.1" + "application/pdf" "application/x-dvi" + "application/vnd.*") + "Media types for viewers not to be killed when selecting a different article. +Instead the viewers will be killed on Gnus exit instead. This is +a list of regexps." + :version "27.1" :type '(repeat regexp) :group 'mime-display) (defcustom mm-automatic-display '("text/plain" "text/enriched" "text/richtext" "text/html" "text/x-verbatim" + "text/calendar" "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*" "message/rfc822" "text/x-patch" "text/dns" "application/pgp-signature" "application/emacs-lisp" "application/x-emacs-lisp" @@ -761,7 +755,7 @@ MIME-Version header before proceeding." (defun mm-copy-to-buffer () "Copy the contents of the current buffer to a fresh buffer." (let ((obuf (current-buffer)) - (mb (mm-multibyte-p)) + (mb enable-multibyte-characters) beg) (goto-char (point-min)) (search-forward-regexp "^\n" nil 'move) ;; There might be no body. @@ -773,15 +767,16 @@ MIME-Version header before proceeding." (insert-buffer-substring obuf beg) (current-buffer)))) -(defun mm-display-parts (handle &optional no-default) - (if (stringp (car handle)) - (mapcar 'mm-display-parts (cdr handle)) - (if (bufferp (car handle)) - (save-restriction - (narrow-to-region (point) (point)) - (mm-display-part handle) - (goto-char (point-max))) - (mapcar 'mm-display-parts handle)))) +(defun mm-display-parts (handle) + (cond + ((stringp (car handle)) (mapcar #'mm-display-parts (cdr handle))) + ((bufferp (car handle)) + (save-restriction + (narrow-to-region (point) (point)) + (mm-display-part handle) + (goto-char (point-max)))) + (t + (mapcar #'mm-display-parts handle)))) (autoload 'mailcap-parse-mailcaps "mailcap") (autoload 'mailcap-mime-info "mailcap") @@ -890,6 +885,7 @@ external if displayed external." (when method (message "Viewing with %s" method)) (let ((mm (current-buffer)) + (attachment-filename (mm-handle-filename handle)) (non-viewer (assq 'non-viewer (mailcap-mime-info (mm-handle-media-type handle) t)))) @@ -897,12 +893,14 @@ external if displayed external." (if method (progn (when (and (boundp 'gnus-summary-buffer) - (bufferp gnus-summary-buffer) - (buffer-name gnus-summary-buffer)) + (buffer-live-p gnus-summary-buffer)) + (when attachment-filename + (with-current-buffer mm + (rename-buffer + (format "*mm* %s" attachment-filename) t))) ;; So that we pop back to the right place, sort of. (switch-to-buffer gnus-summary-buffer) (switch-to-buffer mm)) - (delete-other-windows) (funcall method)) (mm-save-part handle)) (when (and (not non-viewer) @@ -961,15 +959,15 @@ external if displayed external." mm-external-terminal-program "-e" shell-file-name shell-command-switch command) - `(lambda (process state) - (if (eq 'exit (process-status process)) - (run-at-time - 60.0 nil - (lambda () - (ignore-errors (delete-file ,file)) - (ignore-errors (delete-directory - ,(file-name-directory - file)))))))) + (lambda (process _state) + (if (eq 'exit (process-status process)) + (run-at-time + 60.0 nil + (lambda () + (ignore-errors (delete-file file)) + (ignore-errors (delete-directory + (file-name-directory + file)))))))) (require 'term) (require 'gnus-win) (set-buffer @@ -982,13 +980,13 @@ external if displayed external." (term-char-mode) (set-process-sentinel (get-buffer-process buffer) - `(lambda (process state) - (when (eq 'exit (process-status process)) - (ignore-errors (delete-file ,file)) - (ignore-errors - (delete-directory ,(file-name-directory file))) - (gnus-configure-windows - ',gnus-current-window-configuration)))) + (let ((wc gnus-current-window-configuration)) + (lambda (process _state) + (when (eq 'exit (process-status process)) + (ignore-errors (delete-file file)) + (ignore-errors + (delete-directory (file-name-directory file))) + (gnus-configure-windows wc))))) (gnus-configure-windows 'display-term)) (mm-handle-set-external-undisplayer handle (cons file buffer)) (add-to-list 'mm-temp-files-to-be-deleted file t)) @@ -1032,34 +1030,29 @@ external if displayed external." shell-command-switch command) (set-process-sentinel (get-buffer-process buffer) - (lexical-let ((outbuf outbuf) - (file file) - (buffer buffer) - (command command) - (handle handle)) - (lambda (process state) - (when (eq (process-status process) 'exit) - (run-at-time - 60.0 nil - (lambda () - (ignore-errors (delete-file file)) - (ignore-errors (delete-directory - (file-name-directory file))))) - (when (buffer-live-p outbuf) - (with-current-buffer outbuf - (let ((buffer-read-only nil) - (point (point))) - (forward-line 2) - (let ((start (point))) - (mm-insert-inline - handle (with-current-buffer buffer - (buffer-string))) - (put-text-property start (point) - 'face 'mm-command-output)) - (goto-char point)))) - (when (buffer-live-p buffer) - (kill-buffer buffer))) - (message "Displaying %s...done" command))))) + (lambda (process _state) + (when (eq (process-status process) 'exit) + (run-at-time + 60.0 nil + (lambda () + (ignore-errors (delete-file file)) + (ignore-errors (delete-directory + (file-name-directory file))))) + (when (buffer-live-p outbuf) + (with-current-buffer outbuf + (let ((buffer-read-only nil) + (point (point))) + (forward-line 2) + (let ((start (point))) + (mm-insert-inline + handle (with-current-buffer buffer + (buffer-string))) + (put-text-property start (point) + 'face 'mm-command-output)) + (goto-char point)))) + (when (buffer-live-p buffer) + (kill-buffer buffer))) + (message "Displaying %s...done" command)))) (mm-handle-set-external-undisplayer handle (cons file buffer)) (add-to-list 'mm-temp-files-to-be-deleted file t)) @@ -1158,9 +1151,8 @@ external if displayed external." (ignore-errors (delete-file (car object))) (ignore-errors (delete-directory (file-name-directory (car object))))) - ((bufferp object) - (when (buffer-live-p object) - (kill-buffer object))))) + ((buffer-live-p object) + (kill-buffer object)))) (mm-handle-set-undisplayer handle nil)))) (defun mm-display-inline (handle) @@ -1170,9 +1162,9 @@ external if displayed external." (goto-char (point-min)))) (defun mm-assoc-string-match (alist type) - (dolist (elem alist) + (cl-dolist (elem alist) (when (string-match (car elem) type) - (return elem)))) + (cl-return elem)))) (defun mm-automatic-display-p (handle) "Say whether the user wants HANDLE to be displayed automatically." @@ -1302,8 +1294,6 @@ are ignored." 'gnus-decoded) (with-current-buffer (mm-handle-buffer handle) (buffer-string))) - ((mm-multibyte-p) - (string-to-multibyte (mm-get-part handle no-cache))) (t (mm-get-part handle no-cache))))) (save-restriction @@ -1448,8 +1438,7 @@ text/html\\(?:;\\s-*charset=\\([^\t\n\r \"'>]+\\)\\)?[^>]*>" nil t) (defun mm-pipe-part (handle &optional cmd) "Pipe HANDLE to a process. Use CMD as the process." - (let ((name (mail-content-type-get (mm-handle-type handle) 'name)) - (command (or cmd + (let ((command (or cmd (read-shell-command "Shell command on MIME part: " mm-last-shell-command)))) (mm-with-unibyte-buffer @@ -1784,6 +1773,9 @@ If RECURSIVE, search recursively." (declare-function shr-insert-document "shr" (dom)) (defvar shr-blocked-images) (defvar shr-use-fonts) +(defvar shr-width) +(defvar shr-content-function) +(defvar shr-inhibit-images) (defun mm-shr (handle) ;; Require since we bind its variables. @@ -1837,44 +1829,13 @@ text/html;\\s-*charset=\\([^\t\n\r \"'>]+\\)[^>]*>" nil t) (shr-insert-document document) (unless (bobp) (insert "\n")) - (mm-convert-shr-links) (mm-handle-set-undisplayer handle - `(lambda () - (let ((inhibit-read-only t)) - (delete-region ,(point-min-marker) - ,(point-max-marker)))))))) - -(defvar shr-image-map) - -(autoload 'widget-convert-button "wid-edit") -(defvar widget-keymap) - -(defun mm-convert-shr-links () - (let ((start (point-min)) - end keymap) - (while (and start - (< start (point-max))) - (when (setq start (text-property-not-all start (point-max) 'shr-url nil)) - (setq end (next-single-property-change start 'shr-url nil (point-max))) - (widget-convert-button - 'url-link start end - :help-echo (get-text-property start 'help-echo) - :keymap (setq keymap (copy-keymap shr-image-map)) - (get-text-property start 'shr-url)) - ;; Mask keys that launch `widget-button-click'. - ;; Those bindings are provided by `widget-keymap' - ;; that is a parent of `gnus-article-mode-map'. - (dolist (key (where-is-internal #'widget-button-click widget-keymap)) - (unless (lookup-key keymap key) - (define-key keymap key #'ignore))) - ;; Avoid `shr-next-link' and `shr-previous-link' in `keymap' so - ;; TAB and M-TAB run `widget-forward' and `widget-backward' instead. - (substitute-key-definition 'shr-next-link nil keymap) - (substitute-key-definition 'shr-previous-link nil keymap) - (dolist (overlay (overlays-at start)) - (overlay-put overlay 'face nil)) - (setq start end))))) + (let ((min (point-min-marker)) + (max (point-max-marker))) + (lambda () + (let ((inhibit-read-only t)) + (delete-region min max)))))))) (defun mm-handle-filename (handle) "Return filename of HANDLE if any." diff --git a/lisp/gnus/mm-encode.el b/lisp/gnus/mm-encode.el index 9e395b05433..7d1040961fd 100644 --- a/lisp/gnus/mm-encode.el +++ b/lisp/gnus/mm-encode.el @@ -23,7 +23,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'mail-parse) (autoload 'mailcap-extension-to-mime "mailcap") (autoload 'mm-body-7-or-8 "mm-bodies") @@ -204,7 +204,7 @@ This is either `base64' or `quoted-printable'." (goto-char (point-min)) (skip-chars-forward "\x20-\x7f\r\n\t" limit) (while (< (point) limit) - (incf n8bit) + (cl-incf n8bit) (forward-char 1) (skip-chars-forward "\x20-\x7f\r\n\t" limit)) (if (or (< (* 6 n8bit) (- limit (point-min))) diff --git a/lisp/gnus/mm-extern.el b/lisp/gnus/mm-extern.el index 32ba831a0da..c3054432d51 100644 --- a/lisp/gnus/mm-extern.el +++ b/lisp/gnus/mm-extern.el @@ -1,4 +1,4 @@ -;;; mm-extern.el --- showing message/external-body +;;; mm-extern.el --- showing message/external-body -*- lexical-binding:t -*- ;; Copyright (C) 2000-2019 Free Software Foundation, Inc. @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'mm-util) (require 'mm-decode) (require 'mm-url) @@ -33,13 +31,13 @@ (defvar gnus-article-mime-handles) (defvar mm-extern-function-alist - '((local-file . mm-extern-local-file) - (url . mm-extern-url) - (anon-ftp . mm-extern-anon-ftp) - (ftp . mm-extern-ftp) -;;; (tftp . mm-extern-tftp) - (mail-server . mm-extern-mail-server) -;;; (afs . mm-extern-afs)) + `((local-file . ,#'mm-extern-local-file) + (url . ,#'mm-extern-url) + (anon-ftp . ,#'mm-extern-anon-ftp) + (ftp . ,#'mm-extern-ftp) + ;; (tftp . ,#'mm-extern-tftp) + (mail-server . ,#'mm-extern-mail-server) + ;; (afs . ,#'mm-extern-afs)) )) (defvar mm-extern-anonymous "anonymous") @@ -72,7 +70,6 @@ (name (cdr (assq 'name params))) (site (cdr (assq 'site params))) (directory (cdr (assq 'directory params))) - (mode (cdr (assq 'mode params))) (path (concat "/" (or mm-extern-anonymous (read-string (format "ID for %s: " site))) "@" site ":" directory "/" name)) @@ -86,7 +83,7 @@ (let (mm-extern-anonymous) (mm-extern-anon-ftp handle))) -(declare-function message-goto-body "message" ()) +(declare-function message-goto-body "message" (&optional interactive)) (defun mm-extern-mail-server (handle) (require 'message) diff --git a/lisp/gnus/mm-partial.el b/lisp/gnus/mm-partial.el index c2bd58ac5ec..c68ab4a7c13 100644 --- a/lisp/gnus/mm-partial.el +++ b/lisp/gnus/mm-partial.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'gnus-sum) (require 'mm-util) (require 'mm-decode) diff --git a/lisp/gnus/mm-url.el b/lisp/gnus/mm-url.el index 62462d0b360..b53a1bcd303 100644 --- a/lisp/gnus/mm-url.el +++ b/lisp/gnus/mm-url.el @@ -28,7 +28,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'mm-util) (require 'gnus) @@ -318,7 +318,7 @@ If FOLLOW-REFRESH is non-nil, redirect refresh url in META." (done nil) (first t) result) - (while (and (not (zerop (decf times))) + (while (and (not (zerop (cl-decf times))) (not done)) (with-timeout (mm-url-timeout) (unless first diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index bbaab536f1a..00a8a532d27 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -1,4 +1,4 @@ -;;; mm-util.el --- Utility functions for Mule and low level things +;;; mm-util.el --- Utility functions for Mule and low level things -*- lexical-binding:t -*- ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. @@ -23,7 +23,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'mail-prsvr) (require 'timer) @@ -241,7 +241,7 @@ superset of iso-8859-1." (widget-convert 'list `(set :inline t :format "%v" ,@(nreverse rest)) - `(repeat :inline t :tag "Other options" + '(repeat :inline t :tag "Other options" (cons :format "%v" (symbol :size 3 :format "(%v") (symbol :size 3 :format " . %v)\n"))))))) @@ -431,7 +431,7 @@ mail with multiple parts is preferred to sending a Unicode one.") (#x94 . #x201D) (#x95 . #x2022) (#x96 . #x2013) (#x97 . #x2014) (#x98 . #x02DC) (#x99 . #x2122) (#x9A . #x0161) (#x9B . #x203A) (#x9C . #x0153) (#x9E . #x017E) (#x9F . #x0178))) - "*Alist of extra numeric entities and characters other than ISO 10646. + "Alist of extra numeric entities and characters other than ISO 10646. This table is used for decoding extra numeric entities to characters, like \"€\" to the euro sign, mainly in html messages." :type '(alist :key-type character :value-type character) @@ -521,7 +521,7 @@ If POS is out of range, the value is nil." enable-multibyte-characters) (defun mm-iso-8859-x-to-15-region (&optional b e) - (let (charset item c inconvertible) + (let (item c inconvertible) (save-restriction (if e (narrow-to-region b e)) (goto-char (point-min)) @@ -559,7 +559,7 @@ nil means ASCII, a single-element list represents an appropriate MIME charset, and a longer list means no appropriate charset." (let (charsets) ;; The return possibilities of this function are a mess... - (or (and (mm-multibyte-p) + (or (and enable-multibyte-characters mm-use-find-coding-systems-region ;; Find the mime-charset of the most preferred coding ;; system that has one. @@ -597,7 +597,7 @@ charset, and a longer list means no appropriate charset." ;; We're not multibyte, or a single coding system won't cover it. (setq charsets (delete-dups - (mapcar 'mm-mime-charset + (mapcar #'mm-mime-charset (delq 'ascii (mm-find-charset-region b e)))))) (if (and (> (length charsets) 1) @@ -612,45 +612,23 @@ charset, and a longer list means no appropriate charset." charsets)) (defmacro mm-with-unibyte-buffer (&rest forms) - "Create a temporary buffer, and evaluate FORMS there like `progn'. -Use unibyte mode for this." + "Create a temporary unibyte buffer, and evaluate FORMS there like `progn'." + (declare (indent 0) (debug t)) `(with-temp-buffer (mm-disable-multibyte) ,@forms)) -(put 'mm-with-unibyte-buffer 'lisp-indent-function 0) -(put 'mm-with-unibyte-buffer 'edebug-form-spec '(body)) (defmacro mm-with-multibyte-buffer (&rest forms) - "Create a temporary buffer, and evaluate FORMS there like `progn'. -Use multibyte mode for this." + "Create a temporary multibyte buffer, and evaluate FORMS there like `progn'." + (declare (indent 0) (debug t)) `(with-temp-buffer (mm-enable-multibyte) ,@forms)) -(put 'mm-with-multibyte-buffer 'lisp-indent-function 0) -(put 'mm-with-multibyte-buffer 'edebug-form-spec '(body)) - -(defmacro mm-with-unibyte-current-buffer (&rest forms) - "Evaluate FORMS with current buffer temporarily made unibyte. - -Note: We recommend not using this macro any more; there should be -better ways to do a similar thing. The previous version of this macro -bound the default value of `enable-multibyte-characters' to nil while -evaluating FORMS but it is no longer done. So, some programs assuming -it if any may malfunction." - (declare (obsolete nil "25.1") (indent 0) (debug t)) - (let ((multibyte (make-symbol "multibyte"))) - `(let ((,multibyte enable-multibyte-characters)) - (when ,multibyte - (set-buffer-multibyte nil)) - (prog1 - (progn ,@forms) - (when ,multibyte - (set-buffer-multibyte t)))))) (defun mm-find-charset-region (b e) "Return a list of Emacs charsets in the region B to E." (cond - ((mm-multibyte-p) + (enable-multibyte-characters ;; Remove composition since the base charsets have been included. ;; Remove eight-bit-*, treat them as ascii. (let ((css (find-charset-region b e))) @@ -699,21 +677,26 @@ to advanced Emacs features, such as file-name-handlers, format decoding, `find-file-hook', etc. If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'. This function ensures that none of these modifications will take place." - (letf* ((format-alist nil) - (auto-mode-alist (if inhibit nil (mm-auto-mode-alist))) - ((default-value 'major-mode) 'fundamental-mode) - (enable-local-variables nil) - (after-insert-file-functions nil) - (enable-local-eval nil) - (inhibit-file-name-operation (if inhibit - 'insert-file-contents - inhibit-file-name-operation)) - (inhibit-file-name-handlers - (if inhibit - (append mm-inhibit-file-name-handlers - inhibit-file-name-handlers) - inhibit-file-name-handlers)) - (find-file-hook nil)) + (cl-letf* ((format-alist nil) + ;; FIXME: insert-file-contents doesn't look at auto-mode-alist, + ;; nor at (default-value 'major-mode)! + (auto-mode-alist (if inhibit nil (mm-auto-mode-alist))) + ((default-value 'major-mode) 'fundamental-mode) + ;; FIXME: neither enable-local-variables nor enable-local-eval are + ;; run by insert-file-contents, AFAICT?! + (enable-local-variables nil) + (after-insert-file-functions nil) + (enable-local-eval nil) + (inhibit-file-name-operation (if inhibit + 'insert-file-contents + inhibit-file-name-operation)) + (inhibit-file-name-handlers + (if inhibit + (append mm-inhibit-file-name-handlers + inhibit-file-name-handlers) + inhibit-file-name-handlers)) + ;; FIXME: insert-file-contents doesn't run find-file-hook anyway! + (find-file-hook nil)) (insert-file-contents filename visit beg end replace))) (defun mm-append-to-file (start end filename &optional codesys inhibit) @@ -838,7 +821,7 @@ decompressed data. The buffer's multibyteness must be turned off." prog t (list t err-file) nil args) jka-compr-acceptable-retval-list) (erase-buffer) - (insert (mapconcat 'identity + (insert (mapconcat #'identity (split-string (prog2 (insert-file-contents err-file) @@ -849,7 +832,7 @@ decompressed data. The buffer's multibyteness must be turned off." "\n") (setq err-msg (format "Error while executing \"%s %s < %s\"" - prog (mapconcat 'identity args " ") + prog (mapconcat #'identity args " ") filename))) (setq retval (buffer-string))) (error @@ -899,6 +882,19 @@ gzip, bzip2, etc. are allowed." (when decomp (kill-buffer (current-buffer))))))) +(defun mm-images-in-region-p (start end) + (let ((found nil)) + (save-excursion + (goto-char start) + (while (and (not found) + (< (point) end)) + (let ((display (get-text-property (point) 'display))) + (when (and (consp display) + (eq (car display) 'image)) + (setq found t))) + (forward-char 1))) + found)) + (provide 'mm-util) ;;; mm-util.el ends here diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el index c0da31fb568..a00d64015f2 100644 --- a/lisp/gnus/mm-uu.el +++ b/lisp/gnus/mm-uu.el @@ -24,7 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'mail-parse) (require 'nnheader) (require 'mm-decode) diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index 03e1e11813f..6ffa1fc168d 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -22,7 +22,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(require 'cl-lib) (require 'mail-parse) (require 'mailcap) (require 'mm-bodies) @@ -318,6 +318,8 @@ (if entry (setq func (cdr entry))) (cond + ((null func) + (mm-insert-inline handle (mm-get-part handle))) ((functionp func) (funcall func handle)) (t @@ -357,8 +359,8 @@ (save-restriction (narrow-to-region b (point)) (goto-char b) - (fill-flowed nil (equal (cdr (assoc 'delsp (mm-handle-type handle))) - "yes")) + (fill-flowed nil (cl-equalp (cdr (assoc 'delsp (mm-handle-type handle))) + "yes")) (goto-char (point-max)))) (save-restriction (narrow-to-region b (point)) @@ -452,7 +454,7 @@ "Insert HANDLE inline fontifying with MODE. If MODE is not set, try to find mode automatically." (let ((charset (mail-content-type-get (mm-handle-type handle) 'charset)) - text coding-system) + text coding-system ovs) (unless (eq charset 'gnus-decoded) (mm-with-unibyte-buffer (mm-insert-part handle) @@ -470,38 +472,48 @@ If MODE is not set, try to find mode automatically." (buffer-string))) (coding-system (decode-coding-string text coding-system)) - (charset - (mm-decode-string text charset)) - (t - text))) - (require 'font-lock) - ;; I find font-lock a bit too verbose. - (let ((font-lock-verbose nil) - (font-lock-support-mode nil) + (t + (mm-decode-string text (or charset 'undecided))))) + (let ((font-lock-verbose nil) ; font-lock is a bit too verbose. (enable-local-variables nil)) - ;; Disable support modes, e.g., jit-lock, lazy-lock, etc. - ;; Note: XEmacs people use `font-lock-mode-hook' to run those modes. + ;; We used to set font-lock-mode-hook to nil to avoid enabling + ;; support modes, but now that we use font-lock-ensure, support modes + ;; aren't a problem any more. So we could probably get rid of this + ;; setting now, but it seems harmless and potentially still useful. (set (make-local-variable 'font-lock-mode-hook) nil) (setq buffer-file-name (mm-handle-filename handle)) (with-demoted-errors - (if mode - (save-window-excursion - (switch-to-buffer (current-buffer)) - (funcall mode)) + (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)))) - (set-auto-mode))) - ;; The mode function might have already turned on font-lock. + (set-auto-mode) + (setq mode major-mode))) ;; Do not fontify if the guess mode is fundamental. - (unless (or font-lock-mode - (eq major-mode 'fundamental-mode)) + (unless (eq major-mode 'fundamental-mode) (font-lock-ensure)))) (setq text (buffer-string)) + (when (eq mode 'diff-mode) + (setq ovs (mapcar (lambda (ov) (list ov (overlay-start ov) + (overlay-end ov))) + (overlays-in (point-min) (point-max))))) ;; Set buffer unmodified to avoid confirmation when killing the ;; buffer. (set-buffer-modified-p nil)) - (mm-insert-inline handle text))) + (let ((b (- (point) (save-restriction (widen) (point-min))))) + (mm-insert-inline handle text) + (dolist (ov ovs) + (move-overlay (nth 0 ov) (+ (nth 1 ov) b) + (+ (nth 2 ov) b) (current-buffer)))))) ;; Shouldn't these functions check whether the user even wants to use ;; font-lock? Also, it would be nice to change for the size of the @@ -563,7 +575,7 @@ If MODE is not set, try to find mode automatically." (error "Could not identify PKCS#7 type"))))) (defun mm-view-pkcs7 (handle &optional from) - (case (mm-view-pkcs7-get-type handle) + (cl-case (mm-view-pkcs7-get-type handle) (enveloped (mm-view-pkcs7-decrypt handle from)) (signed (mm-view-pkcs7-verify handle)) (otherwise (error "Unknown or unimplemented PKCS#7 type")))) diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el index 4fca4ce67b7..07d20285343 100644 --- a/lisp/gnus/mml-sec.el +++ b/lisp/gnus/mml-sec.el @@ -23,7 +23,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(require 'cl-lib) (require 'gnus-util) (require 'epg) @@ -167,9 +167,9 @@ You can also customize or set `mml-signencrypt-style-alist' instead." (if (or (eq style 'separate) (eq style 'combined)) ;; valid style setting? - (setf (second style-item) style) + (setf (cadr style-item) style) ;; otherwise, just return the current value - (second style-item)) + (cadr style-item)) (message "Warning, attempt to set invalid signencrypt style")))) ;;; Security functions @@ -497,7 +497,8 @@ https://debbugs.gnu.org/cgi/bugreport.cgi?bug=18718" 'mml2015-sign-with-sender 'mml-secure-openpgp-sign-with-sender "25.1") ;mml1991-sign-with-sender did never exist. (defcustom mml-secure-openpgp-sign-with-sender nil - "If t, use message sender to find an OpenPGP key to sign with." + "If t, use message sender to find an OpenPGP key to sign with. +Also use message's sender with GnuPG's --sender option." :group 'mime-security :type 'boolean) @@ -554,7 +555,7 @@ customized in this variable." "For CONTEXT, USAGE, and NAME record fingerprint(s) of KEYS. If optional SAVE is not nil, save customized fingerprints. Return keys." - (assert keys) + (cl-assert keys) (let* ((usage-prefs (mml-secure-cust-usage-lookup context usage)) (curr-fprs (cdr (assoc name (cdr usage-prefs)))) (key-fprs (mapcar 'mml-secure-fingerprint keys)) @@ -647,6 +648,7 @@ The passphrase is read and cached." (when passphrase (let ((password-cache-expiry (mml-secure-cache-expiry-interval (epg-context-protocol context)))) + ;; FIXME test passphrase works before caching it. (password-cache-add password-cache-key-id passphrase)) (mml-secure-add-secret-key-id password-cache-key-id) (copy-sequence passphrase))))) @@ -724,7 +726,7 @@ Otherwise, NAME is treated as user ID, for which no keys are returned if it is expired or revoked. If optional JUSTONE is not nil, return the first key instead of a list." (let* ((keys (epg-list-keys context name)) - (iskeyid (string-match "\\(0x\\)?\\([0-9a-fA-F]\\{8,\\}\\)" name)) + (iskeyid (string-match "\\(0x\\)?\\([[:xdigit:]]\\{8,\\}\\)" name)) (fingerprint (match-string 2 name)) result) (when (and iskeyid (>= (length keys) 2)) @@ -905,14 +907,16 @@ If no one is selected, symmetric encryption will be performed. " (defun mml-secure-epg-encrypt (protocol cont &optional sign) ;; Based on code appearing inside mml2015-epg-encrypt. (let* ((context (epg-make-context protocol)) - (config (epg-configuration)) + (config (epg-find-configuration 'OpenPGP)) (sender (message-options-get 'message-sender)) (recipients (mml-secure-recipients protocol context config sender)) (signer-names (mml-secure-signer-names protocol sender)) cipher signers) (when sign (setq signers (mml-secure-signers context signer-names)) - (setf (epg-context-signers context) signers)) + (setf (epg-context-signers context) signers) + (when mml-secure-openpgp-sign-with-sender + (setf (epg-context-sender context) sender))) (when (eq 'OpenPGP protocol) (setf (epg-context-armor context) t) (setf (epg-context-textmode context) t)) @@ -943,6 +947,8 @@ If no one is selected, symmetric encryption will be performed. " (setf (epg-context-armor context) t) (setf (epg-context-textmode context) t)) (setf (epg-context-signers context) signers) + (when mml-secure-openpgp-sign-with-sender + (setf (epg-context-sender context) sender)) (when (mml-secure-cache-passphrase-p protocol) (epg-context-set-passphrase-callback context diff --git a/lisp/gnus/mml-smime.el b/lisp/gnus/mml-smime.el index 1e61ebf8699..78fac8ac301 100644 --- a/lisp/gnus/mml-smime.el +++ b/lisp/gnus/mml-smime.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'smime) (require 'mm-decode) @@ -238,7 +238,7 @@ Whether the passphrase is cached at all is controlled by ;; todo: try dns/ldap automatically first, before prompting user (let (certs done) (while (not done) - (ecase (read (gnus-completing-read + (cl-ecase (read (gnus-completing-read "Fetch certificate from" '("dns" "ldap" "file") t nil nil "ldap")) diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index d5588971e59..4a0d40ac0ed 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -27,8 +27,9 @@ (require 'mm-encode) (require 'mm-decode) (require 'mml-sec) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'url)) +(eval-when-compile (require 'gnus-util)) (autoload 'message-make-message-id "message") (declare-function gnus-setup-posting-charset "gnus-msg" (group)) @@ -47,7 +48,6 @@ (defvar gnus-article-mime-handles) (defvar gnus-newsrc-hashtb) -(defvar message-default-charset) (defvar message-deletable-headers) (defvar message-options) (defvar message-posting-charset) @@ -295,6 +295,14 @@ part. This is for the internal use, you should never modify the value.") (t (mm-find-mime-charset-region point (point) mm-hack-charsets)))) + ;; If the user has inserted a Content-Type header, then + ;; respect that instead of overwriting with "text/plain". + (save-restriction + (narrow-to-region point (point)) + (let ((content-type (mail-fetch-field "content-type"))) + (when (and content-type + (eq (car tag) 'part)) + (setcdr (assq 'type tag) content-type)))) (when (and (not raw) (memq nil charsets)) (if (or (memq 'unknown-encoding mml-confirmation-set) (message-options-get 'unknown-encoding) @@ -548,6 +556,9 @@ be \"related\" or \"alternate\"." ">"))))))) cont)))) +(autoload 'image-property "image") + +;; FIXME presumably (built-in) ImageMagick could replace exiftool? (defun mml--possibly-alter-image (file-name image) (if (or (null image) (not (consp image)) @@ -699,9 +710,7 @@ be \"related\" or \"alternate\"." filename))))) (t (let ((contents (cdr (assq 'contents cont)))) - (if (if (featurep 'xemacs) - (string-match "[^\000-\377]" contents) - (multibyte-string-p contents)) + (if (multibyte-string-p contents) (progn (set-buffer-multibyte t) (insert contents) @@ -795,12 +804,12 @@ be \"related\" or \"alternate\"." (if (setq recipients (cdr (assq 'recipients cont))) (message-options-set 'message-recipients recipients)) (let ((style (mml-signencrypt-style - (first (or sign-item encrypt-item))))) + (car (or sign-item encrypt-item))))) ;; check if: we're both signing & encrypting, both methods ;; are the same (why would they be different?!), and that ;; the signencrypt style allows for combined operation. - (if (and sign-item encrypt-item (equal (first sign-item) - (first encrypt-item)) + (if (and sign-item encrypt-item (equal (car sign-item) + (car encrypt-item)) (equal style 'combined)) (funcall (nth 1 encrypt-item) cont t) ;; otherwise, revert to the old behavior. @@ -812,7 +821,7 @@ be \"related\" or \"alternate\"." (defun mml-compute-boundary (cont) "Return a unique boundary that does not exist in CONT." (let ((mml-boundary (funcall mml-boundary-function - (incf mml-multipart-number)))) + (cl-incf mml-multipart-number)))) (unless mml-inhibit-compute-boundary ;; This function tries again and again until it has found ;; a unique boundary. @@ -832,7 +841,7 @@ be \"related\" or \"alternate\"." (when (re-search-forward (concat "^--" (regexp-quote mml-boundary)) nil t) (setq mml-boundary (funcall mml-boundary-function - (incf mml-multipart-number))) + (cl-incf mml-multipart-number))) (throw 'not-unique nil)))) ((eq (car cont) 'multipart) (mapc 'mml-compute-boundary-1 (cddr cont)))) @@ -903,8 +912,14 @@ be \"related\" or \"alternate\"." (or disposition (mml-content-disposition type (cdr (assq 'filename cont))))) (when parameters - (mml-insert-parameter-string - cont mml-content-disposition-parameters)) + (let ((cont (copy-sequence cont))) + ;; Set the file name to what's specified by the user. + (when-let ((recipient-filename (cdr (assq 'recipient-filename cont)))) + (setcdr cont + (cons (cons 'filename recipient-filename) + (cdr cont)))) + (mml-insert-parameter-string + cont mml-content-disposition-parameters))) (insert "\n")) (unless (eq encoding '7bit) (insert (format "Content-Transfer-Encoding: %s\n" encoding))) @@ -1011,8 +1026,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer." ;; Skip past any From_ headers. (while (looking-at "From ") (forward-line 1)) - (let ((mail-parse-charset message-default-charset)) - (mail-encode-encoded-word-buffer))) + (mail-encode-encoded-word-buffer)) (message-encode-message-body)) (defun mml-insert-mime (handle &optional no-markup) @@ -1151,7 +1165,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (easy-menu-define mml-menu mml-mode-map "" - `("Attachments" + '("Attachments" ["Attach File..." mml-attach-file :help "Attach a file at point"] ["Attach Buffer..." mml-attach-buffer :help "Attach a buffer to the outgoing message"] @@ -1231,7 +1245,6 @@ See Info node `(emacs-mime)Composing'. \\{mml-mode-map}" :lighter " MML" :keymap mml-mode-map (when mml-mode - (easy-menu-add mml-menu mml-mode-map) (when (boundp 'dnd-protocol-alist) (set (make-local-variable 'dnd-protocol-alist) (append mml-dnd-protocol-alist dnd-protocol-alist))))) @@ -1544,7 +1557,6 @@ Should be adopted if code in `message-send-mail' is changed." (defvar mml-preview-buffer nil) -(autoload 'gnus-make-hashtable "gnus-util") (autoload 'widget-button-press "wid-edit" nil t) (declare-function widget-event-point "wid-edit" (event)) ;; If gnus-buffer-configuration is bound this is loaded. diff --git a/lisp/gnus/mml1991.el b/lisp/gnus/mml1991.el index cb155266994..ce282ec65fb 100644 --- a/lisp/gnus/mml1991.el +++ b/lisp/gnus/mml1991.el @@ -25,9 +25,7 @@ ;;; Code: -(eval-when-compile - (require 'cl) - (require 'mm-util)) +(eval-when-compile (require 'mm-util)) (require 'mm-encode) (require 'mml-sec) @@ -277,6 +275,8 @@ Whether the passphrase is cached at all is controlled by (mm-decode-content-transfer-encoding cte))) (let* ((pair (mml-secure-epg-sign 'OpenPGP 'clear)) (signature (car pair))) + (unless (stringp signature) + (error "Signature failed")) (delete-region (point-min) (point-max)) (insert (with-temp-buffer diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el index 13db3eac686..d7876a3aef0 100644 --- a/lisp/gnus/mml2015.el +++ b/lisp/gnus/mml2015.el @@ -27,7 +27,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'mm-decode) (require 'mm-util) (require 'mml) @@ -237,7 +237,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (setq result (concat result - (case n-slice + (cl-case n-slice (1 slice) (otherwise (concat " " slice)))))) result)) @@ -958,6 +958,8 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (let* ((pair (mml-secure-epg-sign 'OpenPGP t)) (signature (car pair)) (micalg (cdr pair))) + (unless (stringp signature) + (error "Signature failed")) (goto-char (point-min)) (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" boundary)) diff --git a/lisp/gnus/nnagent.el b/lisp/gnus/nnagent.el index f70a384ff11..64f3a861810 100644 --- a/lisp/gnus/nnagent.el +++ b/lisp/gnus/nnagent.el @@ -26,7 +26,6 @@ (require 'nnheader) (require 'nnoo) -(eval-when-compile (require 'cl)) (require 'gnus-agent) (require 'nnml) diff --git a/lisp/gnus/nnbabyl.el b/lisp/gnus/nnbabyl.el index fe027b40930..0f4f4303cd8 100644 --- a/lisp/gnus/nnbabyl.el +++ b/lisp/gnus/nnbabyl.el @@ -35,7 +35,7 @@ 5 "Ignore rmail errors from this file, you don't have rmail"))) (require 'nnmail) (require 'nnoo) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (nnoo-declare nnbabyl) @@ -103,7 +103,7 @@ (insert ".\n")) (and (numberp nnmail-large-newsgroup) (> number nnmail-large-newsgroup) - (zerop (% (incf count) 20)) + (zerop (% (cl-incf count) 20)) (nnheader-message 5 "nnbabyl: Receiving headers... %d%%" (floor (* count 100.0) number)))) @@ -145,10 +145,8 @@ (deffoo nnbabyl-server-opened (&optional server) (and (nnoo-current-server-p 'nnbabyl server) - nnbabyl-mbox-buffer - (buffer-name nnbabyl-mbox-buffer) - nntp-server-buffer - (buffer-name nntp-server-buffer))) + (buffer-live-p nnbabyl-mbox-buffer) + (buffer-live-p nntp-server-buffer))) (deffoo nnbabyl-request-article (article &optional newsgroup server buffer) (nnbabyl-possibly-change-newsgroup newsgroup server) @@ -452,8 +450,7 @@ (when (and server (not (nnbabyl-server-opened server))) (nnbabyl-open-server server)) - (when (or (not nnbabyl-mbox-buffer) - (not (buffer-name nnbabyl-mbox-buffer))) + (unless (buffer-live-p nnbabyl-mbox-buffer) (save-excursion (nnbabyl-read-mbox))) (unless nnbabyl-group-alist (nnmail-activate 'nnbabyl)) @@ -556,8 +553,7 @@ (nnmail-activate 'nnbabyl) (nnbabyl-create-mbox) - (unless (and nnbabyl-mbox-buffer - (buffer-name nnbabyl-mbox-buffer) + (unless (and (buffer-live-p nnbabyl-mbox-buffer) (with-current-buffer nnbabyl-mbox-buffer (= (buffer-size) (nnheader-file-size nnbabyl-mbox-file)))) ;; This buffer has changed since we read it last. Possibly. @@ -624,22 +620,21 @@ (defun nnbabyl-check-mbox () "Go through the nnbabyl mbox and make sure that no article numbers are reused." (interactive) - (let ((idents (make-vector 1000 0)) + (let ((idents (gnus-make-hashtable 1000)) id) (save-excursion - (when (or (not nnbabyl-mbox-buffer) - (not (buffer-name nnbabyl-mbox-buffer))) + (unless (buffer-live-p nnbabyl-mbox-buffer) (nnbabyl-read-mbox)) (set-buffer nnbabyl-mbox-buffer) (goto-char (point-min)) (while (re-search-forward "^X-Gnus-Newsgroup: \\([^ ]+\\) " nil t) - (if (intern-soft (setq id (match-string 1)) idents) + (if (gethash (setq id (match-string 1)) idents) (progn (delete-region (point-at-bol) (progn (forward-line 1) (point))) (nnheader-message 7 "Moving %s..." id) (nnbabyl-save-mail (nnmail-article-group 'nnbabyl-active-number))) - (intern id idents))) + (puthash id t idents))) (when (buffer-modified-p (current-buffer)) (save-buffer)) (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index 5589ab20226..2ad0634e6ad 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -2,8 +2,7 @@ ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. -;; Author: Didier Verna <didier@xemacs.org> -;; Maintainer: Didier Verna <didier@xemacs.org> +;; Author: Didier Verna <didier@didierverna.net> ;; Created: Fri Jul 16 18:55:42 1999 ;; Keywords: calendar mail news @@ -83,7 +82,6 @@ (require 'nnoo) (require 'nnheader) (require 'nnmail) -(eval-when-compile (require 'cl)) (require 'gnus-start) (require 'gnus-sum) @@ -233,7 +231,7 @@ through all nnml directories and generate nov databases for them all. This may very well take some time.") (defvoo nndiary-prepare-save-mail-hook nil - "*Hook run narrowed to an article before saving.") + "Hook run narrowed to an article before saving.") (defvoo nndiary-inhibit-expiry nil "If non-nil, inhibit expiry.") @@ -980,7 +978,7 @@ all. This may very well take some time.") "Add a nov line for the GROUP base." (with-current-buffer (nndiary-open-nov group) (goto-char (point-max)) - (mail-header-set-number headers article) + (setf (mail-header-number headers) article) (nnheader-insert-nov headers))) (defsubst nndiary-header-value () @@ -995,8 +993,8 @@ all. This may very well take some time.") (goto-char (point-min)) (if (search-forward "\n\n" nil t) (1- (point)) (point-max)))) (let ((headers (nnheader-parse-naked-head))) - (mail-header-set-chars headers chars) - (mail-header-set-number headers number) + (setf (mail-header-chars headers) chars) + (setf (mail-header-number headers) number) headers)))) (defun nndiary-open-nov (group) @@ -1017,7 +1015,7 @@ all. This may very well take some time.") (defun nndiary-save-nov () (save-excursion (while nndiary-nov-buffer-alist - (when (buffer-name (cdar nndiary-nov-buffer-alist)) + (when (buffer-live-p (cdar nndiary-nov-buffer-alist)) (set-buffer (cdar nndiary-nov-buffer-alist)) (when (buffer-modified-p) (nnmail-write-region 1 (point-max) nndiary-nov-buffer-file-name @@ -1266,12 +1264,12 @@ all. This may very well take some time.") (date-elts (decode-time date)) ;; ### NOTE: out-of-range values are accepted by encode-time. This ;; makes our life easier. - (monday (- (nth 3 date-elts) + (monday (- (decoded-time-day date-elts) (if nndiary-week-starts-on-monday - (if (zerop (nth 6 date-elts)) + (if (zerop (decoded-time-weekday date-elts)) 6 - (- (nth 6 date-elts) 1)) - (nth 6 date-elts)))) + (- (decoded-time-weekday date-elts) 1)) + (decoded-time-weekday date-elts)))) reminder res) ;; remove the DOW and DST entries (setcdr (nthcdr 5 date-elts) (nthcdr 8 date-elts)) @@ -1279,28 +1277,28 @@ all. This may very well take some time.") (push (cond ((eq (cdr reminder) 'minute) (time-subtract - (apply 'encode-time 0 (nthcdr 1 date-elts)) - (seconds-to-time (* (car reminder) 60.0)))) + (apply #'encode-time 0 (nthcdr 1 date-elts)) + (encode-time (* (car reminder) 60.0)))) ((eq (cdr reminder) 'hour) (time-subtract - (apply 'encode-time 0 0 (nthcdr 2 date-elts)) - (seconds-to-time (* (car reminder) 3600.0)))) + (apply #'encode-time 0 0 (nthcdr 2 date-elts)) + (encode-time (* (car reminder) 3600.0)))) ((eq (cdr reminder) 'day) (time-subtract - (apply 'encode-time 0 0 0 (nthcdr 3 date-elts)) - (seconds-to-time (* (car reminder) 86400.0)))) + (apply #'encode-time 0 0 0 (nthcdr 3 date-elts)) + (encode-time (* (car reminder) 86400.0)))) ((eq (cdr reminder) 'week) (time-subtract - (apply 'encode-time 0 0 0 monday (nthcdr 4 date-elts)) - (seconds-to-time (* (car reminder) 604800.0)))) + (apply #'encode-time 0 0 0 monday (nthcdr 4 date-elts)) + (encode-time (* (car reminder) 604800.0)))) ((eq (cdr reminder) 'month) (time-subtract - (apply 'encode-time 0 0 0 1 (nthcdr 4 date-elts)) - (seconds-to-time (* (car reminder) 18748800.0)))) + (apply #'encode-time 0 0 0 1 (nthcdr 4 date-elts)) + (encode-time (* (car reminder) 18748800.0)))) ((eq (cdr reminder) 'year) (time-subtract - (apply 'encode-time 0 0 0 1 1 (nthcdr 5 date-elts)) - (seconds-to-time (* (car reminder) 400861056.0))))) + (apply #'encode-time 0 0 0 1 1 (nthcdr 5 date-elts)) + (encode-time (* (car reminder) 400861056.0))))) res)) (sort res 'time-less-p))) @@ -1345,9 +1343,10 @@ all. This may very well take some time.") ;; have to know which day is the 1st one for this month. ;; Maybe there's simpler, but decode-time(encode-time) will ;; give us the answer. - (let ((first (nth 6 (decode-time - (encode-time 0 0 0 1 month year - time-zone)))) + (let ((first (decoded-time-weekday + (decode-time + (encode-time 0 0 0 1 month year + time-zone)))) (max (cond ((= month 2) (if (date-leap-year-p year) 29 28)) ((<= month 7) @@ -1392,11 +1391,11 @@ all. This may very well take some time.") ;; If there's no next occurrence, returns the last one (if any) which is then ;; in the past. (let* ((today (decode-time now)) - (this-minute (nth 1 today)) - (this-hour (nth 2 today)) - (this-day (nth 3 today)) - (this-month (nth 4 today)) - (this-year (nth 5 today)) + (this-minute (decoded-time-minute today)) + (this-hour (decoded-time-hour today)) + (this-day (decoded-time-day today)) + (this-month (decoded-time-month today)) + (this-year (decoded-time-year today)) (minute-list (sort (nndiary-flatten (nth 0 sched) 0 59) '<)) (hour-list (sort (nndiary-flatten (nth 1 sched) 0 23) '<)) (dom-list (nth 2 sched)) @@ -1447,9 +1446,10 @@ all. This may very well take some time.") ;; have to know which day is the 1st one for this month. ;; Maybe there's simpler, but decode-time(encode-time) will ;; give us the answer. - (let ((first (nth 6 (decode-time - (encode-time 0 0 0 1 month year - time-zone)))) + (let ((first (decoded-time-weekday + (decode-time + (encode-time 0 0 0 1 month year + time-zone)))) (max (cond ((= month 2) (if (date-leap-year-p year) 29 28)) ((<= month 7) @@ -1532,7 +1532,7 @@ all. This may very well take some time.") ;; past. A permanent schedule never expires. (and sched (setq sched (nndiary-last-occurrence sched)) - (time-less-p sched (current-time)))) + (time-less-p sched nil))) ;; else (nnheader-report 'nndiary "Could not read file %s" file) nil) diff --git a/lisp/gnus/nndir.el b/lisp/gnus/nndir.el index 44487f422d0..82502dfbd19 100644 --- a/lisp/gnus/nndir.el +++ b/lisp/gnus/nndir.el @@ -28,7 +28,6 @@ (require 'nnmh) (require 'nnml) (require 'nnoo) -(eval-when-compile (require 'cl)) (nnoo-declare nndir nnml nnmh) @@ -38,7 +37,7 @@ nnml-current-directory nnmh-current-directory) (defvoo nndir-nov-is-evil nil - "*Non-nil means that nndir will never retrieve NOV headers." + "Non-nil means that nndir will never retrieve NOV headers." nnml-nov-is-evil) diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el index f17dcb96c3e..9c8cab597a6 100644 --- a/lisp/gnus/nndoc.el +++ b/lisp/gnus/nndoc.el @@ -33,19 +33,19 @@ (require 'nnoo) (require 'gnus-util) (require 'mm-util) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (nnoo-declare nndoc) (defvoo nndoc-article-type 'guess - "*Type of the file. + "Type of the file. One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', `rfc934', `rfc822-forward', `mime-parts', `standard-digest', `slack-digest', `clari-briefs', `nsmail', `outlook', `oe-dbx', `mailman', `exim-bounce', or `guess'.") (defvoo nndoc-post-type 'mail - "*Whether the nndoc group is `mail' or `post'.") + "Whether the nndoc group is `mail' or `post'.") (defvoo nndoc-open-document-hook 'nnheader-ms-strip-cr "Hook run after opening a document. @@ -309,8 +309,7 @@ from the document.") (deffoo nndoc-close-group (group &optional server) (nndoc-possibly-change-buffer group server) - (and nndoc-current-buffer - (buffer-name nndoc-current-buffer) + (and (buffer-live-p nndoc-current-buffer) (kill-buffer nndoc-current-buffer)) (setq nndoc-group-alist (delq (assoc group nndoc-group-alist) nndoc-group-alist)) @@ -335,8 +334,7 @@ from the document.") (let (buf) (cond ;; The current buffer is this group's buffer. - ((and nndoc-current-buffer - (buffer-name nndoc-current-buffer) + ((and (buffer-live-p nndoc-current-buffer) (eq nndoc-current-buffer (setq buf (cdr (assoc group nndoc-group-alist)))))) ;; We change buffers by taking an old from the group alist. @@ -344,8 +342,7 @@ from the document.") (buf (setq nndoc-current-buffer buf)) ;; It's a totally new group. - ((or (and (bufferp nndoc-address) - (buffer-name nndoc-address)) + ((or (buffer-live-p nndoc-address) (and (stringp nndoc-address) (file-exists-p nndoc-address) (not (file-directory-p nndoc-address)))) @@ -701,7 +698,7 @@ from the document.") (defun nndoc-lanl-gov-announce-type-p () (when (let ((case-fold-search nil)) - (re-search-forward "^\\\\\\\\\n\\(Paper\\( (\\*cross-listing\\*)\\)?: [a-zA-Z-\\.]+/[0-9]+\\|arXiv:\\)" nil t)) + (re-search-forward "^\\\\\\\\\n\\(Paper\\( (\\*cross-listing\\*)\\)?: [a-zA-Z\\.-]+/[0-9]+\\|arXiv:\\)" nil t)) t)) (defun nndoc-transform-lanl-gov-announce (article) @@ -732,7 +729,7 @@ from the document.") (save-restriction (narrow-to-region (car entry) (nth 1 entry)) (goto-char (point-min)) - (when (looking-at "^\\(Paper.*: \\|arXiv:\\)\\([0-9a-zA-Z-\\./]+\\)") + (when (looking-at "^\\(Paper.*: \\|arXiv:\\)\\([0-9a-zA-Z\\./-]+\\)") (setq subject (concat " (" (match-string 2) ")")) (when (re-search-forward "^From: \\(.*\\)" nil t) (setq from (concat "<" @@ -765,13 +762,13 @@ from the document.") (looking-at "JMF")) (defun nndoc-oe-dbx-type-p () - (looking-at (string-to-multibyte "\317\255\022\376"))) + (looking-at "\317\255\022\376")) (defun nndoc-read-little-endian () (+ (prog1 (char-after) (forward-char 1)) - (lsh (prog1 (char-after) (forward-char 1)) 8) - (lsh (prog1 (char-after) (forward-char 1)) 16) - (lsh (prog1 (char-after) (forward-char 1)) 24))) + (ash (prog1 (char-after) (forward-char 1)) 8) + (ash (prog1 (char-after) (forward-char 1)) 16) + (ash (prog1 (char-after) (forward-char 1)) 24))) (defun nndoc-oe-dbx-decode-block () (list @@ -788,7 +785,7 @@ from the document.") (setq blk (nndoc-oe-dbx-decode-block))) (while (and blk (> (car blk) 0) (or (zerop (nth 3 blk)) (> (nth 3 blk) p))) - (push (list (incf i) p nil nil nil 0) nndoc-dissection-alist) + (push (list (cl-incf i) p nil nil nil 0) nndoc-dissection-alist) (while (and (> (car blk) 0) (> (nth 3 blk) p)) (goto-char (1+ (nth 3 blk))) (setq blk (nndoc-oe-dbx-decode-block))) @@ -927,7 +924,7 @@ from the document.") (and (re-search-backward nndoc-file-end nil t) (beginning-of-line))))) (setq body-end (point)) - (push (list (incf i) head-begin head-end body-begin body-end + (push (list (cl-incf i) head-begin head-end body-begin body-end (count-lines body-begin body-end)) nndoc-dissection-alist))))) (setq nndoc-dissection-alist (nreverse nndoc-dissection-alist)))) @@ -1040,7 +1037,7 @@ PARENT is the message-ID of the parent summary line, or nil for none." (replace-match line t t summary-insert) (concat summary-insert line))))) ;; Generate dissection information for this entity. - (push (list (incf nndoc-mime-split-ordinal) + (push (list (cl-incf nndoc-mime-split-ordinal) head-begin head-end body-begin body-end (count-lines body-begin body-end) article-insert summary-insert) @@ -1078,7 +1075,7 @@ PARENT is the message-ID of the parent summary line, or nil for none." part-begin part-end article-insert (concat position (and position ".") - (format "%d" (incf part-counter))) + (format "%d" (cl-incf part-counter))) message-id))))))))) ;;;###autoload diff --git a/lisp/gnus/nndraft.el b/lisp/gnus/nndraft.el index 0f7df3b4f4b..bc475ee2951 100644 --- a/lisp/gnus/nndraft.el +++ b/lisp/gnus/nndraft.el @@ -31,7 +31,6 @@ (require 'nnmh) (require 'nnoo) (require 'mm-util) -(eval-when-compile (require 'cl)) ;; The nnoo-import at the end, I think. (declare-function nndraft-request-list "nndraft" (&rest args) t) diff --git a/lisp/gnus/nneething.el b/lisp/gnus/nneething.el index 39e8d6ef66d..c3d511bc6e0 100644 --- a/lisp/gnus/nneething.el +++ b/lisp/gnus/nneething.el @@ -25,7 +25,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'mailcap) (require 'nnheader) @@ -101,7 +101,7 @@ included.") (nneething-insert-head file) (insert ".\n")) - (incf count) + (cl-incf count) (and large (zerop (% count 20)) @@ -215,8 +215,9 @@ included.") (setq nneething-map (mapcar (lambda (n) (list (cdr n) (car n) - (nth 5 (file-attributes - (nneething-file-name (car n)))))) + (file-attribute-modification-time + (file-attributes + (nneething-file-name (car n)))))) nneething-map))) ;; Remove files matching the exclusion regexp. (when nneething-exclude-files @@ -244,7 +245,7 @@ included.") (while map (if (and (member (cadr (car map)) files) ;; We also remove files that have changed mod times. - (equal (nth 5 (file-attributes + (equal (file-attribute-modification-time (file-attributes (nneething-file-name (cadr (car map))))) (cadr (cdar map)))) (progn @@ -262,7 +263,7 @@ included.") (setq touched t) (setcdr nneething-active (1+ (cdr nneething-active))) (push (list (cdr nneething-active) (car files) - (nth 5 (file-attributes + (file-attribute-modification-time (file-attributes (nneething-file-name (car files))))) nneething-map)) (setq files (cdr files))) @@ -296,7 +297,7 @@ included.") (defun nneething-decode-file-name (file &optional coding-system) "Decode the name of the FILE is encoded in CODING-SYSTEM." (let ((pos 0) buf) - (while (string-match "%\\([0-9a-fA-F][0-9a-fA-F]\\)" file pos) + (while (string-match "%\\([[:xdigit:]][[:xdigit:]]\\)" file pos) (setq buf (cons (string (string-to-number (match-string 1 file) 16)) (cons (substring file pos (match-beginning 0)) buf)) pos (match-end 0))) @@ -318,15 +319,17 @@ included.") "Subject: " (file-name-nondirectory file) (or extra-msg "") "\n" "Message-ID: <nneething-" (nneething-encode-file-name file) "@" (system-name) ">\n" - (if (equal '(0 0) (nth 5 atts)) "" - (concat "Date: " (current-time-string (nth 5 atts)) "\n")) + (if (time-equal-p 0 (file-attribute-modification-time atts)) "" + (concat "Date: " + (current-time-string (file-attribute-modification-time atts)) + "\n")) (or (when buffer (with-current-buffer buffer (when (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t) (concat "From: " (match-string 0) "\n")))) - (nneething-from-line (nth 2 atts) file)) - (if (> (string-to-number (int-to-string (nth 7 atts))) 0) - (concat "Chars: " (int-to-string (nth 7 atts)) "\n") + (nneething-from-line (file-attribute-user-id atts) file)) + (if (> (file-attribute-size atts) 0) + (concat "Chars: " (int-to-string (file-attribute-size atts)) "\n") "") (if buffer (with-current-buffer buffer diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el index 867bd8dc20e..6334b1c998d 100644 --- a/lisp/gnus/nnfolder.el +++ b/lisp/gnus/nnfolder.el @@ -32,7 +32,6 @@ (require 'message) (require 'nnmail) (require 'nnoo) -(eval-when-compile (require 'cl)) (require 'gnus) (require 'gnus-util) (require 'gnus-range) @@ -329,8 +328,7 @@ all. This may very well take some time.") (delq inf nnfolder-buffer-alist)) (setq nnfolder-current-buffer (cadr inf) nnfolder-current-group (car inf)))) - (when (and nnfolder-current-buffer - (buffer-name nnfolder-current-buffer)) + (when (buffer-live-p nnfolder-current-buffer) (with-current-buffer nnfolder-current-buffer ;; If the buffer was modified, write the file out now. (nnfolder-save-buffer) @@ -863,7 +861,7 @@ deleted. Point is left where the deleted region was." (mm-enable-multibyte) ;; Use multibyte buffer for future copying. (buffer-disable-undo) (if (equal (cadr (assoc group nnfolder-scantime-alist)) - (nth 5 (file-attributes file))) + (file-attribute-modification-time (file-attributes file))) ;; This looks up-to-date, so we don't do any scanning. (if (file-exists-p file) buffer @@ -878,17 +876,17 @@ deleted. Point is left where the deleted region was." (delete-char 1)) (nnmail-activate 'nnfolder) ;; Read in the file. - (let ((delim "^From ") - (marker (concat "\n" nnfolder-article-marker)) - (number "[0-9]+") - (active (or (cadr (assoc group nnfolder-group-alist)) - (cons 1 0))) - (scantime (assoc group nnfolder-scantime-alist)) - (minid most-positive-fixnum) - maxid start end newscantime - novbuf articles newnum - buffer-read-only) - (setq maxid (cdr active)) + (let* ((delim "^From ") + (marker (concat "\n" nnfolder-article-marker)) + (number "[0-9]+") + (active (or (cadr (assoc group nnfolder-group-alist)) + (cons 1 0))) + (scantime (assoc group nnfolder-scantime-alist)) + (minid (cdr active)) + maxid start end newscantime + novbuf articles newnum + buffer-read-only) + (setq maxid minid) (unless (or gnus-nov-is-evil nnfolder-nov-is-evil (and (file-exists-p nov) @@ -959,7 +957,7 @@ deleted. Point is left where the deleted region was." (while (not (= end (point-max))) (setq start (marker-position end)) (goto-char end) - ;; There may be more than one "From " line, so we skip past + ;; There may be more than one "From " line, so we skip past ;; them. (while (looking-at delim) (forward-line 1)) @@ -1111,7 +1109,7 @@ This command does not work if you use short group names." (defun nnfolder-save-nov () (save-excursion (while nnfolder-nov-buffer-alist - (when (buffer-name (cdar nnfolder-nov-buffer-alist)) + (when (buffer-live-p (cdar nnfolder-nov-buffer-alist)) (set-buffer (cdar nnfolder-nov-buffer-alist)) (when (buffer-modified-p) (gnus-make-directory (file-name-directory @@ -1163,15 +1161,15 @@ This command does not work if you use short group names." (with-temp-buffer (insert-buffer-substring buf b e) (let ((headers (nnheader-parse-naked-head))) - (mail-header-set-chars headers chars) - (mail-header-set-number headers number) + (setf (mail-header-chars headers) chars) + (setf (mail-header-number headers) number) headers))))) (defun nnfolder-add-nov (group article headers) "Add a nov line for the GROUP base." (with-current-buffer (nnfolder-open-nov group) (goto-char (point-max)) - (mail-header-set-number headers article) + (setf (mail-header-number headers) article) (nnheader-insert-nov headers))) (provide 'nnfolder) diff --git a/lisp/gnus/nngateway.el b/lisp/gnus/nngateway.el index 2bc2e37f896..92e36a2e4f9 100644 --- a/lisp/gnus/nngateway.el +++ b/lisp/gnus/nngateway.el @@ -24,7 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'nnoo) (require 'message) diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el index dec32361cae..6ef324ae916 100644 --- a/lisp/gnus/nnheader.el +++ b/lisp/gnus/nnheader.el @@ -26,7 +26,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defvar nnmail-extra-headers) (defvar gnus-newsgroup-name) @@ -121,7 +121,6 @@ on your system, you could say something like: (autoload 'nnmail-message-id "nnmail") (autoload 'mail-position-on-field "sendmail") -(autoload 'gnus-buffer-live-p "gnus-util") ;;; Header access macros. @@ -136,97 +135,31 @@ on your system, you could say something like: ;; (That next-to-last entry is defined as "misc" in the NOV format, ;; but Gnus uses it for xrefs.) -(defmacro mail-header-number (header) - "Return article number in HEADER." - `(aref ,header 0)) - -(defmacro mail-header-set-number (header number) - "Set article number of HEADER to NUMBER." - `(aset ,header 0 ,number)) - -(defmacro mail-header-subject (header) - "Return subject string in HEADER." - `(aref ,header 1)) - -(defmacro mail-header-set-subject (header subject) - "Set article subject of HEADER to SUBJECT." - `(aset ,header 1 ,subject)) - -(defmacro mail-header-from (header) - "Return author string in HEADER." - `(aref ,header 2)) - -(defmacro mail-header-set-from (header from) - "Set article author of HEADER to FROM." - `(aset ,header 2 ,from)) - -(defmacro mail-header-date (header) - "Return date in HEADER." - `(aref ,header 3)) - -(defmacro mail-header-set-date (header date) - "Set article date of HEADER to DATE." - `(aset ,header 3 ,date)) - -(defalias 'mail-header-message-id 'mail-header-id) -(defmacro mail-header-id (header) - "Return Id in HEADER." - `(aref ,header 4)) - -(defalias 'mail-header-set-message-id 'mail-header-set-id) -(defmacro mail-header-set-id (header id) - "Set article Id of HEADER to ID." - `(aset ,header 4 ,id)) - -(defmacro mail-header-references (header) - "Return references in HEADER." - `(aref ,header 5)) - -(defmacro mail-header-set-references (header ref) - "Set article references of HEADER to REF." - `(aset ,header 5 ,ref)) - -(defmacro mail-header-chars (header) - "Return number of chars of article in HEADER." - `(aref ,header 6)) - -(defmacro mail-header-set-chars (header chars) - "Set number of chars in article of HEADER to CHARS." - `(aset ,header 6 ,chars)) - -(defmacro mail-header-lines (header) - "Return lines in HEADER." - `(aref ,header 7)) - -(defmacro mail-header-set-lines (header lines) - "Set article lines of HEADER to LINES." - `(aset ,header 7 ,lines)) - -(defmacro mail-header-xref (header) - "Return xref string in HEADER." - `(aref ,header 8)) - -(defmacro mail-header-set-xref (header xref) - "Set article XREF of HEADER to xref." - `(aset ,header 8 ,xref)) - -(defmacro mail-header-extra (header) - "Return the extra headers in HEADER." - `(aref ,header 9)) - -(defun mail-header-set-extra (header extra) - "Set the extra headers in HEADER to EXTRA." - (aset header 9 extra)) +(defalias 'mail-header-p #'vectorp) ;For lack of tag, it's all we have. +(cl-defstruct (mail-header + (:type vector) + (:constructor nil) + (:constructor make-full-mail-header + (&optional number subject from date id + references chars lines xref + extra))) + number + subject + from + date + id + references + chars + lines + xref + extra) + +(defalias 'mail-header-message-id #'mail-header-id) (defsubst make-mail-header (&optional init) "Create a new mail header structure initialized with INIT." - (make-vector 10 init)) - -(defsubst make-full-mail-header (&optional number subject from date id - references chars lines xref - extra) - "Create a new mail header structure initialized with the parameters given." - (vector number subject from date id references chars lines xref extra)) + (make-full-mail-header init init init init init + init init init init init)) ;; fake message-ids: generation and detection @@ -237,7 +170,7 @@ on your system, you could say something like: (format "fake+none+%s+%d" gnus-newsgroup-name number) (format "fake+none+%s+%s" gnus-newsgroup-name - (int-to-string (incf nnheader-fake-message-id))))) + (int-to-string (cl-incf nnheader-fake-message-id))))) (defsubst nnheader-fake-message-id-p (id) (save-match-data ; regular message-id's are <.*> @@ -408,7 +341,7 @@ on your system, you could say something like: `(let ((id (nnheader-nov-field))) (if (string-match "^<[^>]+>$" id) ,(if nnheader-uniquify-message-id - `(if (string-match "__[^@]+@" id) + '(if (string-match "__[^@]+@" id) (concat (substring id 0 (match-beginning 0)) (substring id (1- (match-end 0)))) id) @@ -612,7 +545,7 @@ the line could be found." (while (and (eq nnheader-head-chop-length (nth 1 (mm-insert-file-contents file nil beg - (incf beg nnheader-head-chop-length)))) + (cl-incf beg nnheader-head-chop-length)))) ;; CRLF or CR might be used for the line-break code. (prog1 (not (re-search-forward "\n\r?\n\\|\r\r" nil t)) (goto-char (point-max))) @@ -784,7 +717,7 @@ If FULL, translate everything." (when (setq trans (cdr (assq (aref leaf i) nnheader-file-name-translation-alist))) (aset leaf i trans)) - (incf i)) + (cl-incf i)) (concat path leaf)))) (defun nnheader-report (backend &rest args) @@ -896,7 +829,7 @@ without formatting." (defun nnheader-file-size (file) "Return the file size of FILE or 0." - (or (nth 7 (file-attributes file)) 0)) + (or (file-attribute-size (file-attributes file)) 0)) (defun nnheader-find-etc-directory (package &optional file first) "Go through `load-path' and find the \"../etc/PACKAGE\" directory. @@ -951,7 +884,7 @@ find-file-hook, etc. (mm-insert-file-contents filename visit beg end replace))) (defun nnheader-insert-nov-file (file first) - (let ((size (nth 7 (file-attributes file))) + (let ((size (file-attribute-size (file-attributes file))) (cutoff (* 32 1024))) (when size (if (< size cutoff) @@ -973,7 +906,7 @@ find-file-hook, etc. (defun nnheader-find-file-noselect (&rest args) "Open a file with some variables bound. See `find-file-noselect' for the arguments." - (letf* ((format-alist nil) + (cl-letf* ((format-alist nil) (auto-mode-alist (mm-auto-mode-alist)) ((default-value 'major-mode) 'fundamental-mode) (enable-local-variables nil) @@ -1036,18 +969,14 @@ See `find-file-noselect' for the arguments." "Strip all \r's from the current buffer." (nnheader-skeleton-replace "\r")) -(defalias 'nnheader-cancel-timer 'cancel-timer) -(defalias 'nnheader-cancel-function-timers 'cancel-function-timers) +(define-obsolete-function-alias 'nnheader-cancel-timer 'cancel-timer "27.1") +(define-obsolete-function-alias 'nnheader-cancel-function-timers + 'cancel-function-timers "27.1") ;; When changing this function, consider changing `pop3-accept-process-output' ;; as well. (defun nnheader-accept-process-output (process) - (accept-process-output - process - (truncate nnheader-read-timeout) - (truncate (* (- nnheader-read-timeout - (truncate nnheader-read-timeout)) - 1000)))) + (accept-process-output process nnheader-read-timeout)) (defun nnheader-update-marks-actions (backend-marks actions) (dolist (action actions) @@ -1071,19 +1000,16 @@ See `find-file-noselect' for the arguments." (defmacro nnheader-insert-buffer-substring (buffer &optional start end) "Copy string from unibyte buffer to multibyte current buffer." - `(if enable-multibyte-characters - (insert (with-current-buffer ,buffer - (string-to-multibyte - ,(if (or start end) - `(buffer-substring (or ,start (point-min)) - (or ,end (point-max))) - '(buffer-string))))) - (insert-buffer-substring ,buffer ,start ,end))) + `(insert (with-current-buffer ,buffer + ,(if (or start end) + `(buffer-substring (or ,start (point-min)) + (or ,end (point-max))) + '(buffer-string))))) (defvar nnheader-last-message-time '(0 0)) (defun nnheader-message-maybe (&rest args) (let ((now (current-time))) - (when (> (float-time (time-subtract now nnheader-last-message-time)) 1) + (when (time-less-p 1 (time-subtract now nnheader-last-message-time)) (setq nnheader-last-message-time now) (apply 'nnheader-message args)))) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index 5e26e7babd1..c6eaa54c692 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -27,7 +27,7 @@ ;;; Code: (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'subr-x)) (require 'nnheader) @@ -36,7 +36,6 @@ (require 'nnoo) (require 'netrc) (require 'utf7) -(require 'tls) (require 'parse-time) (require 'nnmail) @@ -56,6 +55,13 @@ If nnimap-stream is `ssl', this will default to `imaps'. If not, it will default to `imap'.") +(defvoo nnimap-use-namespaces nil + "Whether to use IMAP namespaces. +If in Gnus your folder names in all start with (e.g.) `INBOX', +you probably want to set this to t. The effects of this are +purely cosmetic, but changing this variable will affect the +names of your nnimap groups. ") + (defvoo nnimap-stream 'undecided "How nnimap talks to the IMAP server. The value should be either `undecided', `ssl' or `tls', @@ -111,6 +117,8 @@ some servers.") (defvoo nnimap-current-infos nil) +(defvoo nnimap-namespace nil) + (defun nnimap-decode-gnus-group (group) (decode-coding-string group 'utf-8)) @@ -144,7 +152,7 @@ textual parts.") (defvar nnimap-keepalive-timer nil) (defvar nnimap-process-buffers nil) -(defstruct nnimap +(cl-defstruct nnimap group process commands capabilities select-result newlinep server last-command-time greeting examined stream-type initial-resync) @@ -167,6 +175,19 @@ textual parts.") (defvar nnimap-inhibit-logging nil) +(defun nnimap-group-to-imap (group) + "Convert Gnus group name to IMAP mailbox name." + (let* ((inbox (if nnimap-namespace + (substring nnimap-namespace 0 -1) nil))) + (utf7-encode + (cond ((or (not inbox) + (string-equal group inbox)) + group) + ((string-prefix-p "#" group) + (substring group 1)) + (t + (concat nnimap-namespace group))) t))) + (defun nnimap-buffer () (nnimap-find-process-buffer nntp-server-buffer)) @@ -210,25 +231,27 @@ textual parts.") 'headers)) (defun nnimap-transform-headers () + "Transform server's FETCH response into parseable headers." (goto-char (point-min)) - (let (article lines size string labels) - (block nil + (let (seen-articles article lines size string labels) + (cl-block nil (while (not (eobp)) (while (not (looking-at "\\* [0-9]+ FETCH")) (delete-region (point) (progn (forward-line 1) (point))) (when (eobp) - (return))) + (cl-return))) (goto-char (match-end 0)) ;; Unfold quoted {number} strings. - (while (re-search-forward - "[^]][ (]{\\([0-9]+\\)}\r?\n" - (save-excursion - ;; Start of the header section. - (or (re-search-forward "] {[0-9]+}\r?\n" nil t) - ;; Start of the next FETCH. - (re-search-forward "\\* [0-9]+ FETCH" nil t) - (point-max))) - t) + (while (or (looking-at "[ (]{\\([0-9]+\\)}\r?\n") + (re-search-forward + "[^]][ (]{\\([0-9]+\\)}\r?\n" + (save-excursion + ;; Start of the header section. + (or (re-search-forward "] {[0-9]+}\r?\n" nil t) + ;; Start of the next FETCH. + (re-search-forward "\\* [0-9]+ FETCH" nil t) + (point-max))) + t)) (setq size (string-to-number (match-string 1))) (delete-region (+ (match-beginning 0) 2) (point)) (setq string (buffer-substring (point) (+ (point) size))) @@ -239,45 +262,57 @@ textual parts.") (and (re-search-forward "UID \\([0-9]+\\)" (line-end-position) t) (match-string 1))) - (setq lines nil) - (beginning-of-line) - (setq size - (and (re-search-forward "RFC822.SIZE \\([0-9]+\\)" - (line-end-position) - t) - (match-string 1))) - (beginning-of-line) - (when (search-forward "X-GM-LABELS" (line-end-position) t) - (setq labels (ignore-errors (read (current-buffer))))) - (beginning-of-line) - (when (search-forward "BODYSTRUCTURE" (line-end-position) t) - (let ((structure (ignore-errors - (read (current-buffer))))) - (while (and (consp structure) - (not (atom (car structure)))) - (setq structure (car structure))) - (setq lines (if (and - (stringp (car structure)) - (equal (upcase (nth 0 structure)) "MESSAGE") - (equal (upcase (nth 1 structure)) "RFC822")) - (nth 9 structure) - (nth 7 structure))))) - (delete-region (line-beginning-position) (line-end-position)) - (insert (format "211 %s Article retrieved." article)) - (forward-line 1) - (when size - (insert (format "Chars: %s\n" size))) - (when lines - (insert (format "Lines: %s\n" lines))) - (when labels - (insert (format "X-GM-LABELS: %s\n" labels))) - ;; Most servers have a blank line after the headers, but - ;; Davmail doesn't. - (unless (re-search-forward "^\r$\\|^)\r?$" nil t) - (goto-char (point-max))) - (delete-region (line-beginning-position) (line-end-position)) - (insert ".") - (forward-line 1))))) + ;; If we've already got headers for this article, or this + ;; FETCH line doesn't provide headers for the article, skip + ;; it. See bug#35433. + (if (or (member article seen-articles) + (save-excursion + (forward-line) + (null (looking-at-p + ;; We're expecting a mail header. + "^[!-9;-~]+:[[:space:]]")))) + (delete-region (line-beginning-position) + (1+ (line-end-position))) + (setq lines nil) + (beginning-of-line) + (setq size + (and (re-search-forward "RFC822.SIZE \\([0-9]+\\)" + (line-end-position) + t) + (match-string 1))) + (beginning-of-line) + (when (search-forward "X-GM-LABELS" (line-end-position) t) + (setq labels (ignore-errors (read (current-buffer))))) + (beginning-of-line) + (when (search-forward "BODYSTRUCTURE" (line-end-position) t) + (let ((structure (ignore-errors + (read (current-buffer))))) + (while (and (consp structure) + (not (atom (car structure)))) + (setq structure (car structure))) + (setq lines (if (and + (stringp (car structure)) + (equal (upcase (nth 0 structure)) "MESSAGE") + (equal (upcase (nth 1 structure)) "RFC822")) + (nth 9 structure) + (nth 7 structure))))) + (delete-region (line-beginning-position) (line-end-position)) + (insert (format "211 %s Article retrieved." article)) + (forward-line 1) + (when size + (insert (format "Chars: %s\n" size))) + (when lines + (insert (format "Lines: %s\n" lines))) + (when labels + (insert (format "X-GM-LABELS: %s\n" labels))) + ;; Most servers have a blank line after the headers, but + ;; Davmail doesn't. + (unless (re-search-forward "^\r$\\|^)\r?$" nil t) + (goto-char (point-max))) + (delete-region (line-beginning-position) (line-end-position)) + (insert ".") + (forward-line 1) + (push article seen-articles)))))) (defun nnimap-unfold-quoted-lines () ;; Unfold quoted {number} strings. @@ -324,7 +359,7 @@ textual parts.") (with-current-buffer (generate-new-buffer (format " *nnimap %s %s %s*" nnimap-address nnimap-server-port - (gnus-buffer-exists-p buffer))) + buffer)) (mm-disable-multibyte) (buffer-disable-undo) (gnus-add-buffer) @@ -360,16 +395,16 @@ textual parts.") (defun nnimap-keepalive () (let ((now (current-time))) (dolist (buffer nnimap-process-buffers) - (when (buffer-name buffer) + (when (buffer-live-p buffer) (with-current-buffer buffer (when (and nnimap-object (nnimap-last-command-time nnimap-object) - (> (float-time - (time-subtract - now - (nnimap-last-command-time nnimap-object))) - ;; More than five minutes since the last command. - (* 5 60))) + (time-less-p + ;; More than five minutes since the last command. + (* 5 60) + (time-subtract + now + (nnimap-last-command-time nnimap-object)))) (ignore-errors ;E.g. "buffer foo has no process". (nnimap-send-command "NOOP")))))))) @@ -381,7 +416,7 @@ textual parts.") (setq nnimap-stream 'ssl)) (let ((stream (if (eq nnimap-stream 'undecided) - (loop for type in '(ssl network) + (cl-loop for type in '(ssl network) for stream = (let ((nnimap-stream type)) (nnimap-open-connection-1 buffer)) while (eq stream 'no-connect) @@ -391,8 +426,11 @@ textual parts.") nil stream))) +;; This is only needed for Windows XP or earlier (defun nnimap-map-port (port) - (if (equal port "imaps") + (if (and (eq system-type 'windows-nt) + (<= (car (x-server-version)) 5) + (equal port "imaps")) "993" port)) @@ -442,7 +480,8 @@ textual parts.") (props (cdr stream-list)) (greeting (plist-get props :greeting)) (capabilities (plist-get props :capabilities)) - (stream-type (plist-get props :type))) + (stream-type (plist-get props :type)) + (server (nnoo-current-server 'nnimap))) (when (and stream (not (memq (process-status stream) '(open run)))) (setq stream nil)) @@ -475,9 +514,7 @@ textual parts.") ;; the virtual server name and the address (nnimap-credentials (gnus-delete-duplicates - (list - (nnoo-current-server 'nnimap) - nnimap-address)) + (list server nnimap-address)) ports nnimap-user)))) (setq nnimap-object nil) @@ -496,8 +533,17 @@ textual parts.") (dolist (response (cddr (nnimap-command "CAPABILITY"))) (when (string= "CAPABILITY" (upcase (car response))) (setf (nnimap-capabilities nnimap-object) - (mapcar #'upcase (cdr response)))))) - ;; If the login failed, then forget the credentials + (mapcar #'upcase (cdr response))))) + (when (and nnimap-use-namespaces + (nnimap-capability "NAMESPACE")) + (erase-buffer) + (nnimap-wait-for-response (nnimap-send-command "NAMESPACE")) + (let ((response (nnimap-last-response-string))) + (when (string-match + "^\\*\\W+NAMESPACE\\W+((\"\\([^\"\n]+\\)\"\\W+\"\\(.\\)\"))\\W+" + response) + (setq nnimap-namespace (match-string 1 response)))))) + ;; If the login failed, then forget the credentials ;; that are now possibly cached. (dolist (host (list (nnoo-current-server 'nnimap) nnimap-address)) @@ -522,6 +568,7 @@ textual parts.") ((and (not (nnimap-capability "LOGINDISABLED")) (eq (nnimap-stream-type nnimap-object) 'tls) (or (null nnimap-authenticator) + (eq nnimap-authenticator 'anonymous) (eq nnimap-authenticator 'login))) (nnimap-command "LOGIN %S %S" user password)) ((and (nnimap-capability "AUTH=CRAM-MD5") @@ -536,11 +583,13 @@ textual parts.") (base64-encode-string (concat user " " (rfc2104-hash 'md5 64 16 password - (base64-decode-string challenge)))) + (base64-decode-string challenge))) + t) "\r\n")) (nnimap-wait-for-response sequence))) ((and (not (nnimap-capability "LOGINDISABLED")) (or (null nnimap-authenticator) + (eq nnimap-authenticator 'anonymous) (eq nnimap-authenticator 'login))) (nnimap-command "LOGIN %S %S" user password)) ((and (nnimap-capability "AUTH=PLAIN") @@ -551,7 +600,8 @@ textual parts.") (base64-encode-string (format "\000%s\000%s" (nnimap-quote-specials user) - (nnimap-quote-specials password))))))) + (nnimap-quote-specials password)) + t))))) (defun nnimap-quote-specials (string) (with-temp-buffer @@ -772,7 +822,7 @@ textual parts.") (insert "\n--" boundary "--\n"))) (defun nnimap-find-wanted-parts (structure) - (message-flatten-list (nnimap-find-wanted-parts-1 structure ""))) + (flatten-tree (nnimap-find-wanted-parts-1 structure ""))) (defun nnimap-find-wanted-parts-1 (structure prefix) (let ((num 1) @@ -794,7 +844,7 @@ textual parts.") (equal id "1") (string-match nnimap-fetch-partial-articles type)) (push id parts)))) - (incf num))) + (cl-incf num))) (nreverse parts))) (deffoo nnimap-request-group (group &optional server dont-check info) @@ -835,7 +885,7 @@ textual parts.") (with-current-buffer (nnimap-buffer) (erase-buffer) (let ((group-sequence - (nnimap-send-command "SELECT %S" (utf7-encode group t))) + (nnimap-send-command "SELECT %S" (nnimap-group-to-imap group))) (flag-sequence (nnimap-send-command "UID FETCH 1:* FLAGS"))) (setf (nnimap-group nnimap-object) group) @@ -868,13 +918,13 @@ textual parts.") (setq group (nnimap-decode-gnus-group group)) (when (nnimap-change-group nil server) (with-current-buffer (nnimap-buffer) - (car (nnimap-command "CREATE %S" (utf7-encode group t)))))) + (car (nnimap-command "CREATE %S" (nnimap-group-to-imap group)))))) (deffoo nnimap-request-delete-group (group &optional _force server) (setq group (nnimap-decode-gnus-group group)) (when (nnimap-change-group nil server) (with-current-buffer (nnimap-buffer) - (car (nnimap-command "DELETE %S" (utf7-encode group t)))))) + (car (nnimap-command "DELETE %S" (nnimap-group-to-imap group)))))) (deffoo nnimap-request-rename-group (group new-name &optional server) (setq group (nnimap-decode-gnus-group group)) @@ -882,7 +932,7 @@ textual parts.") (with-current-buffer (nnimap-buffer) (nnimap-unselect-group) (car (nnimap-command "RENAME %S %S" - (utf7-encode group t) (utf7-encode new-name t)))))) + (nnimap-group-to-imap group) (nnimap-group-to-imap new-name)))))) (defun nnimap-unselect-group () ;; Make sure we don't have this group open read/write by asking @@ -942,7 +992,7 @@ textual parts.") "UID COPY %d %S")) (result (nnimap-command command article - (utf7-encode internal-move-group t)))) + (nnimap-group-to-imap internal-move-group)))) (when (and (car result) (not can-move)) (nnimap-delete-article article)) (cons internal-move-group @@ -1009,7 +1059,7 @@ textual parts.") "UID MOVE %s %S" "UID COPY %s %S") (nnimap-article-ranges (gnus-compress-sequence articles)) - (utf7-encode (gnus-group-real-name nnmail-expiry-target) t)) + (nnimap-group-to-imap (gnus-group-real-name nnmail-expiry-target))) (set (if can-move 'deleted-articles 'articles-to-delete) articles)))) t) (t @@ -1050,7 +1100,7 @@ textual parts.") (format-time-string (format "%%d-%s-%%Y" (upcase - (car (rassoc (nth 4 (decode-time cutoff)) + (car (rassoc (decoded-time-month (decode-time cutoff)) parse-time-months)))) cutoff)))) (and (car result) @@ -1134,7 +1184,7 @@ If LIMIT, first try to limit the search to the N last articles." (unsubscribe "UNSUBSCRIBE"))))) (when command (with-current-buffer (nnimap-buffer) - (nnimap-command "%s %S" (cadr command) (utf7-encode group t))))))) + (nnimap-command "%s %S" (cadr command) (nnimap-group-to-imap group))))))) (deffoo nnimap-request-set-mark (group actions &optional server) (setq group (nnimap-decode-gnus-group group)) @@ -1145,7 +1195,7 @@ If LIMIT, first try to limit the search to the N last articles." ;; Just send all the STORE commands without waiting for ;; response. If they're successful, they're successful. (dolist (action actions) - (destructuring-bind (range action marks) action + (cl-destructuring-bind (range action marks) action (let ((flags (nnimap-marks-to-flags marks))) (when flags (setq sequence (nnimap-send-command @@ -1171,8 +1221,8 @@ If LIMIT, first try to limit the search to the N last articles." ;; We don't really care about the article number, because ;; that's determined by the IMAP server later. So just ;; return the group name. - `(lambda (group) - (list (list group))))))) + (lambda (group) + (list (list group))))))) (setq group (nnimap-decode-gnus-group group)) (when (nnimap-change-group nil server) (nnmail-check-syntax) @@ -1189,7 +1239,7 @@ If LIMIT, first try to limit the search to the N last articles." (nnimap-unselect-group)) (erase-buffer) (setq sequence (nnimap-send-command - "APPEND %S {%d}" (utf7-encode group t) + "APPEND %S {%d}" (nnimap-group-to-imap group) (length message))) (unless nnimap-streaming (nnimap-wait-for-connection "^[+]")) @@ -1269,8 +1319,12 @@ If LIMIT, first try to limit the search to the N last articles." (defun nnimap-get-groups () (erase-buffer) - (let ((sequence (nnimap-send-command "LIST \"\" \"*\"")) - groups) + (let* ((sequence (nnimap-send-command "LIST \"\" \"*\"")) + (prefix nnimap-namespace) + (prefix-len (if prefix (length prefix) nil)) + (inbox (if prefix + (substring prefix 0 -1) nil)) + groups) (nnimap-wait-for-response sequence) (subst-char-in-region (point-min) (point-max) ?\\ ?% t) @@ -1286,12 +1340,17 @@ If LIMIT, first try to limit the search to the N last articles." (progn (end-of-line) (skip-chars-backward " \r\"") (point))))) - (unless (member '%NoSelect flags) - (push (utf7-decode (if (stringp group) - group - (format "%s" group)) - t) - groups)))) + (unless (member '%Noselect flags) + (let* ((group (utf7-decode (if (stringp group) group + (format "%s" group)) t)) + (group (cond ((or (not prefix) + (equal inbox group)) + group) + ((string-prefix-p prefix group) + (substring group prefix-len)) + (t + (concat "#" group))))) + (push group groups))))) (nreverse groups))) (defun nnimap-get-responses (sequences) @@ -1317,7 +1376,7 @@ If LIMIT, first try to limit the search to the N last articles." (dolist (group groups) (setf (nnimap-examined nnimap-object) group) (push (list (nnimap-send-command "EXAMINE %S" - (utf7-encode group t)) + (nnimap-group-to-imap group)) group) sequences)) (nnimap-wait-for-response (caar sequences)) @@ -1389,7 +1448,7 @@ If LIMIT, first try to limit the search to the N last articles." unexist) (push (list (nnimap-send-command "EXAMINE %S (%s (%s %s))" - (utf7-encode group t) + (nnimap-group-to-imap group) (nnimap-quirk "QRESYNC") uidvalidity modseq) 'qresync @@ -1408,10 +1467,10 @@ If LIMIT, first try to limit the search to the N last articles." (if (and active uidvalidity unexist) ;; Fetch the last 100 flags. (setq start (max 1 (- (cdr active) 100))) - (incf (nnimap-initial-resync nnimap-object)) + (cl-incf (nnimap-initial-resync nnimap-object)) (setq start 1)) (push (list (nnimap-send-command "%s %S" command - (utf7-encode group t)) + (nnimap-group-to-imap group)) (nnimap-send-command "UID FETCH %d:* FLAGS" start) start group command) sequences)))) @@ -1472,7 +1531,7 @@ If LIMIT, first try to limit the search to the N last articles." (nnimap-update-info info marks))))) (defun nnimap-update-info (info marks) - (destructuring-bind (existing flags high low uidnext start-article + (cl-destructuring-bind (existing flags high low uidnext start-article permanent-flags uidvalidity vanished highestmodseq) marks (cond @@ -1544,6 +1603,8 @@ If LIMIT, first try to limit the search to the N last articles." info existing (nnimap-imap-ranges-to-gnus-ranges vanished) flags) ;; Do normal non-QRESYNC flag updates. ;; Update the list of read articles. + (unless start-article + (setq start-article 1)) (let* ((unread (gnus-compress-sequence (gnus-set-difference @@ -1641,18 +1702,19 @@ If LIMIT, first try to limit the search to the N last articles." (cdr (or (assoc (caddr type) flags) ; %Flagged (assoc (intern (cadr type) obarray) flags) (assoc (cadr type) flags))))) ; "\Flagged" - (setq marks (delq ticks marks)) - (pop ticks) - ;; Add the new marks we got. - (setq ticks (gnus-add-to-range ticks new-marks)) - ;; Remove the marks from messages that don't have them. - (setq ticks (gnus-remove-from-range - ticks - (gnus-compress-sequence - (gnus-sorted-complement existing new-marks)))) - (when ticks - (push (cons (car type) ticks) marks))) - (gnus-info-set-marks info marks t)) + (when new-marks + (setq marks (delq ticks marks)) + (pop ticks) + ;; Add the new marks we got. + (setq ticks (gnus-add-to-range ticks new-marks)) + ;; Remove the marks from messages that don't have them. + (setq ticks (gnus-remove-from-range + ticks + (gnus-compress-sequence + (gnus-sorted-complement existing new-marks)))) + (when ticks + (push (cons (car type) ticks) marks)) + (gnus-info-set-marks info marks t)))) ;; Add vanished to the list of unexisting articles. (when vanished (let* ((old-unexists (assq 'unexist marks)) @@ -1725,7 +1787,7 @@ If LIMIT, first try to limit the search to the N last articles." (let (start end articles groups uidnext elems permanent-flags uidvalidity vanished highestmodseq) (dolist (elem sequences) - (destructuring-bind (group-sequence flag-sequence totalp group command) + (cl-destructuring-bind (group-sequence flag-sequence totalp group command) elem (setq start (point)) (when (and @@ -1737,19 +1799,17 @@ If LIMIT, first try to limit the search to the N last articles." (goto-char start) (setq permanent-flags (if (equal command "SELECT") - (and (search-forward "PERMANENTFLAGS " - (or end (point-min)) t) + (and (search-forward "PERMANENTFLAGS " end t) (read (current-buffer))) 'not-scanned)) (goto-char start) (setq uidnext - (and (search-forward "UIDNEXT " - (or end (point-min)) t) + (and (search-forward "UIDNEXT " end t) (read (current-buffer)))) (goto-char start) (setq uidvalidity (and (re-search-forward "UIDVALIDITY \\([0-9]+\\)" - (or end (point-min)) t) + end t) ;; Store UIDVALIDITY as a string, as it's ;; too big for 32-bit Emacsen, usually. (match-string 1))) @@ -1757,12 +1817,12 @@ If LIMIT, first try to limit the search to the N last articles." (setq vanished (and (eq flag-sequence 'qresync) (re-search-forward "^\\* VANISHED .*? \\([0-9:,]+\\)" - (or end (point-min)) t) + end t) (match-string 1))) (goto-char start) (setq highestmodseq (and (re-search-forward "HIGHESTMODSEQ \\([0-9]+\\)" - (or end (point-min)) t) + end t) (match-string 1))) (goto-char end) (forward-line -1)) @@ -1843,7 +1903,7 @@ Return the server's response to the SELECT or EXAMINE command." (if read-only "EXAMINE" "SELECT") - (utf7-encode group t)))) + (nnimap-group-to-imap group)))) (when (car result) (setf (nnimap-group nnimap-object) group (nnimap-select-result nnimap-object) result) @@ -1853,7 +1913,7 @@ Return the server's response to the SELECT or EXAMINE command." "Find the connection delivering to BUFFER." (let ((entry (assoc buffer nnimap-connection-alist))) (when entry - (if (and (buffer-name (cadr entry)) + (if (and (buffer-live-p (cadr entry)) (get-buffer-process (cadr entry)) (memq (process-status (get-buffer-process (cadr entry))) '(open run))) @@ -1861,7 +1921,9 @@ Return the server's response to the SELECT or EXAMINE command." (setq nnimap-connection-alist (delq entry nnimap-connection-alist)) nil)))) -(defvar nnimap-sequence 0) +;; Leave room for `open-network-stream' to issue a couple of IMAP +;; commands before nnimap starts. +(defvar nnimap-sequence 5) (defun nnimap-send-command (&rest args) (setf (nnimap-last-command-time nnimap-object) (current-time)) @@ -1869,7 +1931,7 @@ Return the server's response to the SELECT or EXAMINE command." (get-buffer-process (current-buffer)) (nnimap-log-command (format "%d %s%s\n" - (incf nnimap-sequence) + (cl-incf nnimap-sequence) (apply #'format args) (if (nnimap-newlinep nnimap-object) "" @@ -2099,7 +2161,7 @@ Return the server's response to the SELECT or EXAMINE command." (dolist (spec specs) (when (and (not (member (car spec) groups)) (not (eq (car spec) 'junk))) - (nnimap-command "CREATE %S" (utf7-encode (car spec) t)))) + (nnimap-command "CREATE %S" (nnimap-group-to-imap (car spec))))) ;; Then copy over all the messages. (erase-buffer) (dolist (spec specs) @@ -2115,7 +2177,7 @@ Return the server's response to the SELECT or EXAMINE command." "UID MOVE %s %S" "UID COPY %s %S") (nnimap-article-ranges ranges) - (utf7-encode group t)) + (nnimap-group-to-imap group)) ranges) sequences))))) ;; Wait for the last COPY response... @@ -2166,7 +2228,7 @@ Return the server's response to the SELECT or EXAMINE command." (let ((specs nil) entry) (dolist (elem list) - (destructuring-bind (article spec) elem + (cl-destructuring-bind (article spec) elem (dolist (group (delete nil (mapcar #'car spec))) (unless (setq entry (assoc group specs)) (push (setq entry (list group)) specs)) @@ -2178,12 +2240,12 @@ Return the server's response to the SELECT or EXAMINE command." (defun nnimap-transform-split-mail () (goto-char (point-min)) (let (article bytes) - (block nil + (cl-block nil (while (not (eobp)) (while (not (looking-at "\\* [0-9]+ FETCH.+UID \\([0-9]+\\)")) (delete-region (point) (progn (forward-line 1) (point))) (when (eobp) - (return))) + (cl-return))) (setq article (match-string 1) bytes (nnimap-get-length)) (delete-region (line-beginning-position) (line-end-position)) diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el index 0062cd85893..d66bdf47066 100644 --- a/lisp/gnus/nnir.el +++ b/lisp/gnus/nnir.el @@ -30,7 +30,7 @@ ;;; Commentary: ;; What does it do? Well, it allows you to search your mail using -;; some search engine (imap, namazu, swish-e, gmane and others -- see +;; some search engine (imap, namazu, swish-e and others -- see ;; later) by typing `G G' in the Group buffer. You will then get a ;; buffer which shows all articles matching the query, sorted by ;; Retrieval Status Value (score). @@ -507,17 +507,36 @@ Instead, use this: :type '(repeat (string)) :group 'nnir) -(defcustom nnir-notmuch-remove-prefix (concat (getenv "HOME") "/Mail/") +(defcustom nnir-notmuch-remove-prefix + (regexp-quote (or (getenv "MAILDIR") (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. This variable is very similar to `nnir-namazu-remove-prefix', except that it is for notmuch, not Namazu." - :version "24.1" + :version "27.1" :type '(regexp) :group 'nnir) +(defcustom nnir-notmuch-filter-group-names-function nil + "Whether and how to use Gnus group names as \"path:\" search terms. +When nil, the groups being searched in are not used as notmuch +:path search terms. It's still possible to use \"path:\" terms +manually within the search query, however. + +When a function, map this function over all the group names. To +use the group names unchanged, set to (lambda (g) g). Multiple +transforms (for instance, converting \".\" to \"/\") can be added +like so: + +\(add-function :filter-return + nnir-notmuch-filter-group-names-function + (lambda (g) (replace-regexp-in-string \"\\\\.\" \"/\" g)))" + :version "27.1" + :type '(choice function + nil)) + ;;; Developer Extension Variable: (defvar nnir-engines @@ -530,8 +549,6 @@ that it is for notmuch, not Namazu." nnir-imap-search-argument-history ; the history to use ,nnir-imap-default-search-key ; default ))) - (gmane nnir-run-gmane - ((gmane-author . "Gmane Author: "))) (swish++ nnir-run-swish++ ((swish++-group . "Swish++ Group spec (regexp): "))) (swish-e nnir-run-swish-e @@ -561,7 +578,7 @@ needs the variables `nnir-namazu-program', Add an entry here when adding a new search engine.") -(defcustom nnir-method-default-engines '((nnimap . imap) (nntp . gmane)) +(defcustom nnir-method-default-engines '((nnimap . imap)) "Alist of default search engines keyed by server method." :version "24.1" :group 'nnir @@ -641,10 +658,10 @@ skips all prompting." (let ((backend (car (gnus-server-to-method server)))) (if backend (nnoo-change-server backend server definitions) - (add-hook 'gnus-summary-mode-hook 'nnir-mode) + (add-hook 'gnus-summary-prepared-hook 'nnir-mode) (nnoo-change-server 'nnir server definitions)))) -(deffoo nnir-request-group (group &optional server dont-check info) +(deffoo nnir-request-group (group &optional server dont-check _info) (nnir-possibly-change-group group server) (let ((pgroup (gnus-group-guess-full-name-from-command-method group)) length) @@ -669,7 +686,9 @@ skips all prompting." group)))) ; group name nnir-artlist) -(deffoo nnir-retrieve-headers (articles &optional group server fetch-old) +(defvar gnus-inhibit-demon) + +(deffoo nnir-retrieve-headers (articles &optional _group _server _fetch-old) (with-current-buffer nntp-server-buffer (let ((gnus-inhibit-demon t) (articles-by-group (nnir-categorize @@ -705,7 +724,7 @@ skips all prompting." (mail-header-number novitem))) (art (car (rassq artno articleids)))) (when art - (mail-header-set-number novitem art) + (setf (mail-header-number novitem) art) (push novitem headers)) (forward-line 1))))) (setq headers @@ -716,6 +735,8 @@ skips all prompting." (mapc 'nnheader-insert-nov headers) 'nov))) +(defvar gnus-article-decode-hook) + (deffoo nnir-request-article (article &optional group server to-buffer) (nnir-possibly-change-group group server) (if (and (stringp article) @@ -753,7 +774,7 @@ skips all prompting." (cons artfullgroup artno))))))) (deffoo nnir-request-move-article (article group server accept-form - &optional last internal-move-group) + &optional last _internal-move-group) (nnir-possibly-change-group group server) (let* ((artfullgroup (nnir-article-group article)) (artno (nnir-article-number article)) @@ -803,7 +824,8 @@ skips all prompting." (error "Can't warp to a pseudo-article"))) (backend-article-group (nnir-article-group cur)) (backend-article-number (nnir-article-number cur)) - (quit-config (gnus-ephemeral-group-p gnus-newsgroup-name))) +; (quit-config (gnus-ephemeral-group-p gnus-newsgroup-name)) + ) ;; what should we do here? we could leave all the buffers around ;; and assume that we have to exit from them one by one. or we can @@ -818,7 +840,7 @@ skips all prompting." (gnus-summary-read-group-1 backend-article-group t t nil nil (list backend-article-number)))) -(deffoo nnir-request-update-mark (group article mark) +(deffoo nnir-request-update-mark (_group article mark) (let ((artgroup (nnir-article-group article)) (artnumber (nnir-article-number article))) (or (and artgroup @@ -956,7 +978,7 @@ details on the language and supported extensions." (save-excursion (let ((qstring (cdr (assq 'query query))) (server (cadr (gnus-server-to-method srv))) - (defs (nth 2 (gnus-server-to-method srv))) +;; (defs (nth 2 (gnus-server-to-method srv))) (criteria (or (cdr (assq 'criteria query)) (cdr (assoc nnir-imap-default-search-key nnir-imap-search-arguments)))) @@ -969,7 +991,6 @@ details on the language and supported extensions." (mapcar #'(lambda (group) (let (artlist) - (setq group (nnimap-decode-gnus-group group)) (condition-case () (when (nnimap-change-group (gnus-group-short-name group) server) @@ -1165,7 +1186,7 @@ returning the one at the supplied position." (defun nnir-imap-end-of-input () "Are we at the end of input?" - (skip-chars-forward "[[:blank:]]") + (skip-chars-forward "[:blank:]") (looking-at "$")) @@ -1178,7 +1199,7 @@ returning the one at the supplied position." ;; - article number ;; - file size ;; - group -(defun nnir-run-swish++ (query server &optional group) +(defun nnir-run-swish++ (query server &optional _group) "Run QUERY against swish++. Returns a vector of (group name, file name) pairs (also vectors, actually). @@ -1268,7 +1289,7 @@ Windows NT 4.0." (nnir-artitem-rsv y))))))))) ;; Swish-E interface. -(defun nnir-run-swish-e (query server &optional group) +(defun nnir-run-swish-e (query server &optional _group) "Run given query against swish-e. Returns a vector of (group name, file name) pairs (also vectors, actually). @@ -1434,7 +1455,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." ))) ;; Namazu interface -(defun nnir-run-namazu (query server &optional group) +(defun nnir-run-namazu (query server &optional _group) "Run given query against Namazu. Returns a vector of (group name, file name) pairs (also vectors, actually). @@ -1503,23 +1524,31 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." (> (nnir-artitem-rsv x) (nnir-artitem-rsv y))))))))) -(defun nnir-run-notmuch (query server &optional group) +(defun nnir-run-notmuch (query server &optional groups) "Run QUERY against notmuch. Returns a vector of (group name, file name) pairs (also vectors, -actually)." - - ;; (when group - ;; (error "The notmuch backend cannot search specific groups")) +actually). If GROUPS is a list of group names, use them to +construct path: search terms (see the variable +`nnir-notmuch-filter-group-names-function')." (save-excursion - (let ( (qstring (cdr (assq 'query query))) - (groupspec (cdr (assq 'notmuch-group query))) + (let* ((qstring (cdr (assq 'query query))) (prefix (nnir-read-server-parm 'nnir-notmuch-remove-prefix server)) artlist (article-pattern (if (string-match "\\`nnmaildir:" (gnus-group-server server)) - ":[0-9]+" - "^[0-9]+$")) + ":[0-9]+" + "^[0-9]+$")) + (groups (when nnir-notmuch-filter-group-names-function + (delq nil + (mapcar nnir-notmuch-filter-group-names-function + (mapcar #'gnus-group-short-name groups))))) + (pathquery (when groups + (concat " (" + (mapconcat (lambda (g) + (format "path:%s" g)) + groups " or") + ")"))) artno dirnam filenam) (when (equal "" qstring) @@ -1528,10 +1557,14 @@ actually)." (set-buffer (get-buffer-create nnir-tmp-buffer)) (erase-buffer) - (if groupspec - (message "Doing notmuch query %s on %s..." qstring groupspec) + (if groups + (message "Doing notmuch query %s on %s..." + qstring (mapconcat #'identity groups " ")) (message "Doing notmuch query %s..." qstring)) + (when groups + (setq qstring (concat qstring pathquery))) + (let* ((cp-list `( ,nnir-notmuch-program nil ; input from /dev/null t ; output @@ -1569,10 +1602,7 @@ actually)." (when (string-match article-pattern artno) (when (not (null dirnam)) - ;; maybe limit results to matching groups. - (when (or (not groupspec) - (string-match groupspec dirnam)) - (nnir-add-result dirnam artno "" prefix server artlist))))) + (nnir-add-result dirnam artno "" prefix server artlist)))) (message "Massaging notmuch output...done") @@ -1663,54 +1693,6 @@ actually)." (declare-function mm-url-insert "mm-url" (url &optional follow-refresh)) (declare-function mm-url-encode-www-form-urlencoded "mm-url" (pairs)) -;; gmane interface -(defun nnir-run-gmane (query srv &optional groups) - "Run a search against a gmane back-end server." - (let* ((case-fold-search t) - (qstring (cdr (assq 'query query))) - (server (cadr (gnus-server-to-method srv))) - (groupspec (mapconcat - (lambda (x) - (if (string-match-p "gmane" x) - (format "group:%s" (gnus-group-short-name x)) - (error "Can't search non-gmane groups: %s" x))) - groups " ")) - (authorspec - (if (assq 'gmane-author query) - (format "author:%s" (cdr (assq 'gmane-author query))) "")) - (search (format "%s %s %s" - qstring groupspec authorspec)) - (gnus-inhibit-demon t) - artlist) - (require 'mm-url) - (with-current-buffer (get-buffer-create nnir-tmp-buffer) - (erase-buffer) - (mm-url-insert - (concat - "http://search.gmane.org/nov.php" - "?" - (mm-url-encode-www-form-urlencoded - `(("query" . ,search) - ("HITSPERPAGE" . "999"))))) - (set-buffer-multibyte t) - (decode-coding-region (point-min) (point-max) 'utf-8) - (goto-char (point-min)) - (forward-line 1) - (while (not (eobp)) - (unless (or (eolp) (looking-at "\x0d")) - (let ((header (nnheader-parse-nov))) - (let ((xref (mail-header-xref header)) - (xscore (string-to-number (cdr (assoc 'X-Score - (mail-header-extra header)))))) - (when (string-match " \\([^:]+\\)[:/]\\([0-9]+\\)" xref) - (push - (vector - (gnus-group-prefixed-name (match-string 1 xref) srv) - (string-to-number (match-string 2 xref)) xscore) - artlist))))) - (forward-line 1))) - (apply #'vector (nreverse (delete-dups artlist))))) - ;;; Util Code: (defun gnus-nnir-group-p (group) @@ -1810,8 +1792,7 @@ article came from is also searched." groups) (gnus-request-list method) (with-current-buffer nntp-server-buffer - (let ((cur (current-buffer)) - name) + (let ((cur (current-buffer))) (goto-char (point-min)) (unless (or (null nnir-ignored-newsgroups) (string= nnir-ignored-newsgroups "")) @@ -1819,31 +1800,29 @@ article came from is also searched." (if (eq (car method) 'nntp) (while (not (eobp)) (ignore-errors - (push (string-as-unibyte - (gnus-group-full-name - (buffer-substring - (point) - (progn - (skip-chars-forward "^ \t") - (point))) - method)) + (push (gnus-group-full-name + (buffer-substring + (point) + (progn + (skip-chars-forward "^ \t") + (point))) + method) groups)) (forward-line)) (while (not (eobp)) (ignore-errors - (push (string-as-unibyte - (if (eq (char-after) ?\") - (gnus-group-full-name (read cur) method) - (let ((p (point)) (name "")) - (skip-chars-forward "^ \t\\\\") - (setq name (buffer-substring p (point))) - (while (eq (char-after) ?\\) - (setq p (1+ (point))) - (forward-char 2) - (skip-chars-forward "^ \t\\\\") - (setq name (concat name (buffer-substring - p (point))))) - (gnus-group-full-name name method)))) + (push (if (eq (char-after) ?\") + (gnus-group-full-name (read cur) method) + (let ((p (point)) (name "")) + (skip-chars-forward "^ \t\\\\") + (setq name (buffer-substring p (point))) + (while (eq (char-after) ?\\) + (setq p (1+ (point))) + (forward-char 2) + (skip-chars-forward "^ \t\\\\") + (setq name (concat name (buffer-substring + p (point))))) + (gnus-group-full-name name method))) groups)) (forward-line))))) groups)) @@ -1852,7 +1831,7 @@ article came from is also searched." (declare-function gnus-registry-action "gnus-registry" (action data-header from &optional to method)) -(defun nnir-registry-action (action data-header from &optional to method) +(defun nnir-registry-action (action data-header _from &optional to method) "Call `gnus-registry-action' with the original article group." (gnus-registry-action action @@ -1887,7 +1866,7 @@ article came from is also searched." (gnus-group-find-parameter pgroup))))) -(deffoo nnir-request-create-group (group &optional server args) +(deffoo nnir-request-create-group (group &optional _server args) (message "Creating nnir group %s" group) (let* ((group (gnus-group-prefixed-name group '(nnir "nnir"))) (specs (assq 'nnir-specs args)) @@ -1908,13 +1887,13 @@ article came from is also searched." (nnir-request-update-info group (gnus-get-info group))) t) -(deffoo nnir-request-delete-group (group &optional force server) +(deffoo nnir-request-delete-group (_group &optional _force _server) t) -(deffoo nnir-request-list (&optional server) +(deffoo nnir-request-list (&optional _server) t) -(deffoo nnir-request-scan (group method) +(deffoo nnir-request-scan (_group _method) t) (deffoo nnir-request-close () diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index c52bc03e109..0699e818123 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) ; for macro gnus-kill-buffer, at least (require 'nnheader) @@ -34,8 +34,6 @@ (require 'mm-util) (require 'gnus-int) -(autoload 'gnus-add-buffer "gnus") -(autoload 'gnus-kill-buffer "gnus") (autoload 'mail-send-and-exit "sendmail" nil t) (defgroup nnmail nil @@ -488,7 +486,8 @@ Example: (to . "to\\|cc\\|apparently-to\\|resent-to\\|resent-cc") (from . "from\\|sender\\|resent-from") (nato . "to\\|cc\\|resent-to\\|resent-cc") - (naany . "from\\|to\\|cc\\|sender\\|resent-from\\|resent-to\\|resent-cc")) + (naany . "from\\|to\\|cc\\|sender\\|resent-from\\|resent-to\\|resent-cc") + (list . "list-id\\|list-post\\|x-mailing-list\\|x-beenthere\\|x-loop")) "Alist of abbreviations allowed in `nnmail-split-fancy'." :group 'nnmail-split :type '(repeat (cons :format "%v" symbol regexp))) @@ -567,6 +566,12 @@ using different case (i.e. mailing-list@domain vs Mailing-List@Domain)." :group 'nnmail :type 'boolean) +(defcustom nnmail-debug-splitting nil + "If non-nil, record mail splitting actions. +These will be logged to the \"*nnmail split*\" buffer." + :type 'boolean + :version "27.1") + ;;; Internal variables. (defvar nnmail-article-buffer " *nnmail incoming*" @@ -662,10 +667,10 @@ nn*-request-list should have been called before calling this function." (narrow-to-region (point) (point-at-eol)) (setq group (read buffer)) (unless (stringp group) - (setq group (symbol-name group))) + (setq group (encode-coding-string (symbol-name group) 'latin-1))) (if (and (numberp (setq max (read buffer))) (numberp (setq min (read buffer)))) - (push (list (string-as-unibyte group) (cons min max)) + (push (list group (cons min max)) group-assoc))) (error nil)) (widen) @@ -723,7 +728,7 @@ If SOURCE is a directory spec, try to return the group name component." ;; Skip all the headers in case there are more "From "s... (or (search-forward "\n\n" nil t) (search-forward-regexp "^[^:]*\\( .*\\|\\)$" nil t) - (search-forward "")) + (search-forward "\^_\^L")) (point))) ;; Unquote the ">From " line, if any. (goto-char (point-min)) @@ -763,7 +768,7 @@ If SOURCE is a directory spec, try to return the group name component." (if (or (= (+ (point) content-length) (point-max)) (save-excursion (goto-char (+ (point) content-length)) - (looking-at ""))) + (looking-at "\^_"))) (progn (goto-char (+ (point) content-length)) (setq do-search nil)) @@ -772,7 +777,7 @@ If SOURCE is a directory spec, try to return the group name component." ;; Go to the beginning of the next article - or to the end ;; of the buffer. (when do-search - (if (re-search-forward "^" nil t) + (if (re-search-forward "^\^_" nil t) (goto-char (match-beginning 0)) (goto-char (1- (point-max))))) (delete-char 1) ; delete ^_ @@ -781,7 +786,7 @@ If SOURCE is a directory spec, try to return the group name component." (narrow-to-region start (point)) (goto-char (point-min)) (nnmail-check-duplication message-id func artnum-func) - (incf count) + (cl-incf count) (setq end (point-max)))) (goto-char end)) count)) @@ -927,7 +932,7 @@ If SOURCE is a directory spec, try to return the group name component." (save-restriction (narrow-to-region start (point)) (goto-char (point-min)) - (incf count) + (cl-incf count) (nnmail-check-duplication message-id func artnum-func) (setq end (point-max)))) (goto-char end))) @@ -980,7 +985,7 @@ If SOURCE is a directory spec, try to return the group name component." (save-restriction (narrow-to-region start (point)) (goto-char (point-min)) - (incf count) + (cl-incf count) (nnmail-check-duplication message-id func artnum-func junk-func) (setq end (point-max)))) (goto-char end) @@ -1248,11 +1253,11 @@ Return the number of characters in the body." (progn (forward-line 1) (point)))) (insert (format "Xref: %s" (system-name))) (while group-alist - (insert (if (mm-multibyte-p) - (string-as-multibyte - (format " %s:%d" (caar group-alist) (cdar group-alist))) - (string-as-unibyte - (format " %s:%d" (caar group-alist) (cdar group-alist))))) + (insert (if enable-multibyte-characters + (format " %s:%d" (caar group-alist) (cdar group-alist)) + (encode-coding-string + (format " %s:%d" (caar group-alist) (cdar group-alist)) + 'utf-8))) (setq group-alist (cdr group-alist))) (insert "\n"))) @@ -1360,14 +1365,12 @@ See the documentation for the variable `nnmail-split-fancy' for details." ;; A group name. Do the \& and \N subs into the string. ((stringp split) - (when nnmail-split-tracing - (push split nnmail-split-trace)) + (nnmail-log-split split) (list (nnmail-expand-newtext split t))) ;; Junk the message. ((eq split 'junk) - (when nnmail-split-tracing - (push "junk" nnmail-split-trace)) + (nnmail-log-split "junk") (list 'junk)) ;; Builtin & operation. @@ -1384,8 +1387,7 @@ See the documentation for the variable `nnmail-split-fancy' for details." ;; Builtin : operation. ((eq (car split) ':) - (when nnmail-split-tracing - (push split nnmail-split-trace)) + (nnmail-log-split split) (nnmail-split-it (save-excursion (eval (cdr split))))) ;; Builtin ! operation. @@ -1403,8 +1405,7 @@ See the documentation for the variable `nnmail-split-fancy' for details." (while (and (goto-char end-point) (re-search-backward (cdr cached-pair) nil t)) (setq match-data (match-data)) - (when nnmail-split-tracing - (push split nnmail-split-trace)) + (nnmail-log-split split) (let ((split-rest (cddr split)) (end (match-end 0)) ;; The searched regexp is \(\(FIELD\).*\)\(VALUE\). @@ -1533,7 +1534,8 @@ See the documentation for the variable `nnmail-split-fancy' for details." (and (setq file (ignore-errors (symbol-value (intern (format "%s-active-file" backend))))) - (setq file-time (nth 5 (file-attributes file))) + (setq file-time (file-attribute-modification-time + (file-attributes file))) (or (not (setq timestamp (condition-case () @@ -1541,11 +1543,8 @@ See the documentation for the variable `nnmail-split-fancy' for details." (format "%s-active-timestamp" backend))) (error 'none)))) - (not (consp timestamp)) - (equal timestamp '(0 0)) - (> (nth 0 file-time) (nth 0 timestamp)) - (and (= (nth 0 file-time) (nth 0 timestamp)) - (> (nth 1 file-time) (nth 1 timestamp)))))) + (eq timestamp 'none) + (time-less-p timestamp file-time)))) (save-excursion (or (eq timestamp 'none) (set (intern (format "%s-active-timestamp" backend)) @@ -1564,8 +1563,7 @@ See the documentation for the variable `nnmail-split-fancy' for details." (defun nnmail-cache-open () (if (or (not nnmail-treat-duplicates) - (and nnmail-cache-buffer - (buffer-name nnmail-cache-buffer))) + (buffer-live-p nnmail-cache-buffer)) () ; The buffer is open. (with-current-buffer (setq nnmail-cache-buffer @@ -1577,9 +1575,8 @@ See the documentation for the variable `nnmail-split-fancy' for details." (current-buffer)))) (defun nnmail-cache-close () - (when (and nnmail-cache-buffer - nnmail-treat-duplicates - (buffer-name nnmail-cache-buffer) + (when (and nnmail-treat-duplicates + (buffer-live-p nnmail-cache-buffer) (buffer-modified-p nnmail-cache-buffer)) (with-current-buffer nnmail-cache-buffer ;; Weed out the excess number of Message-IDs. @@ -1836,8 +1833,8 @@ be called once per group or once for all groups." ((error quit) (message "Mail source %s failed: %s" source cond) 0))) - (incf total new) - (incf i))) + (cl-incf total new) + (cl-incf i))) ;; If we did indeed read any incoming spools, we save all info. (if (zerop total) (when mail-source-plugged @@ -1883,7 +1880,7 @@ If TIME is nil, then return the cutoff time for oldness instead." (setq days (days-to-time days)) ;; Compare the time with the current time. (if (null time) - (time-subtract (current-time) days) + (time-since days) (ignore-errors (time-less-p days (time-since time))))))))) (declare-function gnus-group-mark-article-read "gnus-group" (group article)) @@ -1899,7 +1896,7 @@ If TIME is nil, then return the cutoff time for oldness instead." (unless (eq target 'delete) (when (or (gnus-request-group target nil nil (gnus-get-info target)) (gnus-request-create-group target)) - (let ((group-art (gnus-request-accept-article target nil nil t))) + (let ((group-art (gnus-request-accept-article target nil t t))) (when (and (consp group-art) (cdr group-art)) (gnus-group-mark-article-read target (cdr group-art)))))))) @@ -2034,7 +2031,7 @@ If TIME is nil, then return the cutoff time for oldness instead." "Remove all instances of GROUP from `nnmail-split-history'." (let ((history nnmail-split-history)) (while history - (setcar history (gnus-remove-if (lambda (e) (string= (car e) group)) + (setcar history (seq-remove (lambda (e) (string= (car e) group)) (car history))) (pop history)) (setq nnmail-split-history (delq nil nnmail-split-history)))) @@ -2057,6 +2054,17 @@ Doesn't change point." (and (nnmail-search-unix-mail-delim-backward) (not (search-forward "\n\n" pos t)))))) +(defun nnmail-log-split (split) + (when nnmail-split-tracing + (push split nnmail-split-trace)) + (when nnmail-debug-splitting + (with-current-buffer (get-buffer-create "*nnmail split*") + (goto-char (point-max)) + (insert (format-time-string "%FT%T") + " " + (format "%S" split) + "\n")))) + (run-hooks 'nnmail-load-hook) (provide 'nnmail) diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index 272240f5a9f..246f52c8d2b 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -69,7 +69,8 @@ (require 'nnmail) (eval-when-compile - (require 'cl)) + (require 'cl-lib) + (require 'subr-x)) (defconst nnmaildir-version "Gnus") @@ -136,11 +137,10 @@ This variable is set by `nnmaildir-request-article'.") (defconst nnmaildir--delivery-pid (concat "P" (number-to-string (emacs-pid)))) (defvar nnmaildir--delivery-count nil) -;; An obarry containing symbols whose names are server names and whose values -;; are servers: -(defvar nnmaildir--servers (make-vector 3 0)) -;; The current server: -(defvar nnmaildir--cur-server nil) +(defvar nnmaildir--servers nil + "Alist mapping server name strings to servers.") +(defvar nnmaildir--cur-server nil + "The current server.") ;; A copy of nnmail-extra-headers (defvar nnmaildir--extra nil) @@ -165,34 +165,34 @@ This variable is set by `nnmaildir-request-article'.") (defmacro nnmaildir--nov-set-mtime (nov value) `(aset ,nov 3 ,value)) (defmacro nnmaildir--nov-set-extra (nov value) `(aset ,nov 4 ,value)) -(defstruct nnmaildir--art +(cl-defstruct nnmaildir--art (prefix nil :type string) ;; "time.pid.host" (suffix nil :type string) ;; ":2,flags" (num nil :type natnum) ;; article number (msgid nil :type string) ;; "<mess.age@id>" (nov nil :type vector)) ;; cached nov structure, or nil -(defstruct nnmaildir--grp - (name nil :type string) ;; "group.name" - (new nil :type list) ;; new/ modtime - (cur nil :type list) ;; cur/ modtime - (min 1 :type natnum) ;; minimum article number - (count 0 :type natnum) ;; count of articles - (nlist nil :type list) ;; list of articles, ordered descending by number - (flist nil :type vector) ;; obarray mapping filename prefix->article - (mlist nil :type vector) ;; obarray mapping message-id->article - (cache nil :type vector) ;; nov cache - (index nil :type natnum) ;; index of next cache entry to replace - (mmth nil :type vector)) ;; obarray mapping mark name->dir modtime +(cl-defstruct nnmaildir--grp + (name nil :type string) ;; "group.name" + (new nil :type list) ;; new/ modtime + (cur nil :type list) ;; cur/ modtime + (min 1 :type natnum) ;; minimum article number + (count 0 :type natnum) ;; count of articles + (nlist nil :type list) ;; list of articles, ordered descending by number + (flist nil :type hash-table) ;; hash table mapping filename prefix->article + (mlist nil :type hash-table) ;; hash table mapping message-id->article + (cache nil :type vector) ;; nov cache + (index nil :type natnum) ;; index of next cache entry to replace + (mmth nil :type hash-table)) ;; hash table mapping mark name->dir modtime ; ("Mark Mod Time Hash") -(defstruct nnmaildir--srv +(cl-defstruct nnmaildir--srv (address nil :type string) ;; server address string (method nil :type list) ;; (nnmaildir "address" ...) (prefix nil :type string) ;; "nnmaildir+address:" (dir nil :type string) ;; "/expanded/path/to/server/dir/" (ls nil :type function) ;; directory-files function - (groups nil :type vector) ;; obarray mapping group name->group + (groups nil :type hash-table) ;; hash table mapping group name->group (curgrp nil :type nnmaildir--grp) ;; current group, or nil (error nil :type string) ;; last error message, or nil (mtime nil :type list) ;; modtime of dir @@ -239,17 +239,17 @@ This variable is set by `nnmaildir-request-article'.") (setf (nnmaildir--grp-count group) count) (setf (nnmaildir--grp-nlist group) new-nlist) (setcdr nlist-pre nlist-post) - (unintern prefix flist) - (unintern msgid mlist)))) + (remhash prefix flist) + (remhash msgid mlist)))) (defun nnmaildir--nlist-art (group num) (let ((entry (assq num (nnmaildir--grp-nlist group)))) (if entry (cdr entry)))) (defmacro nnmaildir--flist-art (list file) - `(symbol-value (intern-soft ,file ,list))) + `(gethash ,file ,list)) (defmacro nnmaildir--mlist-art (list msgid) - `(symbol-value (intern-soft ,msgid ,list))) + `(gethash ,msgid ,list)) (defun nnmaildir--pgname (server gname) (let ((prefix (nnmaildir--srv-prefix server))) @@ -319,15 +319,13 @@ This variable is set by `nnmaildir-request-article'.") (setq attr (file-attributes (concat dir (number-to-string number-opened)))) (or attr (throw 'return (1- number-opened))) - (setq ino-opened (nth 10 attr) - nlink (nth 1 attr) + (setq ino-opened (file-attribute-inode-number attr) + nlink (file-attribute-link-number attr) number-linked (+ number-opened nlink)) - (if (or (< nlink 1) (< number-linked nlink)) - (signal 'error '("Arithmetic overflow"))) (setq attr (file-attributes (concat dir (number-to-string number-linked)))) (or attr (throw 'return (1- number-linked))) - (unless (equal ino-opened (nth 10 attr)) + (unless (equal ino-opened (file-attribute-inode-number attr)) (setq number-opened number-linked)))))) ;; Make the given server, if non-nil, be the current server. Then make the @@ -338,12 +336,12 @@ This variable is set by `nnmaildir-request-article'.") (if (null server) (unless (setq server nnmaildir--cur-server) (throw 'return nil)) - (unless (setq server (intern-soft server nnmaildir--servers)) + (unless (setq server (alist-get server nnmaildir--servers + nil nil #'equal)) (throw 'return nil)) - (setq server (symbol-value server) - nnmaildir--cur-server server)) + (setq nnmaildir--cur-server server)) (let ((groups (nnmaildir--srv-groups server))) - (when groups + (when (and groups (null (hash-table-empty-p groups))) (unless (nnmaildir--srv-method server) (setf (nnmaildir--srv-method server) (or (gnus-server-to-method @@ -351,7 +349,7 @@ This variable is set by `nnmaildir-request-article'.") (throw 'return nil)))) (if (null group) (nnmaildir--srv-curgrp server) - (symbol-value (intern-soft group groups))))))) + (gethash group groups)))))) (defun nnmaildir--tab-to-space (string) (let ((pos 0)) @@ -393,11 +391,9 @@ This variable is set by `nnmaildir-request-article'.") (setq make-new-file nil previous-number-link 0)) (let* ((attr (file-attributes path-open)) - (nlink (nth 1 attr))) - (setq ino-open (nth 10 attr) - number-link (+ number-open nlink)) - (if (or (< nlink 1) (< number-link nlink)) - (signal 'error '("Arithmetic overflow")))) + (nlink (file-attribute-link-number attr))) + (setq ino-open (file-attribute-inode-number attr) + number-link (+ number-open nlink))) (if (= number-link previous-number-link) ;; We've already tried this number, in the previous loop iteration, ;; and failed. @@ -413,7 +409,7 @@ This variable is set by `nnmaildir-request-article'.") number-open number-link)) ((nnmaildir--eexist-p err) (let ((attr (file-attributes path-link))) - (unless (equal (nth 10 attr) ino-open) + (unless (equal (file-attribute-inode-number attr) ino-open) (setq number-open number-link number-link 0)))) (t (signal (car err) (cdr err))))))))) @@ -438,8 +434,8 @@ This variable is set by `nnmaildir-request-article'.") (unless attr (nnmaildir--expired-article group article) (throw 'return nil)) - (setq mtime (nth 5 attr) - attr (nth 7 attr) + (setq mtime (file-attribute-modification-time attr) + attr (file-attribute-size attr) nov (nnmaildir--art-nov article) dir (nnmaildir--nndir dir) novdir (nnmaildir--nov-dir dir) @@ -575,15 +571,15 @@ This variable is set by `nnmaildir-request-article'.") (if insert-nlist (setcdr nlist (cons (cons num article) nlist-cdr)) (setf (nnmaildir--grp-nlist group) nlist)) - (set (intern (nnmaildir--art-prefix article) - (nnmaildir--grp-flist group)) - article) - (set (intern (nnmaildir--art-msgid article) - (nnmaildir--grp-mlist group)) - article) - (set (intern (nnmaildir--grp-name group) - (nnmaildir--srv-groups server)) - group)) + (puthash (nnmaildir--art-prefix article) + article + (nnmaildir--grp-flist group)) + (puthash (nnmaildir--art-msgid article) + article + (nnmaildir--grp-mlist group)) + (puthash (nnmaildir--grp-name group) + group + (nnmaildir--srv-groups server))) (nnmaildir--cache-nov group article nov) t))) @@ -651,9 +647,6 @@ This variable is set by `nnmaildir-request-article'.") (if (< (car entry) low) (throw 'iterate-loop nil)) (funcall func (cdr entry))))))) -(defun nnmaildir--up2-1 (n) - (if (zerop n) 1 (1- (lsh 1 (1+ (logb n)))))) - (defun nnmaildir--system-name () (replace-regexp-in-string ":" "\\072" @@ -678,19 +671,20 @@ This variable is set by `nnmaildir-request-article'.") (nnmaildir--srv-groups nnmaildir--cur-server) t)) -(defun nnmaildir-open-server (server &optional defs) - (let ((x server) - dir size) +(defun nnmaildir-open-server (server-string &optional defs) + (let ((server (alist-get server-string nnmaildir--servers + nil nil #'equal)) + dir size x) (catch 'return - (setq server (intern-soft x nnmaildir--servers)) (if server - (and (setq server (symbol-value server)) - (nnmaildir--srv-groups server) + (and (nnmaildir--srv-groups server) (setq nnmaildir--cur-server server) (throw 'return t)) - (setq server (make-nnmaildir--srv :address x)) + (setq server (make-nnmaildir--srv :address server-string)) (let ((inhibit-quit t)) - (set (intern x nnmaildir--servers) server))) + (setf (alist-get server-string nnmaildir--servers + nil nil #'equal) + server))) (setq dir (assq 'directory defs)) (unless dir (setf (nnmaildir--srv-error server) @@ -714,8 +708,7 @@ This variable is set by `nnmaildir-request-article'.") (concat "Not a function: " (prin1-to-string x))) (throw 'return nil))) (setf (nnmaildir--srv-ls server) x) - (setq size (length (funcall x dir nil "\\`[^.]" 'nosort)) - size (nnmaildir--up2-1 size)) + (setq size (length (funcall x dir nil "\\`[^.]" 'nosort))) (and (setq x (assq 'get-new-mail defs)) (setq x (cdr x)) (car x) @@ -735,7 +728,8 @@ This variable is set by `nnmaildir-request-article'.") x (file-name-as-directory x)) (setf (nnmaildir--srv-target-prefix server) x)) (setf (nnmaildir--srv-target-prefix server) ""))) - (setf (nnmaildir--srv-groups server) (make-vector size 0)) + (setf (nnmaildir--srv-groups server) + (gnus-make-hashtable size)) (setq nnmaildir--cur-server server) t))) @@ -765,7 +759,7 @@ This variable is set by `nnmaildir-request-article'.") (defun nnmaildir--scan (gname scan-msgs groups _method srv-dir srv-ls) (catch 'return - (let ((36h-ago (- (car (current-time)) 2)) + (let ((36h-ago (time-since 129600)) absdir nndir tdir ndir cdir nattr cattr isnew pgname read-only ls files num dir flist group x) (setq absdir (nnmaildir--srvgrp-dir srv-dir gname) @@ -795,29 +789,33 @@ This variable is set by `nnmaildir-request-article'.") (setq read-only (nnmaildir--param pgname 'read-only) ls (or (nnmaildir--param pgname 'directory-files) srv-ls)) (unless read-only - (setq x (nth 11 (file-attributes tdir))) - (unless (and (equal x (nth 11 nattr)) (equal x (nth 11 cattr))) + (setq x (file-attribute-device-number (file-attributes tdir))) + (unless (and (equal x (file-attribute-device-number nattr)) + (equal x (file-attribute-device-number cattr))) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Maildir spans filesystems: " absdir)) (throw 'return nil)) (dolist (file (funcall ls tdir 'full "\\`[^.]" 'nosort)) (setq x (file-attributes file)) - (if (or (> (cadr x) 1) (< (car (nth 4 x)) 36h-ago)) + (if (or (> (file-attribute-link-number x) 1) + (time-less-p (file-attribute-access-time x) 36h-ago)) (delete-file file)))) (or scan-msgs isnew (throw 'return t)) - (setq nattr (nth 5 nattr)) + (setq nattr (file-attribute-modification-time nattr)) (if (equal nattr (nnmaildir--grp-new group)) (setq nattr nil)) (if read-only (setq dir (and (or isnew nattr) ndir)) (when (or isnew nattr) (dolist (file (funcall ls ndir nil "\\`[^.]" 'nosort)) (setq x (concat ndir file)) - (and (time-less-p (nth 5 (file-attributes x)) (current-time)) + (and (time-less-p (file-attribute-modification-time + (file-attributes x)) + nil) (rename-file x (concat cdir (nnmaildir--ensure-suffix file))))) (setf (nnmaildir--grp-new group) nattr)) - (setq cattr (nth 5 (file-attributes cdir))) + (setq cattr (file-attribute-modification-time (file-attributes cdir))) (if (equal cattr (nnmaildir--grp-cur group)) (setq cattr nil)) (setq dir (and (or isnew cattr) cdir))) @@ -830,10 +828,10 @@ This variable is set by `nnmaildir-request-article'.") (cons (match-string 1 f) (match-string 2 f))) files))) (when isnew - (setq num (nnmaildir--up2-1 (length files))) - (setf (nnmaildir--grp-flist group) (make-vector num 0)) - (setf (nnmaildir--grp-mlist group) (make-vector num 0)) - (setf (nnmaildir--grp-mmth group) (make-vector 1 0)) + (setq num (length files)) + (setf (nnmaildir--grp-flist group) (gnus-make-hashtable num)) + (setf (nnmaildir--grp-mlist group) (gnus-make-hashtable num)) + (setf (nnmaildir--grp-mmth group) (gnus-make-hashtable 1)) (setq num (nnmaildir--param pgname 'nov-cache-size)) (if (numberp num) (if (< num 1) (setq num 1)) (setq num 16 @@ -856,10 +854,10 @@ This variable is set by `nnmaildir-request-article'.") ;; then look in marks directories (not (file-exists-p (concat cdir prefix))) (file-exists-p (concat ndir prefix))) - (incf num))))) + (cl-incf num))))) (setf (nnmaildir--grp-cache group) (make-vector num nil)) (let ((inhibit-quit t)) - (set (intern gname groups) group)) + (puthash gname group groups)) (or scan-msgs (throw 'return t))) (setq flist (nnmaildir--grp-flist group) files (mapcar @@ -898,49 +896,46 @@ This variable is set by `nnmaildir-request-article'.") groups (nnmaildir--srv-groups nnmaildir--cur-server) target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server)) (nnmaildir--with-work-buffer - (save-match-data - (if (stringp scan-group) - (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls) - (if (nnmaildir--srv-gnm nnmaildir--cur-server) - (nnmail-get-new-mail 'nnmaildir nil nil scan-group)) - (unintern scan-group groups)) - (setq x (nth 5 (file-attributes srv-dir)) - scan-group (null scan-group)) - (if (equal x (nnmaildir--srv-mtime nnmaildir--cur-server)) - (if scan-group - (mapatoms (lambda (sym) - (nnmaildir--scan (symbol-name sym) t groups - method srv-dir srv-ls)) - groups)) - (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort) - dirs (if (zerop (length target-prefix)) - dirs - (gnus-remove-if - (lambda (dir) - (and (>= (length dir) (length target-prefix)) - (string= (substring dir 0 - (length target-prefix)) - target-prefix))) - dirs)) - seen (nnmaildir--up2-1 (length dirs)) - seen (make-vector seen 0)) - (dolist (grp-dir dirs) - (if (nnmaildir--scan grp-dir scan-group groups method srv-dir - srv-ls) - (intern grp-dir seen))) - (setq x nil) - (mapatoms (lambda (group) - (setq group (symbol-name group)) - (unless (intern-soft group seen) - (setq x (cons group x)))) - groups) - (dolist (grp x) - (unintern grp groups)) - (setf (nnmaildir--srv-mtime nnmaildir--cur-server) - (nth 5 (file-attributes srv-dir)))) - (and scan-group - (nnmaildir--srv-gnm nnmaildir--cur-server) - (nnmail-get-new-mail 'nnmaildir nil nil)))))) + (save-match-data + (if (stringp scan-group) + (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls) + (when (nnmaildir--srv-gnm nnmaildir--cur-server) + (nnmail-get-new-mail 'nnmaildir nil nil scan-group)) + (remhash scan-group groups)) + (setq x (file-attribute-modification-time (file-attributes srv-dir)) + scan-group (null scan-group)) + (if (equal x (nnmaildir--srv-mtime nnmaildir--cur-server)) + (when scan-group + (maphash (lambda (group-name _group) + (nnmaildir--scan group-name t groups + method srv-dir srv-ls)) + groups)) + (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort) + dirs (if (zerop (length target-prefix)) + dirs + (seq-remove + (lambda (dir) + (and (>= (length dir) (length target-prefix)) + (string= (substring dir 0 + (length target-prefix)) + target-prefix))) + dirs))) + (dolist (grp-dir dirs) + (when (nnmaildir--scan grp-dir scan-group groups + method srv-dir srv-ls) + (push grp-dir seen))) + (setq x nil) + (maphash (lambda (gname _group) + (unless (member gname seen) + (push gname x))) + groups) + (dolist (grp x) + (remhash grp groups)) + (setf (nnmaildir--srv-mtime nnmaildir--cur-server) + (file-attribute-modification-time (file-attributes srv-dir)))) + (and scan-group + (nnmaildir--srv-gnm nnmaildir--cur-server) + (nnmail-get-new-mail 'nnmaildir nil nil)))))) t) (defun nnmaildir-request-list (&optional server) @@ -949,10 +944,9 @@ This variable is set by `nnmaildir-request-article'.") (nnmaildir--prepare server nil) (nnmaildir--with-nntp-buffer (erase-buffer) - (mapatoms (lambda (group) - (setq pgname (symbol-name group) - pgname (nnmaildir--pgname nnmaildir--cur-server pgname) - group (symbol-value group) + (maphash (lambda (gname group) + (setq pgname (nnmaildir--pgname nnmaildir--cur-server gname) + ro (nnmaildir--param pgname 'read-only)) (insert (replace-regexp-in-string " " "\\ " @@ -994,7 +988,7 @@ This variable is set by `nnmaildir-request-article'.") (curdir (nnmaildir--cur (nnmaildir--srvgrp-dir (nnmaildir--srv-dir nnmaildir--cur-server) gname))) - (curdir-mtime (nth 5 (file-attributes curdir))) + (curdir-mtime (file-attribute-modification-time (file-attributes curdir))) pgname flist always-marks never-marks old-marks dir all-marks marks ranges markdir read ls old-mmth new-mmth mtime existing missing deactivate-mark) @@ -1032,8 +1026,7 @@ This variable is set by `nnmaildir-request-article'.") (append (mapcar 'cdr nnmaildir-flag-mark-mapping) (mapcar 'intern (funcall ls dir nil "\\`[^.]" 'nosort)))) - new-mmth (nnmaildir--up2-1 (length all-marks)) - new-mmth (make-vector new-mmth 0) + new-mmth (make-hash-table :size (length all-marks)) old-mmth (nnmaildir--grp-mmth group)) (dolist (mark all-marks) (setq markdir (nnmaildir--subdir dir (symbol-name mark)) @@ -1047,7 +1040,7 @@ This variable is set by `nnmaildir-request-article'.") ;; a filename flag, get the later of the mtimes for markdir and ;; curdir, otherwise only the markdir counts. (setq mtime - (let ((markdir-mtime (nth 5 (file-attributes markdir)))) + (let ((markdir-mtime (file-attribute-modification-time (file-attributes markdir)))) (cond ((null (nnmaildir--mark-to-flag mark)) markdir-mtime) @@ -1060,8 +1053,8 @@ This variable is set by `nnmaildir-request-article'.") curdir-mtime) (t markdir-mtime)))) - (set (intern (symbol-name mark) new-mmth) mtime) - (when (equal mtime (symbol-value (intern-soft (symbol-name mark) old-mmth))) + (puthash mark mtime new-mmth) + (when (equal mtime (gethash mark old-mmth)) (setq ranges (assq mark old-marks)) (if ranges (setq ranges (cdr ranges))) (throw 'got-ranges nil)) @@ -1123,7 +1116,7 @@ This variable is set by `nnmaildir-request-article'.") (nnmaildir--prepare server nil) (catch 'return (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server)) - srv-dir dir groups) + srv-dir dir) (when (zerop (length gname)) (setf (nnmaildir--srv-error nnmaildir--cur-server) "Invalid (empty) group name") @@ -1137,8 +1130,8 @@ This variable is set by `nnmaildir-request-article'.") (concat "Invalid characters (null, tab, or /) in group name: " gname)) (throw 'return nil)) - (setq groups (nnmaildir--srv-groups nnmaildir--cur-server)) - (when (intern-soft gname groups) + (when (gethash + gname (nnmaildir--srv-groups nnmaildir--cur-server)) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Group already exists: " gname)) (throw 'return nil)) @@ -1183,7 +1176,7 @@ This variable is set by `nnmaildir-request-article'.") new-name)) (throw 'return nil)) (if (string-equal gname new-name) (throw 'return t)) - (when (intern-soft new-name + (when (gethash new-name (nnmaildir--srv-groups nnmaildir--cur-server)) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Group already exists: " new-name)) @@ -1196,16 +1189,18 @@ This variable is set by `nnmaildir-request-article'.") (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Error renaming link: " (prin1-to-string err))) (throw 'return nil))) + ;; FIXME: Why are we making copies of the group and the groups + ;; hashtable? Why not just set the group's new name, and puthash the + ;; group under that new name? (setq x (nnmaildir--srv-groups nnmaildir--cur-server) - groups (make-vector (length x) 0)) - (mapatoms (lambda (sym) - (unless (eq (symbol-value sym) group) - (set (intern (symbol-name sym) groups) - (symbol-value sym)))) + groups (gnus-make-hashtable (hash-table-size x))) + (maphash (lambda (gname g) + (unless (eq g group) + (puthash gname g groups))) x) (setq group (copy-sequence group)) (setf (nnmaildir--grp-name group) new-name) - (set (intern new-name groups) group) + (puthash new-name group groups) (setf (nnmaildir--srv-groups nnmaildir--cur-server) groups) t))) @@ -1228,7 +1223,7 @@ This variable is set by `nnmaildir-request-article'.") (throw 'return nil)) (if (eq group (nnmaildir--srv-curgrp nnmaildir--cur-server)) (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) nil)) - (unintern gname (nnmaildir--srv-groups nnmaildir--cur-server)) + (remhash gname (nnmaildir--srv-groups nnmaildir--cur-server)) (if (not force) (progn (setq grp-dir (directory-file-name grp-dir)) @@ -1329,10 +1324,9 @@ This variable is set by `nnmaildir-request-article'.") article (nnmaildir--mlist-art list num-msgid)) (if article (setq num-msgid (nnmaildir--art-num article)) (catch 'found - (mapatoms - (lambda (group-sym) - (setq group (symbol-value group-sym) - list (nnmaildir--grp-mlist group) + (maphash + (lambda (_gname group) + (setq list (nnmaildir--grp-mlist group) article (nnmaildir--mlist-art list num-msgid)) (when article (setq num-msgid (nnmaildir--art-num article)) @@ -1398,7 +1392,8 @@ This variable is set by `nnmaildir-request-article'.") (with-current-buffer buffer (write-region (point-min) (point-max) tmpfile nil 'no-message nil 'excl)) - (unix-sync) ;; no fsync :( + (when (fboundp 'unix-sync) + (unix-sync)) ;; no fsync :( (rename-file tmpfile (concat (nnmaildir--cur dir) file suffix) 'replace) t))) @@ -1464,9 +1459,7 @@ This variable is set by `nnmaildir-request-article'.") (unless (string-equal nnmaildir--delivery-time file) (setq nnmaildir--delivery-time file nnmaildir--delivery-count 0)) - (when (and (consp (cdr time)) - (consp (cddr time))) - (setq file (concat file "M" (number-to-string (caddr time))))) + (setq file (concat file (format-time-string "M%6N" time))) (setq file (concat file nnmaildir--delivery-pid) file (concat file "Q" (number-to-string nnmaildir--delivery-count)) file (concat file "." (nnmaildir--system-name)) @@ -1494,7 +1487,7 @@ This variable is set by `nnmaildir-request-article'.") 'excl) (when (fboundp 'unix-sync) (unix-sync)))) ;; no fsync :( - (nnheader-cancel-timer 24h) + (cancel-timer 24h) (condition-case err (add-name-to-file tmpfile curfile) (error @@ -1521,7 +1514,7 @@ This variable is set by `nnmaildir-request-article'.") (setq groups (nnmaildir--srv-groups nnmaildir--cur-server) ga (car group-art) group-art (cdr group-art) gname (car ga)) - (or (intern-soft gname groups) + (or (gethash gname groups) (nnmaildir-request-create-group gname) (throw 'return nil)) ;; not that nnmail bothers to check :( (unless (nnmaildir-request-accept-article gname) @@ -1538,7 +1531,7 @@ This variable is set by `nnmaildir-request-article'.") (mapcar (lambda (ga) (setq gname (car ga)) - (and (or (intern-soft gname groups) + (and (or (gethash gname groups) (nnmaildir-request-create-group gname)) (nnmaildir-request-accept-article gname) ga)) @@ -1552,7 +1545,7 @@ This variable is set by `nnmaildir-request-article'.") (defun nnmaildir-request-expire-articles (ranges &optional gname server force) (let ((no-force (not force)) (group (nnmaildir--prepare server gname)) - pgname time boundary bound-iter high low target dir nlist + pgname time boundary high low target dir nlist didnt nnmaildir--file nnmaildir-article-file-name deactivate-mark) (catch 'return @@ -1576,14 +1569,7 @@ This variable is set by `nnmaildir-request-article'.") (when no-force (unless (integerp time) ;; handle 'never (throw 'return (gnus-uncompress-range ranges))) - (setq boundary (current-time) - high (- (car boundary) (/ time 65536)) - low (- (cadr boundary) (% time 65536))) - (if (< low 0) - (setq low (+ low 65536) - high (1- high))) - (setcar (cdr boundary) low) - (setcar boundary high)) + (setq boundary (time-since time))) (setq dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir gname) dir (nnmaildir--cur dir) @@ -1601,15 +1587,8 @@ This variable is set by `nnmaildir-request-article'.") ((null time) (nnmaildir--expired-article group article)) ((and no-force - (progn - (setq time (nth 5 time) - bound-iter boundary) - (while (and bound-iter time - (= (car bound-iter) (car time))) - (setq bound-iter (cdr bound-iter) - time (cdr time))) - (and bound-iter time - (car-less-than-car bound-iter time)))) + (time-less-p boundary + (file-attribute-modification-time time))) (setq didnt (cons (nnmaildir--art-num article) didnt))) (t (setq nnmaildir-article-file-name nnmaildir--file @@ -1732,7 +1711,7 @@ This variable is set by `nnmaildir-request-article'.") (setq ranges (car action) todo-marks (caddr action)) (dolist (mark todo-marks) - (pushnew mark all-marks :test #'equal)) + (cl-pushnew mark all-marks :test #'equal)) (if (numberp (cdr ranges)) (setq ranges (list ranges))) (nnmaildir--nlist-iterate nlist ranges (cond ((eq 'del (cadr action)) del-action) @@ -1762,39 +1741,38 @@ This variable is set by `nnmaildir-request-article'.") (lambda (dir) (cons dir (funcall ls dir nil "\\`[^.]" 'nosort))) dirs) - files (funcall ls msgdir nil "\\`[^.]" 'nosort) - flist (nnmaildir--up2-1 (length files)) - flist (make-vector flist 0)) + files (funcall ls msgdir nil "\\`[^.]" 'nosort)) (save-match-data (dolist (file files) (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file) - (intern (match-string 1 file) flist))) + (push (match-string 1 file) flist))) (dolist (dir dirs) (setq files (cdr dir) dir (file-name-as-directory (car dir))) (dolist (file files) - (unless (or (intern-soft file flist) (string= file ":")) + (unless (or (member file flist) (string= file ":")) (setq file (concat dir file)) (delete-file file)))) t))) (defun nnmaildir-close-server (&optional server) - (defvar flist) (defvar ls) (defvar dirs) (defvar dir) - (defvar files) (defvar file) (defvar x) - (let (flist ls dirs dir files file x) - (nnmaildir--prepare server nil) - (when nnmaildir--cur-server - (setq server nnmaildir--cur-server - nnmaildir--cur-server nil) - (unintern (nnmaildir--srv-address server) nnmaildir--servers))) + "Close SERVER, or the current maildir server." + (when (nnmaildir--prepare server nil) + (setq server nnmaildir--cur-server + nnmaildir--cur-server nil) + + ;; This slightly obscure invocation of `alist-get' removes SERVER from + ;; `nnmaildir-servers'. + (setf (alist-get (nnmaildir--srv-address server) + nnmaildir--servers server 'remove #'equal) + server)) t) (defun nnmaildir-request-close () - (let (servers buffer) - (mapatoms (lambda (server) - (setq servers (cons (symbol-name server) servers))) - nnmaildir--servers) - (mapc 'nnmaildir-close-server servers) + (let ((servers + (mapcar #'car nnmaildir--servers)) + buffer) + (mapc #'nnmaildir-close-server servers) (setq buffer (get-buffer " *nnmaildir work*")) (if buffer (kill-buffer buffer)) (setq buffer (get-buffer " *nnmaildir nov*")) diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el index 31c84bdc794..53275e19640 100644 --- a/lisp/gnus/nnmairix.el +++ b/lisp/gnus/nnmairix.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: David Engster <dengste@eml.cc> +;; Author: David Engster <deng@randomsample.de> ;; Keywords: mail searching ;; Old-Version: 0.6 @@ -134,8 +134,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) ;For (pop (cdr ogroup)). - (require 'nnoo) (require 'gnus-group) (require 'gnus-sum) @@ -1421,12 +1419,12 @@ TYPE is either 'nov or 'headers." (setq cur (nnheader-parse-nov)) (when corr (setq article (+ (mail-header-number cur) numc)) - (mail-header-set-number cur article)) + (setf (mail-header-number cur) article)) (setq xref (mail-header-xref cur)) (when (and (stringp xref) (string-match (format "[ \t]%s:[0-9]+" backendgroup) xref)) (setq xref (replace-match (format " %s:%d" mairixgroup article) t nil xref)) - (mail-header-set-xref cur xref)) + (setf (mail-header-xref cur) xref)) (set-buffer buf) (nnheader-insert-nov cur) (set-buffer nntp-server-buffer) @@ -1776,7 +1774,7 @@ If VERSION is a string: must be contained in mairix version output." (setq versionstring (let* ((commandsplit (split-string nnmairix-mairix-command)) (args (append (list (car commandsplit)) - `(nil t nil) (cdr commandsplit) '("-V")))) + '(nil t nil) (cdr commandsplit) '("-V")))) (apply 'call-process args) (goto-char (point-min)) (re-search-forward "mairix.*") diff --git a/lisp/gnus/nnmbox.el b/lisp/gnus/nnmbox.el index 843a8df5af8..110f39a867f 100644 --- a/lisp/gnus/nnmbox.el +++ b/lisp/gnus/nnmbox.el @@ -33,7 +33,6 @@ (require 'nnmail) (require 'nnoo) (require 'gnus-range) -(eval-when-compile (require 'cl)) (nnoo-declare nnmbox) @@ -132,18 +131,15 @@ t))) (deffoo nnmbox-close-server (&optional server) - (when (and nnmbox-mbox-buffer - (buffer-name nnmbox-mbox-buffer)) + (when (buffer-live-p nnmbox-mbox-buffer) (kill-buffer nnmbox-mbox-buffer)) (nnoo-close-server 'nnmbox server) t) (deffoo nnmbox-server-opened (&optional server) (and (nnoo-current-server-p 'nnmbox server) - nnmbox-mbox-buffer - (buffer-name nnmbox-mbox-buffer) - nntp-server-buffer - (buffer-name nntp-server-buffer))) + (buffer-live-p nnmbox-mbox-buffer) + (buffer-live-p nntp-server-buffer))) (deffoo nnmbox-request-article (article &optional newsgroup server buffer) (nnmbox-possibly-change-newsgroup newsgroup server) @@ -464,8 +460,7 @@ (when (and server (not (nnmbox-server-opened server))) (nnmbox-open-server server)) - (when (or (not nnmbox-mbox-buffer) - (not (buffer-name nnmbox-mbox-buffer))) + (unless (buffer-live-p nnmbox-mbox-buffer) (nnmbox-read-mbox)) (when (not nnmbox-group-alist) (nnmail-activate 'nnmbox)) @@ -623,8 +618,7 @@ (defun nnmbox-read-mbox () (nnmail-activate 'nnmbox) (nnmbox-create-mbox) - (if (and nnmbox-mbox-buffer - (buffer-name nnmbox-mbox-buffer) + (if (and (buffer-live-p nnmbox-mbox-buffer) (with-current-buffer nnmbox-mbox-buffer (= (buffer-size) (nnheader-file-size nnmbox-mbox-file)))) () diff --git a/lisp/gnus/nnmh.el b/lisp/gnus/nnmh.el index a9cc1505184..f4b36dc007f 100644 --- a/lisp/gnus/nnmh.el +++ b/lisp/gnus/nnmh.el @@ -33,7 +33,6 @@ (require 'nnmail) (require 'gnus-start) (require 'nnoo) -(eval-when-compile (require 'cl)) (nnoo-declare nnmh) @@ -211,8 +210,10 @@ as unread by Gnus.") min rdir num subdirectoriesp file) ;; Recurse down directories. (setq subdirectoriesp - ;; nth 1 of file-attributes always 1 on MS Windows :( - (/= (nth 1 (file-attributes (file-truename dir))) 2)) + ;; link number always 1 on MS Windows :( + (/= (file-attribute-link-number + (file-attributes (file-truename dir))) + 2)) (dolist (rdir files) (if (or (not subdirectoriesp) (file-regular-p rdir)) @@ -242,12 +243,11 @@ as unread by Gnus.") (file-truename (file-name-as-directory (expand-file-name nnmh-toplev)))) dir) - (string-to-multibyte ;Why? Isn't it multibyte already? - (encode-coding-string - (nnheader-replace-chars-in-string - (substring dir (match-end 0)) - ?/ ?.) - nnmail-pathname-coding-system))) + (encode-coding-string + (nnheader-replace-chars-in-string + (substring dir (match-end 0)) + ?/ ?.) + nnmail-pathname-coding-system)) (or max 0) (or min 1)))))) t) @@ -265,7 +265,8 @@ as unread by Gnus.") (while (and articles is-old) (setq article (concat dir (int-to-string (car articles)))) - (when (setq mod-time (nth 5 (file-attributes article))) + (when (setq mod-time (file-attribute-modification-time + (file-attributes article))) (if (and (nnmh-deletable-article-p newsgroup (car articles)) (setq is-old (nnmail-expired-article-p newsgroup mod-time force))) @@ -536,8 +537,8 @@ as unread by Gnus.") art) (while (setq art (pop arts)) (when (not (equal - (nth 5 (file-attributes - (concat dir (int-to-string (car art))))) + (file-attribute-modification-time + (file-attributes (concat dir (int-to-string (car art))))) (cdr art))) (setq articles (delq art articles)) (push (car art) new)))) @@ -548,8 +549,9 @@ as unread by Gnus.") (mapcar (lambda (art) (cons art - (nth 5 (file-attributes - (concat dir (int-to-string art)))))) + (file-attribute-modification-time + (file-attributes + (concat dir (int-to-string art)))))) new))) ;; Make Gnus mark all new articles as unread. (when new diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index fc68f8b5130..89c8b23b65a 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1995-2019 Free Software Foundation, Inc. -;; Authors: Didier Verna <didier@xemacs.org> (adding compaction) +;; Authors: Didier Verna <didier@didierverna.net> (adding compaction) ;; Simon Josefsson <simon@josefsson.org> ;; Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> @@ -35,7 +35,6 @@ (require 'nnheader) (require 'nnmail) (require 'nnoo) -(eval-when-compile (require 'cl)) ;; FIXME first is unused in this file. (autoload 'gnus-article-unpropagatable-p "gnus-sum") @@ -260,7 +259,7 @@ non-nil.") (t (nnheader-re-read-dir nnml-current-directory) (nnmail-activate 'nnml) - (let ((active (nth 1 (assoc group nnml-group-alist)))) + (let ((active (nth 1 (assoc-string group nnml-group-alist)))) (if (not active) (nnheader-report 'nnml "No such group: %s" decoded) (nnheader-report 'nnml "Selected group %s" decoded) @@ -296,7 +295,7 @@ non-nil.") (nnheader-report 'nnml "%s is a file" (directory-file-name (nnml-group-pathname group nil server)))) - ((assoc group nnml-group-alist) + ((assoc-string group nnml-group-alist) t) (t (let (active) @@ -345,7 +344,8 @@ non-nil.") (while (and articles is-old) (if (and (setq article (nnml-article-to-file (setq number (pop articles)))) - (setq mod-time (nth 5 (file-attributes article))) + (setq mod-time (file-attribute-modification-time + (file-attributes article))) (nnml-deletable-article-p group number) (setq is-old (nnmail-expired-article-p group mod-time force nnml-inhibit-expiry))) @@ -379,7 +379,7 @@ non-nil.") (nnml-nov-delete-article group number)) (push number rest))) (push number rest))) - (let ((active (nth 1 (assoc group nnml-group-alist)))) + (let ((active (nth 1 (assoc-string group nnml-group-alist)))) (when active (setcar active (or (and active-articles (apply 'min active-articles)) @@ -520,7 +520,7 @@ non-nil.") (nnheader-report 'nnml "No such directory: %s/" file)) ;; Remove the group from all structures. (setq nnml-group-alist - (delq (assoc group nnml-group-alist) nnml-group-alist) + (delq (assoc-string group nnml-group-alist) nnml-group-alist) nnml-current-group nil nnml-current-directory nil) ;; Save the active file. @@ -549,7 +549,7 @@ non-nil.") (when (<= (length (directory-files old-dir)) 2) (ignore-errors (delete-directory old-dir))) ;; That went ok, so we change the internal structures. - (let ((entry (assoc group nnml-group-alist))) + (let ((entry (assoc-string group nnml-group-alist))) (when entry (setcar entry new-name)) (setq nnml-current-directory nil @@ -597,7 +597,7 @@ non-nil.") (when (setq path (nnml-article-to-file article)) (when (file-writable-p path) (or (not nnmail-keep-last-article) - (not (eq (cdr (nth 1 (assoc group nnml-group-alist))) + (not (eq (cdr (nth 1 (assoc-string group nnml-group-alist))) article))))))) ;; Find an article number in the current group given the Message-ID. @@ -742,7 +742,7 @@ article number. This function is called narrowed to an article." "Compute the next article number in GROUP on SERVER." (let* ((encoded (if nnmail-group-names-not-encoded-p (nnml-encoded-group-name group server))) - (active (cadr (assoc (or encoded group) nnml-group-alist)))) + (active (cadr (assoc-string (or encoded group) nnml-group-alist)))) ;; The group wasn't known to nnml, so we just create an active ;; entry for it. (unless active @@ -772,7 +772,7 @@ article number. This function is called narrowed to an article." (defun nnml-save-incremental-nov () (save-excursion (while nnml-incremental-nov-buffer-alist - (when (buffer-name (cdar nnml-incremental-nov-buffer-alist)) + (when (buffer-live-p (cdar nnml-incremental-nov-buffer-alist)) (set-buffer (cdar nnml-incremental-nov-buffer-alist)) (when (buffer-modified-p) (nnmail-write-region (point-min) (point-max) @@ -783,7 +783,7 @@ article number. This function is called narrowed to an article." (cdr nnml-incremental-nov-buffer-alist))))) (defun nnml-open-incremental-nov (group) - (or (cdr (assoc group nnml-incremental-nov-buffer-alist)) + (or (cdr (assoc-string group nnml-incremental-nov-buffer-alist)) (let ((buffer (nnml-get-nov-buffer group t))) (push (cons group buffer) nnml-incremental-nov-buffer-alist) buffer))) @@ -792,14 +792,14 @@ article number. This function is called narrowed to an article." "Add a nov line for the GROUP nov headers, incrementally." (with-current-buffer (nnml-open-incremental-nov group) (goto-char (point-max)) - (mail-header-set-number headers article) + (setf (mail-header-number headers) article) (nnheader-insert-nov headers))) (defun nnml-add-nov (group article headers) "Add a nov line for the GROUP base." (with-current-buffer (nnml-open-nov group) (goto-char (point-max)) - (mail-header-set-number headers article) + (setf (mail-header-number headers) article) (nnheader-insert-nov headers))) (defsubst nnml-header-value () @@ -816,8 +816,8 @@ article number. This function is called narrowed to an article." (1- (point)) (point-max)))) (let ((headers (nnheader-parse-naked-head))) - (mail-header-set-chars headers chars) - (mail-header-set-number headers number) + (setf (mail-header-chars headers) chars) + (setf (mail-header-number headers) number) headers)))) (defun nnml-get-nov-buffer (group &optional incrementalp) @@ -838,9 +838,7 @@ article number. This function is called narrowed to an article." buffer)) (defun nnml-open-nov (group) - (or (let ((buffer (cdr (assoc group nnml-nov-buffer-alist)))) - (and (buffer-name buffer) - buffer)) + (or (gnus-buffer-live-p (cdr (assoc group nnml-nov-buffer-alist))) (let ((buffer (nnml-get-nov-buffer group))) (push (cons group buffer) nnml-nov-buffer-alist) buffer))) @@ -848,7 +846,7 @@ article number. This function is called narrowed to an article." (defun nnml-save-nov () (save-excursion (while nnml-nov-buffer-alist - (when (buffer-name (cdar nnml-nov-buffer-alist)) + (when (buffer-live-p (cdar nnml-nov-buffer-alist)) (set-buffer (cdar nnml-nov-buffer-alist)) (when (buffer-modified-p) (nnmail-write-region (point-min) (point-max) diff --git a/lisp/gnus/nnoo.el b/lisp/gnus/nnoo.el index 143c69d5363..c65668a7199 100644 --- a/lisp/gnus/nnoo.el +++ b/lisp/gnus/nnoo.el @@ -25,7 +25,7 @@ ;;; Code: (require 'nnheader) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defvar nnoo-definition-alist nil) (defvar nnoo-state-alist nil) @@ -142,7 +142,7 @@ (if (numberp (nth i (cdr m))) (push `(nth ,i args) margs) (push (nth i (cdr m)) margs)) - (incf i)) + (cl-incf i)) (eval `(deffoo ,(nnoo-symbol backend (nnoo-rest-symbol (car m))) (&rest args) (nnoo-parent-function ',backend ',(car m) @@ -269,8 +269,7 @@ (defun nnoo-server-opened (backend server) (and (nnoo-current-server-p backend server) - nntp-server-buffer - (buffer-name nntp-server-buffer))) + (buffer-live-p nntp-server-buffer))) (defmacro nnoo-define-basics (backend) "Define `close-server', `server-opened' and `status-message'." diff --git a/lisp/gnus/nnregistry.el b/lisp/gnus/nnregistry.el index 4bc74ce5b9a..6dcdac54623 100644 --- a/lisp/gnus/nnregistry.el +++ b/lisp/gnus/nnregistry.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2010-2019 Free Software Foundation, Inc. -;; Authors: Ludovic Courtès <ludo@gnu.org> +;; Author: Ludovic Courtès <ludo@gnu.org> ;; Keywords: news, mail ;; This file is part of GNU Emacs. diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index 01cf7c08c98..0bfecb28e09 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'nnoo) @@ -49,7 +49,7 @@ "Where nnrss will save its files.") (defvoo nnrss-ignore-article-fields '(slash:comments) - "*List of fields that should be ignored when comparing RSS articles. + "List of fields that should be ignored when comparing RSS articles. Some RSS feeds update article fields during their lives, e.g. to indicate the number of comments or the number of times the articles have been seen. However, if there is a difference @@ -340,10 +340,10 @@ for decoding when the cdr that the data specify is not available.") (let (elem) ;; There may be two or more entries in `nnrss-group-alist' since ;; this function didn't delete them formerly. - (while (setq elem (assoc group nnrss-group-alist)) + (while (setq elem (assoc-string group nnrss-group-alist)) (setq nnrss-group-alist (delq elem nnrss-group-alist)))) (setq nnrss-server-data - (delq (assoc group nnrss-server-data) nnrss-server-data)) + (delq (assoc-string group nnrss-server-data) nnrss-server-data)) (nnrss-save-server-data server) (ignore-errors (let ((file-name-coding-system nnmail-pathname-coding-system)) @@ -355,8 +355,8 @@ for decoding when the cdr that the data specify is not available.") (with-current-buffer nntp-server-buffer (erase-buffer) (dolist (elem nnrss-group-alist) - (if (third elem) - (insert (car elem) "\t" (third elem) "\n")))) + (if (nth 2 elem) + (insert (car elem) "\t" (nth 2 elem) "\n")))) t) (deffoo nnrss-retrieve-groups (groups &optional server) @@ -367,7 +367,7 @@ for decoding when the cdr that the data specify is not available.") (with-current-buffer nntp-server-buffer (erase-buffer) (dolist (group groups) - (let ((elem (assoc (gnus-group-decoded-name group) nnrss-server-data))) + (let ((elem (assoc-string (gnus-group-decoded-name group) nnrss-server-data))) (insert (format "%S %s 1 y\n" group (or (cadr elem) 0))))) 'active)) @@ -454,7 +454,7 @@ which RSS 2.0 allows." (cond ((null date)) ; do nothing for this case ;; if the date is just digits (unix time stamp): ((string-match "^[0-9]+$" date) - (setq given (seconds-to-time (string-to-number date)))) + (setq given (encode-time (string-to-number date)))) ;; RFC 822 ((string-match " [0-9]+ " date) (setq vector (timezone-parse-date date) @@ -539,7 +539,7 @@ which RSS 2.0 allows." (if (hash-table-p nnrss-group-hashtb) (clrhash nnrss-group-hashtb) (setq nnrss-group-hashtb (make-hash-table :test 'equal))) - (let ((pair (assoc group nnrss-server-data))) + (let ((pair (assoc-string group nnrss-server-data))) (setq nnrss-group-max (or (cadr pair) 0)) (setq nnrss-group-min (+ nnrss-group-max 1))) (let ((file (nnrss-make-filename group server)) @@ -625,7 +625,7 @@ which RSS 2.0 allows." ;;; Snarf functions (defun nnrss-make-hash-index (item) (gnus-message 9 "nnrss: Making hash index of %s" (gnus-prin1-to-string item)) - (setq item (gnus-remove-if + (setq item (seq-remove (lambda (field) (when (listp field) (memq (car field) nnrss-ignore-article-fields))) @@ -644,8 +644,8 @@ which RSS 2.0 allows." (concat group ".xml")) nnrss-directory)))) (setq xml (nnrss-fetch file t)) - (setq url (or (nth 2 (assoc group nnrss-server-data)) - (second (assoc group nnrss-group-alist)))) + (setq url (or (nth 2 (assoc-string group nnrss-server-data)) + (cadr (assoc-string group nnrss-group-alist)))) (unless url (setq url (cdr @@ -653,7 +653,7 @@ which RSS 2.0 allows." (nnrss-discover-feed (read-string (format "URL to search for %s: " group) "http://"))))) - (let ((pair (assoc group nnrss-server-data))) + (let ((pair (assoc-string group nnrss-server-data))) (if pair (setcdr (cdr pair) (list url)) (push (list group nnrss-group-max url) nnrss-server-data))) @@ -691,7 +691,7 @@ which RSS 2.0 allows." (if (and len (integerp (setq len (string-to-number len)))) ;; actually already in `ls-lisp-format-file-size' but ;; probably not worth to require it for one function - (do ((size (/ len 1.0) (/ size 1024.0)) + (cl-do ((size (/ len 1.0) (/ size 1024.0)) (post-fixes (list "" "k" "M" "G" "T" "P" "E") (cdr post-fixes))) ((< size 1024) @@ -705,7 +705,7 @@ which RSS 2.0 allows." (setq enclosure (list url name len type)))) (push (list - (incf nnrss-group-max) + (cl-incf nnrss-group-max) (current-time) url (and subject (nnrss-mime-encode-string subject)) @@ -721,7 +721,7 @@ which RSS 2.0 allows." (setq extra nil)) (when changed (nnrss-save-group-data group server) - (let ((pair (assoc group nnrss-server-data))) + (let ((pair (assoc-string group nnrss-server-data))) (if pair (setcar (cdr pair) nnrss-group-max) (push (list group nnrss-group-max) nnrss-server-data))) @@ -792,7 +792,7 @@ It is useful when `(setq nnrss-use-local t)'." (insert "RSSDIR='" (expand-file-name nnrss-directory) "'\n") (dolist (elem nnrss-server-data) (let ((url (or (nth 2 elem) - (second (assoc (car elem) nnrss-group-alist))))) + (cadr (assoc-string (car elem) nnrss-group-alist))))) (insert "$WGET -q -O \"$RSSDIR\"/'" (nnrss-translate-file-chars (concat (car elem) ".xml")) "' '" url "'\n")))) diff --git a/lisp/gnus/nnspool.el b/lisp/gnus/nnspool.el index 30bc466ad43..767631c6859 100644 --- a/lisp/gnus/nnspool.el +++ b/lisp/gnus/nnspool.el @@ -29,17 +29,17 @@ (require 'nnheader) (require 'nntp) (require 'nnoo) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; Probably this entire thing should be obsolete. ;; It's only used to init nnspool-spool-directory, so why not just ;; set that variable's default directly? (eval-and-compile + (defvaralias 'news-path 'news-directory) (defvar news-directory (if (file-exists-p "/usr/spool/news/") "/usr/spool/news/" "/var/spool/news/") - "The root directory below which all news files are stored.") - (defvaralias 'news-path 'news-directory)) + "The root directory below which all news files are stored.")) ;; Ditto re obsolescence. (defvar news-inews-program @@ -105,7 +105,7 @@ If nil, nnspool will load the entire file into a buffer and process it there.") (defvoo nnspool-rejected-article-hook nil - "*A hook that will be run when an article has been rejected by the server.") + "A hook that will be run when an article has been rejected by the server.") (defvoo nnspool-file-coding-system nnheader-file-coding-system "Coding system for nnspool.") @@ -172,7 +172,7 @@ there.") (delete-region (point) (point-max))) (and do-message - (zerop (% (incf count) 20)) + (zerop (% (cl-incf count) 20)) (nnheader-message 5 "nnspool: Receiving headers... %d%%" (floor (* count 100.0) number)))) @@ -305,25 +305,18 @@ there.") (while (and (not (looking-at "\\([^ ]+\\) +\\([0-9]+\\)[0-9][0-9][0-9] ")) (zerop (forward-line -1)))) - ;; We require nnheader which requires gnus-util. - (let ((seconds (float-time (date-to-time date))) + (let ((seconds (encode-time (date-to-time date) 'integer)) groups) ;; Go through lines and add the latest groups to a list. (while (and (looking-at "\\([^ ]+\\) +[0-9]+ ") (progn - ;; We insert a .0 to make the list reader - ;; interpret the number as a float. It is far - ;; too big to be stored in a lisp integer. - (goto-char (1- (match-end 0))) - (insert ".0") - (> (progn - (goto-char (match-end 1)) - (read (current-buffer))) - seconds)) - (push (buffer-substring - (match-beginning 1) (match-end 1)) - groups) - (zerop (forward-line -1)))) + (goto-char (match-end 1)) + (< seconds (read (current-buffer)))) + (progn + (push (buffer-substring + (match-beginning 1) (match-end 1)) + groups) + (zerop (forward-line -1))))) (erase-buffer) (dolist (group groups) (insert group " 0 0 y\n"))) diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index cbd0e85e694..49aa6ab1446 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -1,4 +1,4 @@ -;;; nntp.el --- nntp access for Gnus +;;; nntp.el --- nntp access for Gnus -*- lexical-binding:t -*- ;; Copyright (C) 1987-1990, 1992-1998, 2000-2019 Free Software ;; Foundation, Inc. @@ -33,7 +33,7 @@ (nnoo-declare nntp) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (autoload 'auth-source-search "auth-source") @@ -48,19 +48,21 @@ "Port number on the physical nntp server.") (defvoo nntp-server-opened-hook '(nntp-send-mode-reader) - "*Hook used for sending commands to the server at startup. + "Hook used for sending commands to the server at startup. The default value is `nntp-send-mode-reader', which makes an innd server spawn an nnrpd server.") -(defvoo nntp-authinfo-function 'nntp-send-authinfo +(defvoo nntp-authinfo-function #'nntp-send-authinfo "Function used to send AUTHINFO to the server. It is called with no parameters.") +(defvar nntp-server-list-active-group) + (defvoo nntp-server-action-alist - '(("nntpd 1\\.5\\.11t" - (remove-hook 'nntp-server-opened-hook 'nntp-send-mode-reader)) - ("NNRP server Netscape" - (setq nntp-server-list-active-group nil))) + `(("nntpd 1\\.5\\.11t" + ,(lambda () (remove-hook 'nntp-server-opened-hook #'nntp-send-mode-reader))) + ("NNRP server Netscape" + ,(lambda () (setq nntp-server-list-active-group nil)))) "Alist of regexps to match on server types and actions to be taken. For instance, if you want Gnus to beep every time you connect to innd, you could say something like: @@ -94,7 +96,7 @@ For indirect connections: - `nntp-open-via-telnet-and-telnet'") (defvoo nntp-never-echoes-commands nil - "*Non-nil means the nntp server never echoes commands. + "Non-nil means the nntp server never echoes commands. It is reported that some nntps server doesn't echo commands. So, you may want to set this to non-nil in the method for such a server setting `nntp-open-connection-function' to `nntp-open-ssl-stream' for example. @@ -103,102 +105,102 @@ variable overrides the nil value of this variable.") (defvoo nntp-open-connection-functions-never-echo-commands '(nntp-open-network-stream) - "*List of functions that never echo commands. + "List of functions that never echo commands. Add or set a function which you set to `nntp-open-connection-function' to this list if it does not echo commands. Note that a non-nil value of the `nntp-never-echoes-commands' variable overrides this variable.") (defvoo nntp-pre-command nil - "*Pre-command to use with the various nntp-open-via-* methods. + "Pre-command to use with the various nntp-open-via-* methods. This is where you would put \"runsocks\" or stuff like that.") (defvoo nntp-telnet-command "telnet" - "*Telnet command used to connect to the nntp server. + "Telnet command used to connect to the nntp server. This command is used by the methods `nntp-open-telnet-stream', `nntp-open-via-rlogin-and-telnet' and `nntp-open-via-telnet-and-telnet'.") (defvoo nntp-telnet-switches '("-8") - "*Switches given to the telnet command `nntp-telnet-command'.") + "Switches given to the telnet command `nntp-telnet-command'.") (defvoo nntp-end-of-line "\r\n" - "*String to use on the end of lines when talking to the NNTP server. + "String to use on the end of lines when talking to the NNTP server. This is \"\\r\\n\" by default, but should be \"\\n\" when using an indirect connection method (nntp-open-via-*).") (defvoo nntp-via-rlogin-command "rsh" - "*Rlogin command used to connect to an intermediate host. + "Rlogin command used to connect to an intermediate host. This command is used by the methods `nntp-open-via-rlogin-and-telnet' and `nntp-open-via-rlogin-and-netcat'. The default is \"rsh\", but \"ssh\" is a popular alternative.") (defvoo nntp-via-rlogin-command-switches nil - "*Switches given to the rlogin command `nntp-via-rlogin-command'. + "Switches given to the rlogin command `nntp-via-rlogin-command'. If you use \"ssh\" for `nntp-via-rlogin-command', you may set this to \(\"-C\") in order to compress all data connections, otherwise set this to \(\"-t\" \"-e\" \"none\") or (\"-C\" \"-t\" \"-e\" \"none\") if the telnet command requires a pseudo-tty allocation on an intermediate host.") (defvoo nntp-via-telnet-command "telnet" - "*Telnet command used to connect to an intermediate host. + "Telnet command used to connect to an intermediate host. This command is used by the `nntp-open-via-telnet-and-telnet' method.") (defvoo nntp-via-telnet-switches '("-8") - "*Switches given to the telnet command `nntp-via-telnet-command'.") + "Switches given to the telnet command `nntp-via-telnet-command'.") (defvoo nntp-netcat-command "nc" - "*Netcat command used to connect to the nntp server. + "Netcat command used to connect to the nntp server. This command is used by the `nntp-open-netcat-stream' and `nntp-open-via-rlogin-and-netcat' methods.") (defvoo nntp-netcat-switches nil - "*Switches given to the netcat command `nntp-netcat-command'.") + "Switches given to the netcat command `nntp-netcat-command'.") (defvoo nntp-via-user-name nil - "*User name to log in on an intermediate host with. + "User name to log in on an intermediate host with. This variable is used by the various nntp-open-via-* methods.") (defvoo nntp-via-user-password nil - "*Password to use to log in on an intermediate host with. + "Password to use to log in on an intermediate host with. This variable is used by the `nntp-open-via-telnet-and-telnet' method.") (defvoo nntp-via-address nil - "*Address of an intermediate host to connect to. + "Address of an intermediate host to connect to. This variable is used by the various nntp-open-via-* methods.") (defvoo nntp-via-envuser nil - "*Whether both telnet client and server support the ENVIRON option. + "Whether both telnet client and server support the ENVIRON option. If non-nil, there will be no prompt for a login name.") (defvoo nntp-via-shell-prompt "bash\\|[$>] *\r?$" - "*Regular expression to match the shell prompt on an intermediate host. + "Regular expression to match the shell prompt on an intermediate host. This variable is used by the `nntp-open-via-telnet-and-telnet' method.") (defvoo nntp-large-newsgroup 50 - "*The number of articles which indicates a large newsgroup. + "The number of articles which indicates a large newsgroup. If the number of articles is greater than the value, verbose messages will be shown to indicate the current status.") (defvoo nntp-maximum-request 400 - "*The maximum number of the requests sent to the NNTP server at one time. + "The maximum number of the requests sent to the NNTP server at one time. If Emacs hangs up while retrieving headers, set the variable to a lower value.") (defvoo nntp-nov-is-evil nil - "*If non-nil, nntp will never attempt to use XOVER when talking to the server.") + "If non-nil, nntp will never attempt to use XOVER when talking to the server.") (defvoo nntp-xover-commands '("XOVER" "XOVERVIEW") - "*List of strings that are used as commands to fetch NOV lines from a server. + "List of strings that are used as commands to fetch NOV lines from a server. The strings are tried in turn until a positive response is gotten. If none of the commands are successful, nntp will just grab headers one by one.") (defvoo nntp-nov-gap 5 - "*Maximum allowed gap between two articles. + "Maximum allowed gap between two articles. If the gap between two consecutive articles is bigger than this variable, split the XOVER request into two requests.") (defvoo nntp-xref-number-is-evil nil - "*If non-nil, Gnus never trusts article numbers in the Xref header. + "If non-nil, Gnus never trusts article numbers in the Xref header. Some news servers, e.g., ones running Diablo, run multiple engines having the same articles but article numbers are not kept synchronized between them. If you connect to such a server, set this to a non-nil @@ -206,7 +208,7 @@ value, and Gnus never uses article numbers (that appear in the Xref header and vary by which engine is chosen) to refer to articles.") (defvoo nntp-prepare-server-hook nil - "*Hook run before a server is opened. + "Hook run before a server is opened. If can be used to set up a server remotely, for instance. Say you have an account at the machine \"other.machine\". This machine has access to an NNTP server that you can't access locally. You could @@ -216,7 +218,6 @@ server there that you can connect to. See also (defcustom nntp-authinfo-file "~/.authinfo" ".netrc-like file that holds nntp authinfo passwords." - :group 'nntp :type '(choice file (repeat :tag "Entries" @@ -237,11 +238,11 @@ server there that you can connect to. See also (defvoo nntp-connection-timeout nil - "*Number of seconds to wait before an nntp connection times out. + "Number of seconds to wait before an nntp connection times out. If this variable is nil, which is the default, no timers are set.") (defvoo nntp-prepare-post-hook nil - "*Hook run just before posting an article. It is supposed to be used + "Hook run just before posting an article. It is supposed to be used to insert Cancel-Lock headers.") (defvoo nntp-server-list-active-group 'try @@ -254,7 +255,6 @@ update their active files often, this can help.") (defvoo nntp-retrieval-in-progress nil) (defcustom nntp-record-commands nil "If non-nil, nntp will record all commands in the \"*nntp-log*\" buffer." - :group 'nntp :type 'boolean) (defvar nntp-have-messaged nil) @@ -289,9 +289,7 @@ update their active files often, this can help.") "A custom error condition used to report `Authentication Rejected' errors. Condition handlers that match just this condition ensure that the nntp backend doesn't catch this error.") -(put 'nntp-authinfo-rejected 'error-conditions '(error nntp-authinfo-rejected)) -(put 'nntp-authinfo-rejected 'error-message "Authorization Rejected") - +(define-error 'nntp-authinfo-rejected "Authorization Rejected") ;;; Internal functions. @@ -335,16 +333,14 @@ retried once before actually displaying the error report." (nnheader-report 'nntp args) - (apply 'error args))) + (apply #'error args))) (defmacro nntp-copy-to-buffer (buffer start end) "Copy string from unibyte current buffer to multibyte buffer." `(let ((string (buffer-substring ,start ,end))) (with-current-buffer ,buffer (erase-buffer) - (insert (if enable-multibyte-characters - (string-to-multibyte string) - string)) + (insert string) (goto-char (point-min)) nil))) @@ -402,7 +398,7 @@ retried once before actually displaying the error report." (erase-buffer))))) (defun nntp-kill-buffer (buffer) - (when (buffer-name buffer) + (when (buffer-live-p buffer) (let ((process (get-buffer-process buffer))) (when process (delete-process process))) @@ -440,7 +436,7 @@ retried once before actually displaying the error report." (when process (process-buffer process)))) -(defsubst nntp-retrieve-data (command address port buffer +(defsubst nntp-retrieve-data (command address _port buffer &optional wait-for callback decode) "Use COMMAND to retrieve data into BUFFER from PORT on ADDRESS." (let ((process (or (nntp-find-connection buffer) @@ -475,10 +471,10 @@ retried once before actually displaying the error report." (defsubst nntp-send-command (wait-for &rest strings) "Send STRINGS to server and wait until WAIT-FOR returns." - (when (and (not nnheader-callback-function) - (not nntp-inhibit-output)) + (when (not (or nnheader-callback-function + nntp-inhibit-output)) (nntp-erase-buffer nntp-server-buffer)) - (let* ((command (mapconcat 'identity strings " ")) + (let* ((command (mapconcat #'identity strings " ")) (process (nntp-find-connection nntp-server-buffer)) (buffer (and process (process-buffer process))) (pos (and buffer (with-current-buffer buffer (point))))) @@ -509,7 +505,7 @@ retried once before actually displaying the error report." (defun nntp-send-command-nodelete (wait-for &rest strings) "Send STRINGS to server and wait until WAIT-FOR returns." - (let* ((command (mapconcat 'identity strings " ")) + (let* ((command (mapconcat #'identity strings " ")) (process (nntp-find-connection nntp-server-buffer)) (buffer (and process (process-buffer process))) (pos (and buffer (with-current-buffer buffer (point))))) @@ -532,10 +528,10 @@ retried once before actually displaying the error report." (defun nntp-send-command-and-decode (wait-for &rest strings) "Send STRINGS to server and wait until WAIT-FOR returns." - (when (and (not nnheader-callback-function) - (not nntp-inhibit-output)) + (when (not (or nnheader-callback-function + nntp-inhibit-output)) (nntp-erase-buffer nntp-server-buffer)) - (let* ((command (mapconcat 'identity strings " ")) + (let* ((command (mapconcat #'identity strings " ")) (process (nntp-find-connection nntp-server-buffer)) (buffer (and process (process-buffer process))) (pos (and buffer (with-current-buffer buffer (point))))) @@ -559,13 +555,13 @@ retried once before actually displaying the error report." (defun nntp-send-buffer (wait-for) "Send the current buffer to server and wait until WAIT-FOR returns." - (when (and (not nnheader-callback-function) - (not nntp-inhibit-output)) + (when (not (or nnheader-callback-function + nntp-inhibit-output)) (nntp-erase-buffer (nntp-find-connection-buffer nntp-server-buffer))) (nntp-encode-text) ;; Make sure we did not forget to encode some of the content. - (assert (save-excursion (goto-char (point-min)) + (cl-assert (save-excursion (goto-char (point-min)) (not (re-search-forward "[^\000-\377]" nil t)))) (mm-disable-multibyte) (process-send-region (nntp-find-connection nntp-server-buffer) @@ -603,7 +599,7 @@ retried once before actually displaying the error report." (t nil))) -(defun nntp-with-open-group-function (-group -server -connectionless -bodyfun) +(defun nntp-with-open-group-function (group server connectionless bodyfun) "Protect against servers that don't like clients that keep idle connections opens. The problem being that these servers may either close a connection or simply ignore any further requests on a connection. Closed @@ -619,37 +615,37 @@ command whose response triggered the error." (while (catch 'nntp-with-open-group-error ;; Open the connection to the server ;; NOTE: Existing connections are NOT tested. - (nntp-possibly-change-group -group -server -connectionless) + (nntp-possibly-change-group group server connectionless) - (let ((-timer + (let ((timer (and nntp-connection-timeout (run-at-time nntp-connection-timeout nil (lambda () - (let* ((-process (nntp-find-connection + (let* ((process (nntp-find-connection nntp-server-buffer)) - (-buffer (and -process - (process-buffer -process)))) + (buffer (and process + (process-buffer process)))) ;; When I an able to identify the ;; connection to the server AND I've ;; received NO response for ;; nntp-connection-timeout seconds. - (when (and -buffer (eq 0 (buffer-size -buffer))) + (when (and buffer (eq 0 (buffer-size buffer))) ;; Close the connection. Take no ;; other action as the accept input ;; code will handle the closed ;; connection. - (nntp-kill-buffer -buffer)))))))) + (nntp-kill-buffer buffer)))))))) (unwind-protect (setq nntp-with-open-group-internal (condition-case nil - (funcall -bodyfun) + (funcall bodyfun) (quit (unless debug-on-quit (nntp-close-server)) (signal 'quit nil)))) - (when -timer - (nnheader-cancel-timer -timer))) + (when timer + (cancel-timer timer))) nil)) (setq nntp--report-1 nntp-report-n)) nntp-with-open-group-internal)) @@ -669,7 +665,8 @@ command whose response triggered the error." (not (eq connectionless nil))) (setq forms (cons connectionless forms) connectionless nil)) - `(nntp-with-open-group-function ,group ,server ,connectionless (lambda () ,@forms))) + `(nntp-with-open-group-function ,group ,server ,connectionless + (lambda () ,@forms))) (deffoo nntp-retrieve-headers (articles &optional group server fetch-old) "Retrieve the headers of ARTICLES." @@ -701,7 +698,7 @@ command whose response triggered the error." ;; `articles' is either a list of article numbers ;; or a list of article IDs. article)) - (incf count) + (cl-incf count) ;; Every 400 requests we have to read the stream in ;; order to avoid deadlocks. (when (or (null articles) ;All requests have been sent. @@ -713,7 +710,7 @@ command whose response triggered the error." ;; Count replies. (while (nntp-next-result-arrived-p) (setq last-point (point)) - (incf received)) + (cl-incf received)) (< received count)) ;; If number of headers is greater than 100, give ;; informative messages. @@ -786,7 +783,7 @@ command whose response triggered the error." "^[.]" "^[0-9]") nil t) - (incf received)) + (cl-incf received)) (setq last-point (point)) (< received count))) (nntp-accept-response)) @@ -851,7 +848,7 @@ command whose response triggered the error." (throw 'done nil)) ;; Send the command to the server. (nntp-send-command nil command (pop groups)) - (incf count) + (cl-incf count) ;; Every 400 requests we have to read the stream in ;; order to avoid deadlocks. (when (or (null groups) ;All requests have been sent. @@ -865,7 +862,7 @@ command whose response triggered the error." (goto-char last-point) ;; Count replies. (while (re-search-forward "^[0-9]" nil t) - (incf received)) + (cl-incf received)) (setq last-point (point)) (< received count))) (nntp-accept-response)))) @@ -923,7 +920,7 @@ command whose response triggered the error." (last-point (point-min)) (buf (nntp-find-connection-buffer nntp-server-buffer)) (nntp-inhibit-erase t) - (map (apply 'vector articles)) + (map (apply #'vector articles)) (point 1) article) (set-buffer buf) @@ -937,7 +934,7 @@ command whose response triggered the error." ;; `articles' is either a list of article numbers ;; or a list of article IDs. article)) - (incf count) + (cl-incf count) ;; Every 400 requests we have to read the stream in ;; order to avoid deadlocks. (when (or (null articles) ;All requests have been sent. @@ -950,7 +947,7 @@ command whose response triggered the error." (while (nntp-next-result-arrived-p) (aset map received (cons (aref map received) (point))) (setq last-point (point)) - (incf received)) + (cl-incf received)) (< received count)) ;; If number of headers is greater than 100, give ;; informative messages. @@ -1004,7 +1001,7 @@ command whose response triggered the error." nil server (nntp-send-command "^\\.*\r?\n" "LISTGROUP" group))) -(deffoo nntp-request-article (article &optional group server buffer command) +(deffoo nntp-request-article (article &optional group server buffer _command) (nntp-with-open-group group server (when (nntp-send-command-and-decode @@ -1033,14 +1030,14 @@ command whose response triggered the error." "\r?\n\\.\r?\n" "BODY" (if (numberp article) (int-to-string article) article)))) -(deffoo nntp-request-group (group &optional server dont-check info) +(deffoo nntp-request-group (group &optional server _dont-check _info) (nntp-with-open-group nil server (when (nntp-send-command "^[245].*\n" "GROUP" group) (let ((entry (nntp-find-connection-entry nntp-server-buffer))) (setcar (cddr entry) group))))) -(deffoo nntp-close-group (group &optional server) +(deffoo nntp-close-group (_group &optional _server) t) (deffoo nntp-server-opened (&optional server) @@ -1139,7 +1136,7 @@ command whose response triggered the error." (run-hooks 'nntp-prepare-post-hook) (nntp-send-buffer "^[23].*\n"))))) -(deffoo nntp-request-type (group article) +(deffoo nntp-request-type (_group _article) 'news) (deffoo nntp-asynchronous-p () @@ -1230,16 +1227,15 @@ If SEND-IF-FORCE, only send authinfo to the server if the (with-current-buffer (generate-new-buffer (format " *server %s %s %s*" - nntp-address nntp-port-number - (gnus-buffer-exists-p buffer))) + nntp-address nntp-port-number buffer)) (mm-disable-multibyte) - (set (make-local-variable 'after-change-functions) nil) - (set (make-local-variable 'nntp-process-wait-for) nil) - (set (make-local-variable 'nntp-process-callback) nil) - (set (make-local-variable 'nntp-process-to-buffer) nil) - (set (make-local-variable 'nntp-process-start-point) nil) - (set (make-local-variable 'nntp-process-decode) nil) - (set (make-local-variable 'nntp-retrieval-in-progress) nil) + (setq-local after-change-functions nil) + (setq-local nntp-process-wait-for nil) + (setq-local nntp-process-callback nil) + (setq-local nntp-process-to-buffer nil) + (setq-local nntp-process-start-point nil) + (setq-local nntp-process-decode nil) + (setq-local nntp-retrieval-in-progress nil) (current-buffer))) (defun nntp-open-connection (buffer) @@ -1282,7 +1278,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the (signal 'quit nil) nil)))) (when timer - (nnheader-cancel-timer timer)) + (cancel-timer timer)) (when (and process (not (memq (process-status process) '(open run)))) (with-current-buffer pbuffer @@ -1292,7 +1288,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the (setq process nil)) (unless process (nntp-kill-buffer pbuffer)) - (when (and (buffer-name pbuffer) + (when (and (buffer-live-p pbuffer) process) (when (eq (process-type process) 'network) ;; Use TCP-keepalive so that connections that pass through a NAT router @@ -1322,8 +1318,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the ;; Run server-specific commands. (dolist (entry nntp-server-action-alist) (when (string-match (car entry) nntp-server-type) - (if (and (listp (cadr entry)) - (not (eq 'lambda (caadr entry)))) + (if (not (functionp (cadr entry))) (eval (cadr entry)) (funcall (cadr entry))))))) @@ -1336,15 +1331,16 @@ If SEND-IF-FORCE, only send authinfo to the server if the nntp-process-decode decode nntp-process-callback callback nntp-process-start-point (point-max)) - (setq after-change-functions '(nntp-after-change-function)))) + ;; FIXME: We should use add-hook/remove-hook here! + (setq after-change-functions (list #'nntp-after-change-function)))) (defun nntp-async-stop (proc) (setq nntp-async-process-list (delq proc nntp-async-process-list)) (when (and nntp-async-timer (not nntp-async-process-list)) - (nnheader-cancel-timer nntp-async-timer) + (cancel-timer nntp-async-timer) (setq nntp-async-timer nil))) -(defun nntp-after-change-function (beg end len) +(defun nntp-after-change-function (_beg end len) (unwind-protect ;; we only care about insertions at eob (when (and (eq 0 len) (eq (point-max) end)) @@ -1355,22 +1351,24 @@ If SEND-IF-FORCE, only send authinfo to the server if the ;; any throw from after-change-functions will leave it ;; set to nil. so we reset it here, if necessary. (when quit-flag + ;; FIXME: We shouldn't assume that it had value + ;; (nntp-after-change-function)! (setq after-change-functions '(nntp-after-change-function))))) (defun nntp-async-trigger (process) (with-current-buffer (process-buffer process) (when nntp-process-callback - ;; do we have an error message? + ;; Do we have an error message? (goto-char nntp-process-start-point) (if (memq (following-char) '(?4 ?5)) - ;; wants credentials? - (if (looking-at "480") + ;; Wants credentials? + (if (looking-at-p "480") (nntp-handle-authinfo process) - ;; report error message. + ;; Report error message. (nntp-snarf-error-message) (nntp-do-callback nil)) - ;; got what we expect? + ;; Got what we expect? (goto-char (point-max)) (when (re-search-backward nntp-process-wait-for nntp-process-start-point t) @@ -1378,8 +1376,8 @@ If SEND-IF-FORCE, only send authinfo to the server if the (with-current-buffer nntp-server-buffer (setq nntp-process-response response))) (nntp-async-stop process) - ;; convert it. - (when (gnus-buffer-exists-p nntp-process-to-buffer) + ;; Convert it. + (when (gnus-buffer-live-p nntp-process-to-buffer) (let ((buf (current-buffer)) (start nntp-process-start-point) (decode nntp-process-decode)) @@ -1390,7 +1388,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the (nnheader-insert-buffer-substring buf start) (when decode (nntp-decode-text)))))) - ;; report it. + ;; Report it. (goto-char (point-max)) (nntp-do-callback (buffer-name (get-buffer nntp-process-to-buffer)))))))) @@ -1536,7 +1534,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the in-process-buffer-p (buf nntp-server-buffer) (process-buffer (nntp-find-connection-buffer nntp-server-buffer)) - first last status) + first status) ;; We have to check `nntp-server-xover'. If it gets set to nil, ;; that means that the server does not understand XOVER, but we ;; won't know that until we try. @@ -1549,7 +1547,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the (setq articles (cdr articles))) (setq in-process-buffer-p (stringp nntp-server-xover)) - (nntp-send-xover-command first (setq last (car articles))) + (nntp-send-xover-command first (car articles)) (setq articles (cdr articles)) (when (and nntp-server-xover in-process-buffer-p) @@ -1572,7 +1570,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the ;; Count replies. (while (re-search-forward "^\\([0-9][0-9][0-9]\\) .*\n" nil t) - (incf received) + (cl-incf received) (setq status (match-string 1)) (if (string-match "^[45]" status) (setq status 'error) @@ -1666,10 +1664,9 @@ If SEND-IF-FORCE, only send authinfo to the server if the nntp-server-xover)))) (defun nntp-find-group-and-number (&optional group) - (save-excursion + (with-current-buffer nntp-server-buffer (save-restriction ;; FIXME: This is REALLY FISHY: set-buffer after save-restriction?!? - (set-buffer nntp-server-buffer) (narrow-to-region (goto-char (point-min)) (or (search-forward "\n\n" nil t) (point-max))) (goto-char (point-min)) @@ -1743,26 +1740,26 @@ If SEND-IF-FORCE, only send authinfo to the server if the ;; ========================================================================== (defvoo nntp-open-telnet-envuser nil - "*If non-nil, telnet session (client and server both) will support the ENVIRON option and not prompt for login name.") + "If non-nil, telnet session (client and server both) will support the ENVIRON option and not prompt for login name.") (defvoo nntp-telnet-shell-prompt "bash\\|[$>] *\r?$" - "*Regular expression to match the shell prompt on the remote machine.") + "Regular expression to match the shell prompt on the remote machine.") (defvoo nntp-rlogin-program "rsh" - "*Program used to log in on remote machines. + "Program used to log in on remote machines. The default is \"rsh\", but \"ssh\" is a popular alternative.") (defvoo nntp-rlogin-parameters '("telnet" "-8" "${NNTPSERVER:=news}" "nntp") - "*Parameters to `nntp-open-rlogin'. + "Parameters to `nntp-open-rlogin'. That function may be used as `nntp-open-connection-function'. In that case, this list will be used as the parameter list given to rsh.") (defvoo nntp-rlogin-user-name nil - "*User name on remote system when using the rlogin connect method.") + "User name on remote system when using the rlogin connect method.") (defvoo nntp-telnet-parameters '("exec" "telnet" "-8" "${NNTPSERVER:=news}" "nntp") - "*Parameters to `nntp-open-telnet'. + "Parameters to `nntp-open-telnet'. That function may be used as `nntp-open-connection-function'. In that case, this list will be executed as a command after logging in via telnet.") @@ -1790,7 +1787,7 @@ via telnet.") (with-current-buffer buffer (erase-buffer) (let ((proc (apply - 'start-process + #'start-process "nntpd" buffer nntp-telnet-command nntp-telnet-switches)) (case-fold-search t)) (when (memq (process-status proc) '(open run)) @@ -1819,7 +1816,7 @@ via telnet.") "\n")) (nntp-wait-for-string nntp-telnet-shell-prompt) (process-send-string - proc (concat (mapconcat 'identity nntp-telnet-parameters " ") "\n")) + proc (concat (mapconcat #'identity nntp-telnet-parameters " ") "\n")) (nntp-wait-for-string "^\r*20[01]") (beginning-of-line) (delete-region (point-min) (point)) @@ -1836,11 +1833,11 @@ via telnet.") (defun nntp-open-rlogin (buffer) "Open a connection to SERVER using rsh." (let ((proc (if nntp-rlogin-user-name - (apply 'start-process + (apply #'start-process "nntpd" buffer nntp-rlogin-program nntp-address "-l" nntp-rlogin-user-name nntp-rlogin-parameters) - (apply 'start-process + (apply #'start-process "nntpd" buffer nntp-rlogin-program nntp-address nntp-rlogin-parameters)))) (with-current-buffer buffer @@ -1873,7 +1870,7 @@ Please refer to the following variables to customize the connection: proc) (and nntp-pre-command (push nntp-pre-command command)) - (setq proc (apply 'start-process "nntpd" buffer command)) + (setq proc (apply #'start-process "nntpd" buffer command)) (with-current-buffer buffer (nntp-wait-for-string "^\r*20[01]") (beginning-of-line) @@ -1909,7 +1906,7 @@ Please refer to the following variables to customize the connection: (push nntp-via-rlogin-command command) (and nntp-pre-command (push nntp-pre-command command)) - (setq proc (apply 'start-process "nntpd" buffer command)) + (setq proc (apply #'start-process "nntpd" buffer command)) (with-current-buffer buffer (nntp-wait-for-string "^r?telnet") (process-send-string proc (concat "open " nntp-address " " @@ -1959,7 +1956,7 @@ Please refer to the following variables to customize the connection: ;; ssh process. --Stef ;; Also a nil connection allow ssh-askpass to work under X11. (let ((process-connection-type nil)) - (apply 'start-process "nntpd" buffer command)))) + (apply #'start-process "nntpd" buffer command)))) (defun nntp-open-netcat-stream (buffer) "Open a connection to an nntp server through netcat. @@ -1977,7 +1974,7 @@ Please refer to the following variables to customize the connection: ,(nntp-service-to-port nntp-port-number)))) (and nntp-pre-command (push nntp-pre-command command)) (let ((process-connection-type nil)) ;See `nntp-open-via-rlogin-and-netcat'. - (apply 'start-process "nntpd" buffer command)))) + (apply #'start-process "nntpd" buffer command)))) (defun nntp-open-via-telnet-and-telnet (buffer) @@ -2005,7 +2002,7 @@ Please refer to the following variables to customize the connection: (case-fold-search t) proc) (and nntp-pre-command (push nntp-pre-command command)) - (setq proc (apply 'start-process "nntpd" buffer command)) + (setq proc (apply #'start-process "nntpd" buffer command)) (when (memq (process-status proc) '(open run)) (nntp-wait-for-string "^r?telnet") (process-send-string proc "set escape \^X\n") @@ -2038,7 +2035,7 @@ Please refer to the following variables to customize the connection: ,nntp-address ,(nntp-service-to-port nntp-port-number)))) (process-send-string proc - (concat (mapconcat 'identity + (concat (mapconcat #'identity real-telnet-command " ") "\n"))) (nntp-wait-for-string "^\r*20[01]") diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index 310ab9425a6..25f3413fcd5 100644 --- a/lisp/gnus/nnvirtual.el +++ b/lisp/gnus/nnvirtual.el @@ -38,7 +38,7 @@ (require 'gnus-start) (require 'gnus-sum) (require 'gnus-msg) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (nnoo-declare nnvirtual) @@ -234,14 +234,12 @@ component group will show up when you enter the virtual group.") nnvirtual-mapping-marks nil nnvirtual-info-installed nil) (when nnvirtual-component-regexp - ;; Go through the newsrc alist and find all component groups. - (let ((newsrc (cdr gnus-newsrc-alist)) - group) - (while (setq group (car (pop newsrc))) - (when (string-match nnvirtual-component-regexp group) ; Match - ;; Add this group to the list of component groups. - (setq nnvirtual-component-groups - (cons group (delete group nnvirtual-component-groups))))))) + ;; Go through the list of groups and find all component groups. + (dolist (group (cdr gnus-group-list)) + (when (string-match nnvirtual-component-regexp group) ; Match + ;; Add this group to the list of component groups. + (setq nnvirtual-component-groups + (cons group (delete group nnvirtual-component-groups)))))) (if (not nnvirtual-component-groups) (nnheader-report 'nnvirtual "No component groups: %s" server) t))) @@ -372,7 +370,7 @@ component group will show up when you enter the virtual group.") (defun nnvirtual-convert-headers () "Convert HEAD headers into NOV headers." (with-current-buffer nntp-server-buffer - (let* ((dependencies (make-vector 100 0)) + (let* ((dependencies (make-hash-table :test #'equal)) (headers (gnus-get-newsgroup-headers dependencies))) (erase-buffer) (mapc 'nnheader-insert-nov headers)))) @@ -493,9 +491,9 @@ If UPDATE-P is not nil, call gnus-group-update-group on the components." -;;; This is currently O(kn^2) to merge n lists of length k. -;;; You could do it in O(knlogn), but we have a small n, and the -;;; overhead of the other approach is probably greater. +;; This is currently O(kn^2) to merge n lists of length k. +;; You could do it in O(knlogn), but we have a small n, and the +;; overhead of the other approach is probably greater. (defun nnvirtual-merge-sorted-lists (&rest lists) "Merge many sorted lists of numbers." (if (null (cdr lists)) @@ -503,68 +501,68 @@ If UPDATE-P is not nil, call gnus-group-update-group on the components." (sort (apply 'nconc lists) '<))) -;;; We map between virtual articles and real articles in a manner -;;; which keeps the size of the virtual active list the same as the -;;; sum of the component active lists. - -;;; To achieve fair mixing of the groups, the last article in each of -;;; N component groups will be in the last N articles in the virtual -;;; group. - -;;; If you have 3 components A, B and C, with articles 1-8, 1-5, and -;;; 6-7 respectively, then the virtual article numbers look like: -;;; -;;; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 -;;; A1 A2 A3 A4 B1 A5 B2 A6 B3 A7 B4 C6 A8 B5 C7 - -;;; To compute these mappings we generate a couple tables and then -;;; do some fast operations on them. Tables for the example above: -;;; -;;; Offsets - [(A 0) (B -3) (C -1)] -;;; -;;; a b c d e -;;; Mapping - ([ 3 0 1 3 0 ] -;;; [ 6 3 2 9 3 ] -;;; [ 8 6 3 15 9 ]) -;;; -;;; (note column 'e' is different in real algorithm, which is slightly -;;; different than described here, but this gives you the methodology.) -;;; -;;; The basic idea is this, when going from component->virtual, apply -;;; the appropriate offset to the article number. Then search the first -;;; column of the table for a row where 'a' is less than or equal to the -;;; modified number. You can see that only group A can therefore go to -;;; the first row, groups A and B to the second, and all to the last. -;;; The third column of the table is telling us the number of groups -;;; which might be able to reach that row (it might increase by more than -;;; 1 if several groups have the same size). -;;; Then column 'b' provides an additional offset you apply when you have -;;; found the correct row. You then multiply by 'c' and add on the groups -;;; _position_ in the offset table. The basic idea here is that on -;;; any given row we are going to map back and forth using X'=X*c+Y and -;;; X=(X'/c), Y=(X' mod c). Then once you've done this transformation, -;;; you apply a final offset from column 'e' to give the virtual article. -;;; -;;; Going the other direction, you instead search on column 'd' instead -;;; of 'a', and apply everything in reverse order. - -;;; Convert component -> virtual: -;;; set num = num - Offset(group) -;;; find first row in Mapping where num <= 'a' -;;; num = (num-'b')*c + Position(group) + 'e' - -;;; Convert virtual -> component: -;;; find first row in Mapping where num <= 'd' -;;; num = num - 'e' -;;; group_pos = num mod 'c' -;;; num = (num / 'c') + 'b' + Offset(group_pos) - -;;; Easy no? :) -;;; -;;; Well actually, you need to keep column e offset smaller by the 'c' -;;; column for that line, and always add 1 more when going from -;;; component -> virtual. Otherwise you run into a problem with -;;; unique reverse mapping. +;; We map between virtual articles and real articles in a manner +;; which keeps the size of the virtual active list the same as the +;; sum of the component active lists. + +;; To achieve fair mixing of the groups, the last article in each of +;; N component groups will be in the last N articles in the virtual +;; group. + +;; If you have 3 components A, B and C, with articles 1-8, 1-5, and +;; 6-7 respectively, then the virtual article numbers look like: +;; +;; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 +;; A1 A2 A3 A4 B1 A5 B2 A6 B3 A7 B4 C6 A8 B5 C7 + +;; To compute these mappings we generate a couple tables and then +;; do some fast operations on them. Tables for the example above: +;; +;; Offsets - [(A 0) (B -3) (C -1)] +;; +;; a b c d e +;; Mapping - ([ 3 0 1 3 0 ] +;; [ 6 3 2 9 3 ] +;; [ 8 6 3 15 9 ]) +;; +;; (note column 'e' is different in real algorithm, which is slightly +;; different than described here, but this gives you the methodology.) +;; +;; The basic idea is this, when going from component->virtual, apply +;; the appropriate offset to the article number. Then search the first +;; column of the table for a row where 'a' is less than or equal to the +;; modified number. You can see that only group A can therefore go to +;; the first row, groups A and B to the second, and all to the last. +;; The third column of the table is telling us the number of groups +;; which might be able to reach that row (it might increase by more than +;; 1 if several groups have the same size). +;; Then column 'b' provides an additional offset you apply when you have +;; found the correct row. You then multiply by 'c' and add on the groups +;; _position_ in the offset table. The basic idea here is that on +;; any given row we are going to map back and forth using X'=X*c+Y and +;; X=(X'/c), Y=(X' mod c). Then once you've done this transformation, +;; you apply a final offset from column 'e' to give the virtual article. +;; +;; Going the other direction, you instead search on column 'd' instead +;; of 'a', and apply everything in reverse order. + +;; Convert component -> virtual: +;; set num = num - Offset(group) +;; find first row in Mapping where num <= 'a' +;; num = (num-'b')*c + Position(group) + 'e' + +;; Convert virtual -> component: +;; find first row in Mapping where num <= 'd' +;; num = num - 'e' +;; group_pos = num mod 'c' +;; num = (num / 'c') + 'b' + Offset(group_pos) + +;; Easy no? :) +;; +;; Well actually, you need to keep column e offset smaller by the 'c' +;; column for that line, and always add 1 more when going from +;; component -> virtual. Otherwise you run into a problem with +;; unique reverse mapping. (defun nnvirtual-map-article (article) "Return a cons of the component group and article corresponding to the given virtual ARTICLE." @@ -774,13 +772,13 @@ based on the marks on the component groups." ;; We need to convert the unreads to reads. We compress the ;; sequence as we go, otherwise it could be huge. - (while (and (<= (incf i) nnvirtual-mapping-len) + (while (and (<= (cl-incf i) nnvirtual-mapping-len) unreads) (if (= i (car unreads)) (setq unreads (cdr unreads)) ;; try to get a range. (setq beg i) - (while (and (<= (incf i) nnvirtual-mapping-len) + (while (and (<= (cl-incf i) nnvirtual-mapping-len) (not (= i (car unreads))))) (setq i (- i 1)) (if (= i beg) diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el index cbef67ee1de..b08b27dd1eb 100644 --- a/lisp/gnus/nnweb.el +++ b/lisp/gnus/nnweb.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'nnoo) (require 'message) @@ -33,9 +33,7 @@ (require 'nnmail) (require 'mm-util) (require 'mm-url) -(eval-and-compile - (ignore-errors - (require 'url))) +(require 'url) (nnoo-declare nnweb) @@ -111,7 +109,7 @@ Valid types include `google', `dejanews', and `gmane'.") (deffoo nnweb-request-scan (&optional group server) (nnweb-possibly-change-server group server) (if nnweb-ephemeral-p - (setq nnweb-hashtb (gnus-make-hashtable 4095)) + (setq nnweb-hashtb (gnus-make-hashtable 4000)) (unless nnweb-articles (nnweb-read-overview group))) (funcall (nnweb-definition 'map)) @@ -231,11 +229,11 @@ Valid types include `google', `dejanews', and `gmane'.") (nnheader-insert-nov (cadr (pop articles))))))) (defun nnweb-set-hashtb (header data) - (gnus-sethash (nnweb-identifier (mail-header-xref header)) + (puthash (nnweb-identifier (mail-header-xref header)) data nnweb-hashtb)) (defun nnweb-get-hashtb (url) - (gnus-gethash (nnweb-identifier url) nnweb-hashtb)) + (gethash (nnweb-identifier url) nnweb-hashtb)) (defun nnweb-identifier (ident) (funcall (nnweb-definition 'identifier) ident)) @@ -270,7 +268,7 @@ Valid types include `google', `dejanews', and `gmane'.") (unless nnweb-group-alist (nnweb-read-active)) (unless nnweb-hashtb - (setq nnweb-hashtb (gnus-make-hashtable 4095))) + (setq nnweb-hashtb (make-hash-table :size 4000 :test #'equal))) (when group (setq nnweb-group group))) @@ -362,11 +360,11 @@ Valid types include `google', `dejanews', and `gmane'.") (current-time-string))) (setq From (match-string 4))) (widen) - (incf i) + (cl-incf i) (unless (nnweb-get-hashtb url) (push (list - (incf (cdr active)) + (cl-incf (cdr active)) (make-full-mail-header (cdr active) (if Newsgroups (concat "(" Newsgroups ") " Subject) @@ -398,7 +396,7 @@ Valid types include `google', `dejanews', and `gmane'.") (nconc nnweb-articles (nnweb-google-parse-1))) ;; Check if there are more articles to fetch (goto-char (point-min)) - (incf i 100) + (cl-incf i 100) (if (or (not (re-search-forward "<a [^>]+href=\"\n?\\([^>\" \n\t]+\\)[^<]*<img[^>]+src=[^>]+next" nil t)) @@ -463,22 +461,21 @@ Valid types include `google', `dejanews', and `gmane'.") (subject (mail-header-subject header)) (rfc2047-encoding-type 'mime)) (when (string-match " \\([^:]+\\)[:/]\\([0-9]+\\)" xref) - (mail-header-set-xref - header - (format "http://article.gmane.org/%s/%s/raw" - (match-string 1 xref) - (match-string 2 xref)))) + (setf (mail-header-xref header) + (format "http://article.gmane.org/%s/%s/raw" + (match-string 1 xref) + (match-string 2 xref)))) ;; Add host part to gmane-encrypted addresses (when (string-match "@$" from) - (mail-header-set-from header - (concat from "public.gmane.org"))) + (setf (mail-header-from header) + (concat from "public.gmane.org"))) - (mail-header-set-subject header - (rfc2047-encode-string subject)) + (setf (mail-header-subject header) + (rfc2047-encode-string subject)) (unless (nnweb-get-hashtb (mail-header-xref header)) - (mail-header-set-number header (incf (cdr active))) + (setf (mail-header-number header) (cl-incf (cdr active))) (push (list (mail-header-number header) header) map) (nnweb-set-hashtb (cadar map) (car map)))))) (forward-line 1))) @@ -525,10 +522,6 @@ Valid types include `google', `dejanews', and `gmane'.") (defun nnweb-insert-html (parse) "Insert HTML based on a w3 parse tree." (if (stringp parse) - ;; We used to call nnheader-string-as-multibyte here, but it cannot - ;; be right, so I removed it. If a bug shows up because of this change, - ;; please do not blindly revert the change, but help me find the real - ;; cause of the bug instead. --Stef (insert parse) (insert "<" (symbol-name (car parse)) " ") (insert (mapconcat diff --git a/lisp/gnus/score-mode.el b/lisp/gnus/score-mode.el index 83b966bef1c..8ba1eae1abc 100644 --- a/lisp/gnus/score-mode.el +++ b/lisp/gnus/score-mode.el @@ -24,7 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'mm-util) ; for mm-universal-coding-system (require 'gnus-util) ; for gnus-pp, gnus-run-mode-hooks @@ -85,7 +84,7 @@ This mode is an extended emacs-lisp mode. (defun gnus-score-edit-insert-date () "Insert date in numerical format." (interactive) - (princ (time-to-days (current-time)) (current-buffer))) + (princ (time-to-days nil) (current-buffer))) (defun gnus-score-pretty-print () "Format the current score file." diff --git a/lisp/gnus/smiley.el b/lisp/gnus/smiley.el index d41d67f915f..fb1e8de9c06 100644 --- a/lisp/gnus/smiley.el +++ b/lisp/gnus/smiley.el @@ -47,7 +47,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'nnheader) (require 'gnus-art) diff --git a/lisp/gnus/smime.el b/lisp/gnus/smime.el index b8db52752b2..9a38a6c6976 100644 --- a/lisp/gnus/smime.el +++ b/lisp/gnus/smime.el @@ -234,10 +234,12 @@ must be set in `ldap-host-parameters-alist'." If `cache-key' and `password-cache' is non-nil then cache the password under `cache-key'." (let ((passphrase - (password-read-and-add + (password-read "Passphrase for secret key (RET for no passphrase): " cache-key))) (if (string= passphrase "") nil + ;; FIXME test passphrase works before caching it. + (and passphrase cache-key (password-cache-add cache-key passphrase)) passphrase))) ;; OpenSSL wrappers. diff --git a/lisp/gnus/spam-stat.el b/lisp/gnus/spam-stat.el index f5ec440a97f..6cf43df2a25 100644 --- a/lisp/gnus/spam-stat.el +++ b/lisp/gnus/spam-stat.el @@ -77,13 +77,13 @@ ;; Learn spam: (spam-stat-process-spam-directory "~/Mail/mail/spam") ;; Learn non-spam: (spam-stat-process-non-spam-directory "~/Mail/mail/misc") ;; Save table: (spam-stat-save) -;; File size: (nth 7 (file-attributes spam-stat-file)) +;; File size: (file-attribute-size (file-attributes spam-stat-file)) ;; Number of words: (hash-table-count spam-stat) ;; Test spam: (spam-stat-test-directory "~/Mail/mail/spam") ;; Test non-spam: (spam-stat-test-directory "~/Mail/mail/misc") ;; Reduce table size: (spam-stat-reduce-size) ;; Save table: (spam-stat-save) -;; File size: (nth 7 (file-attributes spam-stat-file)) +;; File size: (file-attribute-size (file-attributes spam-stat-file)) ;; Number of words: (hash-table-count spam-stat) ;; Test spam: (spam-stat-test-directory "~/Mail/mail/spam") ;; Test non-spam: (spam-stat-test-directory "~/Mail/mail/misc") @@ -424,7 +424,8 @@ spam-stat (spam-stat-to-hash-table '(" spam-stat-ngood spam-stat-nbad)) (insert ")))")))) (message "Saved %s." spam-stat-file) (setq spam-stat-dirty nil - spam-stat-last-saved-at (nth 5 (file-attributes spam-stat-file))))) + spam-stat-last-saved-at (file-attribute-modification-time + (file-attributes spam-stat-file))))) (defun spam-stat-load () "Read the `spam-stat' hash table from disk." @@ -434,12 +435,14 @@ spam-stat (spam-stat-to-hash-table '(" spam-stat-ngood spam-stat-nbad)) ((or (not (boundp 'spam-stat-last-saved-at)) (null spam-stat-last-saved-at) (not (equal spam-stat-last-saved-at - (nth 5 (file-attributes spam-stat-file))))) + (file-attribute-modification-time + (file-attributes spam-stat-file))))) (progn (load-file spam-stat-file) (setq spam-stat-dirty nil spam-stat-last-saved-at - (nth 5 (file-attributes spam-stat-file))))) + (file-attribute-modification-time + (file-attributes spam-stat-file))))) (t (message "Spam stat file not loaded: no change in disk."))))) (defun spam-stat-to-hash-table (entries) @@ -561,8 +564,10 @@ check the variable `spam-stat-score-data'." (dolist (f files) (when (and (file-readable-p f) (file-regular-p f) - (> (nth 7 (file-attributes f)) 0) - (< (time-to-number-of-days (time-since (nth 5 (file-attributes f)))) + (> (file-attribute-size (file-attributes f)) 0) + (< (time-to-number-of-days + (time-since (file-attribute-modification-time + (file-attributes f)))) spam-stat-process-directory-age)) (setq count (1+ count)) (message "Reading %s: %.2f%%" dir (/ count max)) @@ -607,7 +612,7 @@ display non-spam files; otherwise display spam files." (dolist (f files) (when (and (file-readable-p f) (file-regular-p f) - (> (nth 7 (file-attributes f)) 0)) + (> (file-attribute-size (file-attributes f)) 0)) (setq count (1+ count)) (message "Reading %.2f%%, score %.2f" (/ count max) (/ score count)) diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index 76fa0f89183..d752bf0efee 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -38,8 +38,6 @@ ;;{{{ compilation directives and autoloads/requires -(eval-when-compile (require 'cl)) - (require 'message) ;for the message-fetch-field functions (require 'gnus-sum) (require 'gnus-uu) ; because of key prefix issues @@ -51,6 +49,8 @@ ;; for nnimap-split-download-body-default (eval-when-compile (require 'nnimap)) +(eval-when-compile (require 'cl-lib)) + ;; autoload query-dig (autoload 'query-dig "dig") @@ -366,9 +366,6 @@ Only meaningful if you enable `spam-use-blackholes'." (t :inverse-video t)) "Face for spam-marked articles." :group 'spam) -;; backward-compatibility alias -(put 'spam-face 'face-alias 'spam) -(put 'spam-face 'obsolete-face "22.1") (defcustom spam-face 'spam "Face for spam-marked articles." @@ -1167,12 +1164,12 @@ backends)." (defun spam-article-sort-by-spam-status (h1 h2) "Sort articles by score." (let (result) - (dolist (header (spam-necessary-extra-headers)) + (cl-dolist (header (spam-necessary-extra-headers)) (let ((s1 (spam-summary-score h1 header)) (s2 (spam-summary-score h2 header))) (unless (= s1 s2) (setq result (< s1 s2)) - (return)))) + (cl-return)))) result)) (defvar spam-spamassassin-score-regexp @@ -1208,14 +1205,14 @@ Note this has to be fast." With SPECIFIC-HEADER, returns only that header's score. Will not return a nil score." (let (score) - (dolist (header + (cl-dolist (header (if specific-header (list specific-header) (spam-necessary-extra-headers))) (setq score (spam-extra-header-to-number header headers)) (when score - (return))) + (cl-return))) (or score 0))) (defun spam-generic-score (&optional recheck) @@ -1247,73 +1244,40 @@ Will not return a nil score." (setq found backend))) found)) -(defvar spam-list-of-processors - ;; note the nil processors are not defined in gnus.el - '((gnus-group-spam-exit-processor-bogofilter spam spam-use-bogofilter) - (gnus-group-spam-exit-processor-bsfilter spam spam-use-bsfilter) - (gnus-group-spam-exit-processor-blacklist spam spam-use-blacklist) - (gnus-group-spam-exit-processor-ifile spam spam-use-ifile) - (gnus-group-spam-exit-processor-stat spam spam-use-stat) - (gnus-group-spam-exit-processor-spamoracle spam spam-use-spamoracle) - (gnus-group-spam-exit-processor-spamassassin spam spam-use-spamassassin) - (gnus-group-spam-exit-processor-report-gmane spam spam-use-gmane) ;; Buggy? - (gnus-group-ham-exit-processor-ifile ham spam-use-ifile) - (gnus-group-ham-exit-processor-bogofilter ham spam-use-bogofilter) - (gnus-group-ham-exit-processor-bsfilter ham spam-use-bsfilter) - (gnus-group-ham-exit-processor-stat ham spam-use-stat) - (gnus-group-ham-exit-processor-whitelist ham spam-use-whitelist) - (gnus-group-ham-exit-processor-BBDB ham spam-use-BBDB) - (gnus-group-ham-exit-processor-copy ham spam-use-ham-copy) - (gnus-group-ham-exit-processor-spamassassin ham spam-use-spamassassin) - (gnus-group-ham-exit-processor-spamoracle ham spam-use-spamoracle)) - "The OBSOLETE `spam-list-of-processors' list. -This list contains pairs associating the obsolete ham/spam exit -processor variables with a classification and a spam-use-* -variable. When the processor variable is nil, just the -classification and spam-use-* check variable are used. This is -superseded by the new spam backend code, so it's only consulted -for backwards compatibility.") -(make-obsolete-variable 'spam-list-of-processors nil "22.1") - (defun spam-group-processor-p (group backend &optional classification) "Checks if GROUP has a BACKEND with CLASSIFICATION registered. -Also accepts the obsolete processors, which can be found in -gnus.el and in spam-list-of-processors. In the case of mover -backends, checks the setting of `spam-summary-exit-behavior' in -addition to the set values for the group." +In the case of mover backends, checks the setting of +`spam-summary-exit-behavior' in addition to the set values for the group." (if (and (stringp group) (symbolp backend)) - (let ((old-style (assq backend spam-list-of-processors)) - (parameters (nth 0 (gnus-parameter-spam-process group))) + (let ((parameters (nth 0 (gnus-parameter-spam-process group))) found) - (if old-style ; old-style processor - (spam-group-processor-p group (nth 2 old-style) (nth 1 old-style)) - ;; now search for the parameter - (dolist (parameter parameters) - (when (and (null found) - (listp parameter) - (eq classification (nth 0 parameter)) - (eq backend (nth 1 parameter))) - (setq found t))) - - ;; now, if the parameter was not found, do the - ;; spam-summary-exit-behavior-logic for mover backends - (unless found - (when (spam-backend-mover-p backend) - (setq - found - (cond - ((eq spam-summary-exit-behavior 'move-all) t) - ((eq spam-summary-exit-behavior 'move-none) nil) - ((eq spam-summary-exit-behavior 'default) - (or (eq classification 'spam) ;move spam out of all groups - ;; move ham out of spam groups - (and (eq classification 'ham) - (spam-group-spam-contents-p group)))) - (t (gnus-error 5 "Unknown spam-summary-exit-behavior: %s" - spam-summary-exit-behavior)))))) - - found)) + ;; now search for the parameter + (dolist (parameter parameters) + (when (and (null found) + (listp parameter) + (eq classification (nth 0 parameter)) + (eq backend (nth 1 parameter))) + (setq found t))) + + ;; now, if the parameter was not found, do the + ;; spam-summary-exit-behavior-logic for mover backends + (unless found + (when (spam-backend-mover-p backend) + (setq + found + (cond + ((eq spam-summary-exit-behavior 'move-all) t) + ((eq spam-summary-exit-behavior 'move-none) nil) + ((eq spam-summary-exit-behavior 'default) + (or (eq classification 'spam) ;move spam out of all groups + ;; move ham out of spam groups + (and (eq classification 'ham) + (spam-group-spam-contents-p group)))) + (t (gnus-error 5 "Unknown spam-summary-exit-behavior: %s" + spam-summary-exit-behavior)))))) + + found) nil)) ;;}}} @@ -1556,7 +1520,7 @@ addition to the set values for the group." ;; nil))) (defun spam-fetch-field-fast (article field &optional prepared-data-header) - "Fetch a FIELD for ARTICLE with the internal `gnus-data-list' function. + "Fetch a FIELD for ARTICLE with the internal `gnus-data-find' function. When PREPARED-DATA-HEADER is given, don't look in the Gnus data. When FIELD is 'number, ARTICLE can be any number (since we want to find it out)." @@ -1622,7 +1586,7 @@ to find it out)." (defun spam-fetch-article-header (article) (with-current-buffer gnus-summary-buffer (gnus-read-header article) - (nth 3 (assq article gnus-newsgroup-data)))) + (gnus-data-header (gnus-data-find article)))) ;;}}} ;;{{{ Spam determination. @@ -1697,10 +1661,10 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." article-cannot-be-faked) - (dolist (backend methods) + (cl-dolist (backend methods) (when (spam-backend-statistical-p backend) (setq article-cannot-be-faked t) - (return))) + (cl-return))) (when (memq 'default methods) (setq article-cannot-be-faked t)) @@ -1785,7 +1749,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." ;; eliminate duplicates (dolist (article (copy-sequence ulist)) (when (memq article rlist) - (incf delcount) + (cl-incf delcount) (setq rlist (delq article rlist)) (setq ulist (delq article ulist)))) @@ -2173,7 +2137,7 @@ See `spam-ifile-database'." (apply 'call-process-region (point-min) (point-max) spam-ifile-program nil temp-buffer-name nil "-c" - (if db-param `(,db-param "-q") `("-q")))) + (if db-param `(,db-param "-q") '("-q")))) ;; check the return now (we're back in the temp buffer) (goto-char (point-min)) (if (not (eobp)) @@ -2202,7 +2166,7 @@ Uses `gnus-newsgroup-name' if category is nil (for ham registration)." (point-min) (point-max) spam-ifile-program nil nil nil add-or-delete-option category - (if db `(,db "-h") `("-h")))))) + (if db `(,db "-h") '("-h")))))) (defun spam-ifile-register-spam-routine (articles &optional unregister) (spam-ifile-register-with-ifile articles spam-ifile-spam-category unregister)) @@ -2335,10 +2299,10 @@ With a non-nil REMOVE, remove the ADDRESSES." (when (stringp from) (spam-filelist-build-cache type) (let (found) - (dolist (address (gethash type spam-caches)) + (cl-dolist (address (gethash type spam-caches)) (when (and address (string-match address from)) (setq found t) - (return))) + (cl-return))) found))) ;;; returns t if the sender is in the whitelist, nil or @@ -2509,7 +2473,7 @@ With a non-nil REMOVE, remove the ADDRESSES." (point-min) (point-max) spam-bogofilter-program nil temp-buffer-name nil - (if db `("-d" ,db "-v") `("-v")))) + (if db `("-d" ,db "-v") '("-v")))) (setq return (spam-check-bogofilter-headers score)))) return) (gnus-error 5 "`spam.el' doesn't support obsolete bogofilter versions"))) @@ -2537,7 +2501,7 @@ With a non-nil REMOVE, remove the ADDRESSES." (point-min) (point-max) spam-bogofilter-program nil nil nil switch - (if db `("-d" ,db "-v") `("-v"))))))) + (if db `("-d" ,db "-v") '("-v"))))))) (gnus-error 5 "`spam.el' doesn't support obsolete bogofilter versions"))) (defun spam-bogofilter-register-spam-routine (articles &optional unregister) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 8684a853af2..0b5c547d6b0 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -40,7 +40,21 @@ "List of functions to run in help buffer in `describe-function'. Those functions will be run after the header line and argument list was inserted, and before the documentation will be inserted. -The functions will receive the function name as argument.") +The functions will receive the function name as argument. +They can assume that a newline was output just before they were called, +and they should terminate any of their own output with a newline. +By convention they should indent their output by 2 spaces.") + +(defvar help-fns-describe-variable-functions nil + "List of functions to run in help buffer in `describe-variable'. +Those functions will be run after the header line and value was inserted, +and before the documentation will be inserted. +The functions will receive the variable name as argument. +They can assume that a newline was output just before they were called, +and they should terminate any of their own output with a newline. +By convention they should indent their output by 2 spaces. +Current buffer is the buffer in which we queried the variable, +and the output should go to `standard-output'.") ;; Functions @@ -68,12 +82,15 @@ The functions will receive the function name as argument.") (defun help--loaded-p (file) "Try and figure out if FILE has already been loaded." + ;; FIXME: this regexp business is not good enough: for file + ;; `toto', it will say `toto' is loaded when in reality it was + ;; just cedet/semantic/toto that has been loaded. (or (let ((feature (intern-soft file))) (and feature (featurep feature))) (let* ((re (load-history-regexp file)) (done nil)) (dolist (x load-history) - (and (car x) (string-match-p re (car x)) (setq done t))) + (and (stringp (car x)) (string-match-p re (car x)) (setq done t))) done))) (defun help--load-prefixes (prefixes) @@ -83,11 +100,9 @@ The functions will receive the function name as argument.") (dolist (file files) ;; FIXME: Should we scan help-definition-prefixes to remove ;; other prefixes of the same file? - ;; FIXME: this regexp business is not good enough: for file - ;; `toto', it will say `toto' is loaded when in reality it was - ;; just cedet/semantic/toto that has been loaded. (unless (help--loaded-p file) - (load file 'noerror 'nomessage))))) + (with-demoted-errors "while loading: %S" + (load file 'noerror 'nomessage)))))) (defcustom help-enable-completion-auto-load t "Whether completion for Help commands can perform autoloading. @@ -181,7 +196,8 @@ When called from lisp, FUNCTION may also be a function object." ;;;###autoload (defun help-C-file-name (subr-or-var kind) "Return the name of the C file where SUBR-OR-VAR is defined. -KIND should be `var' for a variable or `subr' for a subroutine." +KIND should be `var' for a variable or `subr' for a subroutine. +If we can't find the file name, nil is returned." (let ((docbuf (get-buffer-create " *DOC*")) (name (if (eq 'var kind) (concat "V" (symbol-name subr-or-var)) @@ -193,19 +209,24 @@ KIND should be `var' for a variable or `subr' for a subroutine." (expand-file-name internal-doc-file-name doc-directory))) (let ((file (catch 'loop (while t - (let ((pnt (search-forward (concat "" name "\n")))) - (re-search-backward "S\\(.*\\)") - (let ((file (match-string 1))) - (if (member file build-files) - (throw 'loop file) - (goto-char pnt)))))))) - (if (string-match "^ns.*\\(\\.o\\|obj\\)\\'" file) - (setq file (replace-match ".m" t t file 1)) - (if (string-match "\\.\\(o\\|obj\\)\\'" file) - (setq file (replace-match ".c" t t file)))) - (if (string-match "\\.\\(c\\|m\\)\\'" file) - (concat "src/" file) - file))))) + (let ((pnt (search-forward (concat "\^_" name "\n") + nil t))) + (if (not pnt) + (throw 'loop nil) + (re-search-backward "\^_S\\(.*\\)") + (let ((file (match-string 1))) + (if (member file build-files) + (throw 'loop file) + (goto-char pnt))))))))) + (if (not file) + nil + (if (string-match "^ns.*\\(\\.o\\|obj\\)\\'" file) + (setq file (replace-match ".m" t t file 1)) + (if (string-match "\\.\\(o\\|obj\\)\\'" file) + (setq file (replace-match ".c" t t file)))) + (if (string-match "\\.\\(c\\|m\\)\\'" file) + (concat "src/" file) + file)))))) (defcustom help-downcase-arguments nil "If non-nil, argument names in *Help* buffers are downcased." @@ -423,7 +444,7 @@ suitable file is found, return nil." (defun help-fns--compiler-macro (function) (let ((handler (function-get function 'compiler-macro))) (when handler - (insert "\nThis function has a compiler macro") + (insert " This function has a compiler macro") (if (symbolp handler) (progn (insert (format-message " `%s'" handler)) @@ -497,7 +518,7 @@ suitable file is found, return nil." (get function 'derived-mode-parent)))) (when parent-mode - (insert (substitute-command-keys "\nParent mode: `")) + (insert (substitute-command-keys " Parent mode: `")) (let ((beg (point))) (insert (format "%s" parent-mode)) (make-text-button beg (point) @@ -511,15 +532,15 @@ suitable file is found, return nil." (get function 'byte-obsolete-info))) (use (car obsolete))) (when obsolete - (insert "\nThis " + (insert " This " (if (eq (car-safe (symbol-function function)) 'macro) "macro" "function") " is obsolete") (when (nth 2 obsolete) (insert (format " since %s" (nth 2 obsolete)))) - (insert (cond ((stringp use) (concat ";\n" use)) - (use (format-message ";\nuse `%s' instead." use)) + (insert (cond ((stringp use) (concat ";\n " use)) + (use (format-message ";\n use `%s' instead." use)) (t ".")) "\n")))) @@ -532,7 +553,7 @@ FILE is the file where FUNCTION was probably defined." (target (cons t function)) found) (while (and load-hist (not found)) - (and (caar load-hist) + (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))) @@ -549,17 +570,71 @@ FILE is the file where FUNCTION was probably defined." (memq function byte-compile-interactive-only-functions))))) (when interactive-only - (insert "\nThis function is for interactive use only" + (insert " This function is for interactive use only" ;; Cf byte-compile-form. (cond ((stringp interactive-only) - (format ";\nin Lisp code %s" interactive-only)) + (format ";\n in Lisp code %s" interactive-only)) ((and (symbolp 'interactive-only) (not (eq interactive-only t))) - (format-message ";\nin Lisp code use `%s' instead." + (format-message ";\n in Lisp code use `%s' instead." interactive-only)) (t ".")) "\n"))))) +(add-hook 'help-fns-describe-function-functions #'help-fns--side-effects) +(defun help-fns--side-effects (function) + (when (and (symbolp function) + (or (function-get function 'pure) + (function-get function 'side-effect-free))) + (insert " This function does not change global state, " + "including the match data.\n"))) + +(defun help-fns--first-release (symbol) + "Return the likely first release that defined SYMBOL, or nil." + ;; Code below relies on the etc/NEWS* files. + ;; FIXME: Maybe we should also use the */ChangeLog* files when available. + ;; FIXME: Maybe we should also look for announcements of the addition + ;; of the *packages* in which the function is defined. + (let* ((name (symbol-name symbol)) + (re (concat "\\_<" (regexp-quote name) "\\_>")) + (news (directory-files data-directory t "\\`NEWS.[1-9]")) + (place nil) + (first nil)) + (with-temp-buffer + (dolist (f news) + (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))))))))) + (when first + (make-text-button first nil 'type 'help-news 'help-args place)) + first)) + +(add-hook 'help-fns-describe-function-functions + #'help-fns--mention-first-release) +(add-hook 'help-fns-describe-variable-functions + #'help-fns--mention-first-release) +(defun help-fns--mention-first-release (object) + (let ((first (if (symbolp object) (help-fns--first-release object)))) + (when first + (with-current-buffer standard-output + (insert (format " Probably introduced at or before Emacs version %s.\n" + first)))))) + (defun help-fns-short-filename (filename) (let* ((abbrev (abbreviate-file-name filename)) (short abbrev)) @@ -622,9 +697,9 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." (memq (car-safe def) '(macro lambda closure))) (stringp file-name) (help-fns--autoloaded-p function file-name)) - (if (commandp def) - "an interactive autoloaded " - "an autoloaded ") + (concat + "an autoloaded " (if (commandp def) + "interactive ")) (if (commandp def) "an interactive " "a ")))) ;; Print what kind of function-like object FUNCTION is. @@ -638,14 +713,16 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." (aliased (format-message "an alias for `%s'" real-def)) ((subrp def) - (if (eq 'unevalled (cdr (subr-arity def))) - (concat beg "special form") - (concat beg "built-in function"))) + (concat beg (if (eq 'unevalled (cdr (subr-arity def))) + "special form" + "built-in function"))) ((autoloadp def) - (format "%s autoloaded %s" - (if (commandp def) "an interactive" "an") - (if (eq (nth 4 def) 'keymap) "keymap" - (if (nth 4 def) "Lisp macro" "Lisp function")))) + (format "an autoloaded %s" + (cond + ((commandp def) "interactive Lisp function") + ((eq (nth 4 def) 'keymap) "keymap") + ((nth 4 def) "Lisp macro") + (t "Lisp function")))) ((or (eq (car-safe def) 'macro) ;; For advised macros, def is a lambda ;; expression or a byte-code-function-p, so we @@ -654,6 +731,8 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." (concat beg "Lisp macro")) ((byte-code-function-p def) (concat beg "compiled Lisp function")) + ((module-function-p def) + (concat beg "module function")) ((eq (car-safe def) 'lambda) (concat beg "Lisp function")) ((eq (car-safe def) 'closure) @@ -694,6 +773,10 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." (help-xref-button 1 'help-function-def function file-name)))) (princ ".")))) +(defun help-fns--ensure-empty-line () + (unless (eolp) (insert "\n")) + (unless (eq ?\n (char-before (1- (point)))) (insert "\n"))) + ;;;###autoload (defun describe-function-1 (function) (let ((pt1 (with-current-buffer (help-buffer) (point)))) @@ -731,8 +814,10 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." real-function key-bindings-buffer) ;; E.g. an alias for a not yet defined function. ((invalid-function void-function) doc-raw)))) + (help-fns--ensure-empty-line) (run-hook-with-args 'help-fns-describe-function-functions function) - (insert "\n" (or doc "Not documented."))) + (help-fns--ensure-empty-line) + (insert (or doc "Not documented."))) ;; Avoid asking the user annoying questions if she decides ;; to save the help buffer, when her locale's codeset ;; isn't UTF-8. @@ -775,14 +860,15 @@ If ANY-SYMBOL is non-nil, don't insist the symbol be bound." (and (or any-symbol (boundp sym)) sym))))) 0))) -(defun describe-variable-custom-version-info (variable) +(defun describe-variable-custom-version-info (variable &optional type) (let ((custom-version (get variable 'custom-version)) (cpv (get variable 'custom-package-version)) + (type (or type "variable")) (output nil)) (if custom-version (setq output - (format "This variable was introduced, or its default value was changed, in\nversion %s of Emacs.\n" - custom-version)) + (format "This %s was introduced, or its default value was changed, in\nversion %s of Emacs.\n" + type custom-version)) (when cpv (let* ((package (car-safe cpv)) (version (if (listp (cdr-safe cpv)) @@ -792,11 +878,11 @@ If ANY-SYMBOL is non-nil, don't insist the symbol be bound." (emacsv (cdr (assoc version pkg-versions)))) (if (and package version) (setq output - (format (concat "This variable was introduced, or its default value was changed, in\nversion %s of the %s package" + (format (concat "This %s was introduced, or its default value was changed, in\nversion %s of the %s package" (if emacsv (format " that is part of Emacs %s" emacsv)) ".\n") - version package)))))) + type version package)))))) output)) ;;;###autoload @@ -835,7 +921,6 @@ it is displayed along with the global value." (message "You did not specify a variable") (save-excursion (let ((valvoid (not (with-current-buffer buffer (boundp variable)))) - (permanent-local (get variable 'permanent-local)) val val-start-pos locus) ;; Extract the value before setting up the output buffer, ;; in case `buffer' *is* the output buffer. @@ -851,26 +936,26 @@ it is displayed along with the global value." (prin1 variable) (setq file-name (find-lisp-object-file-name variable 'defvar)) - (if file-name - (progn - (princ (format-message - " is a variable defined in `%s'.\n" - (if (eq file-name 'C-source) - "C source code" - (file-name-nondirectory file-name)))) - (with-current-buffer standard-output - (save-excursion - (re-search-backward (substitute-command-keys - "`\\([^`']+\\)'") - nil t) - (help-xref-button 1 'help-variable-def - variable file-name))) - (if valvoid - (princ "It is void as a variable.") - (princ "Its "))) - (if valvoid - (princ " is void as a variable.") - (princ (substitute-command-keys "'s "))))) + (princ (if file-name + (progn + (princ (format-message + " is a variable defined in `%s'.\n" + (if (eq file-name 'C-source) + "C source code" + (file-name-nondirectory file-name)))) + (with-current-buffer standard-output + (save-excursion + (re-search-backward (substitute-command-keys + "`\\([^`']+\\)'") + nil t) + (help-xref-button 1 'help-variable-def + variable file-name))) + (if valvoid + "It is void as a variable." + "Its ")) + (if valvoid + " is void as a variable." + (substitute-command-keys "'s "))))) (unless valvoid (with-current-buffer standard-output (setq val-start-pos (point)) @@ -899,7 +984,7 @@ it is displayed along with the global value." (let* ((sv (get variable 'standard-value)) (origval (and (consp sv) (condition-case nil - (eval (car sv)) + (eval (car sv) t) (error :help-eval-error)))) from) (when (and (consp sv) @@ -974,132 +1059,17 @@ it is displayed along with the global value." (let* ((alias (condition-case nil (indirect-variable variable) (error variable))) - (obsolete (get variable 'byte-obsolete-variable)) - (watchpoints (get-variable-watchers variable)) - (use (car obsolete)) - (safe-var (get variable 'safe-local-variable)) (doc (or (documentation-property variable 'variable-documentation) (documentation-property - alias 'variable-documentation))) - (extra-line nil)) + alias 'variable-documentation)))) - ;; Mention if it's a local variable. - (cond - ((and (local-variable-if-set-p variable) - (or (not (local-variable-p variable)) - (with-temp-buffer - (local-variable-if-set-p variable)))) - (setq extra-line t) - (princ " Automatically becomes ") - (if permanent-local - (princ "permanently ")) - (princ "buffer-local when set.\n")) - ((not permanent-local)) - ((bufferp locus) - (setq extra-line t) - (princ - (substitute-command-keys - " This variable's buffer-local value is permanent.\n"))) - (t - (setq extra-line t) - (princ (substitute-command-keys - " This variable's value is permanent \ -if it is given a local binding.\n")))) - - ;; Mention if it's an alias. - (unless (eq alias variable) - (setq extra-line t) - (princ (format-message - " This variable is an alias for `%s'.\n" - alias))) - - (when obsolete - (setq extra-line t) - (princ " This variable is obsolete") - (if (nth 2 obsolete) - (princ (format " since %s" (nth 2 obsolete)))) - (princ (cond ((stringp use) (concat ";\n " use)) - (use (format-message ";\n use `%s' instead." - (car obsolete))) - (t "."))) - (terpri)) - - (when watchpoints - (setq extra-line t) - (princ " Calls these functions when changed: ") - (princ watchpoints) - (terpri)) - - (when (member (cons variable val) - (with-current-buffer buffer - file-local-variables-alist)) - (setq extra-line t) - (if (member (cons variable val) - (with-current-buffer buffer - dir-local-variables-alist)) - (let ((file (and (buffer-file-name buffer) - (not (file-remote-p - (buffer-file-name buffer))) - (dir-locals-find-file - (buffer-file-name buffer)))) - (is-directory nil)) - (princ (substitute-command-keys - " This variable's value is directory-local")) - (when (consp file) ; result from cache - ;; If the cache element has an mtime, we - ;; assume it came from a file. - (if (nth 2 file) - ;; (car file) is a directory. - (setq file (dir-locals--all-files (car file))) - ;; Otherwise, assume it was set directly. - (setq file (car file) - is-directory t))) - (if (null file) - (princ ".\n") - (princ ", set ") - (princ (substitute-command-keys - (cond - (is-directory "for the directory\n `") - ;; Many files matched. - ((and (consp file) (cdr file)) - (setq file (file-name-directory (car file))) - (format "by one of the\n %s files in the directory\n `" - dir-locals-file)) - (t (setq file (car file)) - "by the file\n `")))) - (with-current-buffer standard-output - (insert-text-button - file 'type 'help-dir-local-var-def - 'help-args (list variable file))) - (princ (substitute-command-keys "'.\n")))) - (princ (substitute-command-keys - " This variable's value is file-local.\n")))) - - (when (memq variable ignored-local-variables) - (setq extra-line t) - (princ " This variable is ignored as a file-local \ -variable.\n")) - - ;; Can be both risky and safe, eg auto-fill-function. - (when (risky-local-variable-p variable) - (setq extra-line t) - (princ " This variable may be risky if used as a \ -file-local variable.\n") - (when (assq variable safe-local-variable-values) - (princ (substitute-command-keys - " However, you have added it to \ -`safe-local-variable-values'.\n")))) - - (when safe-var - (setq extra-line t) - (princ " This variable is safe as a file local variable ") - (princ "if its value\n satisfies the predicate ") - (princ (if (byte-code-function-p safe-var) - "which is a byte-compiled expression.\n" - (format-message "`%s'.\n" safe-var)))) - - (if extra-line (terpri)) + (with-current-buffer buffer + (run-hook-with-args 'help-fns-describe-variable-functions + variable)) + + (with-current-buffer standard-output + (help-fns--ensure-empty-line)) (princ "Documentation:\n") (with-current-buffer standard-output (insert (or doc "Not documented as a variable.")))) @@ -1126,6 +1096,134 @@ file-local variable.\n") ;; Return the text we displayed. (buffer-string)))))))) +(add-hook 'help-fns-describe-variable-functions #'help-fns--var-safe-local) +(defun help-fns--var-safe-local (variable) + (let ((safe-var (get variable 'safe-local-variable))) + (when safe-var + (princ " This variable is safe as a file local variable ") + (princ "if its value\n satisfies the predicate ") + (princ (if (byte-code-function-p safe-var) + "which is a byte-compiled expression.\n" + (format-message "`%s'.\n" safe-var)))))) + +(add-hook 'help-fns-describe-variable-functions #'help-fns--var-risky) +(defun help-fns--var-risky (variable) + ;; Can be both risky and safe, eg auto-fill-function. + (when (risky-local-variable-p variable) + (princ " This variable may be risky if used as a \ +file-local variable.\n") + (when (assq variable safe-local-variable-values) + (princ (substitute-command-keys + " However, you have added it to \ +`safe-local-variable-values'.\n"))))) + +(add-hook 'help-fns-describe-variable-functions #'help-fns--var-ignored-local) +(defun help-fns--var-ignored-local (variable) + (when (memq variable ignored-local-variables) + (princ " This variable is ignored as a file-local \ +variable.\n"))) + +(add-hook 'help-fns-describe-variable-functions #'help-fns--var-file-local) +(defun help-fns--var-file-local (variable) + (when (boundp variable) + (let ((val (symbol-value variable))) + (when (member (cons variable val) + file-local-variables-alist) + (if (member (cons variable val) + dir-local-variables-alist) + (let ((file (and buffer-file-name + (not (file-remote-p buffer-file-name)) + (dir-locals-find-file buffer-file-name))) + (is-directory nil)) + (princ (substitute-command-keys + " This variable's value is directory-local")) + (when (consp file) ; result from cache + ;; If the cache element has an mtime, we + ;; assume it came from a file. + (if (nth 2 file) + ;; (car file) is a directory. + (setq file (dir-locals--all-files (car file))) + ;; Otherwise, assume it was set directly. + (setq file (car file) + is-directory t))) + (if (null file) + (princ ".\n") + (princ ", set ") + (princ (substitute-command-keys + (cond + (is-directory "for the directory\n `") + ;; Many files matched. + ((and (consp file) (cdr file)) + (setq file (file-name-directory (car file))) + (format "by one of the\n %s files in the directory\n `" + dir-locals-file)) + (t (setq file (car file)) + "by the file\n `")))) + (with-current-buffer standard-output + (insert-text-button + file 'type 'help-dir-local-var-def + 'help-args (list variable file))) + (princ (substitute-command-keys "'.\n")))) + (princ (substitute-command-keys + " This variable's value is file-local.\n"))))))) + +(add-hook 'help-fns-describe-variable-functions #'help-fns--var-watchpoints) +(defun help-fns--var-watchpoints (variable) + (let ((watchpoints (get-variable-watchers variable))) + (when watchpoints + (princ " Calls these functions when changed: ") + ;; FIXME: Turn function names into hyperlinks. + (princ watchpoints) + (terpri)))) + +(add-hook 'help-fns-describe-variable-functions #'help-fns--var-obsolete) +(defun help-fns--var-obsolete (variable) + (let* ((obsolete (get variable 'byte-obsolete-variable)) + (use (car obsolete))) + (when obsolete + (princ " This variable is obsolete") + (if (nth 2 obsolete) + (princ (format " since %s" (nth 2 obsolete)))) + (princ (cond ((stringp use) (concat ";\n " use)) + (use (format-message ";\n use `%s' instead." + (car obsolete))) + (t "."))) + (terpri)))) + +(add-hook 'help-fns-describe-variable-functions #'help-fns--var-alias) +(defun help-fns--var-alias (variable) + ;; Mention if it's an alias. + (let ((alias (condition-case nil + (indirect-variable variable) + (error variable)))) + (unless (eq alias variable) + (princ (format-message + " This variable is an alias for `%s'.\n" + alias))))) + +(add-hook 'help-fns-describe-variable-functions #'help-fns--var-bufferlocal) +(defun help-fns--var-bufferlocal (variable) + (let ((permanent-local (get variable 'permanent-local)) + (locus (variable-binding-locus variable))) + ;; Mention if it's a local variable. + (cond + ((and (local-variable-if-set-p variable) + (or (not (local-variable-p variable)) + (with-temp-buffer + (local-variable-if-set-p variable)))) + (princ " Automatically becomes ") + (if permanent-local + (princ "permanently ")) + (princ "buffer-local when set.\n")) + ((not permanent-local)) + ((bufferp locus) + (princ + (substitute-command-keys + " This variable's buffer-local value is permanent.\n"))) + (t + (princ (substitute-command-keys + " This variable's value is permanent \ +if it is given a local binding.\n")))))) (defvar help-xref-stack-item) @@ -1147,7 +1245,7 @@ current buffer and the selected frame, respectively." (format "Describe symbol (default %s): " v-or-f) "Describe symbol: ") - obarray + #'help--symbol-completion-table (lambda (vv) (cl-some (lambda (x) (funcall (nth 1 x) vv)) describe-symbol-backends)) @@ -1299,7 +1397,7 @@ BUFFER should be a buffer or a buffer name." ".AU Richard M. Stallman\n") (insert-file-contents file) (let (notfirst) - (while (search-forward "" nil 'move) + (while (search-forward "\^_" nil 'move) (if (= (following-char) ?S) (delete-region (1- (point)) (line-end-position)) (delete-char -1) @@ -1332,12 +1430,12 @@ BUFFER should be a buffer or a buffer name." (insert "@") (forward-char 1)) (goto-char (point-min)) - (while (search-forward "" nil t) + (while (search-forward "\^_" nil t) (when (/= (following-char) ?S) (setq type (char-after) name (buffer-substring (1+ (point)) (line-end-position)) doc (buffer-substring (line-beginning-position 2) - (if (search-forward "" nil 'move) + (if (search-forward "\^_" nil 'move) (1- (point)) (point))) alist (cons (list name type doc) alist)) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index be488ea80ca..fb29bd2be4f 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -203,12 +203,18 @@ The format is (FUNCTION ARGS...).") (help-C-file-name (indirect-function fun) 'fun))) ;; Don't use find-function-noselect because it follows ;; aliases (which fails for built-in functions). - (let ((location - (find-function-search-for-symbol fun type file))) + (let* ((location + (find-function-search-for-symbol fun type file)) + (position (cdr location))) (pop-to-buffer (car location)) (run-hooks 'find-function-after-hook) - (if (cdr location) - (goto-char (cdr location)) + (if position + (progn + ;; Widen the buffer if necessary to go to this position. + (when (or (< position (point-min)) + (> position (point-max))) + (widen)) + (goto-char position)) (message "Unable to find location in file"))))) 'help-echo (purecopy "mouse-2, RET: find function's definition")) @@ -219,6 +225,7 @@ The format is (FUNCTION ARGS...).") (if (and file (file-readable-p file)) (progn (pop-to-buffer (find-file-noselect file)) + (widen) (goto-char (point-min)) (if (re-search-forward (format "^[ \t]*(\\(cl-\\)?define-compiler-macro[ \t]+%s" @@ -234,12 +241,18 @@ The format is (FUNCTION ARGS...).") 'help-function (lambda (var &optional file) (when (eq file 'C-source) (setq file (help-C-file-name var 'var))) - (let ((location (find-variable-noselect var file))) + (let* ((location (find-variable-noselect var file)) + (position (cdr location))) (pop-to-buffer (car location)) (run-hooks 'find-function-after-hook) - (if (cdr location) - (goto-char (cdr location)) - (message "Unable to find location in file")))) + (if position + (progn + ;; Widen the buffer if necessary to go to this position. + (when (or (< position (point-min)) + (> position (point-max))) + (widen)) + (goto-char position)) + (message "Unable to find location in file")))) 'help-echo (purecopy "mouse-2, RET: find variable's definition")) (define-button-type 'help-face-def @@ -248,12 +261,18 @@ The format is (FUNCTION ARGS...).") (require 'find-func) ;; Don't use find-function-noselect because it follows ;; aliases (which fails for built-in functions). - (let ((location - (find-function-search-for-symbol fun 'defface file))) + (let* ((location + (find-function-search-for-symbol fun 'defface file)) + (position (cdr location))) (pop-to-buffer (car location)) - (if (cdr location) - (goto-char (cdr location)) - (message "Unable to find location in file")))) + (if position + (progn + ;; Widen the buffer if necessary to go to this position. + (when (or (< position (point-min)) + (> position (point-max))) + (widen)) + (goto-char position)) + (message "Unable to find location in file")))) 'help-echo (purecopy "mouse-2, RET: find face's definition")) (define-button-type 'help-package @@ -268,12 +287,12 @@ The format is (FUNCTION ARGS...).") (define-button-type 'help-theme-def :supertype 'help-xref - 'help-function 'find-file + 'help-function #'find-file 'help-echo (purecopy "mouse-2, RET: visit theme file")) (define-button-type 'help-theme-edit :supertype 'help-xref - 'help-function 'customize-create-theme + 'help-function #'customize-create-theme 'help-echo (purecopy "mouse-2, RET: edit this theme file")) (define-button-type 'help-dir-local-var-def @@ -283,7 +302,13 @@ The format is (FUNCTION ARGS...).") ;; local variable was defined. (find-file file)) 'help-echo (purecopy "mouse-2, RET: open directory-local variables file")) - +(define-button-type 'help-news + :supertype 'help-xref + 'help-function + (lambda (file pos) + (pop-to-buffer (find-file-noselect file)) + (goto-char pos)) + 'help-echo (purecopy "mouse-2, RET: show corresponding NEWS announcement")) (defvar bookmark-make-record-function) @@ -402,7 +427,15 @@ it does not already exist." (or (and (boundp symbol) (not (keywordp symbol))) (get symbol 'variable-documentation))) ,#'describe-variable) - ("face" ,#'facep ,(lambda (s _b _f) (describe-face s))))) + ("face" ,#'facep ,(lambda (s _b _f) (describe-face s)))) + "List of providers of information about symbols. +Each element has the form (NAME TESTFUN DESCFUN) where: + NAME is a string naming a category of object, such as \"type\" or \"face\". + TESTFUN is a predicate which takes a symbol and returns non-nil if the + symbol is such an object. + DESCFUN is a function which takes three arguments (a symbol, a buffer, + and a frame), inserts the description of that symbol in the current buffer + and returns that text as well.") ;;;###autoload (defun help-make-xrefs (&optional buffer) @@ -754,7 +787,9 @@ Implements `bookmark-make-record-function' for help-mode buffers." (error "Cannot create bookmark - help command not known")) `(,@(bookmark-make-record-default 'NO-FILE 'NO-CONTEXT) (help-fn . ,(car help-xref-stack-item)) - (help-args . ,(cdr help-xref-stack-item)) + (help-args . ,(mapcar (lambda (a) + (if (bufferp a) (buffer-name a) a)) + (cdr help-xref-stack-item))) (position . ,(point)) (handler . help-bookmark-jump))) diff --git a/lisp/help.el b/lisp/help.el index c23d4d8fe54..039d0c44e4f 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1,4 +1,4 @@ -;;; help.el --- help commands for Emacs +;;; help.el --- help commands for Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1985-1986, 1993-1994, 1998-2019 Free Software ;; Foundation, Inc. @@ -67,6 +67,7 @@ (define-key map "\C-n" 'view-emacs-news) (define-key map "\C-o" 'describe-distribution) (define-key map "\C-p" 'view-emacs-problems) + (define-key map "\C-s" 'search-forward-help-for-help) (define-key map "\C-t" 'view-emacs-todo) (define-key map "\C-w" 'describe-no-warranty) @@ -240,6 +241,7 @@ C-m How to order printed Emacs manuals. C-n News of recent Emacs changes. C-o Emacs ordering and distribution information. C-p Info about known Emacs problems. +C-s Search forward \"help window\". C-t Emacs TODO list. C-w Information on absence of warranty for GNU Emacs." help-map) @@ -263,17 +265,19 @@ If that doesn't give a function, return nil." (condition-case () (save-excursion (save-restriction - (narrow-to-region (max (point-min) - (- (point) 1000)) (point-max)) - ;; Move up to surrounding paren, then after the open. - (backward-up-list 1) - (forward-char 1) - ;; If there is space here, this is probably something - ;; other than a real Lisp function call, so ignore it. - (if (looking-at "[ \t]") - (error "Probably not a Lisp function call")) - (let ((obj (read (current-buffer)))) - (and (symbolp obj) (fboundp obj) obj)))) + (let ((forward-sexp-function nil)) ;Use elisp-mode's value + (narrow-to-region (max (point-min) + (- (point) 1000)) + (point-max)) + ;; Move up to surrounding paren, then after the open. + (backward-up-list 1) + (forward-char 1) + ;; If there is space here, this is probably something + ;; other than a real Lisp function call, so ignore it. + (if (looking-at "[ \t]") + (error "Probably not a Lisp function call")) + (let ((obj (read (current-buffer)))) + (and (symbolp obj) (fboundp obj) obj))))) (error nil)) (let* ((str (find-tag-default)) (sym (if str (intern-soft str)))) @@ -308,8 +312,6 @@ If that doesn't give a function, return nil." (interactive) (browse-url "https://www.gnu.org/gnu/thegnuproject.html")) -(define-obsolete-function-alias 'describe-project 'describe-gnu-project "22.2") - (defun describe-no-warranty () "Display info on all the kinds of warranty Emacs does NOT have." (interactive) @@ -413,28 +415,27 @@ With argument, display info only for the selected version." (interactive "P") (view-help-file "TODO")) -(define-obsolete-function-alias 'view-todo 'view-emacs-todo "22.2") - - (defun view-echo-area-messages () "View the log of recent echo-area messages: the `*Messages*' buffer. -The number of messages retained in that buffer -is specified by the variable `message-log-max'." +The number of messages retained in that buffer is specified by +the variable `message-log-max'." (interactive) (with-current-buffer (messages-buffer) (goto-char (point-max)) - (display-buffer (current-buffer)))) + (let ((win (display-buffer (current-buffer)))) + ;; If the buffer is already displayed, we need to forcibly set + ;; the window point to scroll to the end of the buffer. + (set-window-point win (point)) + win))) (defun view-order-manuals () "Display information on how to buy printed copies of Emacs manuals." (interactive) -;; (view-help-file "ORDERS") (info "(emacs)Printed Books")) (defun view-emacs-FAQ () "Display the Emacs Frequently Asked Questions (FAQ) file." (interactive) - ;; (find-file-read-only (expand-file-name "FAQ" data-directory)) (info "(efaq)")) (defun view-emacs-problems () @@ -447,7 +448,8 @@ is specified by the variable `message-log-max'." (interactive) (view-help-file "DEBUG")) -;; This used to visit MORE.STUFF; maybe it should just be removed. +;; This used to visit a plain text file etc/MORE.STUFF; +;; maybe this command should just be removed. (defun view-external-packages () "Display info on where to get more Emacs packages." (interactive) @@ -455,6 +457,8 @@ is specified by the variable `message-log-max'." (defun view-lossage () "Display last few input keystrokes and the commands run. +For convenience this uses the same format as +`edit-last-kbd-macro'. To record all your input, use `open-dribble-file'." (interactive) @@ -465,8 +469,8 @@ To record all your input, use `open-dribble-file'." (princ (mapconcat (lambda (key) (cond ((and (consp key) (null (car key))) - (format "[%s]\n" (if (symbolp (cdr key)) (cdr key) - "anonymous-command"))) + (format ";; %s\n" (if (symbolp (cdr key)) (cdr key) + "anonymous-command"))) ((or (integerp key) (symbolp key) (listp key)) (single-key-description key)) (t @@ -475,12 +479,12 @@ To record all your input, use `open-dribble-file'." " ")) (with-current-buffer standard-output (goto-char (point-min)) - (while (not (eobp)) - (move-to-column 50) - (unless (eolp) - (fill-region (line-beginning-position) (line-end-position))) - (forward-line 1)) - ;; jidanni wants to see the last keystrokes immediately. + (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))))) @@ -593,19 +597,27 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer." string (format "%s (translated from %s)" string otherstring)))))) +(defun help--binding-undefined-p (defn) + (or (null defn) (integerp defn) (equal defn 'undefined))) + (defun help--analyze-key (key untranslated) "Get information about KEY its corresponding UNTRANSLATED events. Returns a list of the form (BRIEF-DESC DEFN EVENT MOUSE-MSG)." (if (numberp untranslated) - (setq untranslated (this-single-command-raw-keys))) - (let* ((event (aref key (if (and (symbolp (aref key 0)) - (> (length key) 1) - (consp (aref key 1))) - 1 - 0))) + (error "Missing `untranslated'!")) + (let* ((event (when (> (length key) 0) + (aref key (if (and (symbolp (aref key 0)) + (> (length key) 1) + (consp (aref key 1))) + ;; Look at the second event when the first + ;; is a pseudo-event like `mode-line' or + ;; `left-fringe'. + 1 + 0)))) (modifiers (event-modifiers event)) (mouse-msg (if (or (memq 'click modifiers) (memq 'down modifiers) - (memq 'drag modifiers)) " at that spot" "")) + (memq 'drag modifiers)) + " at that spot" "")) (defn (key-binding key t))) ;; Handle the case where we faked an entry in "Select and Paste" menu. (when (and (eq defn nil) @@ -621,27 +633,47 @@ Returns a list of the form (BRIEF-DESC DEFN EVENT MOUSE-MSG)." (list ;; Now describe the key, perhaps as changed. (let ((key-desc (help-key-description key untranslated))) - (if (or (null defn) (integerp defn) (equal defn 'undefined)) + (if (help--binding-undefined-p defn) (format "%s%s is undefined" key-desc mouse-msg) (format "%s%s runs the command %S" key-desc mouse-msg defn))) defn event mouse-msg))) -(defun describe-key-briefly (&optional key insert untranslated) - "Print the name of the function KEY invokes. KEY is a string. +(defun help--filter-info-list (info-list i) + "Drop the undefined keys." + (or + ;; Remove all `undefined' keys. + (delq nil (mapcar (lambda (x) + (unless (help--binding-undefined-p (nth i x)) x)) + info-list)) + ;; If nothing left, then keep one (the last one). + (last info-list))) + +(defun describe-key-briefly (&optional key-list insert untranslated) + "Print the name of the functions KEY-LIST invokes. +KEY-LIST is a list of pairs (SEQ . RAW-SEQ) of key sequences, where +RAW-SEQ is the untranslated form of the key sequence SEQ. If INSERT (the prefix arg) is non-nil, insert the message in the buffer. -If non-nil, UNTRANSLATED is a vector of the untranslated events. -It can also be a number in which case the untranslated events from -the last key hit are used. -If KEY is a menu item or a tool-bar button that is disabled, this command -temporarily enables it to allow getting help on disabled items and buttons." +While reading KEY-LIST interactively, this command temporarily enables +menu items or tool-bar buttons that are disabled to allow getting help +on them." + (declare (advertised-calling-convention (key-list &optional insert) "27.1")) (interactive ;; Ignore mouse movement events because it's too easy to miss the ;; message while moving the mouse. - (pcase-let ((`(,key ,_up-event) (help-read-key-sequence 'no-mouse-movement))) - `(,key ,current-prefix-arg 1))) - (princ (car (help--analyze-key key untranslated)) - (if insert (current-buffer) standard-output))) + (let ((key-list (help--read-key-sequence 'no-mouse-movement))) + `(,key-list ,current-prefix-arg))) + (when (arrayp key-list) + ;; Old calling convention, changed + (setq key-list (list (cons key-list + (if (numberp untranslated) + (this-single-command-raw-keys) + untranslated))))) + (let* ((info-list (mapcar (lambda (kr) + (help--analyze-key (car kr) (cdr kr))) + key-list)) + (msg (mapconcat #'car (help--filter-info-list info-list 1) "\n"))) + (if insert (insert msg) (message "%s" msg)))) (defun help--key-binding-keymap (key &optional accept-default no-remap position) "Return a keymap holding a binding for KEY within current keymaps. @@ -688,8 +720,7 @@ function `key-binding'." (format "%s-map" mode))))) minor-mode-map-alist)) (list 'global-map - (intern-soft (format "%s-map" major-mode))))) - found) + (intern-soft (format "%s-map" major-mode)))))) ;; Look into these advertised symbols first. (dolist (sym advertised-syms) (when (and @@ -706,225 +737,146 @@ function `key-binding'." (throw 'found x)))) nil))))) -(defun help-read-key-sequence (&optional no-mouse-movement) - "Reads a key sequence from the user. -Returns a list of the form (KEY UP-EVENT), where KEY is the key -sequence, and UP-EVENT is the up-event that was discarded by -reading KEY, or nil. +(defun help--read-key-sequence (&optional no-mouse-movement) + "Read a key sequence from the user. +Usually reads a single key sequence, except when that sequence might +hide another one (e.g. a down event, where the user is interested +in getting info about the up event, or a click event, where the user +wants to get info about the double click). +Return a list of elements of the form (SEQ . RAW-SEQ), where SEQ is a key +sequence, and RAW-SEQ is its untranslated form. If NO-MOUSE-MOVEMENT is non-nil, ignore key sequences starting with `mouse-movement' events." (let ((enable-disabled-menus-and-buttons t) (cursor-in-echo-area t) + (side-event nil) saved-yank-menu) (unwind-protect - (let (key keys down-ev discarded-up) + (let (last-modifiers key-list) ;; If yank-menu is empty, populate it temporarily, so that ;; "Select and Paste" menu can generate a complete event. (when (null (cdr yank-menu)) (setq saved-yank-menu (copy-sequence yank-menu)) (menu-bar-update-yank-menu "(any string)" nil)) (while - (pcase (setq key (read-key-sequence "\ -Describe the following key, mouse click, or menu item: ")) - ((and (pred vectorp) (let `(,key0 . ,_) (aref key 0)) - (guard (symbolp key0)) (let keyname (symbol-name key0))) - (or - (and no-mouse-movement - (string-match "mouse-movement" keyname)) - (progn (push key keys) nil) - (and (string-match "\\(mouse\\|down\\|click\\|drag\\)" - keyname) - (progn - ;; Discard events (e.g. <help-echo>) which might - ;; spuriously trigger the `sit-for'. - (sleep-for 0.01) - (while (read-event nil nil 0.01)) - (not (sit-for - (if (numberp double-click-time) - (/ double-click-time 1000.0) - 3.0) - t)))))))) - ;; When we have a sequence of mouse events, discard the most - ;; recent ones till we find one with a binding. - (let ((keys-1 keys)) - (while (and keys-1 - (not (key-binding (car keys-1)))) - ;; If we discard the last event, and this was a mouse - ;; up, remember this. - (if (and (eq keys-1 keys) - (vectorp (car keys-1)) - (let* ((last-idx (1- (length (car keys-1)))) - (last (aref (car keys-1) last-idx))) - (and (eventp last) - (memq 'click (event-modifiers last))))) - (setq discarded-up t)) - (setq keys-1 (cdr keys-1))) - (if keys-1 - (setq key (car keys-1)))) - (list - key - ;; If KEY is a down-event, read and include the - ;; corresponding up-event. Note that there are also - ;; down-events on scroll bars and mode lines: the actual - ;; event then is in the second element of the vector. - (and (not discarded-up) ; Don't attempt to ignore the up-event twice. - (vectorp key) - (let ((last-idx (1- (length key)))) - (and (eventp (aref key last-idx)) - (memq 'down (event-modifiers (aref key last-idx))))) - (or (and (eventp (setq down-ev (aref key 0))) - (memq 'down (event-modifiers down-ev)) - ;; However, for the C-down-mouse-2 popup - ;; menu, there is no subsequent up-event. In - ;; this case, the up-event is the next - ;; element in the supplied vector. - (= (length key) 1)) - (and (> (length key) 1) - (eventp (setq down-ev (aref key 1))) - (memq 'down (event-modifiers down-ev)))) - (if (and (terminal-parameter nil 'xterm-mouse-mode) - (equal (terminal-parameter nil 'xterm-mouse-last-down) - down-ev)) - (aref (read-key-sequence-vector nil) 0) - (read-event))))) + ;; Read at least one key-sequence. + (or (null key-list) + ;; After a down event, also read the (presumably) following + ;; up-event. + (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)))) + (let* ((seq (read-key-sequence "\ +Describe the following key, mouse click, or menu item: " + nil nil 'can-return-switch-frame)) + (raw-seq (this-single-command-raw-keys)) + (keyn (when (> (length seq) 0) + (aref seq (1- (length seq))))) + (base (event-basic-type keyn)) + (modifiers (event-modifiers keyn))) + (cond + ((zerop (length seq))) ;FIXME: Can this happen? + ((and no-mouse-movement (eq base 'mouse-movement)) nil) + ((memq base '(mouse-movement switch-frame select-window)) + ;; Mostly ignore these events since it's sometimes difficult to + ;; generate the event you care about without also generating + ;; these side-events along the way. + (setq side-event (cons seq raw-seq))) + ((eq base 'help-echo) nil) + (t + (setq last-modifiers modifiers) + (push (cons seq raw-seq) key-list))))) + (if side-event + (cons side-event (nreverse key-list)) + (nreverse key-list))) ;; Put yank-menu back as it was, if we changed it. (when saved-yank-menu (setq yank-menu (copy-sequence saved-yank-menu)) (fset 'yank-menu (cons 'keymap yank-menu)))))) -(defun help-downify-mouse-event-type (base) - "Add \"down-\" to BASE if it is not already there. -BASE is a symbol, a mouse event type. If the modification is done, -return the new symbol. Otherwise return nil." - (let ((base-s (symbol-name base))) - ;; Note: the order of the components in the following string is - ;; determined by `apply_modifiers_uncached' in src/keyboard.c. - (string-match "\\(A-\\)?\ -\\(C-\\)?\ -\\(H-\\)?\ -\\(M-\\)?\ -\\(S-\\)?\ -\\(s-\\)?\ -\\(double-\\)?\ -\\(triple-\\)?\ -\\(up-\\)?\ -\\(\\(down-\\)?\\)\ -\\(drag-\\)?" base-s) - (when (and (null (match-beginning 11)) ; "down-" - (null (match-beginning 12))) ; "drag-" - (intern (replace-match "down-" t t base-s 10)) ))) - -(defun describe-key (&optional key untranslated up-event) - "Display documentation of the function invoked by KEY. -KEY can be any kind of a key sequence; it can include keyboard events, +(defun describe-key (&optional key-list buffer up-event) + "Display documentation of the function invoked by KEY-LIST. +KEY-LIST can be any kind of a key sequence; it can include keyboard events, mouse events, and/or menu events. When calling from a program, -pass KEY as a string or a vector. - -If non-nil, UNTRANSLATED is a vector of the corresponding untranslated events. -It can also be a number, in which case the untranslated events from -the last key sequence entered are used. -UP-EVENT is the up-event that was discarded by reading KEY, or nil. - -If KEY is a menu item or a tool-bar button that is disabled, this command -temporarily enables it to allow getting help on disabled items and buttons." - (interactive - (pcase-let ((`(,key ,up-event) (help-read-key-sequence))) - `(,key ,(prefix-numeric-value current-prefix-arg) ,up-event))) - (pcase-let ((`(,brief-desc ,defn ,event ,mouse-msg) - (help--analyze-key key untranslated)) - (defn-up nil) (defn-up-tricky nil) - (key-locus-up nil) (key-locus-up-tricky nil) - (mouse-1-remapped nil) (mouse-1-tricky nil) - (ev-type nil)) - (if (or (null defn) - (integerp defn) - (equal defn 'undefined)) - (message "%s" brief-desc) - (help-setup-xref (list #'describe-function defn) - (called-interactively-p 'interactive)) - ;; Need to do this before erasing *Help* buffer in case event - ;; is a mouse click in an existing *Help* buffer. - (when up-event - (setq ev-type (event-basic-type up-event)) - (let ((sequence (vector up-event))) - (when (and (eq ev-type 'mouse-1) - mouse-1-click-follows-link - (not (eq mouse-1-click-follows-link 'double)) - (setq mouse-1-remapped - (mouse-on-link-p (event-start up-event)))) - (setq mouse-1-tricky (and (integerp mouse-1-click-follows-link) - (> mouse-1-click-follows-link 0))) - (cond ((stringp mouse-1-remapped) - (setq sequence mouse-1-remapped)) - ((vectorp mouse-1-remapped) - (setcar up-event (elt mouse-1-remapped 0))) - (t (setcar up-event 'mouse-2)))) - (setq defn-up (key-binding sequence nil nil (event-start up-event))) - (setq key-locus-up (help--binding-locus sequence (event-start up-event))) - (when mouse-1-tricky - (setq sequence (vector up-event)) - (aset sequence 0 'mouse-1) - (setq defn-up-tricky (key-binding sequence nil nil (event-start up-event))) - (setq key-locus-up-tricky (help--binding-locus sequence (event-start up-event)))))) +pass KEY-LIST as a list of elements (SEQ . RAW-SEQ) where SEQ is +a key-sequence and RAW-SEQ is its untranslated form. + +While reading KEY-LIST interactively, this command temporarily enables +menu items or tool-bar buttons that are disabled to allow getting help +on them. + +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")) + (interactive (list (help--read-key-sequence))) + (when (arrayp key-list) + ;; Compatibility with old calling convention. + (setq key-list (cons (list key-list) (if up-event (list up-event)))) + (when 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))) + (on-link + (mapcar (lambda (kr) + (let ((raw (cdr kr))) + (and (not (memq mouse-1-click-follows-link '(nil double))) + (> (length raw) 0) + (eq (car-safe (aref raw 0)) 'mouse-1) + (with-current-buffer buf + (mouse-on-link-p (event-start (aref raw 0))))))) + key-list)) + (info-list + (help--filter-info-list + (with-current-buffer buf + (mapcar (lambda (x) + (pcase-let* ((`(,seq . ,raw-seq) x) + (`(,brief-desc ,defn ,event ,_mouse-msg) + (help--analyze-key seq raw-seq)) + (locus + (help--binding-locus + seq (event-start event)))) + `(,seq ,brief-desc ,defn ,locus))) + key-list)) + 2))) + (help-setup-xref (list (lambda (key-list buf) + (describe-key key-list + (if (buffer-live-p buf) buf))) + key-list buf) + (called-interactively-p 'interactive)) + (if (and (<= (length info-list) 1) + (help--binding-undefined-p (nth 2 (car info-list)))) + (message "%s" (nth 1 (car info-list))) (with-help-window (help-buffer) - (princ brief-desc) - (let ((key-locus (help--binding-locus key (event-start event)))) - (when key-locus - (princ (format " (found in %s)" key-locus)))) - (princ ", which is ") - (describe-function-1 defn) - (when (vectorp key) - (let* ((last (1- (length key))) - (elt (aref key last)) - (elt-1 (if (listp elt) (copy-sequence elt) elt)) - key-1 down-event-type) - (when (and (listp elt-1) - (symbolp (car elt-1)) - (setq down-event-type (help-downify-mouse-event-type - (car elt-1)))) - (setcar elt-1 down-event-type) - (setq key-1 (vector elt-1)) - (when (key-binding key-1) - (princ (format " - -For documentation of the corresponding mouse down event <%s>, -click and hold the mouse button longer than %s second(s)." - down-event-type (if (numberp double-click-time) - (/ double-click-time 1000.0) - 3))))))) - (when up-event - (unless (or (null defn-up) - (integerp defn-up) - (equal defn-up 'undefined)) - (princ (format " - ------------------ up-event %s---------------- - -%s%s%s runs the command %S%s, which is " - (if mouse-1-tricky "(short click) " "") - (key-description (vector up-event)) - mouse-msg - (if mouse-1-remapped - " is remapped to <mouse-2>, which" "") - defn-up (if key-locus-up - (format " (found in %s)" key-locus-up) - ""))) - (describe-function-1 defn-up)) - (unless (or (null defn-up-tricky) - (integerp defn-up-tricky) - (eq defn-up-tricky 'undefined)) - (princ (format " - ------------------ up-event (long click) ---------------- - -Pressing <%S>%s for longer than %d milli-seconds -runs the command %S%s, which is " - ev-type mouse-msg - mouse-1-click-follows-link - defn-up-tricky (if key-locus-up-tricky - (format " (found in %s)" key-locus-up-tricky) - ""))) - (describe-function-1 defn-up-tricky))))))) + (when (> (length info-list) 1) + ;; FIXME: Make this into clickable hyperlinks. + (princ "There were several key-sequences:\n\n") + (princ (mapconcat (lambda (info) + (pcase-let ((`(,_seq ,brief-desc ,_defn ,_locus) + info)) + (concat " " brief-desc))) + info-list + "\n")) + (when (delq nil on-link) + (princ "\n\nThose are influenced by `mouse-1-click-follows-link'")) + (princ "\n\nThey're all described below.")) + (pcase-dolist (`(,_seq ,brief-desc ,defn ,locus) + info-list) + (when defn + (when (> (length info-list) 1) + (with-current-buffer standard-output + (insert "\n\n" + ;; FIXME: Can't use eval-when-compile because purified + ;; strings lose their text properties :-( + (propertize "\n" 'face '(:height 0.1 :inverse-video t)) + "\n"))) + + (princ brief-desc) + (when locus + (princ (format " (found in %s)" locus))) + (princ ", which is ") + (describe-function-1 defn))))))) (defun describe-mode (&optional buffer) "Display documentation of current major mode and minor modes. @@ -970,6 +922,10 @@ documentation for the major and minor modes of that buffer." (push (list fmode pretty-minor-mode (format-mode-line (assq mode minor-mode-alist))) minor-modes))))) + ;; Narrowing is not a minor mode, but its indicator is part of + ;; mode-line-modes. + (when (buffer-narrowed-p) + (push '(narrow-to-region "Narrow" " Narrow") minor-modes)) (setq minor-modes (sort minor-modes (lambda (a b) (string-lessp (cadr a) (cadr b))))) @@ -1029,6 +985,13 @@ documentation for the major and minor modes of that buffer." ;; For the sake of IELM and maybe others nil) +(defun search-forward-help-for-help () + "Search forward \"help window\"." + (interactive) + ;; Move cursor to the "help window". + (pop-to-buffer " *Metahelp*") + ;; Do incremental search forward. + (isearch-forward nil t)) (defun describe-minor-mode (minor-mode) "Display documentation of a minor mode given as MINOR-MODE. @@ -1118,9 +1081,12 @@ is currently activated with completion." (setq minor-modes (cdr minor-modes))))) result)) +(declare-function x-display-pixel-height "xfns.c" (&optional terminal)) +(declare-function x-display-pixel-width "xfns.c" (&optional terminal)) + ;;; Automatic resizing of temporary buffers. (defcustom temp-buffer-max-height - (lambda (buffer) + (lambda (_buffer) (if (and (display-graphic-p) (eq (selected-window) (frame-root-window))) (/ (x-display-pixel-height) (frame-char-height) 2) (/ (- (frame-height) 2) 2))) @@ -1137,7 +1103,7 @@ function is called, the window to be resized is selected." :version "24.3") (defcustom temp-buffer-max-width - (lambda (buffer) + (lambda (_buffer) (if (and (display-graphic-p) (eq (selected-window) (frame-root-window))) (/ (x-display-pixel-width) (frame-char-width) 2) (/ (- (frame-width) 2) 2))) @@ -1155,9 +1121,6 @@ function is called, the window to be resized is selected." (define-minor-mode temp-buffer-resize-mode "Toggle auto-resizing temporary buffer windows (Temp Buffer Resize Mode). -With a prefix argument ARG, enable Temp Buffer Resize mode if ARG -is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. When Temp Buffer Resize mode is enabled, the windows in which we show a temporary buffer are automatically resized in height to diff --git a/lisp/hexl.el b/lisp/hexl.el index 000e79566a2..ee5a9c0fce2 100644 --- a/lisp/hexl.el +++ b/lisp/hexl.el @@ -58,53 +58,45 @@ (const 16) (const 32) (const 64)) - :group 'hexl :version "24.3") (defcustom hexl-program "hexl" "The program that will hexlify and dehexlify its stdin. `hexl-program' will always be concatenated with `hexl-options' and \"-de\" when dehexlifying a buffer." - :type 'string - :group 'hexl) + :type 'string) (defcustom hexl-iso "" "If your Emacs can handle ISO characters, this should be set to \"-iso\" otherwise it should be \"\"." - :type 'string - :group 'hexl) + :type 'string) (defcustom hexl-options (format "-hex %s" hexl-iso) "Space separated options to `hexl-program' that suit your needs. Quoting cannot be used, so the arguments cannot themselves contain spaces. If you wish to set the `-group-by-X-bits' options, set `hexl-bits' instead, as that will override any bit grouping options set here." - :type 'string - :group 'hexl) + :type 'string) (defcustom hexl-follow-ascii t "If non-nil then highlight the ASCII character corresponding to point." :type 'boolean - :group 'hexl :version "20.3") (defcustom hexl-mode-hook '(hexl-follow-line hexl-activate-ruler) "Normal hook run when entering Hexl mode." :type 'hook - :options '(hexl-follow-line hexl-activate-ruler eldoc-mode) - :group 'hexl) + :options '(hexl-follow-line hexl-activate-ruler eldoc-mode)) (defface hexl-address-region '((t (:inherit header-line))) - "Face used in address area of Hexl mode buffer." - :group 'hexl) + "Face used in address area of Hexl mode buffer.") (defface hexl-ascii-region '((t (:inherit header-line))) - "Face used in ASCII area of Hexl mode buffer." - :group 'hexl) + "Face used in ASCII area of Hexl mode buffer.") -(defvar hexl-max-address 0 +(defvar-local hexl-max-address 0 "Maximum offset into hexl buffer.") (defvar hexl-mode-map @@ -252,24 +244,6 @@ as that will override any bit grouping options set here." "The length of a hexl display line (varies with `hexl-bits')." (+ 60 (/ 128 (or hexl-bits 16)))) -(defun hexl-mode--minor-mode-p (var) - (memq var '(ruler-mode hl-line-mode))) - -(defun hexl-mode--setq-local (var val) - ;; `var' can be either a symbol or a pair, in which case the `car' - ;; is the getter function and the `cdr' is the corresponding setter. - (unless (or (member var hexl-mode--old-var-vals) - (assoc var hexl-mode--old-var-vals)) - (push (if (or (consp var) (boundp var)) - (cons var - (if (consp var) (funcall (car var)) (symbol-value var))) - var) - hexl-mode--old-var-vals)) - (cond - ((consp var) (funcall (cdr var) val)) - ((hexl-mode--minor-mode-p var) (funcall var (if val 1 -1))) - (t (set (make-local-variable var) val)))) - ;;;###autoload (defun hexl-mode (&optional arg) "\\<hexl-mode-map>A mode for editing binary files in hex dump format. @@ -364,35 +338,33 @@ You can use \\[hexl-find-file] to visit a file in Hexl mode. (or (bolp) (setq original-point (1- original-point)))) (hexlify-buffer) (restore-buffer-modified-p modified)) - (set (make-local-variable 'hexl-max-address) - (+ (* (/ (1- (buffer-size)) (hexl-line-displen)) 16) 15)) + (setq hexl-max-address + (+ (* (/ (1- (buffer-size)) (hexl-line-displen)) 16) 15)) (condition-case nil (hexl-goto-address original-point) (error nil))) - ;; We do not turn off the old major mode; instead we just - ;; override most of it. That way, we can restore it perfectly. + (let ((max-address hexl-max-address)) + (major-mode-suspend) + (setq hexl-max-address max-address)) - (hexl-mode--setq-local '(current-local-map . use-local-map) hexl-mode-map) + (use-local-map hexl-mode-map) - (hexl-mode--setq-local 'mode-name "Hexl") - (hexl-mode--setq-local 'isearch-search-fun-function - 'hexl-isearch-search-function) - (hexl-mode--setq-local 'major-mode 'hexl-mode) + (setq-local mode-name "Hexl") + (setq-local isearch-search-fun-function #'hexl-isearch-search-function) + (setq-local major-mode 'hexl-mode) - (hexl-mode--setq-local '(syntax-table . set-syntax-table) - (standard-syntax-table)) + ;; (set-syntax-table (standard-syntax-table)) - (add-hook 'write-contents-functions 'hexl-save-buffer nil t) + (add-hook 'write-contents-functions #'hexl-save-buffer nil t) - (hexl-mode--setq-local 'require-final-newline nil) + (setq-local require-final-newline nil) - (hexl-mode--setq-local 'font-lock-defaults '(hexl-font-lock-keywords t)) + (setq-local font-lock-defaults '(hexl-font-lock-keywords t)) - (hexl-mode--setq-local 'revert-buffer-function - #'hexl-revert-buffer-function) - (add-hook 'change-major-mode-hook 'hexl-maybe-dehexlify-buffer nil t) + (setq-local revert-buffer-function #'hexl-revert-buffer-function) + (add-hook 'change-major-mode-hook #'hexl-maybe-dehexlify-buffer nil t) ;; Set a callback function for eldoc. (add-function :before-until (local 'eldoc-documentation-function) @@ -401,7 +373,7 @@ You can use \\[hexl-find-file] to visit a file in Hexl mode. (eldoc-remove-command "hexl-save-buffer" "hexl-current-address") - (if hexl-follow-ascii (hexl-follow-ascii 1))) + (if hexl-follow-ascii (hexl-follow-ascii-mode 1))) (run-mode-hooks 'hexl-mode-hook)) @@ -469,6 +441,7 @@ and edit the file in `hexl-mode'." (hexl-mode))) (defun hexl-revert-buffer-function (_ignore-auto _noconfirm) + ;; FIXME: We don't obey revert-buffer-preserve-modes! (let ((coding-system-for-read 'no-conversion) revert-buffer-function) ;; Call the original `revert-buffer' without code conversion; also @@ -481,7 +454,7 @@ and edit the file in `hexl-mode'." ;; already hexl-mode. ;; 2. reset change-major-mode-hook in case that `hexl-mode' ;; previously added hexl-maybe-dehexlify-buffer to it. - (remove-hook 'change-major-mode-hook 'hexl-maybe-dehexlify-buffer t) + (remove-hook 'change-major-mode-hook #'hexl-maybe-dehexlify-buffer t) (setq major-mode 'fundamental-mode) (hexl-mode))) @@ -494,7 +467,7 @@ With arg, don't unhexlify buffer." (inhibit-read-only t) (original-point (1+ (hexl-current-address)))) (dehexlify-buffer) - (remove-hook 'write-contents-functions 'hexl-save-buffer t) + (remove-hook 'write-contents-functions #'hexl-save-buffer t) (restore-buffer-modified-p modified) (goto-char original-point) ;; Maybe adjust point for the removed CR characters. @@ -504,27 +477,8 @@ With arg, don't unhexlify buffer." (or (bobp) (setq original-point (1+ original-point)))) (goto-char original-point))) - (remove-hook 'change-major-mode-hook 'hexl-maybe-dehexlify-buffer t) - (remove-hook 'post-command-hook 'hexl-follow-ascii-find t) - (setq hexl-ascii-overlay nil) - - (let ((mms ())) - (dolist (varval hexl-mode--old-var-vals) - (let* ((bound (consp varval)) - (var (if bound (car varval) varval)) - (val (cdr-safe varval))) - (cond - ((consp var) (funcall (cdr var) val)) - ((hexl-mode--minor-mode-p var) (push (cons var val) mms)) - (bound (set (make-local-variable var) val)) - (t (kill-local-variable var))))) - (kill-local-variable 'hexl-mode--old-var-vals) - ;; Enable/disable minor modes. Do it after having reset the other vars, - ;; since some of them may affect the minor modes. - (dolist (mm mms) - (funcall (car mm) (if (cdr mm) 1 -1)))) - - (force-mode-line-update)) + (remove-hook 'change-major-mode-hook #'hexl-maybe-dehexlify-buffer t) + (major-mode-restore)) (defun hexl-maybe-dehexlify-buffer () "Convert a hexl format buffer to binary. @@ -534,7 +488,7 @@ Ask the user for confirmation." (inhibit-read-only t) (original-point (1+ (hexl-current-address)))) (dehexlify-buffer) - (remove-hook 'write-contents-functions 'hexl-save-buffer t) + (remove-hook 'write-contents-functions #'hexl-save-buffer t) (restore-buffer-modified-p modified) (goto-char original-point)))) @@ -923,17 +877,18 @@ and their encoded form is inserted byte by byte." "0x%x -- invalid character code; use \\[hexl-insert-hex-string]" ch)) (t - (let ((encoded (encode-coding-char ch coding)) - (internal (string-as-unibyte (char-to-string ch))) - internal-hex) - ;; If encode-coding-char returns nil, it means our character - ;; cannot be safely encoded with buffer-file-coding-system. - ;; In that case, we offer to insert the internal representation - ;; of that character, byte by byte. - (when (null encoded) - (setq internal-hex - (mapconcat (function (lambda (c) (format "%x" c))) - internal " ")) + (let ((encoded (encode-coding-char ch coding)) + (internal (char-to-string ch)) + internal-hex) + ;; If encode-coding-char returns nil, it means our character + ;; cannot be safely encoded with buffer-file-coding-system. + ;; In that case, we offer to insert the internal representation + ;; of that character, byte by byte. + (when (null encoded) + (setq internal (encode-coding-string internal 'utf-8-emacs) + internal-hex + (mapconcat (function (lambda (c) (format "%x" c))) + internal " ")) (if (yes-or-no-p (format-message "Insert char 0x%x's internal representation \"%s\"? " @@ -1041,48 +996,49 @@ Embedded whitespace, dashes, and periods in the string are ignored." (error "Decimal number out of range") (hexl-insert-multibyte-char num arg)))) -(defun hexl-follow-ascii (&optional arg) - "Toggle following ASCII in Hexl buffers. -With prefix ARG, turn on following if and only if ARG is positive. +(define-minor-mode hexl-follow-ascii-mode + "Minor mode to follow ASCII in current Hexl buffer. + When following is enabled, the ASCII character corresponding to the element under the point is highlighted. -Customize the variable `hexl-follow-ascii' to disable this feature." - (interactive "P") +The default activation is controlled by `hexl-follow-ascii'." + :global nil + (if hexl-follow-ascii-mode + ;; turn it on + (progn + (unless hexl-ascii-overlay + (setq hexl-ascii-overlay (make-overlay (point) (point))) + (overlay-put hexl-ascii-overlay 'face 'highlight)) + (add-hook 'post-command-hook #'hexl-follow-ascii-find nil t)) + ;; turn it off + (when hexl-ascii-overlay + (delete-overlay hexl-ascii-overlay) + (setq hexl-ascii-overlay nil)) + (remove-hook 'post-command-hook #'hexl-follow-ascii-find t))) + +(define-minor-mode hexl-follow-ascii + "Toggle following ASCII in Hexl buffers. +Like `hexl-follow-ascii-mode' but remembers the choice globally." + :global t (let ((on-p (if arg (> (prefix-numeric-value arg) 0) (not hexl-ascii-overlay)))) - - (if on-p - ;; turn it on - (if (not hexl-ascii-overlay) - (progn - (setq hexl-ascii-overlay (make-overlay 1 1) - hexl-follow-ascii t) - (overlay-put hexl-ascii-overlay 'face 'highlight) - (add-hook 'post-command-hook 'hexl-follow-ascii-find nil t))) - ;; turn it off - (if hexl-ascii-overlay - (progn - (delete-overlay hexl-ascii-overlay) - (setq hexl-ascii-overlay nil - hexl-follow-ascii nil) - (remove-hook 'post-command-hook 'hexl-follow-ascii-find t) - ))))) + (hexl-follow-ascii-mode (if on-p 1 -1)) + ;; Remember this choice globally for later use. + (setq hexl-follow-ascii hexl-follow-ascii-mode))) (defun hexl-activate-ruler () "Activate `ruler-mode'." (require 'ruler-mode) - (hexl-mode--setq-local 'ruler-mode-ruler-function - #'hexl-mode-ruler) - (hexl-mode--setq-local 'ruler-mode t)) + (setq-local ruler-mode-ruler-function #'hexl-mode-ruler) + (ruler-mode 1)) (defun hexl-follow-line () "Activate `hl-line-mode'." (require 'hl-line) - (hexl-mode--setq-local 'hl-line-range-function - #'hexl-highlight-line-range) - (hexl-mode--setq-local 'hl-line-face 'highlight) - (hexl-mode--setq-local 'hl-line-mode t)) + (setq-local hl-line-range-function #'hexl-highlight-line-range) + (setq-local hl-line-face 'highlight) ;FIXME: Why? + (hl-line-mode 1)) (defun hexl-highlight-line-range () "Return the range of address region for the point. @@ -1134,7 +1090,7 @@ This function is assumed to be used as callback function for `hl-line-mode'." ;; startup stuff. (easy-menu-define hexl-menu hexl-mode-map "Hexl Mode menu" - `("Hexl" + '("Hexl" :help "Hexl-specific Features" ["Backward short" hexl-backward-short diff --git a/lisp/hfy-cmap.el b/lisp/hfy-cmap.el index 310805652f2..70fcd1504e7 100644 --- a/lisp/hfy-cmap.el +++ b/lisp/hfy-cmap.el @@ -1,15 +1,14 @@ -;;; hfy-cmap.el --- Fallback colour name -> rgb mapping for `htmlfontify' +;;; hfy-cmap.el --- Fallback color name -> rgb mapping for `htmlfontify' ;; Copyright (C) 2002-2003, 2009-2019 Free Software Foundation, Inc. ;; Emacs Lisp Archive Entry ;; Package: htmlfontify ;; Filename: hfy-cmap.el -;; Keywords: colour, rgb +;; Keywords: color, rgb ;; Author: Vivek Dasmohapatra <vivek@etla.org> -;; Maintainer: Vivek Dasmohapatra <vivek@etla.org> ;; Created: 2002-01-20 -;; Description: fallback code for colour name -> rgb mapping +;; Description: fallback code for color name -> rgb mapping ;; URL: http://rtfm.etla.org/emacs/htmlfontify/ ;; Last-Updated: Sat 2003-02-15 03:49:32 +0000 @@ -32,7 +31,11 @@ ;;; Code: -(defconst hfy-fallback-colour-map +(define-obsolete-variable-alias + 'hfy-fallback-colour-map + 'hfy-fallback-color-map "27.1") + +(defconst hfy-fallback-color-map '(("snow" 65535 64250 64250) ("ghost white" 63736 63736 65535) ("GhostWhite" 63736 63736 65535) @@ -786,7 +789,11 @@ ("light green" 37008 61166 37008) ("LightGreen" 37008 61166 37008)) ) -(defvar hfy-rgb-txt-colour-map nil) +(define-obsolete-variable-alias + 'hfy-rgb-txt-colour-map + 'hfy-rgb-txt-color-map "27.1") + +(defvar hfy-rgb-txt-color-map nil) (defvar hfy-rgb-load-path (list "/etc/X11" @@ -806,8 +813,8 @@ (defun htmlfontify-load-rgb-file (&optional file) "Load an X11 style rgb.txt FILE. Search `hfy-rgb-load-path' if FILE is not specified. -Loads the variable `hfy-rgb-txt-colour-map', which is used by -`hfy-fallback-colour-values'." +Loads the variable `hfy-rgb-txt-color-map', which is used by +`hfy-fallback-color-values'." (interactive (list (read-file-name "rgb.txt (equivalent) file: " "" nil t (hfy-rgb-file)))) @@ -822,25 +829,28 @@ Loads the variable `hfy-rgb-txt-colour-map', which is used by (htmlfontify-unload-rgb-file) (while (/= end-of-rgb 1) (if (looking-at hfy-rgb-regex) - (setq hfy-rgb-txt-colour-map + (setq hfy-rgb-txt-color-map (cons (list (match-string 4) (string-to-number (match-string 1)) (string-to-number (match-string 2)) (string-to-number (match-string 3))) - hfy-rgb-txt-colour-map)) ) + hfy-rgb-txt-color-map)) ) (setq end-of-rgb (forward-line))) (kill-buffer rgb-buffer))))) (defun htmlfontify-unload-rgb-file () "Unload the current color name -> rgb translation map." (interactive) - (setq hfy-rgb-txt-colour-map nil)) + (setq hfy-rgb-txt-color-map nil)) ;;;###autoload -(defun hfy-fallback-colour-values (colour-string) +(defun hfy-fallback-color-values (color-string) "Use a fallback method for obtaining the rgb values for a color." - (cdr (assoc-string colour-string (or hfy-rgb-txt-colour-map - hfy-fallback-colour-map))) ) + (cdr (assoc-string color-string (or hfy-rgb-txt-color-map + hfy-fallback-color-map))) ) +(define-obsolete-function-alias + 'hfy-fallback-colour-values + 'hfy-fallback-color-values "27.1") (provide 'hfy-cmap) diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el index ce16c924524..f790546747d 100644 --- a/lisp/hi-lock.el +++ b/lisp/hi-lock.el @@ -177,6 +177,26 @@ Instead, each hi-lock command will cycle through the faces in "Face for hi-lock mode." :group 'hi-lock-faces) +(defface hi-salmon + '((((min-colors 88) (background dark)) + (:background "light salmon" :foreground "black")) + (((background dark)) (:background "red" :foreground "black")) + (((min-colors 88)) (:background "light salmon")) + (t (:background "red"))) + "Face for hi-lock mode." + :group 'hi-lock-faces + :version "27.1") + +(defface hi-aquamarine + '((((min-colors 88) (background dark)) + (:background "aquamarine" :foreground "black")) + (((background dark)) (:background "blue" :foreground "black")) + (((min-colors 88)) (:background "aquamarine")) + (t (:background "blue"))) + "Face for hi-lock mode." + :group 'hi-lock-faces + :version "27.1") + (defface hi-black-b '((t (:weight bold))) "Face for hi-lock mode." @@ -189,13 +209,13 @@ Instead, each hi-lock command will cycle through the faces in :group 'hi-lock-faces) (defface hi-green-b - '((((min-colors 88)) (:weight bold :foreground "green1")) + '((((min-colors 88)) (:weight bold :foreground "green3")) (t (:weight bold :foreground "green"))) "Face for hi-lock mode." :group 'hi-lock-faces) (defface hi-red-b - '((((min-colors 88)) (:weight bold :foreground "red1")) + '((((min-colors 88)) (:weight bold :foreground "firebrick2")) (t (:weight bold :foreground "red"))) "Face for hi-lock mode." :group 'hi-lock-faces) @@ -216,8 +236,8 @@ Instead, each hi-lock command will cycle through the faces in (define-obsolete-variable-alias 'hi-lock-face-history 'hi-lock-face-defaults "23.1") (defvar hi-lock-face-defaults - '("hi-yellow" "hi-pink" "hi-green" "hi-blue" "hi-black-b" - "hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb") + '("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.") (define-obsolete-variable-alias 'hi-lock-regexp-history @@ -289,9 +309,6 @@ a library is being loaded.") ;;;###autoload (define-minor-mode hi-lock-mode "Toggle selective highlighting of patterns (Hi Lock mode). -With a prefix argument ARG, enable Hi Lock mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Hi Lock mode is automatically enabled when you invoke any of the highlighting commands listed below, such as \\[highlight-regexp]. @@ -436,10 +453,12 @@ highlighting will not update as you type." ;;;###autoload (defalias 'highlight-regexp 'hi-lock-face-buffer) ;;;###autoload -(defun hi-lock-face-buffer (regexp &optional face) +(defun hi-lock-face-buffer (regexp &optional face subexp) "Set face of each match of REGEXP to FACE. Interactively, prompt for REGEXP using `read-regexp', then FACE. -Use the global history list for FACE. +Use the global history list for FACE. Limit face setting to the +corresponding SUBEXP (interactively, the prefix argument) of REGEXP. +If SUBEXP is omitted or nil, the entire REGEXP is highlighted. Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, use overlays for highlighting. If overlays are used, the @@ -448,10 +467,11 @@ highlighting will not update as you type." (list (hi-lock-regexp-okay (read-regexp "Regexp to highlight" 'regexp-history-last)) - (hi-lock-read-face-name))) + (hi-lock-read-face-name) + current-prefix-arg)) (or (facep face) (setq face 'hi-yellow)) (unless hi-lock-mode (hi-lock-mode 1)) - (hi-lock-set-pattern regexp face)) + (hi-lock-set-pattern regexp face subexp)) ;;;###autoload (defalias 'highlight-phrase 'hi-lock-face-phrase-buffer) @@ -563,7 +583,7 @@ then remove all hi-lock highlighting." (x-popup-menu t (cons - `keymap + 'keymap (cons "Select Pattern to Unhighlight" (mapcar (lambda (pattern) (list (car pattern) @@ -693,11 +713,14 @@ with completion and history." (add-to-list 'hi-lock-face-defaults face t)) (intern face))) -(defun hi-lock-set-pattern (regexp face) - "Highlight REGEXP with face FACE." +(defun hi-lock-set-pattern (regexp face &optional subexp) + "Highlight SUBEXP of REGEXP with face FACE. +If omitted or nil, SUBEXP defaults to zero, i.e. the entire +REGEXP is highlighted." ;; Hashcons the regexp, so it can be passed to remove-overlays later. (setq regexp (hi-lock--hashcons regexp)) - (let ((pattern (list regexp (list 0 (list 'quote face) 'prepend))) + (setq subexp (or subexp 0)) + (let ((pattern (list regexp (list subexp (list 'quote face) 'prepend))) (no-matches t)) ;; Refuse to highlight a text that is already highlighted. (if (assoc regexp hi-lock-interactive-patterns) @@ -719,7 +742,8 @@ with completion and history." (goto-char search-start) (while (re-search-forward regexp search-end t) (when no-matches (setq no-matches nil)) - (let ((overlay (make-overlay (match-beginning 0) (match-end 0)))) + (let ((overlay (make-overlay (match-beginning subexp) + (match-end subexp)))) (overlay-put overlay 'hi-lock-overlay t) (overlay-put overlay 'hi-lock-overlay-regexp regexp) (overlay-put overlay 'face face)) diff --git a/lisp/hilit-chg.el b/lisp/hilit-chg.el index d4d83902d97..272f7584bbe 100644 --- a/lisp/hilit-chg.el +++ b/lisp/hilit-chg.el @@ -204,9 +204,6 @@ :group 'highlight-changes) ;; A (not very good) default list of colors to rotate through. -(define-obsolete-variable-alias 'highlight-changes-colours - 'highlight-changes-colors "22.1") - (defcustom highlight-changes-colors (if (eq (frame-parameter nil 'background-mode) 'light) ;; defaults for light background: @@ -322,9 +319,6 @@ remove it from existing buffers." ;;;###autoload (define-minor-mode highlight-changes-mode "Toggle highlighting changes in this buffer (Highlight Changes mode). -With a prefix argument ARG, enable Highlight Changes mode if ARG -is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. When Highlight Changes is enabled, changes are marked with a text property. Normally they are displayed in a distinctive face, but @@ -363,9 +357,6 @@ buffer with the contents of a file ;;;###autoload (define-minor-mode highlight-changes-visible-mode "Toggle visibility of highlighting due to Highlight Changes mode. -With a prefix argument ARG, enable Highlight Changes Visible mode -if ARG is positive, and disable it otherwise. If called from -Lisp, enable the mode if ARG is omitted or nil. Highlight Changes Visible mode only has an effect when Highlight Changes mode is on. When enabled, the changed text is displayed diff --git a/lisp/hl-line.el b/lisp/hl-line.el index 3abebe6c690..8d929b8bb09 100644 --- a/lisp/hl-line.el +++ b/lisp/hl-line.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1998, 2000-2019 Free Software Foundation, Inc. -;; Author: Dave Love <fx@gnu.org> +;; Author: Dave Love <fx@gnu.org> ;; Maintainer: emacs-devel@gnu.org ;; Created: 1998-09-13 ;; Keywords: faces, frames, emulations @@ -132,9 +132,6 @@ This variable is expected to be made buffer-local by modes.") ;;;###autoload (define-minor-mode hl-line-mode "Toggle highlighting of the current line (Hl-Line mode). -With a prefix argument ARG, enable Hl-Line mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Hl-Line mode is a buffer-local minor mode. If `hl-line-sticky-flag' is non-nil, Hl-Line mode highlights the @@ -203,9 +200,6 @@ such overlays in all buffers except the current one." ;;;###autoload (define-minor-mode global-hl-line-mode "Toggle line highlighting in all buffers (Global Hl-Line mode). -With a prefix argument ARG, enable Global Hl-Line mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. 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 diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el index 93e8a8a1f79..dfba025742a 100644 --- a/lisp/htmlfontify.el +++ b/lisp/htmlfontify.el @@ -8,7 +8,6 @@ ;; Version: 0.21 ;; Keywords: html, hypermedia, markup, etags ;; Author: Vivek Dasmohapatra <vivek@etla.org> -;; Maintainer: Vivek Dasmohapatra <vivek@etla.org> ;; Created: 2002-01-05 ;; Description: htmlize a buffer/source tree with optional hyperlinks ;; URL: http://rtfm.etla.org/emacs/htmlfontify/ @@ -448,6 +447,7 @@ and so on." (background (choice (const :tag "Dark" dark ) (const :tag "Bright" light ))) )) +(define-obsolete-variable-alias 'hfy-optimisations 'hfy-optimizations "25.1") (defcustom hfy-optimizations (list 'keep-overlays) "Optimizations to turn on: So far, the following have been implemented:\n merge-adjacent-tags: If two (or more) span tags are adjacent, identical and @@ -483,7 +483,6 @@ which can never slow you down, but may result in incomplete fontification." (const :tag "body-text-only" body-text-only )) :group 'htmlfontify :tag "optimizations") -(define-obsolete-variable-alias 'hfy-optimisations 'hfy-optimizations "25.1") (defvar hfy-tags-cache nil "Alist of the form:\n @@ -567,7 +566,7 @@ therefore no longer care about) will be invalid at any time.\n (defvar hfy-tmpfont-stack nil "An alist of derived fonts resulting from overlays.") -(defconst hfy-hex-regex "[0-9A-Fa-f]") +(defconst hfy-hex-regex "[[:xdigit:]]") (defconst hfy-triplet-regex (concat @@ -584,22 +583,23 @@ therefore no longer care about) will be invalid at any time.\n (if (memq elt set-b) (setq interq (cons elt interq)))) interq)) -(defun hfy-colour-vals (colour) - "Where COLOUR is a color name or #XXXXXX style triplet, return a +(defun hfy-color-vals (color) + "Where COLOR is a color name or #XXXXXX style triplet, return a list of three (16 bit) rgb values for said color.\n -If a window system is unavailable, calls `hfy-fallback-colour-values'." - (if (string-match hfy-triplet-regex colour) +If a window system is unavailable, calls `hfy-fallback-color-values'." + (if (string-match hfy-triplet-regex color) (mapcar - (lambda (x) (* (string-to-number (match-string x colour) 16) 257)) + (lambda (x) (* (string-to-number (match-string x color) 16) 257)) '(1 2 3)) - ;;(message ">> %s" colour) + ;;(message ">> %s" color) (if window-system (if (fboundp 'color-values) - (color-values colour) + (color-values color) ;;(message "[%S]" window-system) - (x-color-values colour)) + (x-color-values color)) ;; blarg - tty colors are no good - go fetch some X colors: - (hfy-fallback-colour-values colour)))) + (hfy-fallback-color-values color)))) +(define-obsolete-function-alias 'hfy-colour-vals 'hfy-color-vals "27.1") (defvar hfy-cperl-mode-kludged-p nil) @@ -738,7 +738,7 @@ FILE is the name of the file being rendered, in case it is needed." "Replace the end of a CSS style declaration STYLE-STRING with the contents of the variable `hfy-src-doc-link-style', removing text matching the regex `hfy-src-doc-link-unstyle' first, if necessary." - ;;(message "hfy-colour-vals");;DBUG + ;;(message "hfy-color-vals");;DBUG (if (string-match hfy-src-doc-link-unstyle style-string) (setq style-string (replace-match "" 'fixed-case 'literal style-string))) (if (and (not (string-match hfy-src-doc-link-style style-string)) @@ -751,19 +751,19 @@ of the variable `hfy-src-doc-link-style', removing text matching the regex ;; utility functions - cast emacs style specification values into their ;; css2 equivalents: -(defun hfy-triplet (colour) - "Takes a COLOUR name (string) and return a CSS rgb(R, G, B) triplet string. +(defun hfy-triplet (color) + "Takes a COLOR name (string) and return a CSS rgb(R, G, B) triplet string. Uses the definition of \"white\" to map the numbers to the 0-255 range, so if you've redefined white, (esp. if you've redefined it to have a triplet member lower than that of the color you are processing) strange things may happen." - ;;(message "hfy-colour-vals");;DBUG + ;;(message "hfy-color-vals");;DBUG ;; TODO? Can we do somehow do better than this? (cond - ((equal colour "unspecified-fg") (setq colour "black")) - ((equal colour "unspecified-bg") (setq colour "white"))) - (let ((white (mapcar (lambda (I) (float (1+ I))) (hfy-colour-vals "white"))) - (rgb16 (mapcar (lambda (I) (float (1+ I))) (hfy-colour-vals colour)))) + ((equal color "unspecified-fg") (setq color "black")) + ((equal color "unspecified-bg") (setq color "white"))) + (let ((white (mapcar (lambda (I) (float (1+ I))) (hfy-color-vals "white"))) + (rgb16 (mapcar (lambda (I) (float (1+ I))) (hfy-color-vals color)))) (if rgb16 ;;(apply 'format "rgb(%d, %d, %d)" ;; Use #rrggbb instead, it is smaller @@ -774,8 +774,9 @@ may happen." '(0 1 2)))))) (defun hfy-family (family) (list (cons "font-family" family))) -(defun hfy-bgcol (colour) (list (cons "background" (hfy-triplet colour)))) -(defun hfy-colour (colour) (list (cons "color" (hfy-triplet colour)))) +(defun hfy-bgcol (color) (list (cons "background" (hfy-triplet color)))) +(defun hfy-color (color) (list (cons "color" (hfy-triplet color)))) +(define-obsolete-function-alias 'hfy-colour 'hfy-color "27.1") (defun hfy-width (width) (list (cons "font-stretch" (symbol-name width)))) (defcustom hfy-font-zoom 1.05 @@ -825,17 +826,17 @@ regular specifiers." (let ((tag (car spec)) (val (cadr spec))) (cons (cl-case tag - (:color (cons "colour" val)) + (:color (cons "color" val)) (:width (cons "width" val)) (:style (cons "style" val))) (hfy-box-to-border-assoc (cddr spec)))))) (defun hfy-box-to-style (spec) (let* ((css (hfy-box-to-border-assoc spec)) - (col (cdr (assoc "colour" css))) + (col (cdr (assoc "color" css))) (s (cdr (assoc "style" css)))) (list - (if col (cons "border-color" (cdr (assoc "colour" css)))) + (if col (cons "border-color" (cdr (assoc "color" css)))) (cons "border-width" (format "%dpx" (or (cdr (assoc "width" css)) 1))) (cons "border-style" (cl-case s (released-button "outset") @@ -1014,7 +1015,7 @@ merged by the user - `hfy-flatten-style' should do this." (:width (hfy-width val)) (:weight (hfy-weight val)) (:slant (hfy-slant val)) - (:foreground (hfy-colour val)) + (:foreground (hfy-color val)) (:background (hfy-bgcol val)) (:box (hfy-box val)) (:height (hfy-size val)) @@ -1650,7 +1651,8 @@ The default handler is `hfy-end-span'.") SRCDIR, if set, is the directory being htmlfontified. FILE, if set, is the file name." (if srcdir (setq srcdir (directory-file-name srcdir))) - (let* ( (html-buffer (hfy-buffer)) + (let* ( (inhibit-read-only t) + (html-buffer (hfy-buffer)) (css-sheet nil) (css-map nil) (invis-ranges nil) @@ -1828,10 +1830,11 @@ fontified. This is a simple convenience wrapper around (noninteractive (message "hfy batch mode (%s:%S)" (or (buffer-file-name) (buffer-name)) major-mode) - (if (fboundp 'font-lock-ensure) + (if (fboundp 'font-lock-ensure) ; Emacs >= 25.1 (font-lock-ensure) (when font-lock-defaults - (font-lock-fontify-buffer)))) + ; Silence "interactive use only" warning on Emacs >= 25.1. + (with-no-warnings (font-lock-fontify-buffer))))) ((fboundp #'jit-lock-fontify-now) (message "hfy jit-lock mode (%S %S)" window-system major-mode) (jit-lock-fontify-now)) diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index 2e33d10c4c0..1b69574a392 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -403,10 +403,7 @@ format. See `ibuffer-update-saved-filters-format' and ;;;###autoload (define-minor-mode ibuffer-auto-mode - "Toggle use of Ibuffer's auto-update facility (Ibuffer Auto mode). -With a prefix argument ARG, enable Ibuffer Auto mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil." + "Toggle use of Ibuffer's auto-update facility (Ibuffer Auto mode)." nil nil nil (unless (derived-mode-p 'ibuffer-mode) (error "This buffer is not in Ibuffer mode")) @@ -726,7 +723,7 @@ specification, with the same structure as an element of the list (not (not (pcase (car filter) - (`or + ('or ;;; ATTN: Short-circuiting alternative with parallel structure w/`and ;;(catch 'has-match ;; (dolist (filter-spec (cdr filter) nil) @@ -735,12 +732,12 @@ specification, with the same structure as an element of the list (memq t (mapcar #'(lambda (x) (ibuffer-included-in-filter-p buf x)) (cdr filter)))) - (`and + ('and (catch 'no-match (dolist (filter-spec (cdr filter) t) (unless (ibuffer-included-in-filter-p buf filter-spec) (throw 'no-match nil))))) - (`saved + ('saved (let ((data (assoc (cdr filter) ibuffer-saved-filters))) (unless data (ibuffer-filter-disable t) @@ -1033,8 +1030,11 @@ group definitions by setting `ibuffer-filter-groups' to nil." (ibuffer-jump-to-buffer (buffer-name buf))))) (defun ibuffer-push-filter (filter-specification) - "Add FILTER-SPECIFICATION to `ibuffer-filtering-qualifiers'." - (push filter-specification ibuffer-filtering-qualifiers)) + "Add FILTER-SPECIFICATION to `ibuffer-filtering-qualifiers'. +If FILTER-SPECIFICATION is already in the list then return nil. Otherwise, +return the updated list." + (unless (member filter-specification ibuffer-filtering-qualifiers) + (push filter-specification ibuffer-filtering-qualifiers))) ;;;###autoload (defun ibuffer-decompose-filter () @@ -1051,14 +1051,14 @@ turned into separate filters, like [name: foo] and [mode: bar-mode]." (tail (cdr filters)) (value (pcase (caar filters) - ((or `or 'and) (nconc head tail)) - (`saved + ((or 'or 'and) (nconc head tail)) + ('saved (let ((data (assoc head ibuffer-saved-filters))) (unless data (ibuffer-filter-disable) (error "Unknown saved filter %s" head)) (append (cdr data) tail))) - (`not (cons (ibuffer-unary-operand (car filters)) tail)) + ('not (cons (ibuffer-unary-operand (car filters)) tail)) (_ (error "Filter type %s is not compound" (caar filters)))))) (setq ibuffer-filtering-qualifiers value)) @@ -1197,12 +1197,12 @@ Interactively, prompt for NAME, and use the current filters." (defun ibuffer-format-qualifier-1 (qualifier) (pcase (car qualifier) - (`saved + ('saved (concat " [filter: " (cdr qualifier) "]")) - (`or + ('or (concat " [OR" (mapconcat #'ibuffer-format-qualifier (cdr qualifier) "") "]")) - (`and + ('and (concat " [AND" (mapconcat #'ibuffer-format-qualifier (cdr qualifier) "") "]")) (_ @@ -1228,28 +1228,33 @@ If INCLUDE-PARENTS is non-nil then include parent modes." ;;;###autoload (autoload 'ibuffer-filter-by-mode "ibuf-ext") (define-ibuffer-filter mode - "Limit current view to buffers with major mode QUALIFIER." + "Limit current view to buffers with major mode(s) specified by QUALIFIER. +QUALIFIER is the mode name as a symbol or a list of symbols. +Called interactively, accept a comma separated list of mode names." (:description "major mode" :reader (let* ((buf (ibuffer-current-buffer)) (default (if (and buf (buffer-live-p buf)) (symbol-name (buffer-local-value 'major-mode buf))))) - (intern - (completing-read + (mapcar #'intern + (completing-read-multiple (if default (format "Filter by major mode (default %s): " default) "Filter by major mode: ") obarray - #'(lambda (e) - (string-match "-mode\\'" (symbol-name e))) - t nil nil default)))) + (lambda (e) + (string-match "-mode\\'" (if (symbolp e) (symbol-name e) e))) + t nil nil default))) + :accept-list t) (eq qualifier (buffer-local-value 'major-mode buf))) ;;;###autoload (autoload 'ibuffer-filter-by-used-mode "ibuf-ext") (define-ibuffer-filter used-mode - "Limit current view to buffers with major mode QUALIFIER. -Called interactively, this function allows selection of modes + "Limit current view to buffers with major mode(s) specified by QUALIFIER. +QUALIFIER is the mode name as a symbol or a list of symbols. + +Called interactively, accept a comma separated list of mode names currently used by buffers." (:description "major mode in use" :reader @@ -1257,23 +1262,29 @@ currently used by buffers." (default (if (and buf (buffer-live-p buf)) (symbol-name (buffer-local-value 'major-mode buf))))) - (intern - (completing-read + (mapcar #'intern + (completing-read-multiple (if default (format "Filter by major mode (default %s): " default) "Filter by major mode: ") - (ibuffer-list-buffer-modes) nil t nil nil default)))) + (ibuffer-list-buffer-modes) nil t nil nil default))) + :accept-list t) (eq qualifier (buffer-local-value 'major-mode buf))) ;;;###autoload (autoload 'ibuffer-filter-by-derived-mode "ibuf-ext") (define-ibuffer-filter derived-mode - "Limit current view to buffers whose major mode inherits from QUALIFIER." + "Limit current view to buffers with major mode(s) specified by QUALIFIER. +QUALIFIER is the mode name as a symbol or a list of symbols. + Restrict the view to buffers whose major mode derivates + from modes specified by QUALIFIER. +Called interactively, accept a comma separated list of mode names." (:description "derived mode" - :reader - (intern - (completing-read "Filter by derived mode: " - (ibuffer-list-buffer-modes t) - nil t))) + :reader + (mapcar #'intern + (completing-read-multiple "Filter by derived mode: " + (ibuffer-list-buffer-modes t) + nil t)) + :accept-list t) (with-current-buffer buf (derived-mode-p qualifier))) ;;;###autoload (autoload 'ibuffer-filter-by-name "ibuf-ext") @@ -1283,6 +1294,12 @@ currently used by buffers." :reader (read-from-minibuffer "Filter by name (regexp): ")) (string-match qualifier (buffer-name buf))) +;;;###autoload (autoload 'ibuffer-filter-by-process "ibuf-ext") +(define-ibuffer-filter process + "Limit current view to buffers running a process." + (:description "process") + (get-buffer-process buf)) + ;;;###autoload (autoload 'ibuffer-filter-by-starred-name "ibuf-ext") (define-ibuffer-filter starred-name "Limit current view to buffers with name beginning and ending @@ -1931,11 +1948,10 @@ Otherwise buffers whose name matches an element of (ibuffer-mark-on-buffer #'(lambda (buf) (with-current-buffer buf - ;; hacked from midnight.el (when buffer-display-time - (let* ((now (float-time)) - (then (float-time buffer-display-time))) - (> (- now then) (* 60 60 ibuffer-old-time)))))))) + (time-less-p + (* 60 60 ibuffer-old-time) + (time-since buffer-display-time))))))) ;;;###autoload (defun ibuffer-mark-special-buffers () diff --git a/lisp/ibuf-macs.el b/lisp/ibuf-macs.el index 69184604d0b..2b28f18da5c 100644 --- a/lisp/ibuf-macs.el +++ b/lisp/ibuf-macs.el @@ -280,14 +280,18 @@ buffer object. ;;;###autoload (cl-defmacro define-ibuffer-filter (name documentation - (&key - reader - description) - &rest body) + (&key + reader + description + accept-list) + &rest body) "Define a filter named NAME. DOCUMENTATION is the documentation of the function. READER is a form which should read a qualifier from the user. DESCRIPTION is a short string describing the filter. +ACCEPT-LIST is a boolean; if non-nil, the filter accepts either +a single condition or a list of them; in the latter +case the filter is the `or' composition of the conditions. BODY should contain forms which will be evaluated to test whether or not a particular buffer should be displayed or not. The forms in BODY @@ -296,26 +300,41 @@ bound to the current value of the filter. \(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)" (declare (indent 2) (doc-string 2)) - (let ((fn-name (intern (concat "ibuffer-filter-by-" (symbol-name name))))) + (let ((fn-name (intern (concat "ibuffer-filter-by-" (symbol-name name)))) + (filter (make-symbol "ibuffer-filter")) + (qualifier-str (make-symbol "ibuffer-qualifier-str"))) `(progn (defun ,fn-name (qualifier) - ,(or documentation "This filter is not documented.") - (interactive (list ,reader)) - (ibuffer-push-filter (cons ',name qualifier)) - (message "%s" - (format ,(concat (format "Filter by %s added: " description) - " %s") - qualifier)) - (ibuffer-update nil t)) + ,(or documentation "This filter is not documented.") + (interactive (list ,reader)) + (let ((,filter (cons ',name qualifier)) + (,qualifier-str qualifier)) + ,(when accept-list + `(progn + (unless (listp qualifier) (setq qualifier (list qualifier))) + ;; Reject equivalent filters: (or f1 f2) is same as (or f2 f1). + (setq qualifier (sort (delete-dups qualifier) #'string-lessp)) + (setq ,filter (cons ',name (car qualifier))) + (setq ,qualifier-str + (mapconcat (lambda (m) (if (symbolp m) (symbol-name m) m)) + qualifier ",")) + (when (cdr qualifier) ; Compose individual filters with `or'. + (setq ,filter `(or ,@(mapcar (lambda (m) (cons ',name m)) qualifier)))))) + (if (null (ibuffer-push-filter ,filter)) + (message ,(format "Filter by %s already applied: %%s" description) + ,qualifier-str) + (message ,(format "Filter by %s added: %%s" description) + ,qualifier-str) + (ibuffer-update nil t)))) (push (list ',name ,description - (lambda (buf qualifier) - (condition-case nil - (progn ,@body) - (error (ibuffer-pop-filter) - (when (eq ',name 'predicate) - (error "Wrong filter predicate: %S" - qualifier)))))) - ibuffer-filtering-alist) + (lambda (buf qualifier) + (condition-case nil + (progn ,@body) + (error (ibuffer-pop-filter) + (when (eq ',name 'predicate) + (error "Wrong filter predicate: %S" + qualifier)))))) + ibuffer-filtering-alist) :autoload-end))) (provide 'ibuf-macs) diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el index 8cb9a97d92c..23f7a2a8e4a 100644 --- a/lisp/ibuffer.el +++ b/lisp/ibuffer.el @@ -24,9 +24,22 @@ ;;; Commentary: -;; ibuffer.el is an advanced replacement for the `buffer-menu' which -;; is normally distributed with Emacs. Its interface is intended to -;; be analogous to that of Dired. +;; Ibuffer is an advanced replacement for the `buffer-menu' which is +;; distributed with Emacs. It lets you operate on buffers in a +;; Dired-like way, with the ability to sort, mark by regular +;; expression, and filter displayed buffers by various criteria. Its +;; interface is intended to be analogous to that of Dired. +;; +;; To start using it, type `M-x ibuffer'. If you use it regularly, +;; you might be interested in replacing the default `list-buffers' key +;; binding by adding the following to your init file: +;; +;; (global-set-key (kbd "C-x C-b") 'ibuffer) +;; +;; See also the various customization options, not least the +;; documentation for `ibuffer-formats'. +;; +;; For more help, type `?' in the "*Ibuffer*" buffer. ;;; Code: @@ -139,23 +152,21 @@ value for this variable would be Using \\[ibuffer-switch-format], you can rotate the display between the specified formats in the list." :version "26.1" - :type '(repeat sexp) - :group 'ibuffer) + :type '(repeat sexp)) (defcustom ibuffer-always-compile-formats (featurep 'bytecomp) "If non-nil, then use the byte-compiler to optimize `ibuffer-formats'. This will increase the redisplay speed, at the cost of loading the elisp byte-compiler." - :type 'boolean - :group 'ibuffer) + :type 'boolean) (defcustom ibuffer-fontification-alist - `((10 buffer-read-only font-lock-constant-face) + '((10 buffer-read-only font-lock-constant-face) (15 (and buffer-file-name (string-match ibuffer-compressed-file-name-regexp buffer-file-name)) font-lock-doc-face) - (20 (string-match "^*" (buffer-name)) font-lock-keyword-face) + (20 (string-match "^\\*" (buffer-name)) font-lock-keyword-face) (25 (and (string-match "^ " (buffer-name)) (null buffer-file-name)) italic) @@ -174,34 +185,28 @@ recreate it for the change to take effect." :type '(repeat (list (integer :tag "Priority") (sexp :tag "Test Form") - face)) - :group 'ibuffer) + face))) (defcustom ibuffer-use-other-window nil "If non-nil, display Ibuffer in another window by default." - :type 'boolean - :group 'ibuffer) + :type 'boolean) (defcustom ibuffer-default-shrink-to-minimum-size nil "If non-nil, minimize the size of the Ibuffer window by default." - :type 'boolean - :group 'ibuffer) + :type 'boolean) (defvar ibuffer-shrink-to-minimum-size nil) (defcustom ibuffer-display-summary t "If non-nil, summarize Ibuffer columns." - :type 'boolean - :group 'ibuffer) + :type 'boolean) (defcustom ibuffer-truncate-lines t "If non-nil, do not display continuation lines." - :type 'boolean - :group 'ibuffer) + :type 'boolean) (defcustom ibuffer-case-fold-search case-fold-search "If non-nil, ignore case when searching." - :type 'boolean - :group 'ibuffer) + :type 'boolean) (defcustom ibuffer-default-sorting-mode 'recency "The criteria by which to sort the buffers. @@ -213,29 +218,18 @@ view of the buffers." (const :tag "Lexicographic" :value alphabetic) (const :tag "Buffer size" :value size) (const :tag "File name" :value filename/process) - (const :tag "Major mode" :value major-mode)) - :group 'ibuffer) + (const :tag "Major mode" :value major-mode))) (defvar ibuffer-sorting-mode nil) (defvar ibuffer-last-sorting-mode nil) (defcustom ibuffer-default-sorting-reversep nil "If non-nil, reverse the default sorting order." - :type 'boolean - :group 'ibuffer) + :type 'boolean) (defvar ibuffer-sorting-reversep nil) -(defcustom ibuffer-elide-long-columns nil - "If non-nil, then elide column entries which exceed their max length." - :type 'boolean - :group 'ibuffer) -(make-obsolete-variable 'ibuffer-elide-long-columns - "use the :elide argument of `ibuffer-formats'." - "22.1") - (defcustom ibuffer-eliding-string "..." "The string to use for eliding long columns." - :type 'string - :group 'ibuffer) + :type 'string) (defcustom ibuffer-maybe-show-predicates `(,(lambda (buf) (and (string-match "^ " (buffer-name buf)) @@ -251,13 +245,11 @@ Viewing of buffers hidden because of these predicates may be customized via `ibuffer-default-display-maybe-show-predicates' and is toggled by giving a non-nil prefix argument to `ibuffer-update'. Note that this specialized filtering occurs before real filtering." - :type '(repeat (choice regexp function)) - :group 'ibuffer) + :type '(repeat (choice regexp function))) (defcustom ibuffer-default-display-maybe-show-predicates nil "Non-nil means show buffers that match `ibuffer-maybe-show-predicates'." - :type 'boolean - :group 'ibuffer) + :type 'boolean) (defvar ibuffer-display-maybe-show-predicates nil) @@ -265,47 +257,39 @@ Note that this specialized filtering occurs before real filtering." (defcustom ibuffer-movement-cycle t "If non-nil, then forward and backwards movement commands cycle." - :type 'boolean - :group 'ibuffer) + :type 'boolean) (defcustom ibuffer-modified-char ?* "The character to display for modified buffers." - :type 'character - :group 'ibuffer) + :type 'character) (defcustom ibuffer-read-only-char ?% "The character to display for read-only buffers." - :type 'character - :group 'ibuffer) + :type 'character) (defcustom ibuffer-marked-char ?> "The character to display for marked buffers." - :type 'character - :group 'ibuffer) + :type 'character) (defcustom ibuffer-locked-char ?L "The character to display for locked buffers." :version "26.1" - :type 'character - :group 'ibuffer) + :type 'character) (defcustom ibuffer-deletion-char ?D "The character to display for buffers marked for deletion." - :type 'character - :group 'ibuffer) + :type 'character) (defcustom ibuffer-expert nil "If non-nil, don't ask for confirmation of \"dangerous\" operations." - :type 'boolean - :group 'ibuffer) + :type 'boolean) (defcustom ibuffer-view-ibuffer nil "If non-nil, display the current Ibuffer buffer itself. Note that this has a drawback - the data about the current Ibuffer buffer will most likely be inaccurate. This includes modification state, size, etc." - :type 'boolean - :group 'ibuffer) + :type 'boolean) (defcustom ibuffer-always-show-last-buffer nil "If non-nil, always display the previous buffer. @@ -313,19 +297,16 @@ This variable takes precedence over filtering, and even `ibuffer-never-show-predicates'." :type '(choice (const :tag "Always" :value t) (const :tag "Never" :value nil) - (const :tag "Always except minibuffer" :value :nomini)) - :group 'ibuffer) + (const :tag "Always except minibuffer" :value :nomini))) (defcustom ibuffer-jump-offer-only-visible-buffers nil "If non-nil, only offer buffers visible in the Ibuffer buffer in completion lists of the `ibuffer-jump-to-buffer' command." - :type 'boolean - :group 'ibuffer) + :type 'boolean) (defcustom ibuffer-use-header-line (boundp 'header-line-format) "If non-nil, display a header line containing current filters." - :type 'boolean - :group 'ibuffer) + :type 'boolean) (defcustom ibuffer-default-directory nil "The default directory to use for a new Ibuffer buffer. @@ -333,69 +314,54 @@ If nil, inherit the directory of the buffer in which `ibuffer' was called. Otherwise, this variable should be a string naming a directory, like `default-directory'." :type '(choice (const :tag "Inherit" :value nil) - string) - :group 'ibuffer) + string)) (defcustom ibuffer-help-buffer-modes '(help-mode apropos-mode Info-mode Info-edit-mode) "List of \"Help\" major modes." - :type '(repeat function) - :group 'ibuffer) + :type '(repeat function)) (defcustom ibuffer-compressed-file-name-regexp "\\.\\(arj\\|bgz\\|bz2\\|gz\\|lzh\\|taz\\|tgz\\|xz\\|zip\\|z\\)$" "Regexp to match compressed file names." :version "24.1" ; added xz - :type 'regexp - :group 'ibuffer) - -(define-obsolete-variable-alias 'ibuffer-hooks 'ibuffer-hook "22.1") + :type 'regexp) (defcustom ibuffer-hook nil "Hook run when `ibuffer' is called." - :type 'hook - :group 'ibuffer) - -(define-obsolete-variable-alias 'ibuffer-mode-hooks 'ibuffer-mode-hook "22.1") + :type 'hook) (defcustom ibuffer-mode-hook nil "Hook run upon entry into `ibuffer-mode'." :type 'hook - :options '(ibuffer-auto-mode) - :group 'ibuffer) + :options '(ibuffer-auto-mode)) (defcustom ibuffer-load-hook nil "Hook run when Ibuffer is loaded." - :type 'hook - :group 'ibuffer) + :type 'hook) (defcustom ibuffer-marked-face 'warning "Face used for displaying marked buffers." - :type 'face - :group 'ibuffer) + :type 'face) (defcustom ibuffer-deletion-face 'error "Face used for displaying buffers marked for deletion." - :type 'face - :group 'ibuffer) + :type 'face) (defcustom ibuffer-title-face 'font-lock-type-face "Face used for the title string." - :type 'face - :group 'ibuffer) + :type 'face) (defcustom ibuffer-filter-group-name-face 'bold "Face used for displaying filtering group names." - :type 'face - :group 'ibuffer) + :type 'face) (defcustom ibuffer-directory-abbrev-alist nil "An alist of file name abbreviations like `directory-abbrev-alist'." :type '(repeat (cons :format "%v" :value ("" . "") (regexp :tag "From") - (regexp :tag "To"))) - :group 'ibuffer) + (regexp :tag "To")))) (defvar ibuffer-mode-groups-popup (let ((groups-map (make-sparse-keymap "Filter Groups"))) @@ -455,6 +421,49 @@ directory, like `default-directory'." groups-map)) +(defvar ibuffer--filter-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") 'ibuffer-filter-by-mode) + (define-key map (kbd "m") 'ibuffer-filter-by-used-mode) + (define-key map (kbd "M") 'ibuffer-filter-by-derived-mode) + (define-key map (kbd "n") 'ibuffer-filter-by-name) + (define-key map (kbd "E") 'ibuffer-filter-by-process) + (define-key map (kbd "*") 'ibuffer-filter-by-starred-name) + (define-key map (kbd "f") 'ibuffer-filter-by-filename) + (define-key map (kbd "b") 'ibuffer-filter-by-basename) + (define-key map (kbd ".") 'ibuffer-filter-by-file-extension) + (define-key map (kbd "<") 'ibuffer-filter-by-size-lt) + (define-key map (kbd ">") 'ibuffer-filter-by-size-gt) + (define-key map (kbd "i") 'ibuffer-filter-by-modified) + (define-key map (kbd "v") 'ibuffer-filter-by-visiting-file) + (define-key map (kbd "c") 'ibuffer-filter-by-content) + (define-key map (kbd "e") 'ibuffer-filter-by-predicate) + + (define-key map (kbd "r") 'ibuffer-switch-to-saved-filters) + (define-key map (kbd "a") 'ibuffer-add-saved-filters) + (define-key map (kbd "x") 'ibuffer-delete-saved-filters) + (define-key map (kbd "d") 'ibuffer-decompose-filter) + (define-key map (kbd "s") 'ibuffer-save-filters) + (define-key map (kbd "p") 'ibuffer-pop-filter) + (define-key map (kbd "<up>") 'ibuffer-pop-filter) + (define-key map (kbd "!") 'ibuffer-negate-filter) + (define-key map (kbd "t") 'ibuffer-exchange-filters) + (define-key map (kbd "TAB") 'ibuffer-exchange-filters) + (define-key map (kbd "o") 'ibuffer-or-filter) + (define-key map (kbd "|") 'ibuffer-or-filter) + (define-key map (kbd "&") 'ibuffer-and-filter) + (define-key map (kbd "g") 'ibuffer-filters-to-filter-group) + (define-key map (kbd "P") 'ibuffer-pop-filter-group) + (define-key map (kbd "S-<up>") 'ibuffer-pop-filter-group) + (define-key map (kbd "D") 'ibuffer-decompose-filter-group) + (define-key map (kbd "/") 'ibuffer-filter-disable) + + (define-key map (kbd "S") 'ibuffer-save-filter-groups) + (define-key map (kbd "R") 'ibuffer-switch-to-saved-filter-groups) + (define-key map (kbd "X") 'ibuffer-delete-saved-filter-groups) + (define-key map (kbd "\\") 'ibuffer-clear-filter-groups) + map)) + (defvar ibuffer-mode-map (let ((map (make-keymap))) (define-key map (kbd "0") 'digit-argument) @@ -518,40 +527,6 @@ directory, like `default-directory'." (define-key map (kbd "s f") 'ibuffer-do-sort-by-filename/process) (define-key map (kbd "s m") 'ibuffer-do-sort-by-major-mode) - (define-key map (kbd "/ RET") 'ibuffer-filter-by-mode) - (define-key map (kbd "/ m") 'ibuffer-filter-by-used-mode) - (define-key map (kbd "/ M") 'ibuffer-filter-by-derived-mode) - (define-key map (kbd "/ n") 'ibuffer-filter-by-name) - (define-key map (kbd "/ *") 'ibuffer-filter-by-starred-name) - (define-key map (kbd "/ f") 'ibuffer-filter-by-filename) - (define-key map (kbd "/ b") 'ibuffer-filter-by-basename) - (define-key map (kbd "/ .") 'ibuffer-filter-by-file-extension) - (define-key map (kbd "/ <") 'ibuffer-filter-by-size-lt) - (define-key map (kbd "/ >") 'ibuffer-filter-by-size-gt) - (define-key map (kbd "/ i") 'ibuffer-filter-by-modified) - (define-key map (kbd "/ v") 'ibuffer-filter-by-visiting-file) - (define-key map (kbd "/ c") 'ibuffer-filter-by-content) - (define-key map (kbd "/ e") 'ibuffer-filter-by-predicate) - - (define-key map (kbd "/ r") 'ibuffer-switch-to-saved-filters) - (define-key map (kbd "/ a") 'ibuffer-add-saved-filters) - (define-key map (kbd "/ x") 'ibuffer-delete-saved-filters) - (define-key map (kbd "/ d") 'ibuffer-decompose-filter) - (define-key map (kbd "/ s") 'ibuffer-save-filters) - (define-key map (kbd "/ p") 'ibuffer-pop-filter) - (define-key map (kbd "/ <up>") 'ibuffer-pop-filter) - (define-key map (kbd "/ !") 'ibuffer-negate-filter) - (define-key map (kbd "/ t") 'ibuffer-exchange-filters) - (define-key map (kbd "/ TAB") 'ibuffer-exchange-filters) - (define-key map (kbd "/ o") 'ibuffer-or-filter) - (define-key map (kbd "/ |") 'ibuffer-or-filter) - (define-key map (kbd "/ &") 'ibuffer-and-filter) - (define-key map (kbd "/ g") 'ibuffer-filters-to-filter-group) - (define-key map (kbd "/ P") 'ibuffer-pop-filter-group) - (define-key map (kbd "/ S-<up>") 'ibuffer-pop-filter-group) - (define-key map (kbd "/ D") 'ibuffer-decompose-filter-group) - (define-key map (kbd "/ /") 'ibuffer-filter-disable) - (define-key map (kbd "M-n") 'ibuffer-forward-filter-group) (define-key map "\t" 'ibuffer-forward-filter-group) (define-key map (kbd "M-p") 'ibuffer-backward-filter-group) @@ -559,10 +534,6 @@ directory, like `default-directory'." (define-key map (kbd "M-j") 'ibuffer-jump-to-filter-group) (define-key map (kbd "C-k") 'ibuffer-kill-line) (define-key map (kbd "C-y") 'ibuffer-yank) - (define-key map (kbd "/ S") 'ibuffer-save-filter-groups) - (define-key map (kbd "/ R") 'ibuffer-switch-to-saved-filter-groups) - (define-key map (kbd "/ X") 'ibuffer-delete-saved-filter-groups) - (define-key map (kbd "/ \\") 'ibuffer-clear-filter-groups) (define-key map (kbd "% n") 'ibuffer-mark-by-name-regexp) (define-key map (kbd "% m") 'ibuffer-mark-by-mode-regexp) @@ -613,6 +584,8 @@ directory, like `default-directory'." (define-key map (kbd "C-x 4 RET") 'ibuffer-visit-buffer-other-window) (define-key map (kbd "C-x 5 RET") 'ibuffer-visit-buffer-other-frame) + (define-key map (kbd "/") ibuffer--filter-map) + (define-key map [menu-bar view] (cons "View" (make-sparse-keymap "View"))) @@ -956,7 +929,6 @@ directory, like `default-directory'." (defvar ibuffer-compiled-formats nil) (defvar ibuffer-cached-formats nil) (defvar ibuffer-cached-eliding-string nil) -(defvar ibuffer-cached-elide-long-columns 0) (defvar ibuffer-sorting-functions-alist nil "An alist of functions which describe how to sort buffers. @@ -1603,7 +1575,7 @@ If point is on a group name, this function operates on that group." (defun ibuffer-compile-make-eliding-form (strvar elide from-end-p) (let ((ellipsis (propertize ibuffer-eliding-string 'font-lock-face 'bold))) - (if (or elide (with-no-warnings ibuffer-elide-long-columns)) + (if elide `(if (> strlen 5) ,(if from-end-p ;; FIXME: this should probably also be using @@ -1625,8 +1597,8 @@ If point is on a group name, this function operates on that group." `(truncate-string-to-width ,strvar ,maxvar nil ?\s))) (defun ibuffer-compile-make-format-form (strvar widthform alignment) - (let* ((left `(make-string tmp2 ?\s)) - (right `(make-string (- tmp1 tmp2) ?\s))) + (let* ((left '(make-string tmp2 ?\s)) + (right '(make-string (- tmp1 tmp2) ?\s))) `(progn (setq tmp1 ,widthform tmp2 (/ tmp1 2)) @@ -1749,7 +1721,7 @@ If point is on a group name, this function operates on that group." outforms) (push `(setq str ,callform ,@(when strlen-used - `(strlen (string-width str)))) + '(strlen (string-width str)))) outforms) (setq outforms (append outforms @@ -1803,9 +1775,6 @@ If point is on a group name, this function operates on that group." (not (eq ibuffer-cached-formats ibuffer-formats)) (null ibuffer-cached-eliding-string) (not (equal ibuffer-cached-eliding-string ibuffer-eliding-string)) - (eql 0 ibuffer-cached-elide-long-columns) - (not (eql ibuffer-cached-elide-long-columns - (with-no-warnings ibuffer-elide-long-columns))) (and ext-loaded (not (eq ibuffer-cached-filter-formats ibuffer-filter-format-alist)) @@ -1814,8 +1783,7 @@ If point is on a group name, this function operates on that group." (message "Formats have changed, recompiling...") (ibuffer-recompile-formats) (setq ibuffer-cached-formats ibuffer-formats - ibuffer-cached-eliding-string ibuffer-eliding-string - ibuffer-cached-elide-long-columns (with-no-warnings ibuffer-elide-long-columns)) + ibuffer-cached-eliding-string ibuffer-eliding-string) (when ext-loaded (setq ibuffer-cached-filter-formats ibuffer-filter-format-alist)) (message "Formats have changed, recompiling...done")))) @@ -1825,7 +1793,7 @@ If point is on a group name, this function operates on that group." (defface ibuffer-locked-buffer '((((background dark)) (:foreground "RosyBrown")) (t (:foreground "brown4"))) - "*Face used for locked buffers in Ibuffer." + "Face used for locked buffers in Ibuffer." :version "26.1" :group 'ibuffer :group 'font-lock-highlighting-faces) @@ -2221,7 +2189,7 @@ the value of point at the beginning of the line for that buffer." strname (propertize strname 'mouse-face 'highlight 'keymap hmap))) strname))))) - (add-text-properties opos (point) `(ibuffer-title-header t)) + (add-text-properties opos (point) '(ibuffer-title-header t)) (insert "\n") ;; Add the underlines (let ((str (save-excursion @@ -2271,7 +2239,7 @@ the value of point at the beginning of the line for that buffer." align) summary)))))) (point)) - `(ibuffer-summary t))))) + '(ibuffer-summary t))))) (defun ibuffer-redisplay (&optional silent) @@ -2759,7 +2727,6 @@ will be inserted before the group at point." (set (make-local-variable 'ibuffer-compiled-formats) nil) (set (make-local-variable 'ibuffer-cached-formats) nil) (set (make-local-variable 'ibuffer-cached-eliding-string) nil) - (set (make-local-variable 'ibuffer-cached-elide-long-columns) nil) (set (make-local-variable 'ibuffer-current-format) nil) (set (make-local-variable 'ibuffer-did-modification) nil) (set (make-local-variable 'ibuffer-tmp-hide-regexps) nil) diff --git a/lisp/icomplete.el b/lisp/icomplete.el index aaacce154f8..51f2611c6b3 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -1,10 +1,9 @@ -;;; icomplete.el --- minibuffer completion incremental feedback +;;; icomplete.el --- minibuffer completion incremental feedback -*- lexical-binding: t -*- ;; Copyright (C) 1992-1994, 1997, 1999, 2001-2019 Free Software ;; Foundation, Inc. -;; Author: Ken Manheimer <klm@i.am> -;; Maintainer: Ken Manheimer <klm@i.am> +;; Author: Ken Manheimer <ken dot manheimer at gmail...> ;; Created: Mar 1993 Ken Manheimer, klm@nist.gov - first release to usenet ;; Keywords: help, abbrev @@ -145,7 +144,7 @@ icompletion is occurring." (defvar icomplete-minibuffer-map (let ((map (make-sparse-keymap))) - (define-key map [?\M-\t] 'minibuffer-force-complete) + (define-key map [?\M-\t] 'icomplete-force-complete) (define-key map [?\C-j] 'icomplete-force-complete-and-exit) (define-key map [?\C-.] 'icomplete-forward-completions) (define-key map [?\C-,] 'icomplete-backward-completions) @@ -162,6 +161,12 @@ the default otherwise." (minibuffer-force-complete-and-exit) (minibuffer-complete-and-exit))) +(defun icomplete-force-complete () + "Complete the icomplete minibuffer." + (interactive) + ;; We're not at all interested in cycling here (bug#34077). + (minibuffer-force-complete nil nil 'dont-cycle)) + (defun icomplete-forward-completions () "Step forward completions by one entry. Second entry becomes the first and can be selected with @@ -194,9 +199,6 @@ Last entry becomes the first and can be selected with ;;;###autoload (define-minor-mode icomplete-mode "Toggle incremental minibuffer completion (Icomplete mode). -With a prefix argument ARG, enable Icomplete mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. When this global minor mode is enabled, typing in the minibuffer continuously displays a list of possible completions that match @@ -371,8 +373,21 @@ If there are multiple possibilities, `icomplete-separator' separates them. The displays for unambiguous matches have ` [Matched]' appended \(whether complete or not), or ` [No matches]', if no eligible matches exist." - (let* ((minibuffer-completion-table candidates) - (minibuffer-completion-predicate predicate) + (let* ((ignored-extension-re + (and minibuffer-completing-file-name + icomplete-with-completion-tables + completion-ignored-extensions + (concat "\\(?:\\`\\.\\./\\|" + (regexp-opt completion-ignored-extensions) + "\\)\\'"))) + (minibuffer-completion-table candidates) + (minibuffer-completion-predicate + (if ignored-extension-re + (lambda (cand) + (and (not (string-match ignored-extension-re cand)) + (or (null predicate) + (funcall predicate cand)))) + predicate)) (md (completion--field-metadata (icomplete--field-beg))) (comps (completion-all-sorted-completions (icomplete--field-beg) (icomplete--field-end))) @@ -383,11 +398,8 @@ matches exist." ;; `concat'/`mapconcat' is the slow part. (if (not (consp comps)) (progn ;;(debug (format "Candidates=%S field=%S" candidates name)) - (format " %sNo matches%s" open-bracket close-bracket)) + (format " %sNo matches%s" open-bracket close-bracket)) (if last (setcdr last nil)) - (when (and minibuffer-completing-file-name - icomplete-with-completion-tables) - (setq comps (completion-pcm--filename-try-filter comps))) (let* ((most-try (if (and base-size (> base-size 0)) (completion-try-completion @@ -473,11 +485,11 @@ matches exist." (if prefix-len (substring (car comps) prefix-len) (car comps)) comps (cdr comps)) (setq prospects-len - (+ (string-width comp) - (string-width icomplete-separator) - prospects-len)) - (if (< prospects-len prospects-max) - (push comp prospects) + (+ (string-width comp) + (string-width icomplete-separator) + prospects-len)) + (if (< prospects-len prospects-max) + (push comp prospects) (setq limit t)))) (setq prospects (nreverse prospects)) ;; Decorate first of the prospects. diff --git a/lisp/ido.el b/lisp/ido.el index 73a6be08c22..e14f0151690 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -735,6 +735,14 @@ not provide the normal completion. To show the completions, use \\[ido-toggle-i (integer :tag "Size in bytes" 30000)) :group 'ido) +(defcustom ido-big-directories nil + "List of directory pattern strings that should be considered big. +Ido won't attempt to list the contents of directories matching +any of these regular expressions when completing file names." + :type '(repeat regexp) + :group 'ido + :version "27.1") + (defcustom ido-rotate-file-list-default nil "Non-nil means that Ido will always rotate file list to get default in front." :type 'boolean @@ -1135,6 +1143,9 @@ selected.") (defvar ido-current-directory nil "Current directory for `ido-find-file'.") +(defvar ido-predicate nil + "Current completion predicate.") + (defvar ido-auto-merge-timer nil "Delay timer for auto merge.") @@ -1248,8 +1259,7 @@ Only used if `ido-use-virtual-buffers' is non-nil.") (if merge ido-use-merged-list (and (boundp 'ido-completing-read) - (or (featurep 'xemacs) - (= ido-use-mycompletion-depth (minibuffer-depth)))))) + (= ido-use-mycompletion-depth (minibuffer-depth))))) (defvar ido-trace-enable nil) @@ -1512,22 +1522,20 @@ Removes badly formatted data and ignored directories." (files (cdr (cdr (car l))))) (and (stringp dir) - (consp time) - (cond - ((integerp (car time)) - (and (/= (car time) 0) - (integerp (car (cdr time))) - (/= (car (cdr time)) 0) - (ido-may-cache-directory dir))) - ((eq (car time) 'ftp) - (and (numberp (cdr time)) - (ido-is-ftp-directory dir) - (ido-cache-ftp-valid (cdr time)))) - ((eq (car time) 'unc) - (and (numberp (cdr time)) - (ido-is-unc-host dir) - (ido-cache-unc-valid (cdr time)))) - (t nil)) + (if (condition-case nil + (not (time-equal-p time 0)) + (error)) + (ido-may-cache-directory dir) + (and + (consp time) + (numberp (cdr time)) + (cond + ((eq (car time) 'ftp) + (and (ido-is-ftp-directory dir) + (ido-cache-ftp-valid (cdr time)))) + ((eq (car time) 'unc) + (and (ido-is-unc-host dir) + (ido-cache-unc-valid (cdr time))))))) (let ((s files) (ok t)) (while s (if (stringp (car s)) @@ -1579,10 +1587,7 @@ Removes badly formatted data and ignored directories." (add-hook 'choose-completion-string-functions 'ido-choose-completion-string)) (define-minor-mode ido-everywhere - "Toggle use of Ido for all buffer/file reading. -With a prefix argument ARG, enable this feature if ARG is -positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil." + "Toggle use of Ido for all buffer/file reading." :global t :group 'ido (remove-function read-file-name-function #'ido-read-file-name) @@ -1690,27 +1695,27 @@ is enabled then some keybindings are changed in the keymap." (when viper-p (define-key map [remap viper-intercept-ESC-key] 'ignore)) (pcase ido-cur-item - ((or `file `dir) - (when ido-context-switch-command - (define-key map "\C-x\C-b" ido-context-switch-command) - (define-key map "\C-x\C-d" 'ignore)) - (when viper-p - (define-key map [remap viper-backward-char] - 'ido-delete-backward-updir) - (define-key map [remap viper-del-backward-char-in-insert] - 'ido-delete-backward-updir) - (define-key map [remap viper-delete-backward-word] - 'ido-delete-backward-word-updir)) - (set-keymap-parent map - (if (eq ido-cur-item 'file) - ido-file-completion-map - ido-file-dir-completion-map))) - (`buffer - (when ido-context-switch-command - (define-key map "\C-x\C-f" ido-context-switch-command)) - (set-keymap-parent map ido-buffer-completion-map)) - (_ - (set-keymap-parent map ido-common-completion-map))) + ((or 'file 'dir) + (when ido-context-switch-command + (define-key map "\C-x\C-b" ido-context-switch-command) + (define-key map "\C-x\C-d" 'ignore)) + (when viper-p + (define-key map [remap viper-backward-char] + 'ido-delete-backward-updir) + (define-key map [remap viper-del-backward-char-in-insert] + 'ido-delete-backward-updir) + (define-key map [remap viper-delete-backward-word] + 'ido-delete-backward-word-updir)) + (set-keymap-parent map + (if (eq ido-cur-item 'file) + ido-file-completion-map + ido-file-dir-completion-map))) + ('buffer + (when ido-context-switch-command + (define-key map "\C-x\C-f" ido-context-switch-command)) + (set-keymap-parent map ido-buffer-completion-map)) + (_ + (set-keymap-parent map ido-common-completion-map))) (setq ido-completion-map map))) (defun ido-final-slash (dir &optional fix-it) @@ -1745,12 +1750,16 @@ is enabled then some keybindings are changed in the keymap." ;; Return t if dir is a directory, but too big to show ;; Do not check for non-readable directories via tramp, as this causes a premature ;; connect on incomplete tramp paths (after entering just method:). - (let ((ido-enable-tramp-completion nil)) - (and (numberp ido-max-directory-size) - (ido-final-slash dir) - (not (ido-is-unc-host dir)) - (file-directory-p dir) - (> (nth 7 (file-attributes (file-truename dir))) ido-max-directory-size)))) + (let ((ido-enable-tramp-completion nil) + (case-fold-search nil)) + (or (seq-some (lambda (regexp) (string-match-p regexp dir)) + ido-big-directories) + (and (numberp ido-max-directory-size) + (ido-final-slash dir) + (not (ido-is-unc-host dir)) + (file-directory-p dir) + (> (file-attribute-size (file-attributes (file-truename dir))) + ido-max-directory-size))))) (defun ido-set-current-directory (dir &optional subdir no-merge) ;; Set ido's current directory to DIR or DIR/SUBDIR @@ -1793,11 +1802,8 @@ is enabled then some keybindings are changed in the keymap." (defun ido-record-command (command arg) "Add (COMMAND ARG) to `command-history' if `ido-record-commands' is non-nil." - (if ido-record-commands ; FIXME: use `when' instead of `if'? - (let ((cmd (list command arg))) - (if (or (not command-history) ; FIXME: ditto - (not (equal cmd (car command-history)))) - (setq command-history (cons cmd command-history)))))) + (when ido-record-commands + (add-to-history 'command-history (list command arg)))) (defun ido-make-prompt (item prompt) ;; Make the prompt for ido-read-internal @@ -1899,7 +1905,14 @@ If INITIAL is non-nil, it specifies the initial input string." ) (ido-setup-completion-map) - (setq ido-text-init initial) + + (setq ido-text-init + (if (consp initial) + (cons (car initial) + ;; `completing-read' uses 0-based index while + ;; `read-from-minibuffer' uses 1-based index. + (1+ (cdr initial))) + initial)) (setq ido-input-stack nil) (run-hooks 'ido-setup-hook) @@ -3487,6 +3500,11 @@ it is put to the start of the list." (if ido-temp-list (nconc ido-temp-list ido-current-buffers) (setq ido-temp-list ido-current-buffers)) + (if ido-predicate + (setq ido-temp-list (seq-filter + (lambda (name) + (funcall ido-predicate (cons name (get-buffer name)))) + ido-temp-list))) (if default (setq ido-temp-list (cons default (delete default ido-temp-list)))) @@ -3608,7 +3626,7 @@ Uses and updates `ido-dir-file-cache'." (ftp (ido-is-ftp-directory dir)) (unc (ido-is-unc-host dir)) (attr (if (or ftp unc) nil (file-attributes dir))) - (mtime (nth 5 attr)) + (mtime (file-attribute-modification-time attr)) valid) (when cached ; should we use the cached entry ? (cond @@ -3620,8 +3638,7 @@ Uses and updates `ido-dir-file-cache'." (ido-cache-unc-valid (cdr ctime))))) (t (if attr - (setq valid (and (= (car ctime) (car mtime)) - (= (car (cdr ctime)) (car (cdr mtime)))))))) + (setq valid (time-equal-p ctime mtime))))) (unless valid (setq ido-dir-file-cache (delq cached ido-dir-file-cache) cached nil))) @@ -3788,13 +3805,13 @@ frame, rather than all frames, regardless of value of `ido-all-frames'." (not (and (eq ido-cur-item 'buffer) ido-buffer-disable-smart-matches)) (not ido-enable-regexp) - (not (string-match "$\\'" rex0)) + (not (string-match "\\$\\'" rex0)) (concat "\\`" rex0 (if slash "/" "") "\\'"))) (suffix-re (and do-full slash (not (and (eq ido-cur-item 'buffer) ido-buffer-disable-smart-matches)) (not ido-enable-regexp) - (not (string-match "$\\'" rex0)) + (not (string-match "\\$\\'" rex0)) (concat rex0 "/\\'"))) (prefix-re (and full-re (not ido-enable-prefix) (concat "\\`" rexq))) @@ -3965,8 +3982,24 @@ If `ido-change-word-sub' cannot be found in WORD, return nil." (exit-minibuffer) t)) +;; This is a shameless copy of `switch-to-completions'. +(defun ido-switch-to-completions () + "Select the window showing `ido-completion-buffer'." + (interactive) + (let ((window (or (get-buffer-window ido-completion-buffer 0) + ;; Make sure we have a completions window. + (progn (ido-completion-help) + (get-buffer-window ido-completion-buffer 0))))) + (when window + (select-window window) + ;; In the new buffer, go to the first completion. + ;; FIXME: Perhaps this should be done in `ido-completion-help'. + (when (bobp) + (next-completion 1))))) + + (defun ido-completion-help () - "Show possible completions in a \"*File Completions*\" buffer." + "Show possible completions in the `ido-completion-buffer'." (interactive) (setq ido-rescan nil) (let ((temp-buf (and ido-completion-buffer @@ -4008,17 +4041,8 @@ If `ido-change-word-sub' cannot be found in WORD, return nil." (t (copy-sequence (or ido-matches ido-cur-list)))) #'ido-file-lessp))) - (if (featurep 'xemacs) - ;; XEmacs extents are put on by default, doesn't seem to be - ;; any way of switching them off. - (display-completion-list - completion-list - :help-string "ido " - :activate-callback - (lambda (&rest _) (message "Doesn't work yet, sorry!"))) - ;; else running Emacs - ;;(add-hook 'completion-setup-hook 'completion-setup-function) - (display-completion-list completion-list))))))) + ;;(add-hook 'completion-setup-hook 'completion-setup-function) + (display-completion-list completion-list)))))) ;;; KILL CURRENT BUFFER (defun ido-kill-buffer-at-head () @@ -4791,9 +4815,6 @@ Modified from `icomplete-completions'." (when (ido-active) (add-hook 'pre-command-hook 'ido-tidy nil t) (add-hook 'post-command-hook 'ido-exhibit nil t) - (when (featurep 'xemacs) - (ido-exhibit) - (goto-char (point-min))) (run-hooks 'ido-minibuffer-setup-hook) (when ido-initial-position (goto-char (+ (minibuffer-prompt-end) ido-initial-position)) @@ -4852,10 +4873,13 @@ Modified from `icomplete-completions'." Return the name of a buffer selected. PROMPT is the prompt to give to the user. DEFAULT if given is the default buffer to be selected, which will go to the front of the list. -If REQUIRE-MATCH is non-nil, an existing buffer must be selected." +If REQUIRE-MATCH is non-nil, an existing buffer must be selected. +Optional arg PREDICATE if non-nil is a function limiting the +buffers that can be considered." (let* ((ido-current-directory nil) (ido-directory-nonreadable nil) (ido-directory-too-big nil) + (ido-predicate predicate) (ido-context-switch-command 'ignore) (buf (ido-read-internal 'buffer prompt 'ido-buffer-history default require-match))) (if (eq ido-exit 'fallback) diff --git a/lisp/ielm.el b/lisp/ielm.el index 43a586eb32d..e9d3afe4c1b 100644 --- a/lisp/ielm.el +++ b/lisp/ielm.el @@ -115,45 +115,37 @@ such as `edebug-defun' to work with such inputs." :type 'boolean :group 'ielm) +(defvaralias 'inferior-emacs-lisp-mode-hook 'ielm-mode-hook) (defcustom ielm-mode-hook nil "Hooks to be run when IELM (`inferior-emacs-lisp-mode') is started." :options '(eldoc-mode) :type 'hook :group 'ielm) -(defvaralias 'inferior-emacs-lisp-mode-hook 'ielm-mode-hook) -(defvar * nil - "Most recent value evaluated in IELM.") +;; We define these symbols (that are only used buffer-locally in ielm +;; buffers) this way to avoid having them be defined in the global +;; Emacs namespace. +(defvar *) +(put '* 'variable-documentation "Most recent value evaluated in IELM.") -(defvar ** nil - "Second-most-recent value evaluated in IELM.") +(defvar **) +(put '** 'variable-documentation "Second-most-recent value evaluated in IELM.") -(defvar *** nil - "Third-most-recent value evaluated in IELM.") +(defvar ***) +(put '*** 'variable-documentation "Third-most-recent value evaluated in IELM.") (defvar ielm-match-data nil "Match data saved at the end of last command.") -(defvar *1 nil - "During IELM evaluation, most recent value evaluated in IELM. -Normally identical to `*'. However, if the working buffer is an IELM -buffer, distinct from the process buffer, then `*' gives the value in -the working buffer, `*1' the value in the process buffer. -The intended value is only accessible during IELM evaluation.") - -(defvar *2 nil - "During IELM evaluation, second-most-recent value evaluated in IELM. -Normally identical to `**'. However, if the working buffer is an IELM -buffer, distinct from the process buffer, then `**' gives the value in -the working buffer, `*2' the value in the process buffer. -The intended value is only accessible during IELM evaluation.") - -(defvar *3 nil - "During IELM evaluation, third-most-recent value evaluated in IELM. -Normally identical to `***'. However, if the working buffer is an IELM -buffer, distinct from the process buffer, then `***' gives the value in -the working buffer, `*3' the value in the process buffer. -The intended value is only accessible during IELM evaluation.") +;; During IELM evaluation, *1 is the most recent value evaluated in +;; IELM. Normally identical to `*'. However, if the working buffer +;; is an IELM buffer, distinct from the process buffer, then `*' gives +;; the value in the working buffer, `*1' the value in the process +;; buffer. The intended value is only accessible during IELM +;; evaluation. *2 and *3 are the same for ** and ***. +(defvar *1) +(defvar *2) +(defvar *3) ;;; System variables @@ -165,6 +157,7 @@ This variable is buffer-local.") "*** Welcome to IELM *** Type (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) @@ -183,7 +176,6 @@ This variable is buffer-local.") (define-key map "\C-c\C-v" 'ielm-print-working-buffer) map) "Keymap for IELM mode.") -(defvaralias 'inferior-emacs-lisp-mode-map 'ielm-map) (easy-menu-define ielm-menu ielm-map "IELM mode menu." @@ -384,7 +376,7 @@ nonempty, then flushes the buffer." (set-match-data ielm-match-data) (save-excursion (with-temp-buffer - (condition-case err + (condition-case-unless-debug err (unwind-protect ;; The next let form creates default ;; bindings for *, ** and ***. But @@ -436,15 +428,26 @@ nonempty, then flushes the buffer." (goto-char pmark) (unless error-type - (condition-case nil + (condition-case err ;; Self-referential objects cause loops in the printer, so ;; trap quits here. May as well do errors, too (unless for-effect - (setq output (concat output (pp-to-string result) - (let ((str (eval-expression-print-format result))) - (if str (propertize str 'font-lock-face 'shadow)))))) - (error (setq error-type "IELM Error") - (setq result "Error during pretty-printing (bug in pp)")) + (let* ((ielmbuf (current-buffer)) + (aux (let ((str (eval-expression-print-format result))) + (if str (propertize str 'font-lock-face 'shadow))))) + (setq output (with-temp-buffer + (let ((tmpbuf (current-buffer))) + ;; Use print settings (e.g. print-circle, + ;; print-gensym, etc...) from the + ;; right buffer! + (with-current-buffer ielmbuf + (cl-prin1 result tmpbuf)) + (pp-buffer) + (concat (buffer-string) aux)))))) + (error + (setq error-type "IELM Error") + (setq result (format "Error during pretty-printing (bug in pp): %S" + err))) (quit (setq error-type "IELM Error") (setq result "Quit during pretty-printing")))) (if error-type @@ -517,9 +520,6 @@ causes output to be directed to the ielm buffer. set to a different value during evaluation. You can use (princ VALUE) or (pp VALUE) to write to the ielm buffer. -Expressions evaluated by IELM are not subject to `debug-on-quit' or -`debug-on-error'. - The behavior of IELM may be customized with the following variables: * To stop beeping on error, set `ielm-noisy' to nil. * If you don't like the prompt, you can change it by setting `ielm-prompt'. @@ -551,10 +551,11 @@ Customized bindings may be defined in `ielm-map', which currently contains: ;; Useful for `hs-minor-mode'. (setq-local comment-start ";") (setq-local comment-use-syntax t) + (setq-local lexical-binding t) - (set (make-local-variable 'indent-line-function) 'ielm-indent-line) + (set (make-local-variable 'indent-line-function) #'ielm-indent-line) (set (make-local-variable 'ielm-working-buffer) (current-buffer)) - (set (make-local-variable 'fill-paragraph-function) 'lisp-fill-paragraph) + (set (make-local-variable 'fill-paragraph-function) #'lisp-fill-paragraph) ;; Value holders (set (make-local-variable '*) nil) @@ -604,17 +605,19 @@ Customized bindings may be defined in `ielm-map', which currently contains: ;;; User command ;;;###autoload -(defun ielm nil +(defun ielm (&optional buf-name) "Interactively evaluate Emacs Lisp expressions. -Switches to the buffer `*ielm*', or creates it if it does not exist. +Switches to the buffer named BUF-NAME if provided (`*ielm*' by default), +or creates it if it does not exist. See `inferior-emacs-lisp-mode' for details." (interactive) - (let (old-point) - (unless (comint-check-proc "*ielm*") - (with-current-buffer (get-buffer-create "*ielm*") + (let (old-point + (buf-name (or buf-name "*ielm*"))) + (unless (comint-check-proc buf-name) + (with-current-buffer (get-buffer-create buf-name) (unless (zerop (buffer-size)) (setq old-point (point))) (inferior-emacs-lisp-mode))) - (pop-to-buffer-same-window "*ielm*") + (pop-to-buffer-same-window buf-name) (when old-point (push-mark old-point)))) (provide 'ielm) diff --git a/lisp/iimage.el b/lisp/iimage.el index e51108ee28f..3b5006491aa 100644 --- a/lisp/iimage.el +++ b/lisp/iimage.el @@ -90,7 +90,7 @@ Examples of image filename patterns to match: (interactive "P") (iimage-mode-buffer nil) (iimage-mode-buffer t) - (recenter arg)) + (recenter-top-bottom arg)) ;;;###autoload (define-obsolete-function-alias 'turn-on-iimage-mode 'iimage-mode "24.1") @@ -116,6 +116,7 @@ Examples of image filename patterns to match: (defun iimage-mode-buffer (arg) "Display images if ARG is non-nil, undisplay them otherwise." (let ((image-path (cons default-directory iimage-mode-image-search-path)) + (edges (window-inside-pixel-edges (get-buffer-window))) file) (with-silent-modifications (save-excursion @@ -128,10 +129,15 @@ Examples of image filename patterns to match: ;; remove them either (we may leave some of ours, and we ;; may remove other packages's display properties). (if arg - (add-text-properties (match-beginning 0) (match-end 0) - `(display ,(create-image file) - modification-hooks - (iimage-modification-hook))) + (add-text-properties + (match-beginning 0) (match-end 0) + `(display + ,(create-image file nil nil + :max-width (- (nth 2 edges) (nth 0 edges)) + :max-height (- (nth 3 edges) (nth 1 edges))) + keymap ,image-map + modification-hooks + (iimage-modification-hook))) (remove-text-properties (match-beginning 0) (match-end 0) '(display modification-hooks)))))))))) diff --git a/lisp/image-dired.el b/lisp/image-dired.el index 9d4e45639ae..c9b31e9f1f8 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -587,8 +587,9 @@ Create the thumbnails directory if it does not exist." (let* ((thumb-file (image-dired-thumb-name file)) (thumb-attr (file-attributes thumb-file))) (when (or (not thumb-attr) - (time-less-p (nth 5 thumb-attr) - (nth 5 (file-attributes file)))) + (time-less-p (file-attribute-modification-time thumb-attr) + (file-attribute-modification-time + (file-attributes file)))) (image-dired-create-thumb file thumb-file)) (create-image thumb-file) ;; (list 'image :type 'jpeg @@ -752,7 +753,8 @@ Increase at own risk.") (let* ((width (int-to-string (image-dired-thumb-size 'width))) (height (int-to-string (image-dired-thumb-size 'height))) (modif-time (format-time-string - "%s" (nth 5 (file-attributes original-file)))) + "%s" (file-attribute-modification-time + (file-attributes original-file)))) (thumbnail-nq8-file (replace-regexp-in-string ".png\\'" "-nq8.png" thumbnail-file)) (spec @@ -2652,8 +2654,8 @@ tags to their respective image file. Internal function used by ;; (mapcar ;; (lambda (f) ;; (let ((fattribs (file-attributes f))) -;; ;; Get last access time and file size -;; `(,(nth 4 fattribs) ,(nth 7 fattribs) ,f))) +;; `(,(file-attribute-access-time fattribs) +;; ,(file-attribute-size fattribs) ,f))) ;; (directory-files (image-dired-dir) t ".+\\.thumb\\..+$")) ;; ;; Sort function. Compare time between two files. ;; (lambda (l1 l2) diff --git a/lisp/image-file.el b/lisp/image-file.el index 123a50e1846..6cadc42110f 100644 --- a/lisp/image-file.el +++ b/lisp/image-file.el @@ -110,11 +110,8 @@ absolute file name and number of characters inserted." (let* ((ibeg (point)) (iend (+ (point) (cadr rval))) (visitingp (and visit (= ibeg (point-min)) (= iend (point-max)))) - (data - (string-make-unibyte - (buffer-substring-no-properties ibeg iend))) - (image - (create-image data nil t)) + (image (create-image (encode-coding-region ibeg iend 'binary t) + nil t)) (props `(display ,image yank-handler @@ -180,9 +177,6 @@ Optional argument ARGS are the arguments to call FUNCTION with." ;;;###autoload (define-minor-mode auto-image-file-mode "Toggle visiting of image files as images (Auto Image File mode). -With a prefix argument ARG, enable Auto Image File mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. An image file is one whose name has an extension in `image-file-name-extensions', or matches a regexp in diff --git a/lisp/image-mode.el b/lisp/image-mode.el index 3666009c7e0..5c30f4085c3 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -53,7 +53,7 @@ See `image-mode-winprops'.") It is called with one argument, the initial WINPROPS.") ;; FIXME this doesn't seem mature yet. Document in manual when it is. -(defvar image-transform-resize nil +(defvar-local image-transform-resize nil "The image resize operation. Its value should be one of the following: - nil, meaning no resizing. @@ -61,10 +61,10 @@ Its value should be one of the following: - `fit-width', meaning to fit the image to the window width. - A number, which is a scale factor (the default size is 1).") -(defvar image-transform-scale 1.0 +(defvar-local image-transform-scale 1.0 "The scale factor of the image being displayed.") -(defvar image-transform-rotation 0.0 +(defvar-local image-transform-rotation 0.0 "Rotation angle for the image in the current Image mode buffer.") (defvar image-transform-right-angle-fudge 0.0001 @@ -145,7 +145,7 @@ otherwise it defaults to t, used for times when the buffer is not displayed." (unless (listp image-mode-winprops-alist) (setq image-mode-winprops-alist nil)) (add-hook 'window-configuration-change-hook - 'image-mode-reapply-winprops nil t)) + #'image-mode-reapply-winprops nil t)) ;;; Image scrolling functions @@ -412,9 +412,6 @@ call." (defvar-local image-multi-frame nil "Non-nil if image for the current Image mode buffer has multiple frames.") -(defvar image-mode-previous-major-mode nil - "Internal variable to keep the previous non-image major mode.") - (defvar image-mode-map (let ((map (make-sparse-keymap))) (define-key map "\C-c\C-c" 'image-toggle-display) @@ -551,7 +548,7 @@ Key bindings: (unless (display-images-p) (error "Display does not support images")) - (kill-all-local-variables) + (major-mode-suspend) (setq major-mode 'image-mode) (if (not (image-get-display-property)) @@ -575,8 +572,8 @@ Key bindings: ;; Keep track of [vh]scroll when switching buffers (image-mode-setup-winprops) - (add-hook 'change-major-mode-hook 'image-toggle-display-text nil t) - (add-hook 'after-revert-hook 'image-after-revert-hook nil t) + (add-hook 'change-major-mode-hook #'image-toggle-display-text nil t) + (add-hook 'after-revert-hook #'image-after-revert-hook nil t) (run-mode-hooks 'image-mode-hook) (let ((image (image-get-display-property)) (msg1 (substitute-command-keys @@ -620,9 +617,6 @@ mouse-3: Previous frame" ;;;###autoload (define-minor-mode image-minor-mode "Toggle Image minor mode in this buffer. -With a prefix argument ARG, enable Image minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. 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 @@ -641,26 +635,7 @@ A non-mage major mode found from `auto-mode-alist' or fundamental mode displays an image file as text." ;; image-mode-as-text = normal-mode + image-minor-mode (let ((previous-image-type image-type)) ; preserve `image-type' - (if image-mode-previous-major-mode - ;; Restore previous major mode that was already found by this - ;; function and cached in `image-mode-previous-major-mode' - (funcall image-mode-previous-major-mode) - (let ((auto-mode-alist - (delq nil (mapcar - (lambda (elt) - (unless (memq (or (car-safe (cdr elt)) (cdr elt)) - '(image-mode image-mode-maybe image-mode-as-text)) - elt)) - auto-mode-alist))) - (magic-fallback-mode-alist - (delq nil (mapcar - (lambda (elt) - (unless (memq (or (car-safe (cdr elt)) (cdr elt)) - '(image-mode image-mode-maybe image-mode-as-text)) - elt)) - magic-fallback-mode-alist)))) - (normal-mode) - (setq-local image-mode-previous-major-mode major-mode))) + (major-mode-restore '(image-mode image-mode-maybe image-mode-as-text)) ;; Restore `image-type' after `kill-all-local-variables' in `normal-mode'. (setq image-type previous-image-type) ;; Enable image minor mode with `C-c C-c'. @@ -717,6 +692,7 @@ on these modes." Remove text properties that display the image." (let ((inhibit-read-only t) (buffer-undo-list t) + (create-lockfiles nil) ; avoid changing dir mtime by lock_file (modified (buffer-modified-p))) (remove-list-of-text-properties (point-min) (point-max) '(display read-nonsticky ;; intangible @@ -749,16 +725,19 @@ was inserted." (not (and (boundp 'epa-file-encrypt-to) (local-variable-p 'epa-file-encrypt-to)))))) - (file-or-data (if data-p - (string-make-unibyte - (buffer-substring-no-properties (point-min) (point-max))) - filename)) + (file-or-data + (if data-p + (let ((str + (buffer-substring-no-properties (point-min) (point-max)))) + (if enable-multibyte-characters + (encode-coding-string str buffer-file-coding-system) + str)) + filename)) ;; If we have a `fit-width' or a `fit-height', don't limit ;; the size of the image to the window size. (edges (and (null image-transform-resize) - (window-inside-pixel-edges - (get-buffer-window (current-buffer))))) - (type (if (fboundp 'imagemagick-types) + (window-inside-pixel-edges (get-buffer-window)))) + (type (if (image--imagemagick-wanted-p filename) 'imagemagick (image-type file-or-data nil data-p))) ;; :scale 1: If we do not set this, create-image will apply @@ -782,7 +761,7 @@ was inserted." rear-nonsticky (display) ;; intangible read-only t front-sticky (read-only))) - (let ((buffer-file-truename nil)) ; avoid changing dir mtime by lock_file + (let ((create-lockfiles nil)) ; avoid changing dir mtime by lock_file (add-text-properties (point-min) (point-max) props) (restore-buffer-modified-p modified)) ;; Inhibit the cursor when the buffer contains only an image, @@ -805,6 +784,13 @@ was inserted." (if (called-interactively-p 'any) (message "Repeat this command to go back to displaying the file as text")))) +(defun image--imagemagick-wanted-p (filename) + (and (fboundp 'imagemagick-types) + (not (eq imagemagick-types-inhibit t)) + (not (and filename (file-name-extension filename) + (memq (intern (upcase (file-name-extension filename)) obarray) + imagemagick-types-inhibit))))) + (defun image-toggle-hex-display () "Toggle between image and hex display." (interactive) @@ -1163,6 +1149,7 @@ compiled with ImageMagick support." ;; Note: `image-size' looks up and thus caches the untransformed ;; image. There's no easy way to prevent that. (let* ((size (image-size spec t)) + (edges (window-inside-pixel-edges (get-buffer-window))) (resized (cond ((numberp image-transform-resize) @@ -1172,13 +1159,11 @@ compiled with ImageMagick support." ((eq image-transform-resize 'fit-width) (image-transform-fit-width (car size) (cdr size) - (- (nth 2 (window-inside-pixel-edges)) - (nth 0 (window-inside-pixel-edges))))) + (- (nth 2 edges) (nth 0 edges)))) ((eq image-transform-resize 'fit-height) (let ((res (image-transform-fit-width (cdr size) (car size) - (- (nth 3 (window-inside-pixel-edges)) - (nth 1 (window-inside-pixel-edges)))))) + (- (nth 3 edges) (nth 1 edges))))) (cons (cdr res) (car res))))))) `(,@(when (car resized) (list :width (car resized))) diff --git a/lisp/image.el b/lisp/image.el index 585e6e10be2..b36a5138b1b 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -29,6 +29,7 @@ "Image support." :group 'multimedia) +(declare-function image-flush "image.c" (spec &optional frame)) (defalias 'image-refresh 'image-flush) (defconst image-type-header-regexps @@ -247,6 +248,7 @@ compatibility with versions of Emacs that lack the variable ;; Used to be in image-type-header-regexps, but now not used anywhere ;; (since 2009-08-28). (defun image-jpeg-p (data) + (declare (obsolete "It is unused inside Emacs and will be removed." "27.1")) "Value is non-nil if DATA, a string, consists of JFIF image data. We accept the tag Exif because that is the same format." (setq data (ignore-errors (string-to-unibyte data))) @@ -259,7 +261,7 @@ We accept the tag Exif because that is the same format." (setq i (1+ i)) (when (>= (+ i 2) len) (throw 'jfif nil)) - (let ((nbytes (+ (lsh (aref data (+ i 1)) 8) + (let ((nbytes (+ (ash (aref data (+ i 1)) 8) (aref data (+ i 2)))) (code (aref data i))) (when (and (>= code #xe0) (<= code #xef)) @@ -313,7 +315,7 @@ be determined." (buffer-substring (point-min) (min (point-max) - (+ (point-min) 256)))))) + (+ (point-min) 8192)))))) (setq image-type (cdr image-type)))) (setq type image-type types nil) @@ -337,7 +339,7 @@ be determined." (file-readable-p file) (with-temp-buffer (set-buffer-multibyte nil) - (insert-file-contents-literally file nil 0 256) + (insert-file-contents-literally file nil 0 8192) (image-type-from-buffer)))) @@ -547,7 +549,7 @@ height of the image; integer values are taken as pixel values." `(display ,(if slice (list (cons 'slice slice) image) image) - rear-nonsticky (display) + rear-nonsticky t keymap ,image-map)))) @@ -802,19 +804,22 @@ If the image has a non-nil :speed property, it acts as a multiplier for the animation speed. A negative value means to animate in reverse." (when (and (buffer-live-p (plist-get (cdr image) :animate-buffer)) ;; Delayed more than two seconds more than expected. - (or (<= (- (float-time) target-time) 2) + (or (time-less-p (time-since target-time) 2) (progn (message "Stopping animation; animation possibly too big") nil))) (image-show-frame image n t) (let* ((speed (image-animate-get-speed image)) - (time (float-time)) + (time (current-time)) (animation (image-multi-frame-p image)) + (time-to-load-image (time-since time)) + (stated-delay-time (/ (or (cdr animation) + image-default-frame-delay) + (float (abs speed)))) ;; Subtract off the time we took to load the image from the ;; stated delay time. - (delay (max (+ (* (or (cdr animation) image-default-frame-delay) - (/ 1.0 (abs speed))) - time (- (float-time))) + (delay (max (float-time (time-subtract stated-delay-time + time-to-load-image)) image-minimum-frame-delay)) done) (setq n (if (< speed 0) @@ -980,17 +985,20 @@ default is 20%." 0.8))) (defun image--get-image () - (let ((image (get-text-property (point) 'display))) + "Return the image at point." + (let ((image (get-char-property (point) 'display))) (unless (eq (car-safe image) 'image) (error "No image under point")) image)) (defun image--get-imagemagick-and-warn () - (unless (fboundp 'imagemagick-types) - (error "Cannot rescale images without ImageMagick support")) + (unless (or (fboundp 'imagemagick-types) (image-transforms-p)) + (error "Cannot rescale images on this terminal")) (let ((image (image--get-image))) (image-flush image) - (plist-put (cdr image) :type 'imagemagick) + (when (and (fboundp 'imagemagick-types) + (not (image-transforms-p))) + (plist-put (cdr image) :type 'imagemagick)) image)) (defun image--change-size (factor) @@ -1010,6 +1018,8 @@ default is 20%." (setq new (nconc new (list key val)))))) new))) +(declare-function image-size "image.c" (spec &optional pixels frame)) + (defun image--current-scaling (image new-image) ;; The image may be scaled due to many reasons (:scale, :max-width, ;; etc), so find out what the current scaling is based on the @@ -1018,24 +1028,25 @@ default is 20%." (display-width (car (image-size image t)))) (/ (float display-width) image-width))) -(defun image-rotate () - "Rotate the image under point by 90 degrees clockwise." - (interactive) +(defun image-rotate (&optional angle) + "Rotate the image under point by ANGLE degrees clockwise. +If nil, ANGLE defaults to 90. Interactively, rotate the image 90 +degrees clockwise with no prefix argument, and counter-clockwise +with a prefix argument. Note that most image types support +rotations by only multiples of 90 degrees." + (interactive (and current-prefix-arg '(-90))) (let ((image (image--get-imagemagick-and-warn))) - (plist-put (cdr image) :rotation - (float (mod (+ (or (plist-get (cdr image) :rotation) 0) 90) - ;; We don't want to exceed 360 degrees - ;; rotation, because it's not seen as valid - ;; in exif data. - 360))))) + (setf (image-property image :rotation) + (float (mod (+ (or (image-property image :rotation) 0) + (or angle 90)) + ;; We don't want to exceed 360 degrees rotation, + ;; because it's not seen as valid in Exif data. + 360))))) (defun image-save () "Save the image under point." (interactive) - (let ((image (get-text-property (point) 'display))) - (when (or (not (consp image)) - (not (eq (car image) 'image))) - (error "No image under point")) + (let ((image (image--get-image))) (with-temp-buffer (let ((file (plist-get (cdr image) :file))) (if file diff --git a/lisp/image/compface.el b/lisp/image/compface.el index 23752618542..2f2adbd0292 100644 --- a/lisp/image/compface.el +++ b/lisp/image/compface.el @@ -1,9 +1,9 @@ -;;; compface.el --- functions for converting X-Face headers +;;; compface.el --- functions for converting X-Face headers -*- lexical-binding: t -*- ;; Copyright (C) 2002-2019 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; Keywords: news +;; Keywords: multimedia, news ;; This file is part of GNU Emacs. @@ -24,7 +24,6 @@ ;;; Code: -;;;### (defun uncompface (face) "Convert FACE to pbm. Requires the external programs `uncompface', and `icontopbm'. On a @@ -37,9 +36,8 @@ or `faces-xface' and `netpbm' or `libgr-progs', for instance." ;; At least "icontopbm" doesn't work with Windows because ;; the line-break code is converted into CRLF by default. (coding-system-for-write 'binary)) - (and (eq 0 (apply 'call-process-region (point-min) (point-max) - "uncompface" - 'delete '(t nil) nil)) + (and (eq 0 (call-process-region (point-min) (point-max) + "uncompface" 'delete '(t nil))) (progn (goto-char (point-min)) (insert "/* Format_version=1, Width=48, Height=48, Depth=1,\ diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el index 76c1ac1644d..9a1ec3b556b 100644 --- a/lisp/image/gravatar.el +++ b/lisp/image/gravatar.el @@ -94,11 +94,7 @@ Valid sizes range from 1 to 2048 inclusive." (not (file-exists-p (url-cache-create-filename url)))) (t (let ((cache-time (url-is-cached url))) (if cache-time - (time-less-p - (time-add - cache-time - gravatar-cache-ttl) - (current-time)) + (time-less-p (time-add cache-time gravatar-cache-ttl) nil) t))))) (defun gravatar-get-data () @@ -130,10 +126,8 @@ where GRAVATAR is either an image descriptor, or the symbol (let ((args (list url 'gravatar-retrieved (list cb (when cbargs cbargs))))) - (when (> (length (if (featurep 'xemacs) - (cdr (split-string (function-arglist 'url-retrieve))) - (help-function-arglist 'url-retrieve))) - 4) + (when (> (length (help-function-arglist 'url-retrieve)) + 4) (setq args (nconc args (list t)))) (apply #'url-retrieve args)) (apply cb diff --git a/lisp/imenu.el b/lisp/imenu.el index a4732df6d97..5084fe61eff 100644 --- a/lisp/imenu.el +++ b/lisp/imenu.el @@ -59,7 +59,7 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -102,14 +102,7 @@ This might not yet be honored by all index-building functions." :group 'imenu :version "26.2") -(defvar imenu-always-use-completion-buffer-p nil) -(make-obsolete-variable 'imenu-always-use-completion-buffer-p - 'imenu-use-popup-menu "22.1") - -(defcustom imenu-use-popup-menu - (if imenu-always-use-completion-buffer-p - (not (eq imenu-always-use-completion-buffer-p 'never)) - 'on-mouse) +(defcustom imenu-use-popup-menu 'on-mouse "Use a popup menu rather than a minibuffer prompt. If nil, always use a minibuffer prompt. If t, always use a popup menu, @@ -119,8 +112,7 @@ If `on-mouse' use a popup menu when `imenu' was invoked with the mouse." (other :tag "Always" t)) :group 'imenu) -(defcustom imenu-eager-completion-buffer - (not (eq imenu-always-use-completion-buffer-p 'never)) +(defcustom imenu-eager-completion-buffer t "If non-nil, eagerly popup the completion buffer." :type 'boolean :group 'imenu @@ -356,98 +348,6 @@ Don't move point." (signal 'imenu-unavailable (list (apply #'format-message format args)))) -(defun imenu-example--lisp-extract-index-name () - ;; Example of a candidate for `imenu-extract-index-name-function'. - ;; This will generate a flat index of definitions in a lisp file. - (declare (obsolete nil "23.2")) - (save-match-data - (and (looking-at "(def") - (condition-case nil - (progn - (down-list 1) - (forward-sexp 2) - (let ((beg (point)) - (end (progn (forward-sexp -1) (point)))) - (buffer-substring beg end))) - (error nil))))) - -(defun imenu-example--create-lisp-index () - ;; Example of a candidate for `imenu-create-index-function'. - ;; It will generate a nested index of definitions. - (declare (obsolete nil "23.2")) - (let ((index-alist '()) - (index-var-alist '()) - (index-type-alist '()) - (index-unknown-alist '())) - (goto-char (point-max)) - ;; Search for the function - (while (beginning-of-defun) - (save-match-data - (and (looking-at "(def") - (save-excursion - (down-list 1) - (cond - ((looking-at "def\\(var\\|const\\)") - (forward-sexp 2) - (push (imenu-example--name-and-position) - index-var-alist)) - ((looking-at "def\\(un\\|subst\\|macro\\|advice\\)") - (forward-sexp 2) - (push (imenu-example--name-and-position) - index-alist)) - ((looking-at "def\\(type\\|struct\\|class\\|ine-condition\\)") - (forward-sexp 2) - (if (= (char-after (1- (point))) ?\)) - (progn - (forward-sexp -1) - (down-list 1) - (forward-sexp 1))) - (push (imenu-example--name-and-position) - index-type-alist)) - (t - (forward-sexp 2) - (push (imenu-example--name-and-position) - index-unknown-alist))))))) - (and index-var-alist - (push (cons "Variables" index-var-alist) - index-alist)) - (and index-type-alist - (push (cons "Types" index-type-alist) - index-alist)) - (and index-unknown-alist - (push (cons "Syntax-unknown" index-unknown-alist) - index-alist)) - index-alist)) - -;; Regular expression to find C functions -(defvar imenu-example--function-name-regexp-c - (concat - "^[a-zA-Z0-9]+[ \t]?" ; Type specs; there can be no - "\\([a-zA-Z0-9_*]+[ \t]+\\)?" ; more than 3 tokens, right? - "\\([a-zA-Z0-9_*]+[ \t]+\\)?" - "\\([*&]+[ \t]*\\)?" ; Pointer. - "\\([a-zA-Z0-9_*]+\\)[ \t]*(" ; Name. - )) - -(defun imenu-example--create-c-index (&optional regexp) - (declare (obsolete nil "23.2")) - (let ((index-alist '()) - char) - (goto-char (point-min)) - ;; Search for the function - (save-match-data - (while (re-search-forward - (or regexp imenu-example--function-name-regexp-c) - nil t) - (backward-up-list 1) - (save-excursion - (goto-char (scan-sexps (point) 1)) - (setq char (following-char))) - ;; Skip this function name if it is a prototype declaration. - (if (not (eq char ?\;)) - (push (imenu-example--name-and-position) index-alist)))) - (nreverse index-alist))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Internal variables @@ -827,7 +727,8 @@ depending on PATTERNS." ;; Insert the item unless it is already present. (unless (or (member item (cdr menu)) (and imenu-generic-skip-comments-and-strings - (nth 8 (syntax-ppss)))) + (save-excursion + (goto-char start) (nth 8 (syntax-ppss))))) (setcdr menu (cons item (cdr menu))))) ;; Go to the start of the match, to make sure we @@ -839,9 +740,14 @@ depending on PATTERNS." (dolist (item index-alist) (when (listp item) (setcdr item (sort (cdr item) 'imenu--sort-by-position)))) + ;; Remove any empty menus. That can happen because of skipping + ;; things inside comments or strings. + (setq index-alist (cl-delete-if + (lambda (it) (and (consp it) (null (cdr it)))) + index-alist)) (let ((main-element (assq nil index-alist))) (nconc (delq main-element (delq 'dummy index-alist)) - (cdr main-element))))) + (cdr main-element))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; diff --git a/lisp/indent.el b/lisp/indent.el index da58a420fe6..bf87d6af760 100644 --- a/lisp/indent.el +++ b/lisp/indent.el @@ -294,7 +294,8 @@ indentation by specifying a large negative ARG." "Indent current line to COLUMN. This function removes or adds spaces and tabs at beginning of line only if necessary. It leaves point at end of indentation." - (back-to-indentation) + (beginning-of-line 1) + (skip-chars-forward " \t") (let ((cur-col (current-column))) (cond ((< cur-col column) (if (>= (- column (* (/ cur-col tab-width) tab-width)) tab-width) @@ -302,8 +303,13 @@ only if necessary. It leaves point at end of indentation." (progn (skip-chars-backward " ") (point)))) (indent-to column)) ((> cur-col column) ; too far right (after tab?) - (delete-region (progn (move-to-column column t) (point)) - (progn (backward-to-indentation 0) (point))))))) + (delete-region (progn (move-to-column column t) (point)) + ;; The `move-to-column' call may replace + ;; tabs with spaces, so we can't reuse the + ;; previous start point. + (progn (beginning-of-line 1) + (skip-chars-forward " \t") + (point))))))) (defun current-left-margin () "Return the left margin to use for this line. diff --git a/lisp/info-look.el b/lisp/info-look.el index 045776b6bc9..8a484bbed1a 100644 --- a/lisp/info-look.el +++ b/lisp/info-look.el @@ -3,8 +3,7 @@ ;; Copyright (C) 1995-1999, 2001-2019 Free Software Foundation, Inc. -;; Author: Ralph Schleicher <rs@nunatak.allgaeu.org> -;; (did not show signs of life (Nov 2001) -stef) +;; Author: Ralph Schleicher <rs@ralph-schleicher.de> ;; Keywords: help languages ;; This file is part of GNU Emacs. @@ -619,7 +618,8 @@ Return nil if there is nothing appropriate in the buffer near point." beg end) (cond ((and (memq (get-char-property (point) 'face) - '(custom-variable-tag custom-variable-tag-face)) + '(custom-variable-tag custom-variable-obsolete + custom-variable-tag-face)) (setq beg (previous-single-char-property-change (point) 'face nil (line-beginning-position))) (setq end (next-single-char-property-change diff --git a/lisp/info-xref.el b/lisp/info-xref.el index e8750a7db72..c55398b73f9 100644 --- a/lisp/info-xref.el +++ b/lisp/info-xref.el @@ -71,7 +71,7 @@ you should set this variable to nil." (defun info-xref-lock-file-p (filename) "Return non-nil if FILENAME is an Emacs lock file. A lock file is \".#foo.txt\" etc per `lock-buffer'." - (string-match "\\(\\`\\|\\/\\)\\.#" filename)) + (string-match "\\(\\`\\|/\\)\\.#" filename)) (defun info-xref-subfile-p (filename) "Return t if FILENAME is an info subfile. diff --git a/lisp/info.el b/lisp/info.el index 94b0ef6ce75..cc18ea11f33 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -343,7 +343,9 @@ This only has an effect if `Info-hide-note-references' is non-nil." This applies to Info search for regular expressions. You might want to use something like \"[ \\t\\r\\n]+\" instead. In the Customization buffer, that is `[' followed by a space, -a tab, a carriage return (control-M), a newline, and `]+'." +a tab, a carriage return (control-M), a newline, and `]+'. Don't +add any capturing groups into this value; that can change the +numbering of existing capture groups in unexpected ways." :type 'regexp :group 'info) @@ -380,12 +382,6 @@ with wrapping around the current Info node." :type 'hook :group 'info) -(defvar Info-edit-mode-hook nil - "Hook run when `Info-edit-mode' is activated.") - -(make-obsolete-variable 'Info-edit-mode-hook - "editing Info nodes by hand is not recommended." "24.4") - (defvar-local Info-current-file nil "Info file that Info is now looking at, or nil. This is the name that was specified in Info, not the actual file name. @@ -642,21 +638,23 @@ Do the right thing if the file has been compressed or zipped." (insert-file-contents-literally fullname visit) (let ((inhibit-read-only t) (coding-system-for-write 'no-conversion) - (inhibit-null-byte-detection t) ; Index nodes include null bytes + (inhibit-nul-byte-detection t) ; Index nodes include null bytes (default-directory (or (file-name-directory fullname) default-directory))) (or (consp decoder) (setq decoder (list decoder))) (apply #'call-process-region (point-min) (point-max) (car decoder) t t nil (cdr decoder)))) - (let ((inhibit-null-byte-detection t)) ; Index nodes include null bytes + (let ((inhibit-nul-byte-detection t)) ; Index nodes include null bytes (insert-file-contents fullname visit))) ;; Clear the caches of modified Info files. (let* ((attribs-old (cdr (assoc fullname Info-file-attributes))) - (modtime-old (and attribs-old (nth 5 attribs-old))) + (modtime-old (and attribs-old + (file-attribute-modification-time attribs-old))) (attribs-new (and (stringp fullname) (file-attributes fullname))) - (modtime-new (and attribs-new (nth 5 attribs-new)))) + (modtime-new (and attribs-new + (file-attribute-modification-time attribs-new)))) (when (and modtime-old modtime-new (time-less-p modtime-old modtime-new)) (setq Info-index-nodes (remove (assoc (or Info-current-file filename) @@ -877,10 +875,13 @@ In standalone mode, \\<Info-mode-map>\\[Info-exit] exits Emacs itself." (forward-line 1) ; does the line after delimiter match REGEXP? (re-search-backward regexp beg t)))) -(defun Info-find-file (filename &optional noerror) +(defun Info-find-file (filename &optional noerror no-pop-to-dir) "Return expanded FILENAME, or t if FILENAME is \"dir\". Optional second argument NOERROR, if t, means if file is not found -just return nil (no error)." +just return nil (no error). + +If NO-POP-TO-DIR, don't try to pop to the info buffer if we can't +find a node." ;; Convert filename to lower case if not found as specified. ;; Expand it. (cond @@ -939,7 +940,8 @@ just return nil (no error)." (if noerror (setq filename nil) ;; If there is no previous Info file, go to the directory. - (unless Info-current-file + (when (and (not no-pop-to-dir) + (not Info-current-file)) (Info-directory)) (user-error "Info file %s does not exist" filename))) filename)))) @@ -1371,7 +1373,7 @@ is non-nil)." ;; Index nodes include null bytes. DIR ;; files should not have indices, but who ;; knows... - (let ((inhibit-null-byte-detection t)) + (let ((inhibit-nul-byte-detection t)) (insert-file-contents file) (setq Info-dir-file-name file) (push (current-buffer) buffers) @@ -1525,7 +1527,7 @@ is non-nil)." (save-restriction (narrow-to-region start (point)) (goto-char (point-min)) - (while (re-search-forward "^* \\([^:\n]+:\\(:\\|[^.\n]+\\).\\)" nil 'move) + (while (re-search-forward "^\\* \\([^:\n]+:[^.\n]+.\\)" nil 'move) ;; Fold case straight away; `member-ignore-case' here wasteful. (let ((x (downcase (match-string 1)))) (if (member x seen) @@ -1596,7 +1598,7 @@ is non-nil)." "Unescape double quotes and backslashes in VALUE." (let ((start 0) (unquote value)) - (while (string-match "[^\\\"]*\\(\\\\\\)[\\\\\"]" unquote start) + (while (string-match "[^\\\"]*\\(\\\\\\)[\\\"]" unquote start) (setq unquote (replace-match "" t t unquote 1)) (setq start (- (match-end 0) 1))) unquote)) @@ -1613,7 +1615,7 @@ escaped (\\\",\\\\)." (let ((start 0) (parameter-alist)) (while (string-match - "\\s *\\([^=]+\\)=\\(?:\\([^\\s \"]+\\)\\|\\(?:\"\\(\\(?:[^\\\"]\\|\\\\[\\\\\"]\\)*\\)\"\\)\\)" + "\\s *\\([^=]+\\)=\\(?:\\([^\\s \"]+\\)\\|\\(?:\"\\(\\(?:[^\\\"]\\|\\\\[\\\"]\\)*\\)\"\\)\\)" parameter-string start) (setq start (match-end 0)) (push (cons (match-string 1 parameter-string) @@ -1877,7 +1879,7 @@ See `completing-read' for a description of arguments and usage." (lambda (string pred action) (complete-with-action action - (Info-build-node-completions (Info-find-file file1)) + (Info-build-node-completions (Info-find-file file1 nil t)) string pred)) nodename predicate code)))) ;; Otherwise use Info-read-node-completion-table. @@ -2022,7 +2024,7 @@ If DIRECTION is `backward', search in the reverse direction." Info-isearch-initial-node bound (and found (> found opoint-min) (< found opoint-max))) - (signal 'user-search-failed (list regexp "(end of node)"))) + (signal 'user-search-failed (list regexp "end of node"))) ;; If no subfiles, give error now. (unless (or found Info-current-subfile) @@ -2450,11 +2452,12 @@ Table of contents is created from the tree structure of menus." "Insert table of contents with references to nodes." (let ((section "Top")) (while nodes - (let ((node (assoc (car nodes) node-list))) - (unless (member (nth 2 node) (list nil section)) - (insert (setq section (nth 2 node)) "\n")) - (insert (make-string level ?\t)) - (insert "*Note " (car nodes) ":: \n") + (let ((node (assoc (car nodes) node-list)) + (indentation (make-string level ?\t))) + (when (and (not (member (nth 2 node) (list nil section))) + (not (equal (nth 1 node) (nth 2 node)))) + (insert indentation (setq section (nth 2 node)) "\n")) + (insert indentation "*Note " (car nodes) ":: \n") (Info-toc-insert (nth 3 node) node-list (1+ level) curr-file) (setq nodes (cdr nodes)))))) @@ -2728,7 +2731,7 @@ Because of ambiguities, this should be concatenated with something like (user-error "No menu in this node")) (cond ((eq (car-safe action) 'boundaries) nil) - ((eq action 'metadata) `(metadata (category . info-menu))) + ((eq action 'metadata) '(metadata (category . info-menu))) ((eq action 'lambda) (re-search-forward (concat "\n\\* +" (regexp-quote string) ":") nil t)) @@ -3934,8 +3937,8 @@ If FORK is a string, it is the name to use for the new buffer." If FORK is non-nil, it is passed to `Info-goto-node'." (let (node) (cond - ((setq node (Info-get-token (point) "[hf]t?tps?://" - "\\([hf]t?tps?://[^ \t\n\"`‘({<>})’']+\\)")) + ((setq node (Info-get-token (point) "\\(?:f\\(?:ile\\|tp\\)\\|https?\\)://" + "\\(\\(?:f\\(?:ile\\|tp\\)\\|https?\\)://[^ \t\n\"`‘({<>})’']+\\)")) (browse-url node) (setq node t)) ((setq node (Info-get-token (point) "\\*note[ \n\t]+" @@ -4378,59 +4381,6 @@ Advanced commands: (copy-marker (marker-position m))) (make-marker)))))) -(define-obsolete-variable-alias 'Info-edit-map 'Info-edit-mode-map "24.1") -(defvar Info-edit-mode-map (let ((map (make-sparse-keymap))) - (set-keymap-parent map text-mode-map) - (define-key map "\C-c\C-c" 'Info-cease-edit) - map) - "Local keymap used within `e' command of Info.") - -(make-obsolete-variable 'Info-edit-mode-map - "editing Info nodes by hand is not recommended." - "24.4") - -;; Info-edit mode is suitable only for specially formatted data. -(put 'Info-edit-mode 'mode-class 'special) - -(define-derived-mode Info-edit-mode text-mode "Info Edit" - "Major mode for editing the contents of an Info node. -Like text mode with the addition of `Info-cease-edit' -which returns to Info mode for browsing." - (setq buffer-read-only nil) - (force-mode-line-update) - (buffer-enable-undo (current-buffer))) - -(make-obsolete 'Info-edit-mode - "editing Info nodes by hand is not recommended." "24.4") - -(defun Info-edit () - "Edit the contents of this Info node." - (interactive) - (Info-edit-mode) - (message "%s" (substitute-command-keys - "Editing: Type \\<Info-edit-mode-map>\\[Info-cease-edit] to return to info"))) - -(put 'Info-edit 'disabled "Editing Info nodes by hand is not recommended. -This feature will be removed in future.") - -(make-obsolete 'Info-edit - "editing Info nodes by hand is not recommended." "24.4") - -(defun Info-cease-edit () - "Finish editing Info node; switch back to Info proper." - (interactive) - ;; Do this first, so nothing has changed if user C-g's at query. - (and (buffer-modified-p) - (y-or-n-p "Save the file? ") - (save-buffer)) - (Info-mode) - (force-mode-line-update) - (and (marker-position Info-tag-table-marker) - (buffer-modified-p) - (message "Tags may have changed. Use Info-tagify if necessary"))) - -(make-obsolete 'Info-cease-edit - "editing Info nodes by hand is not recommended." "24.4") (defvar Info-file-list-for-emacs '("ediff" "eudc" "forms" "gnus" "info" ("Info" . "info") ("mh" . "mh-e") @@ -4763,7 +4713,7 @@ first line or header line, and for breadcrumb links.") ;; This is a serious problem for trying to handle multiple ;; frame types at once. We want this text to be invisible ;; on frames that can display the font above. - (when (memq (framep (selected-frame)) '(x pc w32 ns)) + (when (display-multi-font-p) (add-text-properties (1- (match-beginning 2)) (match-end 2) '(invisible t front-sticky nil rear-nonsticky t)))))) @@ -5199,7 +5149,7 @@ The INDENT level is ignored." TEXT is the text of the button we clicked on, a + or - item. TOKEN is data related to this node (NAME . FILE). INDENT is the current indentation depth." - (cond ((string-match "+" text) ;we have to expand this file + (cond ((string-match "\\+" text) ;we have to expand this file (speedbar-change-expand-button-char ?-) (if (speedbar-with-writable (save-excursion diff --git a/lisp/international/ccl.el b/lisp/international/ccl.el index 7f8aa7dda37..51626f51618 100644 --- a/lisp/international/ccl.el +++ b/lisp/international/ccl.el @@ -184,11 +184,19 @@ (defvar ccl-current-ic 0 "The current index for `ccl-program-vector'.") +;; The CCL compiled codewords are 28bits, but the CCL implementation +;; assumes that the codewords are sign-extended, so that data constants in +;; the upper part of the codeword are signed. This function truncates a +;; codeword to 28bits, and then sign extends the result to a fixnum. +(defun ccl-fixnum (code) + "Convert a CCL code word to a fixnum value." + (- (logxor (logand code #x0fffffff) #x08000000) #x08000000)) + (defun ccl-embed-data (data &optional ic) "Embed integer DATA in `ccl-program-vector' at `ccl-current-ic' and increment it. If IC is specified, embed DATA at IC." (if ic - (aset ccl-program-vector ic data) + (aset ccl-program-vector ic (ccl-fixnum data)) (let ((len (length ccl-program-vector))) (if (>= ccl-current-ic len) (let ((new (make-vector (* len 2) nil))) @@ -196,7 +204,7 @@ increment it. If IC is specified, embed DATA at IC." (setq len (1- len)) (aset new len (aref ccl-program-vector len))) (setq ccl-program-vector new)))) - (aset ccl-program-vector ccl-current-ic data) + (aset ccl-program-vector ccl-current-ic (ccl-fixnum data)) (setq ccl-current-ic (1+ ccl-current-ic)))) (defun ccl-embed-symbol (symbol prop) @@ -230,7 +238,8 @@ proper index number for SYMBOL. PROP should be `ccl-program-vector' at IC without altering the other bit field." (let ((relative (- ccl-current-ic (1+ ic)))) (aset ccl-program-vector ic - (logior (aref ccl-program-vector ic) (ash relative 8))))) + (logior (aref ccl-program-vector ic) + (ccl-fixnum (ash relative 8)))))) (defun ccl-embed-code (op reg data &optional reg2) "Embed CCL code for the operation OP and arguments REG and DATA in @@ -986,7 +995,8 @@ is a list of CCL-BLOCKs." (defun ccl-get-next-code () "Return a CCL code in `ccl-code' at `ccl-current-ic'." (prog1 - (aref ccl-code ccl-current-ic) + (let ((code (aref ccl-code ccl-current-ic))) + (if (numberp code) (ccl-fixnum code) code)) (setq ccl-current-ic (1+ ccl-current-ic)))) (defun ccl-dump-1 () @@ -1142,9 +1152,9 @@ is a list of CCL-BLOCKs." (progn (insert (logand code #xFFFFFF)) (setq i (1+ i))) - (insert (format "%c" (lsh code -16))) + (insert (format "%c" (ash code -16))) (if (< (1+ i) len) - (insert (format "%c" (logand (lsh code -8) 255)))) + (insert (format "%c" (logand (ash code -8) 255)))) (if (< (+ i 2) len) (insert (format "%c" (logand code 255)))) (setq i (+ i 3))))) diff --git a/lisp/international/characters.el b/lisp/international/characters.el index cdd8ba7c403..012827ba1c6 100644 --- a/lisp/international/characters.el +++ b/lisp/international/characters.el @@ -987,11 +987,12 @@ with L, LRE, or LRO Unicode bidi character type.") (#x103D . #x103E) (#x1058 . #x1059) (#x105E . #x1160) - (#x1171 . #x1074) + (#x1071 . #x1074) (#x1082 . #x1082) (#x1085 . #x1086) (#x108D . #x108D) (#x109D . #x109D) + (#x1160 . #x11FF) (#x135D . #x135F) (#x1712 . #x1714) (#x1732 . #x1734) @@ -1081,6 +1082,7 @@ with L, LRE, or LRO Unicode bidi character type.") (#xABE5 . #xABE5) (#xABE8 . #xABE8) (#xABED . #xABED) + (#xD7B0 . #xD7FB) (#xFB1E . #xFB1E) (#xFE00 . #xFE0F) (#xFE20 . #xFE2F) @@ -1217,10 +1219,11 @@ with L, LRE, or LRO Unicode bidi character type.") (#xFE30 . #xFE6F) (#xFF01 . #xFF60) (#xFFE0 . #xFFE6) - (#x16FE0 . #x16FE1) - (#x17000 . #x187F1) + (#x16FE0 . #x16FE3) + (#x17000 . #x187F7) (#x18800 . #x18AF2) - (#x1B000 . #x1B11E) + (#x1B000 . #x1B152) + (#x1B164 . #x1B167) (#x1B170 . #x1B2FB) (#x1F004 . #x1F004) (#x1F0CF . #x1F0CF) @@ -1250,17 +1253,22 @@ with L, LRE, or LRO Unicode bidi character type.") (#x1F680 . #x1F6C5) (#x1F6CC . #x1F6CC) (#x1F6D0 . #x1F6D2) + (#x1F6D5 . #x1F6D5) (#x1F6EB . #x1F6EC) - (#x1F6F4 . #x1F6F9) - (#x1F910 . #x1F93E) - (#x1F940 . #x1F970) + (#x1F6F4 . #x1F6FA) + (#x1F7E0 . #x1F7EB) + (#x1F90D . #x1F971) (#x1F973 . #x1F976) - (#x1F97A . #x1F97A) - (#x1F97C . #x1F9A2) - (#x1F9B0 . #x1F9B9) - (#x1F9C0 . #x1F9C2) - (#x1F9D0 . #x1F9FF) + (#x1F97A . #x1F9A2) + (#x1F9A5 . #x1F9AA) + (#x1F9AE . #x1F9CA) + (#x1F9CD . #x1F9FF) + (#x1FA00 . #x1FA53) (#x1FA60 . #x1FA6D) + (#x1FA70 . #x1FA73) + (#x1FA78 . #x1FA7A) + (#x1FA80 . #x1FA82) + (#x1FA90 . #x1FA95) (#x20000 . #x2FFFF) (#x30000 . #x3FFFF)))) (dolist (elt l) @@ -1334,7 +1342,7 @@ Setup char-width-table appropriate for non-CJK language environment." ;; Setting char-script-table. -(if purify-flag +(if dump-mode ;; While dumping, we can't use require, and international is not ;; in load-path. (load "international/charscript") diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el index c90d4f53bd9..0413646dfb3 100644 --- a/lisp/international/fontset.el +++ b/lisp/international/fontset.el @@ -222,6 +222,7 @@ (hanifi-rohingya #x10D00) (old-sogdian #x10F00) (sogdian #x10F30) + (elymaic #x10fe0) (mahajani #x11150) (sinhala-archaic-number #x111E1) (khojki #x11200) @@ -234,6 +235,7 @@ (takri #x11680) (dogra #x11800) (warang-citi #x118A1) + (nandinagari #x119a0) (zanabazar-square #x11A00) (soyombo #x11A50) (pau-cin-hau #x11AC0) @@ -257,15 +259,19 @@ (ancient-greek-musical-notation #x1D200) (tai-xuan-jing-symbol #x1D300) (counting-rod-numeral #x1D360) + (nyiakeng-puachue-hmong #x1e100) + (wancho #x1e2c0) (mende-kikakui #x1E810) (adlam #x1E900) + (indic-siyaq-number #x1ec71) + (ottoman-siyaq-number #x1ed01) (mahjong-tile #x1F000) (domino-tile #x1F030))) (defvar otf-script-alist) -;; The below was synchronized with the latest Jul 23, 2017 version of -;; https://www.microsoft.com/typography/otspec/scripttags.htm. +;; The below was synchronized with the latest Aug 16, 2018 version of +;; https://docs.microsoft.com/en-us/typography/opentype/spec/scripttags (setq otf-script-alist '((adlm . adlam) (ahom . ahom) @@ -300,6 +306,7 @@ (dsrt . deseret) (deva . devanagari) (dev2 . devanagari) + (dogr . dogra) (dupl . duployan-shorthand) (egyp . egyptian) (elba . elbasan) @@ -311,11 +318,13 @@ (grek . greek) (gujr . gujarati) (gjr2 . gujarati) + (gong . gunjala-gondi) (guru . gurmukhi) (gur2 . gurmukhi) (hani . han) (hang . hangul) (jamo . hangul) + (rohg . hanifi-rohingya) (hano . hanunoo) (hatr . hatran) (hebr . hebrew) @@ -324,9 +333,9 @@ (prti . inscriptional-parthian) (java . javanese) (kthi . kaithi) - (kana . kana) ; Hiragana (knda . kannada) (knd2 . kannada) + (kana . kana) ; Hiragana (kali . kayah-li) (khar . kharoshthi) (khmr . khmer) @@ -342,12 +351,15 @@ (lyci . lycian) (lydi . lydian) (mahj . mahajani) + (maka . makasar) (marc . marchen) (mlym . malayalam) (mlm2 . malayalam) (mand . mandaic) (mani . manichaean) + (gonm . masaram-gondi) (math . mathematical) + (medf . medefaidrin) (mtei . meetei-mayek) (mend . mende-kikakui) (merc . meroitic) @@ -363,12 +375,14 @@ (nbat . nabataean) (newa . newa) (nko\ . nko) + (nshu . nushu) (ogam . ogham) (olck . ol-chiki) (ital . old_italic) (xpeo . old_persian) (narb . old-north-arabian) (perm . old-permic) + (sogo . old-sogdian) (sarb . old-south-arabian) (orkh . old-turkic) (orya . oriya) @@ -392,7 +406,9 @@ (sidd . siddham) (sgnw . sutton-sign-writing) (sinh . sinhala) + (sogd . sogdian) (sora . sora-sompeng) + (soyo . soyombo) (sund . sundanese) (sylo . syloti_nagri) (syrc . syriac) @@ -416,7 +432,8 @@ (ugar . ugaritic) (vai\ . vai) (wara . warang-citi) - (yi\ \ . yi))) + (yi\ \ . yi) + (zanb . zanabazar-square))) ;; Set standard fontname specification of characters in the default ;; fontset to find an appropriate font for each script/charset. The @@ -487,7 +504,7 @@ (data (list (vconcat (mapcar 'car cjk)))) (i 0)) (dolist (elt cjk) - (let ((mask (lsh 1 i))) + (let ((mask (ash 1 i))) (map-charset-chars #'(lambda (range _arg) (let ((from (car range)) (to (cdr range))) @@ -876,7 +893,7 @@ (spec (cdr target-spec))) (if (integerp spec) (dotimes (i (length registries)) - (if (> (logand spec (lsh 1 i)) 0) + (if (> (logand spec (ash 1 i)) 0) (set-fontset-font "fontset-default" target (cons nil (aref registries i)) nil 'append))) @@ -1164,6 +1181,8 @@ given from DEFAULT-SPEC." (setcar (cdr elt) spec))) fontlist)) +(defvar fontset-alias-alist) + (defun fontset-name-p (fontset) "Return non-nil if FONTSET is valid as fontset name. A valid fontset name should conform to XLFD (X Logical Font Description) @@ -1240,11 +1259,12 @@ Done when `mouse-set-font' is called." (latin-iso8859-15 . latin) (latin-iso8859-16 . latin) (latin-jisx0201 . latin) + (thai-iso8859-11 . thai) (thai-tis620 . thai) (cyrillic-iso8859-5 . cyrillic) (arabic-iso8859-6 . arabic) - (greek-iso8859-7 . latin) - (hebrew-iso8859-8 . latin) + (greek-iso8859-7 . greek) + (hebrew-iso8859-8 . hebrew) (katakana-jisx0201 . kana) (chinese-gb2312 . han) (chinese-gbk . han) diff --git a/lisp/international/isearch-x.el b/lisp/international/isearch-x.el index 6c2a2dc9b99..dd4c98fc982 100644 --- a/lisp/international/isearch-x.el +++ b/lisp/international/isearch-x.el @@ -8,8 +8,7 @@ ;; Keywords: i18n, multilingual, isearch -;; Author: Kenichi HANDA <handa@etl.go.jp> -;; Maintainer: Kenichi HANDA <handa@etl.go.jp> +;; Author: Kenichi Handa <handa@gnu.org> ;; This file is part of GNU Emacs. diff --git a/lisp/international/iso-ascii.el b/lisp/international/iso-ascii.el index 4441241a658..395e6c4dcd0 100644 --- a/lisp/international/iso-ascii.el +++ b/lisp/international/iso-ascii.el @@ -163,10 +163,7 @@ (iso-ascii-display 255 "\"y") ; small y with diaeresis or umlaut mark (define-minor-mode iso-ascii-mode - "Toggle ISO-ASCII mode. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "Toggle ISO-ASCII mode." :variable ((eq standard-display-table iso-ascii-display-table) . (lambda (v) (setq standard-display-table diff --git a/lisp/international/ja-dic-cnv.el b/lisp/international/ja-dic-cnv.el index 78d2cd5aced..294711959ec 100644 --- a/lisp/international/ja-dic-cnv.el +++ b/lisp/international/ja-dic-cnv.el @@ -32,15 +32,15 @@ ;; input method (e.g. quail-japanese) can utilize the dictionary. ;; The format of SKK dictionary is quite simple. Each line has the -;; form "KANASTRING /CONV1/CONV2/.../" which means KANASTRING ($B2>L>J8(B -;; $B;zNs(B) can be converted to one of CONVi. CONVi is a Kanji ($B4A;z(B) -;; and Kana ($B2>L>(B) mixed string. +;; form "KANASTRING /CONV1/CONV2/.../" which means KANASTRING (仮名文 +;; 字列) can be converted to one of CONVi. CONVi is a Kanji (漢字) +;; and Kana (仮名) mixed string. ;; -;; KANASTRING may have a trailing ASCII letter for Okurigana ($BAw$j2>L>(B) +;; KANASTRING may have a trailing ASCII letter for Okurigana (送り仮名) ;; information. For instance, the trailing letter `k' means that one -;; of the following Okurigana is allowed: $B$+$-$/$1$3(B. So, in that -;; case, the string "KANASTRING$B$/(B" can be converted to one of "CONV1$B$/(B", -;; CONV2$B$/(B, ... +;; of the following Okurigana is allowed: かきくけこ. So, in that +;; case, the string "KANASTRINGく" can be converted to one of "CONV1く", +;; CONV2く, ... ;;; Code: @@ -48,7 +48,7 @@ (defvar ja-dic-filename "ja-dic.el") (defun skkdic-convert-okuri-ari (skkbuf buf) - (message "Processing OKURI-ARI entries ...") + (byte-compile-info-message "Processing OKURI-ARI entries") (goto-char (point-min)) (with-current-buffer buf (insert ";; Setting okuri-ari entries.\n" @@ -76,28 +76,28 @@ (defconst skkdic-postfix-list '(skkdic-postfix-list)) (defconst skkdic-postfix-data - '(("$B$$$-(B" "$B9T(B") - ("$B$,$+$j(B" "$B78(B") - ("$B$,$/(B" "$B3X(B") - ("$B$,$o(B" "$B@n(B") - ("$B$7$c(B" "$B<R(B") - ("$B$7$e$&(B" "$B=8(B") - ("$B$7$g$&(B" "$B>^(B" "$B>k(B") - ("$B$8$g$&(B" "$B>k(B") - ("$B$;$s(B" "$B@~(B") - ("$B$@$1(B" "$B3Y(B") - ("$B$A$c$/(B" "$BCe(B") - ("$B$F$s(B" "$BE9(B") - ("$B$H$&$2(B" "$BF=(B") - ("$B$I$*$j(B" "$BDL$j(B") - ("$B$d$^(B" "$B;3(B") - ("$B$P$7(B" "$B66(B") - ("$B$O$D(B" "$BH/(B") - ("$B$b$/(B" "$BL\(B") - ("$B$f$-(B" "$B9T(B"))) + '(("いき" "行") + ("がかり" "係") + ("がく" "学") + ("がわ" "川") + ("しゃ" "社") + ("しゅう" "集") + ("しょう" "賞" "城") + ("じょう" "城") + ("せん" "線") + ("だけ" "岳") + ("ちゃく" "着") + ("てん" "店") + ("とうげ" "峠") + ("どおり" "通り") + ("やま" "山") + ("ばし" "橋") + ("はつ" "発") + ("もく" "目") + ("ゆき" "行"))) (defun skkdic-convert-postfix (skkbuf buf) - (message "Processing POSTFIX entries ...") + (byte-compile-info-message "Processing POSTFIX entries") (goto-char (point-min)) (with-current-buffer buf (insert ";; Setting postfix entries.\n" @@ -124,7 +124,7 @@ (setq l (cdr l))))) ;; Search postfix entries. - (while (re-search-forward "^[#<>?]\\(\\(\\cH\\|$B!<(B\\)+\\) " nil t) + (while (re-search-forward "^[#<>?]\\(\\cH+\\) " nil t) (let ((kana (match-string-no-properties 1)) str candidates) (while (looking-at "/[#0-9 ]*\\([^/\n]*\\)/") @@ -151,13 +151,13 @@ (defconst skkdic-prefix-list '(skkdic-prefix-list)) (defun skkdic-convert-prefix (skkbuf buf) - (message "Processing PREFIX entries ...") + (byte-compile-info-message "Processing PREFIX entries") (goto-char (point-min)) (with-current-buffer buf (insert ";; Setting prefix entries.\n" "(skkdic-set-prefix\n")) (save-excursion - (while (re-search-forward "^\\(\\(\\cH\\|$B!<(B\\)+\\)[<>?] " nil t) + (while (re-search-forward "^\\(\\cH+\\)[<>?] " nil t) (let ((kana (match-string-no-properties 1)) str candidates) (while (looking-at "/\\([^/\n]+\\)/") @@ -272,14 +272,15 @@ (defun skkdic-collect-okuri-nasi () (save-excursion - (let ((progress (make-progress-reporter "Collecting OKURI-NASI entries" - (point) (point-max) - nil 10))) - (while (re-search-forward "^\\(\\(\\cH\\|$B!<(B\\)+\\) \\(/\\cj.*\\)/$" + (let ((progress (make-progress-reporter + (byte-compile-info-message "Collecting OKURI-NASI entries") + (point) (point-max) + nil 10))) + (while (re-search-forward "^\\(\\cH+\\) \\(/\\cj.*\\)/$" nil t) (let ((kana (match-string-no-properties 1)) - (candidates (skkdic-get-candidate-list (match-beginning 3) - (match-end 3)))) + (candidates (skkdic-get-candidate-list (match-beginning 2) + (match-end 2)))) (setq skkdic-okuri-nasi-entries (cons (cons kana candidates) skkdic-okuri-nasi-entries)) (progress-reporter-update progress (point)) @@ -299,9 +300,10 @@ (insert ";; Setting okuri-nasi entries.\n" "(skkdic-set-okuri-nasi\n") (let ((l (nreverse skkdic-okuri-nasi-entries)) - (progress (make-progress-reporter "Processing OKURI-NASI entries" - 0 skkdic-okuri-nasi-entries-count - nil 10)) + (progress (make-progress-reporter + (byte-compile-info-message "Processing OKURI-NASI entries") + 0 skkdic-okuri-nasi-entries-count + nil 10)) (count 0)) (while l (let ((kana (car (car l))) @@ -327,7 +329,6 @@ Optional argument DIRNAME if specified is the directory name under which the generated Emacs Lisp is saved. The name of generated file is specified by the variable `ja-dic-filename'." (interactive "FSKK dictionary file: ") - (message "Reading file \"%s\" ..." filename) (let* ((coding-system-for-read 'euc-japan) (skkbuf (get-buffer-create " *skkdic-unannotated*")) (buf (get-buffer-create "*skkdic-work*"))) @@ -452,7 +453,7 @@ To get complete usage, invoke: (aset vec i (if (< ch 128) ; CH is an ASCII letter for OKURIGANA, (- ch) ; represented by a negative code. - (if (= ch ?$B!<(B) ; `$B!<(B' is represented by 0. + (if (= ch ?ー) ; `ー' is represented by 0. 0 (- (logand (encode-char ch 'japanese-jisx0208) #xFF) 32)))) (setq i (1+ i))) @@ -529,21 +530,19 @@ To get complete usage, invoke: `(defconst skkdic-okuri-nasi ',(let ((l entries) (map '(skdic-okuri-nasi)) + (progress (make-progress-reporter + (byte-compile-info-message + "Extracting OKURI-NASI entries") + 0 (length entries))) (count 0) entry) (while l - (setq count (1+ count)) - (if (= (% count 10000) 0) - (message "%d entries" count)) + (progress-reporter-update progress (setq count (1+ count))) (setq entry (skkdic-extract-conversion-data (car l))) (set-nested-alist (car entry) (cdr entry) map) (setq l (cdr l))) + (progress-reporter-done progress) map))) (provide 'ja-dic-cnv) - -;; Local Variables: -;; coding: iso-2022-7bit -;; End: - ;;; ja-dic-cnv.el ends here diff --git a/lisp/international/ja-dic-utl.el b/lisp/international/ja-dic-utl.el index 86ba3749df8..498fb23f707 100644 --- a/lisp/international/ja-dic-utl.el +++ b/lisp/international/ja-dic-utl.el @@ -53,23 +53,23 @@ "Nested alist for OKURI-NASI entries of SKK dictionary.") (defconst skkdic-okurigana-table - '((?$B$!(B . ?a) (?$B$"(B . ?a) (?$B$#(B . ?i) (?$B$$(B . ?i) (?$B$%(B . ?u) - (?$B$&(B . ?u) (?$B$'(B . ?e) (?$B$((B . ?e) (?$B$)(B . ?o) (?$B$*(B . ?o) - (?$B$+(B . ?k) (?$B$,(B . ?g) (?$B$-(B . ?k) (?$B$.(B . ?g) (?$B$/(B . ?k) - (?$B$0(B . ?g) (?$B$1(B . ?k) (?$B$2(B . ?g) (?$B$3(B . ?k) (?$B$4(B . ?g) - (?$B$5(B . ?s) (?$B$6(B . ?z) (?$B$7(B . ?s) (?$B$8(B . ?j) (?$B$9(B . ?s) - (?$B$:(B . ?z) (?$B$;(B . ?s) (?$B$<(B . ?z) (?$B$=(B . ?s) (?$B$>(B . ?z) - (?$B$?(B . ?t) (?$B$@(B . ?d) (?$B$A(B . ?t) (?$B$B(B . ?d) (?$B$C(B . ?t) - (?$B$D(B . ?t) (?$B$E(B . ?d) (?$B$F(B . ?t) (?$B$G(B . ?d) (?$B$H(B . ?t) (?$B$I(B . ?d) - (?$B$J(B . ?n) (?$B$K(B . ?n) (?$B$L(B . ?n) (?$B$M(B . ?n) (?$B$N(B . ?n) - (?$B$O(B . ?h) (?$B$P(B . ?b) (?$B$Q(B . ?p) (?$B$R(B . ?h) (?$B$S(B . ?b) - (?$B$T(B . ?p) (?$B$U(B . ?h) (?$B$V(B . ?b) (?$B$W(B . ?p) (?$B$X(B . ?h) - (?$B$Y(B . ?b) (?$B$Z(B . ?p) (?$B$[(B . ?h) (?$B$\(B . ?b) (?$B$](B . ?p) - (?$B$^(B . ?m) (?$B$_(B . ?m) (?$B$`(B . ?m) (?$B$a(B . ?m) (?$B$b(B . ?m) - (?$B$c(B . ?y) (?$B$d(B . ?y) (?$B$e(B . ?y) (?$B$f(B . ?y) (?$B$g(B . ?y) (?$B$h(B . ?y) - (?$B$i(B . ?r) (?$B$j(B . ?r) (?$B$k(B . ?r) (?$B$l(B . ?r) (?$B$m(B . ?r) - (?$B$o(B . ?w) (?$B$p(B . ?w) (?$B$q(B . ?w) (?$B$r(B . ?w) - (?$B$s(B . ?n) + '((?ぁ . ?a) (?あ . ?a) (?ぃ . ?i) (?い . ?i) (?ぅ . ?u) + (?う . ?u) (?ぇ . ?e) (?え . ?e) (?ぉ . ?o) (?お . ?o) + (?か . ?k) (?が . ?g) (?き . ?k) (?ぎ . ?g) (?く . ?k) + (?ぐ . ?g) (?け . ?k) (?げ . ?g) (?こ . ?k) (?ご . ?g) + (?さ . ?s) (?ざ . ?z) (?し . ?s) (?じ . ?j) (?す . ?s) + (?ず . ?z) (?せ . ?s) (?ぜ . ?z) (?そ . ?s) (?ぞ . ?z) + (?た . ?t) (?だ . ?d) (?ち . ?t) (?ぢ . ?d) (?っ . ?t) + (?つ . ?t) (?づ . ?d) (?て . ?t) (?で . ?d) (?と . ?t) (?ど . ?d) + (?な . ?n) (?に . ?n) (?ぬ . ?n) (?ね . ?n) (?の . ?n) + (?は . ?h) (?ば . ?b) (?ぱ . ?p) (?ひ . ?h) (?び . ?b) + (?ぴ . ?p) (?ふ . ?h) (?ぶ . ?b) (?ぷ . ?p) (?へ . ?h) + (?べ . ?b) (?ぺ . ?p) (?ほ . ?h) (?ぼ . ?b) (?ぽ . ?p) + (?ま . ?m) (?み . ?m) (?む . ?m) (?め . ?m) (?も . ?m) + (?ゃ . ?y) (?や . ?y) (?ゅ . ?y) (?ゆ . ?y) (?ょ . ?y) (?よ . ?y) + (?ら . ?r) (?り . ?r) (?る . ?r) (?れ . ?r) (?ろ . ?r) + (?わ . ?w) (?ゐ . ?w) (?ゑ . ?w) (?を . ?w) + (?ん . ?n) ) "Alist of Okuriganas vs trailing ASCII letters in OKURI-ARI entry.") @@ -125,14 +125,14 @@ LEIM is available from the same ftp directory as Emacs."))) ;; At first, generate vector VEC from SEQ for looking up SKK ;; alists. Nth element in VEC corresponds to Nth element in SEQ. ;; The values are decided as follows. - ;; If SEQ[N] is `$B!<(B', VEC[N] is 0, + ;; If SEQ[N] is `ー', VEC[N] is 0, ;; else if SEQ[N] is a Hiragana character, VEC[N] is: ;; ((The 2nd position code of SEQ[N]) - 32), ;; else VEC[N] is 128. (while (< i len) (let ((ch (aref seq i)) code) - (cond ((= ch ?$B!<(B) + (cond ((= ch ?ー) (aset vec i 0)) ((and (>= ch (car skkdic-jisx0208-hiragana-block)) (<= ch (cdr skkdic-jisx0208-hiragana-block))) @@ -218,9 +218,4 @@ LEIM is available from the same ftp directory as Emacs."))) ;; (provide 'ja-dic-utl) - -;; Local Variables: -;; coding: iso-2022-7bit -;; End: - ;;; ja-dic-utl.el ends here diff --git a/lisp/international/kinsoku.el b/lisp/international/kinsoku.el index 376d23b1fa6..690a80e6595 100644 --- a/lisp/international/kinsoku.el +++ b/lisp/international/kinsoku.el @@ -1,4 +1,4 @@ -;;; kinsoku.el --- `Kinsoku' processing funcs -*- coding: iso-2022-7bit; -*- +;;; kinsoku.el --- `Kinsoku' processing funcs ;; Copyright (C) 1997, 2001-2019 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, @@ -62,19 +62,19 @@ The value 0 means there's no limitation.") idx (1+ idx))) str2) ;; Katakana JISX0201 - "(I!#'()*+,-./0^_(B" + "。」ァィゥェォャュョッー゙゚" ;; Japanese JISX0208 - "$B!"!#!$!%!&!'!(!)!*!+!,!-!.!/!0!1!2!3!4!5!6!7!8!9!:!;!<!=!>(B\ -$B!?!@!A!B!C!D!E!G!I!K!M!O!Q!S!U!W!Y![!k!l!m!n(B\ -$B$!$#$%$'$)$C$c$e$g$n%!%#%%%'%)%C%c%e%g%n%u%v(B" + "、。,.・:;?!゛゜´`¨^ ̄_ヽヾゝゞ〃仝々〆〇ー—‐\ +/\〜‖|…‥’”)〕]}〉》」』】°′″℃\ +ぁぃぅぇぉっゃゅょゎァィゥェォッャュョヮヵヶ" ;; Chinese GB2312 - "$A!"!##.#,!$!%!&!'!(!)!*!+!,!-!/!1#)!3!5!7!9!;!=(B\ -$A!?#;#:#?#!!@!A!B!C!c!d!e!f#/#\#"#_#~#|(e(B" + "、。.,・ˉˇ¨〃々―~‖…’”)〕〉》」』〗\ +】;:?!±×÷∶°′″℃/\"_ ̄|ㄥ" ;; Chinese BIG5 - "$(0!"!#!$!%!&!'!(!)!*!+!,!-!.!/!0!1!2(B\ -$(0!3!4!5!6!7!8!9!:!;!<!=!?!A!C!E!G!I!K(B\ -$(0!M!O!Q!S!U!W!Y![!]!_!a!c!e!g!i!k!q(B\ -$(0"#"$"%"&"'"(")"*"+","2"3"4"j"k"l"x%7(B")) + ",、。.‧;:?!︰…‥﹐﹑﹒·﹔\ +﹕﹖﹗|–︱—︳╴︴﹏)︶}︸〕︺】\ +︼》︾〉﹀」﹂』﹄﹚﹜﹞’”〞′〃\ +¯ ̄_ˍ﹉﹊﹍﹎﹋﹌×÷±℃℉﹩°ㄥ")) (len (length kinsoku-bol)) (idx 0) ch) @@ -102,16 +102,16 @@ The value 0 means there's no limitation.") idx (1+ idx))) str2) ;; JISX0201 Katakana - "(I"(B" + "「" ;; Japanese JISX0208 - "$B!F!H!J!L!N!P!R!T!V!X!Z!k!l!m!n!w!x(B" + "‘“(〔[{〈《「『【°′″℃@§" ;; Chinese GB2312 - "$A!.!0#"#(!2!4!6!8!:!<!>!c!d!e#@!f!l(B\ -$A(E(F(G(H(I(J(K(L(M(N(O(P(Q(R(S(T(U(V(W(X(Y(h(B\ -\$(0!>!@!B!D!F!H!J!L!N!P!R!T!V!X!Z!\!^!`!b(B" + "‘“"(〔〈《「『〖【°′″@℃§\ +ㄅㄆㄇㄈㄉㄊㄋㄌㄍㄎㄏㄐㄑㄒㄓㄔㄕㄖㄗㄘㄙㄨ\ +\(︵{︷〔︹【︻《︽〈︿「﹁『﹃﹙﹛﹝" ;; Chinese BIG5 - "$(0!d!f!h!j!k!q!p"i"j"k"n"x$u$v$w$x$y$z${(B\ -$(0$|$}$~%!%"%#%$%%%&%'%(%)%*%+%:(B")) + "‘“〝‵′〃§@℃℉﹫°ㄅㄆㄇㄈㄉㄊㄋ\ +ㄌㄍㄎㄏㄐㄑㄒㄓㄔㄕㄖㄗㄘㄙㄨ")) (len (length kinsoku-eol)) (idx 0) ch) diff --git a/lisp/international/kkc.el b/lisp/international/kkc.el index df56ce26161..6691ee9eb9b 100644 --- a/lisp/international/kkc.el +++ b/lisp/international/kkc.el @@ -1,4 +1,4 @@ -;;; kkc.el --- Kana Kanji converter -*- coding: iso-2022-7bit; -*- +;;; kkc.el --- Kana Kanji converter ;; Copyright (C) 1997-1998, 2001-2019 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, @@ -36,7 +36,7 @@ (require 'ja-dic-utl) -(defvar kkc-input-method-title "$B4A(B" +(defvar kkc-input-method-title "漢" "String denoting KKC input method. This string is shown at mode line when users are in KKC mode.") diff --git a/lisp/international/latexenc.el b/lisp/international/latexenc.el index 83acce60d3d..f335f277e64 100644 --- a/lisp/international/latexenc.el +++ b/lisp/international/latexenc.el @@ -68,9 +68,9 @@ ("latin2" . iso-8859-2) ("latin3" . iso-8859-3) ("latin4" . iso-8859-4) - ("latin5" . iso-8859-5) + ("latin5" . iso-8859-9) ("latin9" . iso-8859-15) - ;; ("latin10" . undecided) + ("latin10" . iso-8859-16) ;; ("macce" . undecided) ; Apple Central European ("next" . next) ; The Next encoding ("utf8" . utf-8) diff --git a/lisp/international/latin1-disp.el b/lisp/international/latin1-disp.el index 6aa633fb42a..1b7bc49a6be 100644 --- a/lisp/international/latin1-disp.el +++ b/lisp/international/latin1-disp.el @@ -201,10 +201,6 @@ character set: `latin-2', `hebrew' etc." (char (and info (decode-char (car (remq 'ascii info)) ?\ )))) (and char (char-displayable-p char)))) -;; Backwards compatibility. -(define-obsolete-function-alias 'latin1-char-displayable-p - 'char-displayable-p "22.1") - (defun latin1-display-setup (set &optional force) "Set up Latin-1 display for characters in the given SET. SET must be a member of `latin1-display-sets'. Normally, check diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 0be0f0fee2d..1edf80d14c8 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -136,8 +136,7 @@ (expand-file-name "HELLO" data-directory)) :help "Demonstrate various character sets")) (bindings--define-key map [set-various-coding-system] - `(menu-item "Set Coding Systems" ,set-coding-system-map - :enable (default-value 'enable-multibyte-characters))) + `(menu-item "Set Coding Systems" ,set-coding-system-map)) (bindings--define-key map [separator-input-method] menu-bar-separator) (bindings--define-key map [describe-input-method] @@ -282,9 +281,7 @@ wrong, use this command again to toggle back to the right mode." (defun view-hello-file () "Display the HELLO file, which lists many languages and characters." (interactive) - ;; We have to decode the file in any environment. - (let ((coding-system-for-read 'iso-2022-7bit)) - (view-file (expand-file-name "HELLO" data-directory)))) + (view-file (expand-file-name "HELLO" data-directory))) (defun universal-coding-system-argument (coding-system) "Execute an I/O command using the specified coding system." @@ -303,8 +300,7 @@ wrong, use this command again to toggle back to the right mode." (cmd (key-binding keyseq)) prefix) ;; read-key-sequence ignores quit, so make an explicit check. - ;; Like many places, this assumes quit == C-g, but it need not be. - (if (equal last-input-event ?\C-g) + (if (equal last-input-event (nth 3 (current-input-mode))) (keyboard-quit)) (when (memq cmd '(universal-argument digit-argument)) (call-interactively cmd) @@ -317,16 +313,16 @@ wrong, use this command again to toggle back to the right mode." (let ((current-prefix-arg prefix-arg) ;; Have to bind `last-command-event' here so that ;; `digit-argument', for instance, can compute the - ;; prefix arg. + ;; `prefix-arg'. (last-command-event (aref keyseq 0))) (call-interactively cmd))) ;; This is the final call to `universal-argument-other-key', which - ;; set's the final `prefix-arg. + ;; sets the final `prefix-arg'. (let ((current-prefix-arg prefix-arg)) (call-interactively cmd)) - ;; Read the command to execute with the given prefix arg. + ;; Read the command to execute with the given `prefix-arg'. (setq prefix prefix-arg keyseq (read-key-sequence nil t) cmd (key-binding keyseq))) @@ -355,8 +351,7 @@ This also sets the following values: (if (eq system-type 'darwin) ;; The file-name coding system on Darwin systems is always utf-8. (setq default-file-name-coding-system 'utf-8-unix) - (if (and (default-value 'enable-multibyte-characters) - (or (not coding-system) + (if (and (or (not coding-system) (coding-system-get coding-system 'ascii-compatible-p))) (setq default-file-name-coding-system (coding-system-change-eol-conversion coding-system 'unix)))) @@ -456,8 +451,8 @@ non-nil, it is used to sort CODINGS instead." ;; E: 1 if not XXX-with-esc ;; II: if iso-2022 based, 0..3, else 1. (logior - (lsh (if (eq base most-preferred) 1 0) 7) - (lsh + (ash (if (eq base most-preferred) 1 0) 7) + (ash (let ((mime (coding-system-get base :mime-charset))) ;; Prefer coding systems corresponding to a ;; MIME charset. @@ -473,9 +468,9 @@ non-nil, it is used to sort CODINGS instead." (t 3)) 0)) 5) - (lsh (if (memq base lang-preferred) 1 0) 4) - (lsh (if (memq base from-priority) 1 0) 3) - (lsh (if (string-match-p "-with-esc\\'" + (ash (if (memq base lang-preferred) 1 0) 4) + (ash (if (memq base from-priority) 1 0) 3) + (ash (if (string-match-p "-with-esc\\'" (symbol-name base)) 0 1) 2) (if (eq (coding-system-type base) 'iso-2022) @@ -992,6 +987,11 @@ It is highly recommended to fix it before writing to a file." ;; If all the defaults failed, ask a user. (when (not coding-system) + ;; If UTF-8 is in CODINGS, but is not its first member, make + ;; it the first one, so it is offered as the default. + (and (memq 'utf-8 codings) (not (eq 'utf-8 (car codings))) + (setq codings (append '(utf-8) (delq 'utf-8 codings)))) + (setq coding-system (select-safe-coding-system-interactively from to codings unsafe rejected (car codings)))) @@ -1029,7 +1029,13 @@ It is highly recommended to fix it before writing to a file." ;; This check perhaps isn't ideal, but is probably ;; the best thing to do. (not (auto-coding-alist-lookup (or file buffer-file-name ""))) - (not (coding-system-equal coding-system auto-cs))) + (not (coding-system-equal coding-system auto-cs)) + ;; coding-system-equal barfs on 'charset'. + (or (equal (coding-system-type auto-cs) 'charset) + (equal (coding-system-type coding-system) 'charset) + (not (coding-system-equal (coding-system-type auto-cs) + (coding-system-type + coding-system))))) (unless (yes-or-no-p (format "Selected encoding %s disagrees with \ %s specified by file contents. Really save (else edit coding cookies \ @@ -1158,10 +1164,7 @@ see `language-info-alist'." ((eq key 'nonascii-translation) (set-language-environment-nonascii-translation lang-env)) ((eq key 'charset) - (set-language-environment-charset lang-env)) - ((and (not (default-value 'enable-multibyte-characters)) - (or (eq key 'unibyte-syntax) (eq key 'unibyte-display))) - (set-language-environment-unibyte lang-env))))) + (set-language-environment-charset lang-env))))) (defun set-language-info-internal (lang-env key info) "Internal use only. @@ -1333,7 +1336,7 @@ This is the input method activated automatically by the command `toggle-input-method' (\\[toggle-input-method])." :link '(custom-manual "(emacs)Input Methods") :group 'mule - :type `(choice (const nil) + :type '(choice (const nil) mule-input-method-string) :set-after '(current-language-environment)) @@ -1471,12 +1474,7 @@ If INPUT-METHOD is nil, deactivate any current input method." (defun deactivate-input-method () "Turn off the current input method." (when current-input-method - (if input-method-history - (unless (string= current-input-method (car input-method-history)) - (setq input-method-history - (cons current-input-method - (delete current-input-method input-method-history)))) - (setq input-method-history (list current-input-method))) + (add-to-history 'input-method-history current-input-method) (unwind-protect (progn (setq input-method-function nil @@ -1800,6 +1798,9 @@ The default status is as follows: (setq default-sendmail-coding-system 'iso-latin-1) ;; On Darwin systems, this should be utf-8-unix, but when this file is loaded ;; that is not yet defined, so we set it in set-locale-environment instead. + ;; [Actually, it seems to work fine to use utf-8-unix here, and not just + ;; on Darwin. The previous comment seems to be outdated? + ;; See patch at https://debbugs.gnu.org/15803 ] (setq default-file-name-coding-system 'iso-latin-1-unix) ;; Preserve eol-type from existing default-process-coding-systems. ;; On non-unix-like systems in particular, these may have been set @@ -1897,9 +1898,6 @@ the new language environment, it runs `set-language-environment-hook'." (set-language-environment-input-method language-name) (set-language-environment-nonascii-translation language-name) (set-language-environment-charset language-name) - ;; Unibyte setups if necessary. - (unless (default-value 'enable-multibyte-characters) - (set-language-environment-unibyte language-name)) (let ((func (get-language-info language-name 'setup-function))) (if (functionp func) @@ -1951,7 +1949,7 @@ See `set-language-info-alist' for use in programs." (set-language-info-alist (car elt) (cdr elt))) ;; re-set the environment in case its parameters changed (set-language-environment current-language-environment))) - :type `(alist + :type '(alist :key-type (string :tag "Language environment" :completions (lambda (string pred action) @@ -1978,28 +1976,22 @@ See `set-language-info-alist' for use in programs." (defun standard-display-european-internal () ;; Actually set up direct output of non-ASCII characters. (standard-display-8bit (if (eq window-system 'pc) 128 160) 255) - ;; Unibyte Emacs on MS-DOS wants to display all 8-bit characters with - ;; the native font, and codes 160 and 146 stand for something very - ;; different there. - (or (and (eq window-system 'pc) (not (default-value - 'enable-multibyte-characters))) - (progn - ;; Most X fonts used to do the wrong thing for latin-1 code 160. - (unless (and (eq window-system 'x) - ;; XFree86 4 has fixed the fonts. - (string= "The XFree86 Project, Inc" (x-server-vendor)) - (> (aref (number-to-string (nth 2 (x-server-version))) 0) - ?3)) - ;; Make non-line-break space display as a plain space. - (aset standard-display-table (unibyte-char-to-multibyte 160) [32])) - ;; Most Windows programs send out apostrophes as \222. Most X fonts - ;; don't contain a character at that position. Map it to the ASCII - ;; apostrophe. [This is actually RIGHT SINGLE QUOTATION MARK, - ;; U+2019, normally from the windows-1252 character set. XFree 4 - ;; fonts probably have the appropriate glyph at this position, - ;; so they could use standard-display-8bit. It's better to use a - ;; proper windows-1252 coding system. --fx] - (aset standard-display-table (unibyte-char-to-multibyte 146) [39])))) + ;; Most X fonts used to do the wrong thing for latin-1 code 160. + (unless (and (eq window-system 'x) + ;; XFree86 4 has fixed the fonts. + (string= "The XFree86 Project, Inc" (x-server-vendor)) + (> (aref (number-to-string (nth 2 (x-server-version))) 0) + ?3)) + ;; Make non-line-break space display as a plain space. + (aset standard-display-table (unibyte-char-to-multibyte 160) [32])) + ;; Most Windows programs send out apostrophes as \222. Most X fonts + ;; don't contain a character at that position. Map it to the ASCII + ;; apostrophe. [This is actually RIGHT SINGLE QUOTATION MARK, + ;; U+2019, normally from the windows-1252 character set. XFree 4 + ;; fonts probably have the appropriate glyph at this position, + ;; so they could use standard-display-8bit. It's better to use a + ;; proper windows-1252 coding system. --fx] + (aset standard-display-table (unibyte-char-to-multibyte 146) [39])) (defun set-language-environment-coding-systems (language-name) "Do various coding system setups for language environment LANGUAGE-NAME." @@ -2035,10 +2027,8 @@ See `set-language-info-alist' for use in programs." (let ((input-method (get-language-info language-name 'input-method))) (when input-method (setq default-input-method input-method) - (if input-method-history - (setq input-method-history - (cons input-method - (delete input-method input-method-history))))))) + (when input-method-history + (add-to-history 'input-method-history input-method))))) (defun set-language-environment-nonascii-translation (language-name) "Do unibyte/multibyte translation setup for language environment LANGUAGE-NAME." @@ -2197,22 +2187,27 @@ See `set-language-info-alist' for use in programs." (defconst locale-language-names (purecopy '( - ;; Locale names of the form LANGUAGE[_TERRITORY][.CODESET][@MODIFIER] - ;; as specified in the Single Unix Spec, Version 2. - ;; LANGUAGE is a language code taken from ISO 639:1988 (E/F) - ;; with additions from ISO 639/RA Newsletter No.1/1989; - ;; see Internet RFC 2165 (1997-06) and - ;; http://www.evertype.com/standards/iso639/iso639-en.html - ;; TERRITORY is a country code taken from ISO 3166 - ;; http://www.din.de/gremien/nas/nabd/iso3166ma/codlstp1/en_listp1.html. - ;; CODESET and MODIFIER are implementation-dependent. + ;; Locale names of the form LANGUAGE[_TERRITORY][.CODESET][@MODIFIER] + ;; as specified in the Single Unix Spec, Version 2. + ;; LANGUAGE is a language code taken from ISO 639:1988 (E/F) + ;; with additions from ISO 639/RA Newsletter No.1/1989; + ;; see Internet RFC 2165 (1997-06) and + ;; http://www.evertype.com/standards/iso639/iso639-en.html + ;; TERRITORY is a country code taken from ISO 3166 + ;; http://www.din.de/gremien/nas/nabd/iso3166ma/codlstp1/en_listp1.html. + ;; CODESET and MODIFIER are implementation-dependent. + + ;; Language names for which there are no locales (yet) are + ;; commented out. ;; jasonr comments: MS Windows uses three letter codes for ;; languages instead of the two letter ISO codes that POSIX - ;; uses. In most cases the first two letters are the same, so - ;; most of the regexps in locale-language-names work. Japanese - ;; and Chinese are exceptions, which are listed in the - ;; non-standard section at the bottom of locale-language-names. + ;; uses. In most cases the first two letters are the same, so + ;; most of the regexps in locale-language-names work. Japanese, + ;; Chinese, and some others are exceptions, which are listed in the + ;; non-standard section at the bottom of locale-language-names, or + ;; in the main section, if otherwise we would pick up the wrong + ;; entry (because the first matching entry is used). ("aa_DJ" . "Latin-1") ; Afar ("aa" . "UTF-8") @@ -2220,11 +2215,12 @@ See `set-language-info-alist' for use in programs." ("af" . "Latin-1") ; Afrikaans ("am" "Ethiopic" utf-8) ; Amharic ("an" . "Latin-9") ; Aragonese + ("arn" . "UTF-8") ; MS-Windows Mapudungun, Mapuche ("ar" . "Arabic") - ; as Assamese + ("as" . "UTF-8") ; Assamese ; ay Aymara ("az" . "UTF-8") ; Azerbaijani - ; ba Bashkir + ("ba" . "UTF-8") ; Bashkir, Cyrillic script ("be" "Belarusian" cp1251) ; Belarusian [Byelorussian until early 1990s] ("bg" "Bulgarian" cp1251) ; Bulgarian ; bh Bihari @@ -2235,12 +2231,12 @@ See `set-language-info-alist' for use in programs." ("bs" . "Latin-2") ; Bosnian ("byn" . "UTF-8") ; Bilin; Blin ("ca" "Catalan" iso-8859-1) ; Catalan - ; co Corsican + ("co" . "UTF-8") ; Corsican ("cs" "Czech" iso-8859-2) ("cy" "Welsh" iso-8859-14) ("da" . "Latin-1") ; Danish ("de" "German" iso-8859-1) - ; dv Divehi + ("dv" . "UTF-8") ; Divehi ; dz Bhutani ("ee" . "Latin-4") ; Ewe ("el" "Greek" iso-8859-7) @@ -2254,6 +2250,8 @@ See `set-language-info-alist' for use in programs." ("et" . "Latin-9") ; Estonian ("eu" . "Latin-1") ; Basque ("fa" "Persian" utf-8) ; Persian + ("fil" . "UTF-8") ; Filipino + ("fpo" . "UTF-8") ; MS-Windows Filipino ("fi" . "Latin-9") ; Finnish ("fj" . "Latin-1") ; Fiji ("fo" . "Latin-1") ; Faroese @@ -2262,6 +2260,7 @@ See `set-language-info-alist' for use in programs." ("ga" . "Latin-1") ; Irish Gaelic (new orthography) ("gd" . "Latin-9") ; Scots Gaelic ("gez" "Ethiopic" utf-8) ; Geez + ("gla" . "Latin-9") ; MS-Windows Scots Gaelic ("gl" . "Latin-1") ; Gallegan; Galician ; gn Guarani ("gu" "Gujarati" utf-8) ; Gujarati @@ -2272,27 +2271,33 @@ See `set-language-info-alist' for use in programs." ("hni_IN" . "UTF-8") ; Chhattisgarhi ("hr" "Croatian" iso-8859-2) ; Croatian ("hu" . "Latin-2") ; Hungarian - ; hy Armenian + ("hy" . "UTF-8") ; Armenian ; ia Interlingua ("id" . "Latin-1") ; Indonesian ; ie Interlingue - ; ik Inupiak + ("ig" . "UTF-8") ; Igbo (Nigeria) + ("ibo" . "UTF-8") ; MS-Windows Igbo + ; ik Inupiak, Inupiaq ("is" . "Latin-1") ; Icelandic ("it" "Italian" iso-8859-1) ; Italian ; iu Inuktitut ("iw" "Hebrew" iso-8859-8) ("ja" "Japanese" euc-jp) ; jw Javanese + ("kal" . "Latin-1") ; MS-Windows Greenlandic ("ka" "Georgian" georgian-ps) ; Georgian - ; kk Kazakh + ("kk" . "UTF-8") ; Kazakh ("kl" . "Latin-1") ; Greenlandic ("km" "Khmer" utf-8) ; Cambodian, Khmer + ("knk" "Devanagari" utf-8) ; MS-Windows Konkani + ("kok" "Devanagari" utf-8) ; Konkani ("kn" "Kannada" utf-8) ("ko" "Korean" euc-kr) ("ks" . "UTF-8") ; Kashmiri ; ku Kurdish ("kw" . "Latin-1") ; Cornish ("ky" . "UTF-8") ; Kirghiz + ("lao" "Lao" utf-8) ; MS-Windows Lao ("la" . "Latin-1") ; Latin ("lb" . "Latin-1") ; Luxemburgish ("lg" . "Latin-6") ; Ganda, a.k.a. Luganda @@ -2303,18 +2308,22 @@ See `set-language-info-alist' for use in programs." ; mg Malagasy ("mi" . "Latin-7") ; Maori ("mk" "Cyrillic-ISO" iso-8859-5) ; Macedonian + ("mlt" . "Latin-3") ; MS-Windows Maltese ("ml" "Malayalam" utf-8) ("mn" . "UTF-8") ; Mongolian - ; mo Moldavian + ; mo Moldavian (retired) + ("mri" . "Latin-7") ; MS-Windows Maori ("mr" "Devanagari" utf-8) ; Marathi ("ms" . "Latin-1") ; Malay ("mt" . "Latin-3") ; Maltese + ("mym" "Malayalam" utf-8) ; MS-Windows Malayalam ("my" "Burmese" utf-8) ; Burmese ; na Nauru ("nb" . "Latin-1") ; Norwegian ("ne" "Devanagari" utf-8) ; Nepali ("nl" "Dutch" iso-8859-1) ("nn" . "Latin-1") ; Norwegian Nynorsk + ("non" . "Latin-1") ; MS-Windows Norwegian Nynorsk ("no" . "Latin-1") ; Norwegian ("nr_ZA" . "UTF-8") ; South Ndebele ("nso_ZA" . "UTF-8") ; Pedi @@ -2324,7 +2333,8 @@ See `set-language-info-alist' for use in programs." ("or" "Oriya" utf-8) ("pa" "Punjabi" utf-8) ; Punjabi ("pl" "Polish" iso-8859-2) ; Polish - ; ps Pashto, Pushto + ("ps" . "UTF-8") ; Pashto, Pushto + ("pas" . "UTF-8") ; MS-Windows Pashto ("pt_BR" "Brazilian Portuguese" iso-8859-1) ; Brazilian Portuguese ("pt" . "Latin-1") ; Portuguese ; qu Quechua @@ -2334,7 +2344,7 @@ See `set-language-info-alist' for use in programs." ("ru_RU.koi8r" "Cyrillic-KOI8" koi8-r) ("ru_RU" "Russian" iso-8859-5) ("ru_UA" "Russian" koi8-u) - ; rw Kinyarwanda + ("rw" . "UTF-8") ; Kinyarwanda ("sa" . "Devanagari") ; Sanskrit ; sd Sindhi ("se" . "UTF-8") ; Northern Sami @@ -2355,6 +2365,7 @@ See `set-language-info-alist' for use in programs." ; su Sundanese ("sv" "Swedish" iso-8859-1) ; Swedish ("sw" . "Latin-1") ; Swahili + ("taj" "Tajik" koi8-t) ; MS-Windows Tajik w/Cyrillic script ("ta" "Tamil" utf-8) ("te" "Telugu" utf-8) ; Telugu ("tg" "Tajik" koi8-t) @@ -2364,15 +2375,17 @@ See `set-language-info-alist' for use in programs." ("th" "Thai" iso-8859-11) ("ti" "Ethiopic" utf-8) ; Tigrinya ("tig_ER" . "UTF-8") ; Tigre - ; tk Turkmen + ("tk" . "Latin-5") ; Turkmen + ("tuk" . "Latin-5") ; MS-Windows Turkmen ("tl" . "Latin-1") ; Tagalog ("tn" . "Latin-9") ; Setswana, Tswana ; to Tonga ("tr" "Turkish" iso-8859-9) + ("tsn" . "Latin-9") ; MS-Windows Tswana ("ts" . "Latin-1") ; Tsonga ("tt" . "UTF-8") ; Tatar ; tw Twi - ; ug Uighur + ("ug" . "UTF-8") ; Uighur ("uk" "Ukrainian" koi8-u) ("ur" . "UTF-8") ; Urdu ("uz_UZ@cyrillic" . "UTF-8"); Uzbek @@ -2381,10 +2394,10 @@ See `set-language-info-alist' for use in programs." ("vi" "Vietnamese" utf-8) ; vo Volapuk ("wa" . "Latin-1") ; Walloon - ; wo Wolof + ("wo" . "UTF-8") ; Wolof ("xh" . "Latin-1") ; Xhosa ("yi" . "Windows-1255") ; Yiddish - ; yo Yoruba + ("yo" . "UTF-8") ; Yoruba ; za Zhuang ("zh_HK" . "Chinese-Big5") ; zh_HK/BIG5-HKSCS \ @@ -2394,6 +2407,9 @@ See `set-language-info-alist' for use in programs." ("zh_CN.GB18030" "Chinese-GB18030") ("zh_CN.UTF-8" . "Chinese-GBK") ("zh_CN" . "Chinese-GB") + ("zhh" . "Chinese-Big5") ; MS-Windows Chinese (Hong Kong S.A.R.) + ("zhi" . "Chinese-GBK") ; MS-Windows Chinese (Singapore) + ("zhm" . "Chinese-Big5") ; MS-Windows Chinese (Macao S.A.R.) ("zh" . "Chinese-GB") ("zu" . "Latin-1") ; Zulu @@ -2411,12 +2427,23 @@ See `set-language-info-alist' for use in programs." ("sp" . "Cyrillic-ISO") ; Serbian (Cyrillic alphabet), e.g. X11R6.4 ("su" . "Latin-1") ; Finnish, e.g. Solaris 2.6 ("jp" . "Japanese") ; e.g. MS Windows - ("chs" . "Chinese-GBK") ; MS Windows Chinese Simplified - ("cht" . "Chinese-BIG5") ; MS Windows Chinese Traditional + ("chs" . "Chinese-GBK") ; MS Windows Chinese Simplified (PRC) + ("cht" . "Chinese-BIG5") ; MS Windows Chinese Traditional (Taiwan) ("gbz" . "UTF-8") ; MS Windows Dari Persian ("div" . "UTF-8") ; MS Windows Divehi (Maldives) ("wee" . "Latin-2") ; MS Windows Lower Sorbian ("wen" . "Latin-2") ; MS Windows Upper Sorbian + ("ind" . "Latin-1") ; MS-Windows Indonesian + ("sme" . "UTF-8") ; MS-Windows Northern Sami (Norway) + ("smf" . "UTF-8") ; MS-Windows Northern Sami (Sweden) + ("smg" . "UTF-8") ; MS-Windows Northern Sami (Finland) + ("kdi" "Kannada" utf-8) ; MS-Windows Kannada + ("mar" "Devanagari" utf-8) ; MS-Windows Marathi + ("khm" "Khmer" utf-8) ; MS-Windows Khmer + ("iri" . "Latin-1") ; MS-Windows Irish Gaelic + ; mwk MS-Windows Mohawk (Canada) + ("uig" . "UTF-8") ; MS-Windows Uighur + ("kin" . "UTF-8") ; MS-Windows Kinyarwanda )) "Alist of locale regexps vs the corresponding languages and coding systems. Each element has this form: @@ -2675,12 +2702,8 @@ See also `locale-charset-language-names', `locale-language-names', (unless frame (set-language-environment language-name)) - ;; If the default enable-multibyte-characters is nil, - ;; we are using single-byte characters, - ;; so the display table and terminal coding system are irrelevant. - (when (default-value 'enable-multibyte-characters) - (set-display-table-and-terminal-coding-system - language-name coding-system frame)) + (set-display-table-and-terminal-coding-system + language-name coding-system frame) ;; Set the `keyboard-coding-system' if appropriate (tty ;; only). At least X and MS Windows can generate @@ -2722,10 +2745,20 @@ See also `locale-charset-language-names', `locale-language-names', (output-coding (if noninteractive (intern (format "cp%d" (w32-get-console-output-codepage))) - code-page-coding))) - (when (coding-system-p code-page-coding) + code-page-coding)) + (multibyte-code-page-coding + (or (and (boundp 'w32-multibyte-code-page) + (not (zerop w32-multibyte-code-page)) + (intern (format "cp%d" w32-multibyte-code-page))) + code-page-coding)) + (locale-coding + (if noninteractive + code-page-coding + multibyte-code-page-coding))) + (when (and (coding-system-p code-page-coding) + (coding-system-p locale-coding)) (or output-coding (setq output-coding code-page-coding)) - (unless frame (setq locale-coding-system code-page-coding)) + (unless frame (setq locale-coding-system locale-coding)) (set-keyboard-coding-system code-page-coding frame) (set-terminal-coding-system output-coding frame) (setq default-file-name-coding-system ansi-code-page-coding)))) @@ -2747,7 +2780,6 @@ See also `locale-charset-language-names', `locale-language-names', (let ((paper (locale-info 'paper)) locale) (if paper - ;; This will always be null at the time of writing. (cond ((equal paper '(216 279)) (setq ps-paper-type 'letter)) @@ -2866,8 +2898,9 @@ If there's no description string for VALUE, return nil." (?\x9b . "CSI"))) (defun encoded-string-description (str coding-system) - "Return a pretty description of STR that is encoded by CODING-SYSTEM." - (setq str (string-as-unibyte str)) + "Return a pretty description of STR that is encoded by CODING-SYSTEM. +STR should be a unibyte string." + (cl-assert (not (multibyte-string-p str))) (mapconcat (if (and coding-system (eq (coding-system-type coding-system) 'iso-2022)) ;; Try to get a pretty description for ISO 2022 escape sequences. @@ -2881,13 +2914,13 @@ If there's no description string for VALUE, return nil." If CODING-SYSTEM can't safely encode CHAR, return nil. The 3rd optional argument CHARSET, if non-nil, is a charset preferred on encoding." - (let* ((str1 (string-as-multibyte (string char))) - (str2 (string-as-multibyte (string char char))) + (let* ((str1 (string char)) + (str2 (string char char)) (found (find-coding-systems-string str1)) enc1 enc2 i1 i2) - (if (and (consp found) - (eq (car found) 'undecided)) - str1 + (if (eq (car-safe found) 'undecided) ;Aka (not (multibyte-string-p str1)) + ;; `char' is ASCII. + (encode-coding-string str1 coding-system) (when (memq (coding-system-base coding-system) found) ;; We must find the encoded string of CHAR. But, just encoding ;; CHAR will put extra control sequences (usually to designate @@ -2950,12 +2983,13 @@ on encoding." (#x14400 . #x14646) ;; (#x14647 . #x167FF) unused (#x16800 . #x16F9F) - (#x16FE0 . #x16FE0) + (#x16FE0 . #x16FE3) ;; (#x17000 . #x187FF) Tangut Ideographs ;; (#x18800 . #x18AFF) Tangut Components ;; (#x18B00 . #x1AFFF) unused - (#x1B000 . #x1B12F) - ;; (#x1B130 . #x1B16F) unused + (#x1B000 . #x1B11F) + ;; (#x1B120 . #x1B14F) unused + (#x1B150 . #x1B16F) (#x1B170 . #x1B2FF) ;; (#x1B300 . #x1BBFF) unused (#x1BC00 . #x1BCAF) @@ -3045,7 +3079,7 @@ as names, not numbers." (char (cond ((char-from-name input t)) - ((string-match-p "\\`[0-9a-fA-F]+\\'" input) + ((string-match-p "\\`[[:xdigit:]]+\\'" input) (ignore-errors (string-to-number input 16))) ((string-match-p "\\`#\\([bBoOxX]\\|[0-9]+[rR]\\)[0-9a-zA-Z]+\\'" input) diff --git a/lisp/international/mule-conf.el b/lisp/international/mule-conf.el index 6db795739de..69a505d3066 100644 --- a/lisp/international/mule-conf.el +++ b/lisp/international/mule-conf.el @@ -222,20 +222,19 @@ ;; Can this be shared with 8859-11? ;; N.b. not all of these are defined in Unicode. (define-charset 'thai-tis620 - "TIS620.2533" + "MULE charset for TIS620.2533" :short-name "TIS620.2533" :iso-final-char ?T :emacs-mule-id 133 :code-space [32 127] :code-offset #x0E00) -;; Fixme: doc for this, c.f. above (define-charset 'tis620-2533 - "TIS620.2533" + "TIS620.2533, a.k.a. TIS-620. Like `thai-iso8859-11', but without NBSP." :short-name "TIS620.2533" :ascii-compatible-p t :code-space [0 255] - :superset '(ascii eight-bit-control (thai-tis620 . 128))) + :superset '(ascii (thai-tis620 . 128))) (define-charset 'jisx0201 "JISX0201" @@ -1067,6 +1066,15 @@ :mime-charset 'ebcdic-uk :map "EBCDICUK") +(define-charset 'ibm038 + "International version of EBCDIC" + :short-name "IBM038" + :code-space [0 255] + :mime-charset 'ibm038 + :map "IBM038") +(define-charset-alias 'ebcdic-int 'ibm038) +(define-charset-alias 'cp038 'ibm038) + (define-charset 'ibm1047 ;; Says groff: "IBM1047, `EBCDIC Latin 1/Open Systems' used by OS/390 Unix." @@ -1576,6 +1584,61 @@ for decoding and encoding files, process I/O, etc." (aset latin-extra-code-table ?\225 t) (aset latin-extra-code-table ?\226 t) +(defcustom password-word-equivalents + '("password" "passcode" "passphrase" "pass phrase" "pin" + ; These are sorted according to the GNU en_US locale. + "암호" ; ko + "パスワード" ; ja + "ପ୍ରବେଶ ସଙ୍କେତ" ; or + "ពាក្យសម្ងាត់" ; km + "adgangskode" ; da + "contraseña" ; es + "contrasenya" ; ca + "geslo" ; sl + "hasło" ; pl + "heslo" ; cs, sk + "iphasiwedi" ; zu + "jelszó" ; hu + "lösenord" ; sv + "lozinka" ; hr, sr + "mật khẩu" ; vi + "mot de passe" ; fr + "parola" ; tr + "pasahitza" ; eu + "passord" ; nb + "passwort" ; de + "pasvorto" ; eo + "salasana" ; fi + "senha" ; pt + "slaptažodis" ; lt + "wachtwoord" ; nl + "كلمة السر" ; ar + "ססמה" ; he + "лозинка" ; sr + "пароль" ; kk, ru, uk + "गुप्तशब्द" ; mr + "शब्दकूट" ; hi + "પાસવર્ડ" ; gu + "సంకేతపదము" ; te + "ਪਾਸਵਰਡ" ; pa + "ಗುಪ್ತಪದ" ; kn + "கடவுச்சொல்" ; ta + "അടയാളവാക്ക്" ; ml + "গুপ্তশব্দ" ; as + "পাসওয়ার্ড" ; bn_IN + "රහස්පදය" ; si + "密码" ; zh_CN + "密碼" ; zh_TW + ) + "List of words equivalent to \"password\". +This is used by Shell mode and other parts of Emacs to recognize +password prompts, including prompts in languages other than +English. Different case choices should not be assumed to be +included; callers should bind `case-fold-search' to t." + :type '(repeat string) + :version "27.1" + :group 'processes) + ;; The old code-pages library is obsoleted by coding systems based on ;; the charsets defined in this file but might be required by user ;; code. diff --git a/lisp/international/mule-diag.el b/lisp/international/mule-diag.el index d6ac8944d78..472529ffc05 100644 --- a/lisp/international/mule-diag.el +++ b/lisp/international/mule-diag.el @@ -1104,8 +1104,6 @@ system which uses fontsets)." (insert "Version of this emacs:\n " (emacs-version) "\n\n") (insert "Configuration options:\n " system-configuration-options "\n\n") (insert "Multibyte characters awareness:\n" - (format " default: %S\n" (default-value - 'enable-multibyte-characters)) (format " current-buffer: %S\n\n" enable-multibyte-characters)) (insert "Current language environment: " current-language-environment "\n\n") diff --git a/lisp/international/mule-util.el b/lisp/international/mule-util.el index 2526f1ee324..19d6d165cfd 100644 --- a/lisp/international/mule-util.el +++ b/lisp/international/mule-util.el @@ -282,67 +282,11 @@ language environment LANG-ENV." (declare-function internal-char-font "font.c" (position &optional ch)) -;;;###autoload -(defun char-displayable-p (char) - "Return non-nil if we should be able to display CHAR. -On a multi-font display, the test is only whether there is an -appropriate font from the selected frame's fontset to display -CHAR's charset in general. Since fonts may be specified on a -per-character basis, this may not be accurate." - (cond ((< char 128) - ;; ASCII characters are always displayable. - t) - ((not enable-multibyte-characters) - ;; Maybe there's a font for it, but we can't put it in the buffer. - nil) - (t - (let ((font-glyph (internal-char-font nil char))) - (if font-glyph - (if (consp font-glyph) - ;; On a window system, a character is displayable - ;; if a font for that character is in the default - ;; face of the currently selected frame. - (car font-glyph) - ;; On a text terminal supporting glyph codes, CHAR is - ;; displayable if its glyph code is nonnegative. - (<= 0 font-glyph)) - ;; On a text terminal without glyph codes, CHAR is displayable - ;; if the coding system for the terminal can encode it. - (let ((coding (terminal-coding-system))) - (when coding - (let ((cs-list (coding-system-get coding :charset-list))) - (cond - ((listp cs-list) - (catch 'tag - (mapc #'(lambda (charset) - (if (encode-char char charset) - (throw 'tag charset))) - cs-list) - nil)) - ((eq cs-list 'iso-2022) - (catch 'tag2 - (mapc #'(lambda (charset) - (if (and (plist-get (charset-plist charset) - :iso-final-char) - (encode-char char charset)) - (throw 'tag2 charset))) - charset-list) - nil)) - ((eq cs-list 'emacs-mule) - (catch 'tag3 - (mapc #'(lambda (charset) - (if (and (plist-get (charset-plist charset) - :emacs-mule-id) - (encode-char char charset)) - (throw 'tag3 charset))) - charset-list) - nil))))))))))) - (defun filepos-to-bufferpos--dos (byte f) (let ((eol-offset 0) ;; Make sure we terminate, even if BYTE falls right in the middle ;; of a CRLF or some other weird corner case. - (omin 0) (omax most-positive-fixnum) + (omin 0) omax pos lines) (while (progn @@ -355,9 +299,9 @@ per-character basis, this may not be accurate." (setq pos (point-max)))) ;; Adjust POS for DOS EOL format. (setq lines (1- (line-number-at-pos pos))) - (and (not (= lines eol-offset)) (> omax omin))) + (and (not (= lines eol-offset)) (or (not omax) (> omax omin)))) (if (> lines eol-offset) - (setq omax (min (1- omax) lines) + (setq omax (if omax (min (1- omax) lines) lines) eol-offset omax) (setq omin (max (1+ omin) lines) eol-offset omin))) @@ -393,17 +337,17 @@ QUALITY can be: japanese-cp932 korean-cp949))) (setq type 'single-byte)) (pcase type - (`utf-8 + ('utf-8 (when (coding-system-get coding-system :bom) (setq byte (max 0 (- byte 3)))) (if (= eol 1) (filepos-to-bufferpos--dos (+ pm byte) #'byte-to-position) (byte-to-position (+ pm byte)))) - (`single-byte + ('single-byte (if (= eol 1) (filepos-to-bufferpos--dos (+ pm byte) #'identity) (+ pm byte))) - ((and `utf-16 + ((and 'utf-16 ;; FIXME: For utf-16, we could use the same approach as used for ;; dos EOLs (counting the number of non-BMP chars instead of the ;; number of lines). @@ -419,8 +363,8 @@ QUALITY can be: (+ pm byte))) (_ (pcase quality - (`approximate (byte-to-position (+ pm byte))) - (`exact + ('approximate (byte-to-position (+ pm byte))) + ('exact ;; Rather than assume that the file exists and still holds the right ;; data, we reconstruct it based on the buffer's content. (let ((buf (current-buffer))) @@ -456,7 +400,7 @@ QUALITY can be: (lineno (if (= eol 1) (1- (line-number-at-pos position)) 0)) (type (coding-system-type coding-system)) (base (coding-system-base coding-system)) - byte) + (point-min 1)) ;Clarify what the `1' means. (and (eq type 'utf-8) ;; Any post-read/pre-write conversions mean it's not really UTF-8. (not (null (coding-system-get coding-system :post-read-conversion))) @@ -470,36 +414,34 @@ QUALITY can be: japanese-cp932 korean-cp949))) (setq type 'single-byte)) (pcase type - (`utf-8 - (setq byte (position-bytes position)) - (when (null byte) - (if (<= position 0) - (setq byte 1) - (setq byte (position-bytes (point-max))))) - (setq byte (1- byte)) - (+ byte + ('utf-8 + (+ (or (position-bytes position) + (if (<= position 0) + point-min + (position-bytes (point-max)))) ;; Account for BOM, if any. (if (coding-system-get coding-system :bom) 3 0) ;; Account for CR in CRLF pairs. - lineno)) - (`single-byte - (+ position -1 lineno)) - ((and `utf-16 + lineno + (- point-min))) + ('single-byte + (+ position (- point-min) lineno)) + ((and 'utf-16 ;; FIXME: For utf-16, we could use the same approach as used for ;; dos EOLs (counting the number of non-BMP chars instead of the ;; number of lines). (guard (not (eq quality 'exact)))) ;; In approximate mode, assume all characters are within the ;; BMP, i.e. each one takes up 2 bytes. - (+ (* (1- position) 2) + (+ (* (- position point-min) 2) ;; Account for BOM, if any. (if (coding-system-get coding-system :bom) 2 0) ;; Account for CR in CRLF pairs. lineno)) (_ (pcase quality - (`approximate (+ (position-bytes position) -1 lineno)) - (`exact + ('approximate (+ (position-bytes position) (- point-min) lineno)) + ('exact ;; Rather than assume that the file exists and still holds the right ;; data, we reconstruct its relevant portion. (let ((buf (current-buffer))) @@ -511,7 +453,7 @@ QUALITY can be: (widen) (encode-coding-region (point-min) (min (point-max) position) coding-system tmp-buf))) - (1- (point-max))))))))))) + (buffer-size)))))))))) (provide 'mule-util) diff --git a/lisp/international/mule.el b/lisp/international/mule.el index cc0658dc3f4..ec6f6476888 100644 --- a/lisp/international/mule.el +++ b/lisp/international/mule.el @@ -343,7 +343,7 @@ Return t if file exists." ;; Have the original buffer current while we eval. (eval-buffer buffer nil ;; This is compatible with what `load' does. - (if purify-flag file fullname) + (if dump-mode file fullname) nil t)) (let (kill-buffer-hook kill-buffer-query-functions) (kill-buffer buffer))) @@ -481,6 +481,61 @@ Return -1 if charset isn't an ISO 2022 one." (or charset (error "Invalid Emacs-mule charset ID: %d" charset-id)) (make-char charset code1 code2))) + +(defun char-displayable-p (char) + "Return non-nil if we should be able to display CHAR. +On a multi-font display, the test is only whether there is an +appropriate font from the selected frame's fontset to display +CHAR's charset in general. Since fonts may be specified on a +per-character basis, this may not be accurate." + (cond ((< char 128) + ;; ASCII characters are always displayable. + t) + ((not enable-multibyte-characters) + ;; Maybe there's a font for it, but we can't put it in the buffer. + nil) + (t + (let ((font-glyph (internal-char-font nil char))) + (if font-glyph + (if (consp font-glyph) + ;; On a window system, a character is displayable + ;; if a font for that character is in the default + ;; face of the currently selected frame. + (car font-glyph) + ;; On a text terminal supporting glyph codes, CHAR is + ;; displayable if its glyph code is nonnegative. + (<= 0 font-glyph)) + ;; On a text terminal without glyph codes, CHAR is displayable + ;; if the coding system for the terminal can encode it. + (let ((coding (terminal-coding-system))) + (when coding + (let ((cs-list (coding-system-get coding :charset-list))) + (cond + ((listp cs-list) + (catch 'tag + (mapc #'(lambda (charset) + (if (encode-char char charset) + (throw 'tag charset))) + cs-list) + nil)) + ((eq cs-list 'iso-2022) + (catch 'tag2 + (mapc #'(lambda (charset) + (if (and (plist-get (charset-plist charset) + :iso-final-char) + (encode-char char charset)) + (throw 'tag2 charset))) + charset-list) + nil)) + ((eq cs-list 'emacs-mule) + (catch 'tag3 + (mapc #'(lambda (charset) + (if (and (plist-get (charset-plist charset) + :emacs-mule-id) + (encode-char char charset)) + (throw 'tag3 charset))) + charset-list) + nil))))))))))) ;; Save the ASCII case table in case we need it later. Some locales ;; (such as Turkish) modify the case behavior of ASCII characters, @@ -819,10 +874,10 @@ VALUE is a CCL program name defined by `define-ccl-program'. The CCL program reads a character sequence and writes a byte sequence as an encoding result. -`:inhibit-null-byte-detection' +`:inhibit-nul-byte-detection' VALUE non-nil means Emacs ignore null bytes on code detection. -See the variable `inhibit-null-byte-detection'. This attribute +See the variable `inhibit-nul-byte-detection'. This attribute is meaningful only when `:coding-type' is `undecided'. `:inhibit-iso-escape-detection' @@ -867,7 +922,7 @@ non-ASCII files. This attribute is meaningful only when :ccl-encoder :valids)) ((eq coding-type 'undecided) - '(:inhibit-null-byte-detection + '(:inhibit-nul-byte-detection :inhibit-iso-escape-detection :prefer-utf-8)))))) @@ -911,7 +966,7 @@ non-ASCII files. This attribute is meaningful only when (i 0)) (dolist (elt coding-system-iso-2022-flags) (if (memq elt flags) - (setq bits (logior bits (lsh 1 i)))) + (setq bits (logior bits (ash 1 i)))) (setq i (1+ i))) (setcdr (assq :flags spec-attrs) bits)))) @@ -920,8 +975,8 @@ non-ASCII files. This attribute is meaningful only when (cons :name (cons name (cons :docstring (cons (purecopy docstring) props))))) (setcdr (assq :plist common-attrs) props) - (apply 'define-coding-system-internal - name (mapcar 'cdr (append common-attrs spec-attrs))))) + (apply #'define-coding-system-internal + name (mapcar #'cdr (append common-attrs spec-attrs))))) (defun coding-system-doc-string (coding-system) "Return the documentation string for CODING-SYSTEM." @@ -1345,8 +1400,11 @@ just set the variable `buffer-file-coding-system' directly." (setq coding-system (merge-coding-systems coding-system buffer-file-coding-system))) (when (and (called-interactively-p 'interactive) - (not (memq 'emacs (coding-system-get coding-system - :charset-list)))) + ;; FIXME: For some reason + ;; (coding-system-get 'iso-2022-7bit :charset-list) + ;; returns `iso-2022' rather than returning a list! + (let ((css (coding-system-get coding-system :charset-list))) + (not (and (listp css) (memq 'emacs css))))) ;; Check whether save would succeed, and jump to the offending char(s) ;; if not. (let ((css (find-coding-systems-region (point-min) (point-max)))) @@ -1514,6 +1572,7 @@ DECODING is the coding system to be used to decode input from the process, ENCODING is the coding system to be used to encode output to the process. For a list of possible coding systems, use \\[list-coding-systems]." + (declare (interactive-only set-process-coding-system)) (interactive "zCoding-system for output from the process: \nzCoding-system for input to the process: ") (let ((proc (get-buffer-process (current-buffer)))) @@ -2494,7 +2553,18 @@ This function is intended to be added to `auto-coding-functions'." (when end (if (re-search-forward "encoding=[\"']\\(.+?\\)[\"']" end t) (let* ((match (match-string 1)) - (sym (intern (downcase match)))) + (sym-name (downcase match)) + (sym-name + ;; https://www.w3.org/TR/xml/#charencoding says: + ;; "Entities encoded in UTF-16 MUST [...] begin + ;; with the Byte Order Mark." The trick below is + ;; based on the fact that utf-16be/le don't + ;; specify BOM, while utf-16-be/le do. + (cond + ((equal sym-name "utf-16le") "utf-16-le") + ((equal sym-name "utf-16be") "utf-16-be") + (t sym-name))) + (sym (intern sym-name))) (if (coding-system-p sym) ;; If the encoding tag is UTF-8 and the buffer's ;; encoding is one of the variants of UTF-8, use the @@ -2554,7 +2624,7 @@ This function is intended to be added to `auto-coding-functions'." ;; (allowing for whitespace at bob). Note: 'DOCTYPE NETSCAPE' is ;; useful for Mozilla bookmark files. (when (and (re-search-forward "\\`[[:space:]\n]*\\(<!doctype[[:space:]\n]+\\(html\\|netscape\\)\\|<html\\)" size t) - (re-search-forward "<meta\\s-+\\(http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']text/\\sw+;\\s-*\\)?charset=[\"']?\\(.+?\\)[\"'\\s-/>]" size t)) + (re-search-forward "<meta\\s-+\\(http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']text/\\sw+;\\s-*\\)?charset=[\"']?\\(.+?\\)[\"'[:space:]/>]" size t)) (let* ((match (match-string 2)) (sym (intern (downcase match)))) (if (coding-system-p sym) @@ -2583,9 +2653,14 @@ added by processing software." (let ((detected (with-coding-priority '(utf-8) (coding-system-base - (detect-coding-region (point-min) (point-max) t))))) - ;; Pure ASCII always comes back as undecided. + (detect-coding-region (point-min) (point-max) t)))) + (bom (list (char-after 1) (char-after 2)))) (cond + ((equal bom '(#xFE #xFF)) + 'utf-16be-with-signature) + ((equal bom '(#xFF #xFE)) + 'utf-16le-with-signature) + ;; Pure ASCII always comes back as undecided. ((memq detected '(utf-8 undecided)) 'utf-8) ((eq detected 'utf-16le-with-signature) 'utf-16le-with-signature) diff --git a/lisp/international/quail.el b/lisp/international/quail.el index f1fb5f7c605..f42b594dc46 100644 --- a/lisp/international/quail.el +++ b/lisp/international/quail.el @@ -6,9 +6,9 @@ ;; National Institute of Advanced Industrial Science and Technology (AIST) ;; Registration Number H14PRO021 -;; Author: Kenichi HANDA <handa@etl.go.jp> -;; Naoto TAKAHASHI <ntakahas@etl.go.jp> -;; Maintainer: Kenichi HANDA <handa@etl.go.jp> +;; Author: Kenichi Handa <handa@gnu.org> +;; Naoto Takahashi <ntakahas@etl.go.jp> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: mule, multilingual, input method, i18n ;; This file is part of GNU Emacs. @@ -568,7 +568,7 @@ While this input method is active, the variable (quail-delete-overlays) (setq describe-current-input-method-function nil) (quail-hide-guidance) - (remove-hook 'post-command-hook 'quail-show-guidance t) + (remove-hook 'post-command-hook #'quail-show-guidance t) (run-hooks 'quail-deactivate-hook)) (kill-local-variable 'input-method-function)) ;; Let's activate Quail input method. @@ -579,19 +579,18 @@ While this input method is active, the variable (setq name (car (car quail-package-alist))) (error "No Quail package loaded")) (quail-select-package name))) - (setq deactivate-current-input-method-function 'quail-deactivate) - (setq describe-current-input-method-function 'quail-help) + (setq deactivate-current-input-method-function #'quail-deactivate) + (setq describe-current-input-method-function #'quail-help) (quail-delete-overlays) (setq quail-guidance-str "") (quail-show-guidance) ;; If we are in minibuffer, turn off the current input method ;; before exiting. (when (eq (selected-window) (minibuffer-window)) - (add-hook 'minibuffer-exit-hook 'quail-exit-from-minibuffer) - (add-hook 'post-command-hook 'quail-show-guidance nil t)) + (add-hook 'minibuffer-exit-hook #'quail-exit-from-minibuffer) + (add-hook 'post-command-hook #'quail-show-guidance nil t)) (run-hooks 'quail-activate-hook) - (make-local-variable 'input-method-function) - (setq input-method-function 'quail-input-method))) + (setq-local input-method-function #'quail-input-method))) (define-obsolete-variable-alias 'quail-inactivate-hook @@ -1367,9 +1366,7 @@ If STR has `advice' text property, append the following special event: (let ((start (overlay-start overlay)) (end (overlay-end overlay))) (if (< start end) - (prog1 - (string-to-list (buffer-substring start end)) - (delete-region start end))))) + (string-to-list (delete-and-extract-region start end))))) (defsubst quail-delete-region () "Delete the text in the current translation region of Quail." @@ -1394,12 +1391,13 @@ Return the input string." (generated-events nil) ;FIXME: What is this? (input-method-function nil) (modified-p (buffer-modified-p)) - last-command-event last-command this-command) + last-command-event last-command this-command inhibit-record) (setq quail-current-key "" quail-current-str "" quail-translating t) (if key - (setq unread-command-events (cons key unread-command-events))) + (setq unread-command-events (cons key unread-command-events) + inhibit-record t)) (while quail-translating (set-buffer-modified-p modified-p) (quail-show-guidance) @@ -1408,8 +1406,13 @@ Return the input string." (or input-method-previous-message "") quail-current-str quail-guidance-str))) + ;; We inhibit record_char only for the first key, + ;; because it was already recorded before read_char + ;; called quail-input-method. + (inhibit--record-char inhibit-record) (keyseq (read-key-sequence prompt nil nil t)) (cmd (lookup-key (quail-translation-keymap) keyseq))) + (setq inhibit-record nil) (if (if key (and (commandp cmd) (not (eq cmd 'quail-other-command))) (eq cmd 'quail-self-insert-command)) @@ -1453,14 +1456,15 @@ Return the input string." (generated-events nil) ;FIXME: What is this? (input-method-function nil) (modified-p (buffer-modified-p)) - last-command-event last-command this-command) + last-command-event last-command this-command inhibit-record) (setq quail-current-key "" quail-current-str "" quail-translating t quail-converting t quail-conversion-str "") (if key - (setq unread-command-events (cons key unread-command-events))) + (setq unread-command-events (cons key unread-command-events) + inhibit-record t)) (while quail-converting (set-buffer-modified-p modified-p) (or quail-translating @@ -1476,8 +1480,13 @@ Return the input string." quail-conversion-str quail-current-str quail-guidance-str))) + ;; We inhibit record_char only for the first key, + ;; because it was already recorded before read_char + ;; called quail-input-method. + (inhibit--record-char inhibit-record) (keyseq (read-key-sequence prompt nil nil t)) (cmd (lookup-key (quail-conversion-keymap) keyseq))) + (setq inhibit-record nil) (if (if key (commandp cmd) (eq cmd 'quail-self-insert-command)) (progn (setq last-command-event (aref keyseq (1- (length keyseq))) @@ -3051,7 +3060,6 @@ of each directory." (when dirname (setq pkg-list (directory-files dirname 'full "\\.el$")) (while pkg-list - (message "Checking %s ..." (car pkg-list)) (with-temp-buffer (insert-file-contents (car pkg-list)) (goto-char (point-min)) diff --git a/lisp/international/titdic-cnv.el b/lisp/international/titdic-cnv.el index ac5a0e8861d..8615d953319 100644 --- a/lisp/international/titdic-cnv.el +++ b/lisp/international/titdic-cnv.el @@ -1,4 +1,4 @@ -;;; titdic-cnv.el --- convert cxterm dictionary (TIT format) to Quail package -*- coding:iso-2022-7bit; -*- +;;; titdic-cnv.el --- convert cxterm dictionary (TIT format) to Quail package -*- coding: utf-8-emacs; lexical-binding:t -*- ;; Copyright (C) 1997-1998, 2000-2019 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, @@ -83,9 +83,9 @@ ;; how to select a translation from a list of candidates. (defvar quail-cxterm-package-ext-info - '(("chinese-4corner" "$(0(?-F(B") - ("chinese-array30" "$(0#R#O(B") - ("chinese-ccdospy" "$AKuF4(B" + '(("chinese-4corner" "四角") + ("chinese-array30" "30") + ("chinese-ccdospy" "缩拼" "Pinyin base input method for Chinese charset GB2312 (`chinese-gb2312'). Pinyin is the standard Roman transliteration method for Chinese. @@ -94,10 +94,10 @@ method `chinese-py'. This input method works almost the same way as `chinese-py'. The difference is that you type a single key for these Pinyin spelling. - Pinyin: zh en eng ang ch an ao ai ong sh ing yu($A(9(B) + Pinyin: zh en eng ang ch an ao ai ong sh ing yu(ü) keyseq: a f g h i j k l s u y v For example: - Chinese: $A0!(B $A9{(B $AVP(B $AND(B $A9b(B $ASq(B $AH+(B + Chinese: 啊 果 中 文 光 玉 全 Pinyin: a guo zhong wen guang yu quan Keyseq: a1 guo4 as1 wf4 guh1 yu..6 qvj6 @@ -106,14 +106,14 @@ For example: For double-width GB2312 characters corresponding to ASCII, use the input method `chinese-qj'.") - ("chinese-ecdict" "$(05CKH(B" + ("chinese-ecdict" "英漢" "In this input method, you enter a Chinese (Big5) character or word by typing the corresponding English word. For example, if you type -\"computer\", \"$(0IZH+(B\" is input. +\"computer\", \"電腦\" is input. \\<quail-translation-docstring>") - ("chinese-etzy" "$(06/0D(B" + ("chinese-etzy" "倚注" "Zhuyin base input method for Chinese Big5 characters (`chinese-big5-1', `chinese-big5-2'). @@ -122,20 +122,20 @@ compose one Chinese character. In this input method, you enter a Chinese character by first typing keys corresponding to Zhuyin symbols (see the above table) followed by -SPC, 1, 2, 3, or 4 specifying a tone (SPC:$(0?v(N(B, 1:$(0M=Vy(B, 2:$(0Dm(N(B, 3: $(0&9Vy(B, -4:$(0(+Vy(B). +SPC, 1, 2, 3, or 4 specifying a tone (SPC:陰平, 1:輕聲, 2:陽平, 3: 上聲, +4:去聲). \\<quail-translation-docstring>") - ("chinese-punct-b5" "$(0O:(BB" + ("chinese-punct-b5" "標B" "Input method for Chinese punctuation and symbols of Big5 \(`chinese-big5-1' and `chinese-big5-2').") - ("chinese-punct" "$A1j(BG" + ("chinese-punct" "标G" "Input method for Chinese punctuation and symbols of GB2312 \(`chinese-gb2312').") - ("chinese-py-b5" "$(03<(BB" + ("chinese-py-b5" "拼B" "Pinyin base input method for Chinese Big5 characters \(`chinese-big5-1', `chinese-big5-2'). @@ -153,28 +153,28 @@ method `chinese-qj-b5'. The input method `chinese-py' and `chinese-tonepy' are also Pinyin based, but for the character set GB2312 (`chinese-gb2312').") - ("chinese-qj-b5" "$(0)A(BB") + ("chinese-qj-b5" "全B") - ("chinese-qj" "$AH+(BG") + ("chinese-qj" "全G") - ("chinese-sw" "$AJWN2(B" + ("chinese-sw" "首尾" "Radical base input method for Chinese charset GB2312 (`chinese-gb2312'). In this input method, you enter a Chinese character by typing two -keys. The first key corresponds to the first ($AJW(B) radical, the second -key corresponds to the last ($AN2(B) radical. The correspondence of keys +keys. The first key corresponds to the first (首) radical, the second +key corresponds to the last (尾) radical. The correspondence of keys and radicals is as below: first radical: a b c d e f g h i j k l m n o p q r s t u v w x y z - $APD(B $AZ"(B $AJ,(B $AX<(B $A;p(B $A?Z(B $A^P(B $Ac_(B $AZ%(B $A\3(B $AXi(B $AD>(B $Alj(B $Ab;(B $ATB(B $Afy(B $AJ/(B $AMu(B $A0K(B $AX/(B $AHU(B $AeA(B $Aak(B $AVq(B $AR;(B $AHK(B + 心 冖 尸 丶 火 口 扌 氵 讠 艹 亻 木 礻 饣 月 纟 石 王 八 丿 日 辶 犭 竹 一 人 last radical: a b c d e f g h i j k l m n o p q r s t u v w x y z - $ASV(B $AI=(B $AMA(B $A56(B $AZb(B $A?Z(B $ARB(B $Aqb(B $A4s(B $A6!(B $A[L(B $Ala(B $AJ.(B $A4u(B $AXg(B $ACE(B $A=q(B $AX-(B $AE.(B $ARR(B $A`m(B $AP!(B $A3'(B $A3f(B $A_.(B $A27(B + 又 山 土 刀 阝 口 衣 疋 大 丁 厶 灬 十 歹 冂 门 今 丨 女 乙 囗 小 厂 虫 弋 卜 \\<quail-translation-docstring>") - ("chinese-tonepy" "$A5wF4(B" + ("chinese-tonepy" "调拼" "Pinyin base input method for Chinese charset GB2312 (`chinese-gb2312'). Pinyin is the standard roman transliteration method for Chinese. @@ -183,18 +183,18 @@ method `chinese-py'. This input method works almost the same way as `chinese-py'. The difference is that you must type 1..5 after each Pinyin spelling to -specify a tone (1:$ARuF=(B, 2:$AQtF=(B, 3:$AIOIy(B, 4$AOBIy(B, 5:$AGaIy(B). +specify a tone (1:阴平, 2:阳平, 3:上声, 4下声, 5:轻声). \\<quail-translation-docstring> -For instance, to input $ADc(B, you type \"n i 3 3\", the first \"n i\" is +For instance, to input 你, you type \"n i 3 3\", the first \"n i\" is a Pinyin, the next \"3\" specifies tone, and the last \"3\" selects the third character from the candidate list. For double-width GB2312 characters corresponding to ASCII, use the input method `chinese-qj'.") - ("chinese-zozy" "$(0I\0D(B" + ("chinese-zozy" "零注" "Zhuyin base input method for Chinese Big5 characters (`chinese-big5-1', `chinese-big5-2'). @@ -203,8 +203,8 @@ compose a Chinese character. In this input method, you enter a Chinese character by first typing keys corresponding to Zhuyin symbols (see the above table) followed by -SPC, 6, 3, 4, or 7 specifying a tone (SPC:$(0?v(N(B, 6:$(0Dm(N(B, 3:$(0&9Vy(B, 4:$(0(+Vy(B, -7:$(0M=Vy(B). +SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲, +7:輕聲). \\<quail-translation-docstring>"))) @@ -251,7 +251,6 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:$(0?v(N(B, 6:$(0Dm(N(B, 3:$(0&9Vy ;; Analyze header part of TIT dictionary and generate an appropriate ;; `quail-define-package' function call. (defun tit-process-header (filename) - (message "Processing header part...") (goto-char (point-min)) ;; At first, generate header part of the Quail package while @@ -348,7 +347,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:$(0?v(N(B, 6:$(0Dm(N(B, 3:$(0&9Vy (princ (nth 2 (assoc tit-encode tit-encode-list))) (princ "\" \"") (princ (or title - (if (string-match "[:$A!K$(0!(!J(B]+\\([^:$A!K$(0!(!K(B]+\\)" tit-prompt) + (if (string-match "[:∷:【]+\\([^:∷:】]+\\)" tit-prompt) (substring tit-prompt (match-beginning 1) (match-end 1)) tit-prompt))) (princ "\"\n")) @@ -416,10 +415,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:$(0?v(N(B, 6:$(0Dm(N(B, 3:$(0&9Vy ;; Convert body part of TIT dictionary into `quail-define-rules' ;; function call. (defun tit-process-body () - (message "Formatting translation rules...") - (let* ((template (list nil nil)) - (second (cdr template)) - (prev-key "") + (let* ((prev-key "") ch key translations pos) (princ "(quail-define-rules\n") (while (null (eobp)) @@ -496,12 +492,10 @@ the generated Quail package is saved." (if (not slot) (error "Invalid ENCODE: value in TIT dictionary")) (setq coding-system (nth 1 slot)) - (message "Decoding with coding system %s..." coding-system) (goto-char (point-min)) (decode-coding-region (point-min) (point-max) coding-system) ;; Explicitly set eol format to `unix'. - (setq coding-system-for-write - (coding-system-change-eol-conversion coding-system 'unix)) + (setq coding-system-for-write 'utf-8-unix) (remove-text-properties (point-min) (point-max) '(charset nil))) (set-buffer-multibyte t) @@ -522,7 +516,6 @@ the generated Quail package is saved." (princ ";; Local Variables:\n") (princ ";; version-control: never\n") (princ ";; no-update-autoloads: t\n") - (princ (format ";; coding: %s\n" coding-system-for-write)) (princ ";; End:\n")))))) ;;;###autoload @@ -560,7 +553,6 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." (when (or force (file-newer-than-file-p file (tit-make-quail-package-file-name file targetdir))) - (message "Converting %s to quail-package..." file) (titdic-convert file targetdir)) (setq files (cdr files))) (setq command-line-args-left (cdr command-line-args-left))))) @@ -581,7 +573,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; ) (defvar quail-misc-package-ext-info - '(("chinese-b5-tsangchi" "$(06A(BB" + '(("chinese-b5-tsangchi" "倉B" "cangjie-table.b5" big5 "tsang-b5.el" tsang-b5-converter "\ @@ -591,7 +583,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # unmodified versions is granted without royalty provided ;; # this notice is preserved.") - ("chinese-b5-quick" "$(0X|(BB" + ("chinese-b5-quick" "簡B" "cangjie-table.b5" big5 "quick-b5.el" quick-b5-converter "\ @@ -601,7 +593,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # unmodified versions is granted without royalty provided ;; # this notice is preserved.") - ("chinese-cns-tsangchi" "$(GT?(BC" + ("chinese-cns-tsangchi" "倉C" "cangjie-table.cns" iso-2022-cn-ext "tsang-cns.el" tsang-cns-converter "\ @@ -611,7 +603,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # unmodified versions is granted without royalty provided ;; # this notice is preserved.") - ("chinese-cns-quick" "$(Gv|(BC" + ("chinese-cns-quick" "簡C" "cangjie-table.cns" iso-2022-cn-ext "quick-cns.el" quick-cns-converter "\ @@ -621,7 +613,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # unmodified versions is granted without royalty provided ;; # this notice is preserved.") - ("chinese-py" "$AF4(BG" + ("chinese-py" "拼G" "pinyin.map" cn-gb-2312 "PY.el" py-converter "\ @@ -649,7 +641,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; You should have received a copy of the GNU General Public License along with ;; CCE. If not, see <https://www.gnu.org/licenses/>.") - ("chinese-ziranma" "$AWTH;(B" + ("chinese-ziranma" "自然" "ziranma.cin" cn-gb-2312 "ZIRANMA.el" ziranma-converter "\ @@ -677,7 +669,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; You should have received a copy of the GNU General Public License along with ;; CCE. If not, see <https://www.gnu.org/licenses/>.") - ("chinese-ctlau" "$AAuTA(B" + ("chinese-ctlau" "刘粤" "CTLau.html" cn-gb-2312 "CTLau.el" ctlau-gb-converter "\ @@ -702,7 +694,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # You should have received a copy of the GNU General Public License ;; # along with this program. If not, see <https://www.gnu.org/licenses/>.") - ("chinese-ctlaub" "$(0N,Gn(B" + ("chinese-ctlaub" "劉粵" "CTLau-b5.html" big5 "CTLau-b5.el" ctlau-b5-converter "\ @@ -732,38 +724,38 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; dictionary in the buffer DICBUF. The input method name of the ;; Quail package is NAME, and the title string is TITLE. -;; TSANG-P is non-nil, generate $(06AQo(B input method. Otherwise -;; generate $(0X|/y(B (simple version of $(06AQo(B). If BIG5-P is non-nil, the +;; TSANG-P is non-nil, generate 倉頡 input method. Otherwise +;; generate 簡易 (simple version of 倉頡). If BIG5-P is non-nil, the ;; input method is for inputting Big5 characters. Otherwise the input ;; method is for inputting CNS characters. -(defun tsang-quick-converter (dicbuf name title tsang-p big5-p) - (let ((fulltitle (if tsang-p (if big5-p "$(06AQo(B" "$(GT?on(B") - (if big5-p "$(0X|/y(B" "$(Gv|Mx(B"))) +(defun tsang-quick-converter (dicbuf tsang-p big5-p) + (let ((fulltitle (if tsang-p (if big5-p "倉頡" "倉頡") + (if big5-p "簡易" "簡易"))) dic) (goto-char (point-max)) (if big5-p - (insert (format "\"$(0&d'GTT&,!J(B%s$(0!K(BBIG5 + (insert (format "\"中文輸入【%s】BIG5 - $(0KHM$(B%s$(0TT&,WoOu(B + 漢語%s輸入鍵盤 - [Q $(0'D(B] [W $(0(q(B] [E $(0'V(B] [R $(0&H(B] [T $(0'>(B] [Y $(0&4(B] [U $(0&U(B] [I $(0'B(B] [O $(0&*(B] [P $(0'A(B] + [Q 手] [W 田] [E 水] [R 口] [T 廿] [Y 卜] [U 山] [I 戈] [O 人] [P 心] - [A $(0'K(B] [S $(0&T(B] [D $(0'N(B] [F $(0'W(B] [G $(0&I(B] [H $(0*M(B] [J $(0&3(B] [L $(0&d(B] + [A 日] [S 尸] [D 木] [F 火] [G 土] [H 竹] [J 十] [L 中] - [Z ] [X $(0[E(B] [C $(01[(B] [V $(0&M(B] [B $(0'M(B] [N $(0&_(B] [M $(0&"(B] + [Z ] [X 難] [C 金] [V 女] [B 月] [N 弓] [M 一] \\\\<quail-translation-docstring>\"\n" fulltitle fulltitle)) - (insert (format "\"$(GDcEFrSD+!J(B%s$(G!K(BCNS + (insert (format "\"中文輸入【%s】CNS - $(GiGk#(B%s$(GrSD+uomu(B + 漢語%s輸入鍵盤 - [Q $(GEC(B] [W $(GFp(B] [E $(GEU(B] [R $(GDG(B] [T $(GE=(B] [Y $(GD3(B] [U $(GDT(B] [I $(GEA(B] [O $(GD)(B] [P $(GE@(B] + [Q 手] [W 田] [E 水] [R 口] [T 廿] [Y 卜] [U 山] [I 戈] [O 人] [P 心] - [A $(GEJ(B] [S $(GDS(B] [D $(GEM(B] [F $(GEV(B] [G $(GDH(B] [H $(GHL(B] [J $(GD2(B] [L $(GDc(B] + [A 日] [S 尸] [D 木] [F 火] [G 土] [H 竹] [J 十] [L 中] - [Z ] [X $(GyE(B] [C $(GOZ(B] [V $(GDL(B] [B $(GEL(B] [N $(GD^(B] [M $(GD!(B] + [Z ] [X 難] [C 金] [V 女] [B 月] [N 弓] [M 一] \\\\<quail-translation-docstring>\"\n" fulltitle fulltitle))) @@ -782,7 +774,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." (while (not (eobp)) (forward-char 5) (let ((trans (char-to-string (following-char))) - key slot) + key) (re-search-forward "\\([A-Z]+\\)\r*$" nil t) (setq key (downcase (if (or tsang-p @@ -799,63 +791,63 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." (setq dic (sort dic (function (lambda (x y) (string< (car x ) (car y)))))) (dolist (elt dic) (insert (format "(%S\t%S)\n" (car elt) (cdr elt)))) - (let ((punctuation '((";" "$(0!'!2!"!#!.!/(B" "$(G!'!2!"!#!.!/(B") - (":" "$(0!(!+!3!%!$!&!0!1(B" "$(G!(!+!3!%!$!&!0!1(B") - ("'" "$(0!e!d(B" "$(G!e!d(B") - ("\"" "$(0!g!f!h!i!q(B" "$(G!g!f!h!i!q(B") - ("\\" "$(0"`"b#M(B" "$(G"`"b#M(B") - ("|" "$(0!6!8!:"^(B" "$(G!6!8!:"^(B") - ("/" "$(0"_"a#L(B" "$(G"_"a#L(B") - ("?" "$(0!)!4(B" "$(G!)!4(B") - ("<" "$(0!R"6"A!T"H(B" "$(G!R"6"A!T"H(B") - (">" "$(0!S"7"B!U(B" "$(G!S"7"B!U(B") - ("[" "$(0!F!J!b!H!L!V!Z!X!\(B" "$(G!F!J!b!H!L!V!Z!X!\(B") - ("]" "$(0!G!K!c!I!M!W - ("{" "$(0!B!`!D(B " "$(G!B!`!D(B ") - ("}" "$(0!C!a!E(B" "$(G!C!a!E(B") - ("`" "$(0!j!k(B" "$(G!j!k(B") - ("~" "$(0"D"+",!<!=(B" "$(G"D"+",!<!=(B") - ("!" "$(0!*!5(B" "$(G!*!5(B") - ("@" "$(0"i"n(B" "$(G"i"n(B") - ("#" "$(0!l"-(B" "$(G!l"-(B") - ("$" "$(0"c"l(B" "$(G"c"l(B") - ("%" "$(0"h"m(B" "$(G"h"m(B") - ("&" "$(0!m".(B" "$(G!m".(B") - ("*" "$(0!n"/!o!w!x(B" "$(G!n"/!o!w!x(B") - ("(" "$(0!>!^!@(B" "$(G!>!^!@(B") - (")" "$(0!?!_!A(B" "$(G!?!_!A(B") - ("-" "$(0!7!9"#"$"1"@(B" "$(G!7!9"#"$"1"@(B") - ("_" "$(0"%"&(B" "$(G"%"&(B") - ("=" "$(0"8"C(B" "$(G"8"C(B") - ("+" "$(0"0"?(B" "$(G"0"?(B")))) + (let ((punctuation '((";" ";﹔,、﹐﹑" ";﹔,、﹐﹑") + (":" ":︰﹕.。‧﹒·" ":︰﹕.。・﹒·") + ("'" "’‘" "’‘") + ("\"" "”“〝〞〃" "”“〝〞〃") + ("\\" "\﹨╲" "\﹨╲") + ("|" "|︱︳∣" "︱︲|") + ("/" "/∕╱" "/∕╱") + ("?" "?﹖" "?﹖") + ("<" "〈<﹤︿∠" "〈<﹤︿∠") + (">" "〉>﹥﹀" "〉>﹦﹀") + ("[" "〔【﹝︹︻「『﹁﹃" "〔【﹝︹︻「『﹁﹃") + ("]" "〕】﹞︺︼」』﹂﹄" "〕】﹞︺︼」』﹂﹄") + ("{" "{﹛︷ " "{﹛︷ ") + ("}" "}﹜︸" "}﹜︸") + ("`" "‵′" "′‵") + ("~" "~﹋﹌︴﹏" "∼﹋﹌") + ("!" "!﹗" "!﹗") + ("@" "@﹫" "@﹫") + ("#" "#﹟" "#﹟") + ("$" "$﹩" "$﹩") + ("%" "%﹪" "%﹪") + ("&" "&﹠" "&﹠") + ("*" "*﹡※☆★" "*﹡※☆★") + ("(" "(﹙︵" "(﹙︵") + (")" ")﹚︶" ")﹚︶") + ("-" "–—¯ ̄-﹣" "—–‾-﹣") + ("_" "_ˍ" "_") + ("=" "=﹦" "=﹥") + ("+" "+﹢" "+﹢")))) (dolist (elt punctuation) (insert (format "(%S %S)\n" (concat "z" (car elt)) (if big5-p (nth 1 elt) (nth 2 elt)))))) (insert ")\n"))) -(defun tsang-b5-converter (dicbuf name title) - (tsang-quick-converter dicbuf name title t t)) +(defun tsang-b5-converter (dicbuf) + (tsang-quick-converter dicbuf t t)) -(defun quick-b5-converter (dicbuf name title) - (tsang-quick-converter dicbuf name title nil t)) +(defun quick-b5-converter (dicbuf) + (tsang-quick-converter dicbuf nil t)) -(defun tsang-cns-converter (dicbuf name title) - (tsang-quick-converter dicbuf name title t nil)) +(defun tsang-cns-converter (dicbuf) + (tsang-quick-converter dicbuf t nil)) -(defun quick-cns-converter (dicbuf name title) - (tsang-quick-converter dicbuf name title nil nil)) +(defun quick-cns-converter (dicbuf) + (tsang-quick-converter dicbuf nil nil)) ;; Generate a code of a Quail package in the current buffer from ;; Pinyin dictionary in the buffer DICBUF. The input method name of ;; the Quail package is NAME, and the title string is TITLE. -(defun py-converter (dicbuf name title) +(defun py-converter (dicbuf) (goto-char (point-max)) - (insert (format "%S\n" "$A::WVJdHk!KF4Rt!K(B + (insert (format "%S\n" "汉字输入∷拼音∷ - $AF4Rt7=08(B + 拼音方案 - $AP!P4S"NDWVD84z1m!8F4Rt!97{:E#,(B \"u(yu) $ATrSC(B u: $A1mJ>!C(B + 小写英文字母代表「拼音」符号, \"u(yu) 则用 u: 表示∶ Pinyin base input method for Chinese charset GB2312 (`chinese-gb2312'). @@ -869,14 +861,14 @@ character. The sequence is made by the combination of the initials iang ing iong u ua uo uai ui uan un uan ueng yu yue yuan yun (Note: In the correct Pinyin writing, the sequence \"yu\" in the last - four finals should be written by the character u-umlaut `$A(9(B'.) + four finals should be written by the character u-umlaut `ü'.) With this input method, you enter a Chinese character by first entering its pinyin spelling. \\<quail-translation-docstring> -For instance, to input $ADc(B, you type \"n i C-n 3\". The first \"n i\" +For instance, to input 你, you type \"n i C-n 3\". The first \"n i\" is a Pinyin, \"C-n\" selects the next group of candidates (each group contains at most 10 characters), \"3\" select the third character in that group. @@ -924,14 +916,14 @@ method `chinese-tonepy' with which you must specify tones by digits ;; Ziranma dictionary in the buffer DICBUF. The input method name of ;; the Quail package is NAME, and the title string is TITLE. -(defun ziranma-converter (dicbuf name title) +(defun ziranma-converter (dicbuf) (let (dic) (with-current-buffer dicbuf (goto-char (point-min)) (search-forward "\n%keyname end") (forward-line 1) (let ((table (make-hash-table :test 'equal)) - elt pos key trans val) + pos key trans val) (while (not (eobp)) (setq pos (point)) (skip-chars-forward "^ \t") @@ -959,22 +951,22 @@ method `chinese-tonepy' with which you must specify tones by digits table))) (setq dic (sort dic (function (lambda (x y) (string< (car x) (car y)))))) (goto-char (point-max)) - (insert (format "%S\n" "$A::WVJdHk!K!>WTH;!?!K(B - - $A<|EL6TUU1m(B: - $A)3)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)7(B - $A)'#Q(B $A)'#W(B $A)'#E(B $A)'#R(B $A)'#T(B $A)'#Y(B $A)'#U(Bsh$A)'#I(Bch$A)'#O(B $A)'#P(B $A)'(B - $A)'(B iu$A)'(B ua$A)'(B e$A)'(B uan$A)'(B ue$A)'(B uai$A)'(B u$A)'(B i$A)'(B o$A)'(B un$A)'(B - $A)'(B $A)'(B ia$A)'(B $A)'(B van$A)'(B ve$A)'(B ing$A)'(B $A)'(B $A)'(B uo$A)'(B vn$A)'(B - $A);)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)?(B - $A)'#A(B $A)'#S(B $A)'#D(B $A)'#F(B $A)'#G(B $A)'#H(B $A)'#J(B $A)'#K(B $A)'#L(B $A)'(B - $A)'(B a$A)'(Biong$A)'(Buang$A)'(B en$A)'(B eng$A)'(B ang$A)'(B an$A)'(B ao$A)'(B ai$A)'(B - $A)'(B $A)'(B ong$A)'(Biang$A)'(B $A)'(B ng$A)'(B $A)'(B $A)'(B $A)'(B $A)'(B - $A);)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)%)7(B - $A)'#Z(B $A)'#X(B $A)'#C(B $A)'#V(Bzh$A)'#B(B $A)'#N(B $A)'#M(B $A)'#,(B $A)'#.(B $A)'(B $A#/(B $A)'(B - $A)'(B ei$A)'(B ie$A)'(B iao$A)'(B ui$A)'(B ou$A)'(B in$A)'(B ian$A)'G0R3)':sR3)'7{:E)'(B - $A)'(B $A)'(B $A)'(B $A)'(B v$A)'(B $A)'(B $A)'(B $A)'(B $A)'(B $A)'(B $A)'(B - $A);)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)?(B + (insert (format "%S\n" "汉字输入∷【自然】∷ + + 键盘对照表: + ┏━━┳━━┳━━┳━━┳━━┳━━┳━━┳━━┳━━┳━━┓ + ┃Q ┃W ┃E ┃R ┃T ┃Y ┃Ush┃Ich┃O ┃P ┃ + ┃ iu┃ ua┃ e┃ uan┃ ue┃ uai┃ u┃ i┃ o┃ un┃ + ┃ ┃ ia┃ ┃ van┃ ve┃ ing┃ ┃ ┃ uo┃ vn┃ + ┗┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┛ + ┃A ┃S ┃D ┃F ┃G ┃H ┃J ┃K ┃L ┃ + ┃ a┃iong┃uang┃ en┃ eng┃ ang┃ an┃ ao┃ ai┃ + ┃ ┃ ong┃iang┃ ┃ ng┃ ┃ ┃ ┃ ┃ + ┗┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━━┓ + ┃Z ┃X ┃C ┃Vzh┃B ┃N ┃M ┃, ┃. ┃ / ┃ + ┃ ei┃ ie┃ iao┃ ui┃ ou┃ in┃ ian┃前页┃后页┃符号┃ + ┃ ┃ ┃ ┃ v┃ ┃ ┃ ┃ ┃ ┃ ┃ + ┗━━┻━━┻━━┻━━┻━━┻━━┻━━┻━━┻━━┻━━┛ Pinyin base input method for Chinese GB2312 characters (`chinese-gb2312'). @@ -986,34 +978,34 @@ method `chinese-py'. Unlike the standard spelling of Pinyin, in this input method all initials and finals are assigned to single keys (see the above table). For instance, the initial \"ch\" is assigned to the key `i', the final -\"iu\" is assigned to the key `q', and tones 1, 2, 3, 4, and $AGaIy(B are +\"iu\" is assigned to the key `q', and tones 1, 2, 3, 4, and 轻声 are assigned to the keys `q', `w', `e', `r', `t' respectively. \\<quail-translation-docstring> To input one-letter words, you type 4 keys, the first two for the Pinyin of the letter, next one for tone, and the last one is always a -quote ('). For instance, \"vsq'\" input $AVP(B. Exceptions are these +quote ('). For instance, \"vsq'\" input 中. Exceptions are these letters. You can input them just by typing a single key. - Character: $A04(B $A2;(B $A4N(B $A5D(B $A6~(B $A7"(B $A8v(B $A:M(B $A3v(B $A<0(B $A?I(B $AAK(B $AC;(B + Character: 按 不 次 的 二 发 个 和 出 及 可 了 没 Key: a b c d e f g h i j k l m - Character: $ADc(B $AE7(B $AF,(B $AF_(B $AHK(B $AH}(B $AK{(B $AJG(B $AWE(B $ANR(B $AP!(B $AR;(B $ATZ(B + Character: 你 欧 片 七 人 三 他 是 着 我 小 一 在 Key: n o p q r s t u v w x y z To input two-letter words, you have two ways. One way is to type 4 keys, two for the first Pinyin, two for the second Pinyin. For -instance, \"vsgo\" inputs $AVP9z(B. Another way is to type 3 keys: 2 +instance, \"vsgo\" inputs 中国. Another way is to type 3 keys: 2 initials of two letters, and quote ('). For instance, \"vg'\" also -inputs $AVP9z(B. +inputs 中国. To input three-letter words, you type 4 keys: initials of three -letters, and the last is quote ('). For instance, \"bjy'2\" inputs $A11(B -$A>)Q<(B (the last `2' is to select one of the candidates). +letters, and the last is quote ('). For instance, \"bjy'2\" inputs 北 +京鸭 (the last `2' is to select one of the candidates). To input words of more than three letters, you type 4 keys, initials of the first three letters and the last letter. For instance, -\"bjdt\" inputs $A11>)5gJSL((B. +\"bjdt\" inputs 北京电视台. To input symbols and punctuation, type `/' followed by one of `a' to `z', then select one of the candidates.")) @@ -1033,7 +1025,7 @@ To input symbols and punctuation, type `/' followed by one of `a' to ;; method name of the Quail package is NAME, and the title string is ;; TITLE. DESCRIPTION is the string shown by describe-input-method. -(defun ctlau-converter (dicbuf name title description) +(defun ctlau-converter (dicbuf description) (goto-char (point-max)) (insert (format "%S\n" description)) (insert " '((\"\C-?\" . quail-delete-last-char) @@ -1043,7 +1035,7 @@ To input symbols and punctuation, type `/' followed by one of `a' to (\"<\" . quail-prev-translation)) nil nil nil nil)\n\n") (insert "(quail-define-rules\n") - (let (dicbuf-start dicbuf-end key-start key (pos (point))) + (let (dicbuf-start dicbuf-end key-start (pos (point))) ;; Find the dictionary, which starts below a horizontal rule and ;; ends at the second to last line in the HTML file. (with-current-buffer dicbuf @@ -1060,7 +1052,7 @@ To input symbols and punctuation, type `/' followed by one of `a' to ;; which the file is converted have no Big5 equivalent. Go ;; through and delete them. (goto-char pos) - (while (search-forward "$(0!{(B" nil t) + (while (search-forward "□" nil t) (delete-char -1)) ;; Uppercase keys in dictionary need to be downcased. Backslashes ;; at the beginning of keys need to be turned into double @@ -1082,33 +1074,33 @@ To input symbols and punctuation, type `/' followed by one of `a' to (forward-line 1))) (insert ")\n")) -(defun ctlau-gb-converter (dicbuf name title) - (ctlau-converter dicbuf name title -"$A::WVJdHk!KAuN}OiJ=TARt!K(B +(defun ctlau-gb-converter (dicbuf) + (ctlau-converter dicbuf +"汉字输入∷刘锡祥式粤音∷ - $AAuN}OiJ=TASoW"Rt7=08(B + 刘锡祥式粤语注音方案 Sidney Lau's Cantonese transcription scheme as described in his book \"Elementary Cantonese\", The Government Printer, Hong Kong, 1972. - This file was prepared by Fung Fung Lee ($A@n7c7e(B). + This file was prepared by Fung Fung Lee (李枫峰). Originally converted from CTCPS3.tit Last modified: June 2, 1993. Some infrequent GB characters are accessed by typing \\, followed by - the Cantonese romanization of the respective radical ($A2?JW(B).")) + the Cantonese romanization of the respective radical (部首).")) -(defun ctlau-b5-converter (dicbuf name title) - (ctlau-converter dicbuf name title -"$(0KH)tTT&,!(N,Tg>A*#Gn5x!((B +(defun ctlau-b5-converter (dicbuf) + (ctlau-converter dicbuf +"漢字輸入:劉錫祥式粵音: - $(0N,Tg>A*#GnM$0D5x'J7{(B + 劉錫祥式粵語注音方案 Sidney Lau's Cantonese transcription scheme as described in his book \"Elementary Cantonese\", The Government Printer, Hong Kong, 1972. - This file was prepared by Fung Fung Lee ($(0,XFS76(B). + This file was prepared by Fung Fung Lee (李楓峰). Originally converted from CTCPS3.tit Last modified: June 2, 1993. Some infrequent characters are accessed by typing \\, followed by - the Cantonese romanization of the respective radical ($(0?f5}(B).")) + the Cantonese romanization of the respective radical (部首).")) (declare-function dos-8+3-filename "dos-fns.el" (filename)) @@ -1122,8 +1114,7 @@ the generated Quail package is saved." (let ((tail quail-misc-package-ext-info) coding-system-for-write slot - name title dicfile coding quailfile converter copyright - dicbuf) + name title dicfile coding quailfile converter copyright) (while tail (setq slot (car tail) dicfile (nth 2 slot) @@ -1146,10 +1137,8 @@ the generated Quail package is saved." coding (nth 3 slot) converter (nth 5 slot) copyright (nth 6 slot)) - (message "Converting %s to %s..." dicfile quailfile) ;; Explicitly set eol format to `unix'. - (setq coding-system-for-write - (coding-system-change-eol-conversion coding 'unix)) + (setq coding-system-for-write 'utf-8-unix) (with-temp-file (expand-file-name quailfile dirname) (insert (format-message ";; Quail package `%s'\n" name)) (insert (format-message @@ -1174,14 +1163,12 @@ the generated Quail package is saved." (insert-file-contents filename) (let ((dicbuf (current-buffer))) (with-current-buffer dstbuf - (funcall converter dicbuf name title))))) + (funcall converter dicbuf))))) (insert ";; Local Variables:\n" ";; version-control: never\n" ";; no-update-autoloads: t\n" - (format ";; coding: %s\n" coding) ";; End:\n\n" - ";;; " quailfile " ends here\n")) - (message "Converting %s to %s...done" dicfile quailfile)) + ";;; " quailfile " ends here\n"))) (setq tail (cdr tail))))) (defun batch-miscdic-convert () @@ -1210,6 +1197,38 @@ to store generated Quail packages." (miscdic-convert filename dir)))) (kill-emacs 0)) +(defun pinyin-convert () + "Convert text file pinyin.map into an elisp library. +The library is named pinyin.el, and contains the constant +`pinyin-character-map'." + (let ((src-file (car command-line-args-left)) + (dst-file (cadr command-line-args-left)) + (coding-system-for-write 'utf-8-unix)) + (with-temp-file dst-file + (insert ";; This file is automatically generated from pinyin.map,\ + by the\n;; function pinyin-convert.\n\n") + (insert "(defconst pinyin-character-map\n'(") + (let ((pos (point))) + (insert-file-contents src-file) + (goto-char pos) + (re-search-forward "^[a-z]") + (beginning-of-line) + (delete-region pos (point)) + (while (not (eobp)) + (insert "(\"") + (skip-chars-forward "a-z") + (insert "\" . \"") + (delete-char 1) + (end-of-line) + (while (= (preceding-char) ?\r) + (delete-char -1)) + (insert "\")") + (forward-line 1))) + (insert ")\n\"An alist holding correspondences between pinyin syllables\ + and\nChinese characters.\")\n\n") + (insert "(provide 'pinyin)\n")) + (kill-emacs 0))) + ;; Prevent "Local Variables" above confusing Emacs. diff --git a/lisp/international/ucs-normalize.el b/lisp/international/ucs-normalize.el index 9d55470d948..6f1e770c09c 100644 --- a/lisp/international/ucs-normalize.el +++ b/lisp/international/ucs-normalize.el @@ -109,7 +109,9 @@ (defconst ucs-normalize-version "1.2") -(eval-when-compile (require 'cl-lib)) +(eval-when-compile + (require 'cl-lib) + (require 'regexp-opt)) (declare-function nfd "ucs-normalize" (char)) diff --git a/lisp/international/utf7.el b/lisp/international/utf7.el index 0e67a62aa6b..73ee5ad27c3 100644 --- a/lisp/international/utf7.el +++ b/lisp/international/utf7.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. ;; Author: Jon K Hellan <hellan@acm.org> -;; Maintainer: bugs@gnus.org +;; Maintainer: emacs-devel@gnu.org ;; Keywords: mail ;; This file is part of GNU Emacs. diff --git a/lisp/isearch.el b/lisp/isearch.el index 25d6ad591eb..97c75b2978b 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -54,6 +54,7 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) +(declare-function tmm-menubar-keymap "tmm.el") ;; Some additional options and constants. @@ -67,8 +68,18 @@ (defcustom search-exit-option t - "Non-nil means random control characters terminate incremental search." - :type 'boolean) + "Defines what control characters do in incremental search. +If t, random control and meta characters terminate the search +and are then executed normally. +If `edit', edit the search string instead of exiting. +If `append', the characters which you type that are not interpreted by +the incremental search are simply appended to the search string. +If nil, run the command without exiting Isearch." + :type '(choice (const :tag "Terminate incremental search" t) + (const :tag "Edit the search string" edit) + (const :tag "Append control characters to the search string" append) + (const :tag "Don't terminate incremental search" nil)) + :version "27.1") (defcustom search-slow-window-lines 1 "Number of lines in slow search display windows. @@ -118,8 +129,10 @@ regexp incremental search. If the value is nil, or then each space you type matches literally, against one space. You might want to use something like \"[ \\t\\r\\n]+\" instead. -In the Customization buffer, that is `[' followed by a space, -a tab, a carriage return (control-M), a newline, and `]+'." +In the Customization buffer, that is `[' followed by a space, a +tab, a carriage return (control-M), a newline, and `]+'. Don't +add any capturing groups into this value; that can change the +numbering of existing capture groups in unexpected ways." :type '(choice (const :tag "Match Spaces Literally" nil) regexp) :version "24.3") @@ -180,8 +193,11 @@ If nil, use function `isearch-message'.") (defvar isearch-wrap-function nil "Function to call to wrap the search when search is failed. -If nil, move point to the beginning of the buffer for a forward search, -or to the end of the buffer for a backward search.") +The function is called with no parameters, and would typically +move point. + +If nil, move point to the beginning of the buffer for a forward +search, or to the end of the buffer for a backward search.") (defvar isearch-push-state-function nil "Function to save a function restoring the mode-specific Isearch state @@ -287,9 +303,9 @@ are `word-search-regexp' \(`\\[isearch-toggle-word]'), `isearch-symbol-regexp' (defcustom isearch-lazy-highlight t "Controls the lazy-highlighting during incremental search. -When non-nil, all text in the buffer matching the current search -string is highlighted lazily (see `lazy-highlight-initial-delay' -and `lazy-highlight-interval'). +When non-nil, all text currently visible on the screen +matching the current search string is highlighted lazily +(see `lazy-highlight-initial-delay' and `lazy-highlight-interval'). When multiple windows display the current buffer, the highlighting is displayed only on the selected window, unless @@ -299,6 +315,16 @@ this variable is set to the symbol `all-windows'." :group 'lazy-highlight :group 'isearch) +(defcustom isearch-lazy-count nil + "Show match numbers in the search prompt. +When both this option and `isearch-lazy-highlight' are non-nil, +show the current match number and the total number of matches +in the buffer (or its restriction)." + :type 'boolean + :group 'lazy-count + :group 'isearch + :version "27.1") + ;;; Lazy highlight customization. (defgroup lazy-highlight nil @@ -308,10 +334,6 @@ this variable is set to the symbol `all-windows'." :group 'isearch :group 'matching) -(define-obsolete-variable-alias 'isearch-lazy-highlight-cleanup - 'lazy-highlight-cleanup - "22.1") - (defcustom lazy-highlight-cleanup t "Controls whether to remove extra highlighting after a search. If this is nil, extra highlighting can be \"manually\" removed with @@ -319,28 +341,16 @@ If this is nil, extra highlighting can be \"manually\" removed with :type 'boolean :group 'lazy-highlight) -(define-obsolete-variable-alias 'isearch-lazy-highlight-initial-delay - 'lazy-highlight-initial-delay - "22.1") - (defcustom lazy-highlight-initial-delay 0.25 "Seconds to wait before beginning to lazily highlight all matches." :type 'number :group 'lazy-highlight) -(define-obsolete-variable-alias 'isearch-lazy-highlight-interval - 'lazy-highlight-interval - "22.1") - (defcustom lazy-highlight-interval 0 ; 0.0625 "Seconds between lazily highlighting successive matches." :type 'number :group 'lazy-highlight) -(define-obsolete-variable-alias 'isearch-lazy-highlight-max-at-a-time - 'lazy-highlight-max-at-a-time - "22.1") - (defcustom lazy-highlight-max-at-a-time nil ; 20 (bug#25751) "Maximum matches to highlight at a time (for `lazy-highlight'). Larger values may reduce Isearch's responsiveness to user input; @@ -350,6 +360,27 @@ A value of nil means highlight all matches shown on the screen." (integer :tag "Some")) :group 'lazy-highlight) +(defcustom lazy-highlight-buffer-max-at-a-time 20 + "Maximum matches to highlight at a time (for `lazy-highlight-buffer'). +Larger values may reduce Isearch's responsiveness to user input; +smaller values make matches highlight slowly. +A value of nil means highlight all matches in the buffer." + :type '(choice (const :tag "All" nil) + (integer :tag "Some")) + :group 'lazy-highlight + :version "27.1") + +(defcustom lazy-highlight-buffer nil + "Controls the lazy-highlighting of the full buffer. +When non-nil, all text in the buffer matching the current search +string is highlighted lazily (see `lazy-highlight-initial-delay', +`lazy-highlight-interval' and `lazy-highlight-buffer-max-at-a-time'). +This is useful when `lazy-highlight-cleanup' is customized to nil +and doesn't remove full-buffer highlighting after a search." + :type 'boolean + :group 'lazy-highlight + :version "27.1") + (defface lazy-highlight '((((class color) (min-colors 88) (background light)) (:background "paleturquoise")) @@ -364,6 +395,29 @@ A value of nil means highlight all matches shown on the screen." :group 'lazy-highlight :group 'basic-faces) +;;; Lazy count customization. + +(defgroup lazy-count nil + "Lazy counting feature for reporting the number of matches." + :prefix "lazy-count-" + :version "27.1" + :group 'isearch + :group 'matching) + +(defcustom lazy-count-prefix-format "%s/%s " + "Format of the current/total number of matches for the prompt prefix." + :type '(choice (const :tag "No prefix" nil) + (string :tag "Prefix format string" "%s/%s ")) + :group 'lazy-count + :version "27.1") + +(defcustom lazy-count-suffix-format nil + "Format of the current/total number of matches for the prompt suffix." + :type '(choice (const :tag "No suffix" nil) + (string :tag "Suffix format string" " [%s of %s]")) + :group 'lazy-count + :version "27.1") + ;; Define isearch help map. @@ -434,6 +488,170 @@ This is like `describe-bindings', but displays only Isearch keys." ;; Define isearch-mode keymap. +(defun isearch-tmm-menubar () + "Run `tmm-menubar' while `isearch-mode' is enabled." + (interactive) + (require 'tmm) + (run-hooks 'menu-bar-update-hook) + (let ((command nil)) + (let ((menu-bar (tmm-menubar-keymap))) + (with-isearch-suspended + (setq command (let ((isearch-mode t)) ; Show bindings from + ; `isearch-mode-map' in + ; tmm's prompt. + (tmm-prompt menu-bar nil nil t))))) + (call-interactively command))) + +(defvar isearch-menu-bar-commands + '(isearch-tmm-menubar menu-bar-open mouse-minor-mode-menu) + "List of commands that can open a menu during Isearch.") + +(defvar isearch-menu-bar-yank-map + (let ((map (make-sparse-keymap))) + (define-key map [isearch-yank-pop] + '(menu-item "Previous kill" isearch-yank-pop + :help "Replace previous yanked kill on search string")) + (define-key map [isearch-yank-kill] + '(menu-item "Current kill" isearch-yank-kill + :help "Append current kill to search string")) + (define-key map [isearch-yank-line] + '(menu-item "Rest of line" isearch-yank-line + :help "Yank the rest of the current line on search string")) + (define-key map [isearch-yank-symbol-or-char] + '(menu-item "Symbol/char" + isearch-yank-symbol-or-char + :help "Yank next symbol or char on search string")) + (define-key map [isearch-yank-word-or-char] + '(menu-item "Word/char" + isearch-yank-word-or-char + :help "Yank next word or char on search string")) + (define-key map [isearch-yank-char] + '(menu-item "Char" isearch-yank-char + :help "Yank char at point on search string")) + map)) + +(defvar isearch-menu-bar-map + (let ((map (make-sparse-keymap "Isearch"))) + (define-key map [isearch-complete] + '(menu-item "Complete current search string" isearch-complete + :help "Complete current search string over search history")) + (define-key map [isearch-complete-separator] + '(menu-item "--")) + (define-key map [isearch-query-replace-regexp] + '(menu-item "Replace search string as regexp" isearch-query-replace-regexp + :help "Replace matches for current search string as regexp")) + (define-key map [isearch-query-replace] + '(menu-item "Replace search string" isearch-query-replace + :help "Replace matches for current search string")) + (define-key map [isearch-occur] + '(menu-item "Show all matches for search string" isearch-occur + :help "Show all matches for current search string")) + (define-key map [isearch-highlight-regexp] + '(menu-item "Highlight all matches for search string" + isearch-highlight-regexp + :help "Highlight all matches for current search string")) + (define-key map [isearch-search-replace-separator] + '(menu-item "--")) + (define-key map [isearch-toggle-specified-input-method] + '(menu-item "Turn on specific input method" + isearch-toggle-specified-input-method + :help "Turn on specific input method for search")) + (define-key map [isearch-toggle-input-method] + '(menu-item "Toggle input method" isearch-toggle-input-method + :help "Toggle input method for search")) + (define-key map [isearch-input-method-separator] + '(menu-item "--")) + (define-key map [isearch-char-by-name] + '(menu-item "Search for char by name" isearch-char-by-name + :help "Search for character by name")) + (define-key map [isearch-quote-char] + '(menu-item "Search for literal char" isearch-quote-char + :help "Search for literal char")) + (define-key map [isearch-special-char-separator] + '(menu-item "--")) + (define-key map [isearch-toggle-word] + '(menu-item "Word matching" isearch-toggle-word + :help "Word matching" + :button (:toggle + . (eq isearch-regexp-function 'word-search-regexp)))) + (define-key map [isearch-toggle-symbol] + '(menu-item "Symbol matching" isearch-toggle-symbol + :help "Symbol matching" + :button (:toggle + . (eq isearch-regexp-function + 'isearch-symbol-regexp)))) + (define-key map [isearch-toggle-regexp] + '(menu-item "Regexp matching" isearch-toggle-regexp + :help "Regexp matching" + :button (:toggle . isearch-regexp))) + (define-key map [isearch-toggle-invisible] + '(menu-item "Invisible text matching" isearch-toggle-invisible + :help "Invisible text matching" + :button (:toggle . isearch-invisible))) + (define-key map [isearch-toggle-char-fold] + '(menu-item "Character folding matching" isearch-toggle-char-fold + :help "Character folding matching" + :button (:toggle + . (eq isearch-regexp-function + 'char-fold-to-regexp)))) + (define-key map [isearch-toggle-case-fold] + '(menu-item "Case folding matching" isearch-toggle-case-fold + :help "Case folding matching" + :button (:toggle . isearch-case-fold-search))) + (define-key map [isearch-toggle-lax-whitespace] + '(menu-item "Lax whitespace matching" isearch-toggle-lax-whitespace + :help "Lax whitespace matching" + :button (:toggle . isearch-lax-whitespace))) + (define-key map [isearch-toggle-separator] + '(menu-item "--")) + (define-key map [isearch-yank-menu] + `(menu-item "Yank on search string" ,isearch-menu-bar-yank-map)) + (define-key map [isearch-edit-string] + '(menu-item "Edit current search string" isearch-edit-string + :help "Edit current search string")) + (define-key map [isearch-ring-retreat] + '(menu-item "Edit previous search string" isearch-ring-retreat + :help "Edit previous search string in Isearch history")) + (define-key map [isearch-ring-advance] + '(menu-item "Edit next search string" isearch-ring-advance + :help "Edit next search string in Isearch history")) + (define-key map [isearch-del-char] + '(menu-item "Delete last char from search string" isearch-del-char + :help "Delete last character from search string")) + (define-key map [isearch-delete-char] + '(menu-item "Undo last input item" isearch-delete-char + :help "Undo the effect of the last Isearch command")) + (define-key map [isearch-end-of-buffer] + '(menu-item "Go to last match" isearch-end-of-buffer + :help "Go to last occurrence of current search string")) + (define-key map [isearch-beginning-of-buffer] + '(menu-item "Go to first match" isearch-beginning-of-buffer + :help "Go to first occurrence of current search string")) + (define-key map [isearch-repeat-backward] + '(menu-item "Repeat search backward" isearch-repeat-backward + :help "Repeat current search backward")) + (define-key map [isearch-repeat-forward] + '(menu-item "Repeat search forward" isearch-repeat-forward + :help "Repeat current search forward")) + (define-key map [isearch-nonincremental] + '(menu-item "Nonincremental search" isearch-exit + :help "Start nonincremental search" + :visible (string-equal isearch-string ""))) + (define-key map [isearch-exit] + '(menu-item "Finish search" isearch-exit + :help "Finish search leaving point where it is" + :visible (not (string-equal isearch-string "")))) + (define-key map [isearch-abort] + '(menu-item "Remove characters not found" isearch-abort + :help "Quit current search" + :visible (not isearch-success))) + (define-key map [isearch-cancel] + `(menu-item "Cancel search" isearch-cancel + :help "Cancel current search and return to starting point" + :filter ,(lambda (binding) + (if isearch-success 'isearch-abort binding)))) + map)) + (defvar isearch-mode-map (let ((i 0) (map (make-keymap))) @@ -483,11 +701,15 @@ This is like `describe-bindings', but displays only Isearch keys." (define-key map [?\S-\ ] 'isearch-printing-char) (define-key map "\C-w" 'isearch-yank-word-or-char) - (define-key map "\M-\C-w" 'isearch-del-char) + (define-key map "\M-\C-w" 'isearch-yank-symbol-or-char) + (define-key map "\M-\C-d" 'isearch-del-char) (define-key map "\M-\C-y" 'isearch-yank-char) (define-key map "\C-y" 'isearch-yank-kill) (define-key map "\M-s\C-e" 'isearch-yank-line) + (define-key map "\M-s\M-<" 'isearch-beginning-of-buffer) + (define-key map "\M-s\M->" 'isearch-end-of-buffer) + (define-key map (char-to-string help-char) isearch-help-map) (define-key map [help] isearch-help-map) (define-key map [f1] isearch-help-map) @@ -523,6 +745,8 @@ This is like `describe-bindings', but displays only Isearch keys." (define-key map "\M-r" 'isearch-toggle-regexp) (define-key map "\M-e" 'isearch-edit-string) + (put 'isearch-toggle-case-fold :advertised-binding "\M-sc") + (put 'isearch-toggle-regexp :advertised-binding "\M-sr") (put 'isearch-edit-string :advertised-binding "\M-se") (define-key map "\M-se" 'isearch-edit-string) @@ -532,14 +756,65 @@ This is like `describe-bindings', but displays only Isearch keys." (define-key map [?\C-\M-%] 'isearch-query-replace-regexp) (define-key map "\M-so" 'isearch-occur) (define-key map "\M-shr" 'isearch-highlight-regexp) + (define-key map "\M-shl" 'isearch-highlight-lines-matching-regexp) ;; 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 [menu-bar search-menu] + (list 'menu-item "Isearch" isearch-menu-bar-map)) + (define-key map [remap tmm-menubar] 'isearch-tmm-menubar) + map) "Keymap for `isearch-mode'.") +(defvar isearch-tool-bar-old-map nil + "Variable holding the old local value of `tool-bar-map', if any.") + +(defun isearch-tool-bar-image (image-name) + "Return an image specification for IMAGE-NAME." + (eval (tool-bar--image-expression image-name))) + +(defvar isearch-tool-bar-map + (let ((map (make-sparse-keymap))) + (define-key map [isearch-describe-mode] + (list 'menu-item "Help" 'isearch-describe-mode + :help "Get help for Isearch" + :image '(isearch-tool-bar-image "help"))) + (define-key map [isearch-occur] + (list 'menu-item "Show hits" 'isearch-occur + :help "Show each search hit" + :image '(isearch-tool-bar-image "index"))) + (define-key map [isearch-query-replace] + (list 'menu-item "Replace" 'isearch-query-replace + :help "Replace search string" + :image '(isearch-tool-bar-image "search-replace"))) + (define-key map [isearch-delete-char] + (list 'menu-item "Undo" 'isearch-delete-char + :help "Undo last input item" + :image '(isearch-tool-bar-image "undo"))) + (define-key map [isearch-exit] + (list 'menu-item "Finish" 'isearch-exit + :help "Finish search leaving point where it is" + :image '(isearch-tool-bar-image "exit") + :visible '(not (string-equal isearch-string "")))) + (define-key map [isearch-cancel] + (list 'menu-item "Abort" 'isearch-cancel + :help "Abort search" + :image '(isearch-tool-bar-image "close") + :filter (lambda (binding) + (if isearch-success 'isearch-abort binding)))) + (define-key map [isearch-repeat-forward] + (list 'menu-item "Repeat forward" 'isearch-repeat-forward + :help "Repeat search forward" + :image '(isearch-tool-bar-image "right-arrow"))) + (define-key map [isearch-repeat-backward] + (list 'menu-item "Repeat backward" 'isearch-repeat-backward + :help "Repeat search backward" + :image '(isearch-tool-bar-image "left-arrow"))) + map)) + (defvar minibuffer-local-isearch-map (let ((map (make-sparse-keymap))) (set-keymap-parent map minibuffer-local-map) @@ -558,20 +833,28 @@ This is like `describe-bindings', but displays only Isearch keys." (defvar isearch-forward nil) ; Searching in the forward direction. (defvar isearch-regexp nil) ; Searching for a regexp. +;; We still support setting this to t for backwards compatibility. +(define-obsolete-variable-alias 'isearch-word + 'isearch-regexp-function "25.1") (defvar isearch-regexp-function nil "Regexp-based search mode for words/symbols. -If the value is a function (e.g. `isearch-symbol-regexp'), it is -called to convert a plain search string to a regexp used by -regexp search functions. +If non-nil, a function to convert a search string to a regexp +used by regexp search functions. + +The function should accept 1 or 2 arguments: the original string +to convert, and a flag, whose non-nil value means the match +doesn't have to start or end on a word boundary. The function +should return the corresponding regexp, a string. + The symbol property `isearch-message-prefix' put on this function specifies the prefix string displayed in the search message. +Existing functions you could use as values are `word-search-regexp', +`isearch-symbol-regexp', and `char-fold-to-regexp'. + This variable is set and changed during isearch. To change the default behavior used for searches, see `search-default-mode' instead.") -;; We still support setting this to t for backwards compatibility. -(define-obsolete-variable-alias 'isearch-word - 'isearch-regexp-function "25.1") (defvar isearch-lax-whitespace t "If non-nil, a space will match a sequence of whitespace chars. @@ -592,7 +875,7 @@ variable by the command `isearch-toggle-lax-whitespace'.") (defvar isearch-cmds nil "Stack of search status elements. Each element is an `isearch--state' struct where the slots are - [STRING MESSAGE POINT SUCCESS FORWARD OTHER-END WORD + [STRING MESSAGE POINT SUCCESS FORWARD OTHER-END WORD/REGEXP-FUNCTION ERROR WRAPPED BARRIER CASE-FOLD-SEARCH POP-FUN]") (defvar isearch-string "") ; The current search string. @@ -670,11 +953,19 @@ Each element is an `isearch--state' struct where the slots are ;; Minor-mode-alist changes - kind of redundant with the ;; echo area, but if isearching in multiple windows, it can be useful. +;; Also, clicking the mode-line indicator pops up +;; `isearch-menu-bar-map'. (or (assq 'isearch-mode minor-mode-alist) (nconc minor-mode-alist (list '(isearch-mode isearch-mode)))) +;; We add an entry for `isearch-mode' to `minor-mode-map-alist' so +;; that `isearch-menu-bar-map' can show on the menu bar. +(or (assq 'isearch-mode minor-mode-map-alist) + (nconc minor-mode-map-alist + (list (cons 'isearch-mode isearch-mode-map)))) + (defvar-local isearch-mode nil) ;; Name of the minor mode, if non-nil. (define-key global-map "\C-s" 'isearch-forward) @@ -700,6 +991,8 @@ Type \\[isearch-exit] to exit, leaving point at location found. Type LFD (C-j) to match end of line. Type \\[isearch-repeat-forward] to search again forward,\ \\[isearch-repeat-backward] to search again backward. +Type \\[isearch-beginning-of-buffer] to go to the first match,\ + \\[isearch-end-of-buffer] to go to the last match. Type \\[isearch-yank-word-or-char] to yank next word or character in buffer onto the end of the search string, and search for it. Type \\[isearch-del-char] to delete character from end of search string. @@ -750,6 +1043,9 @@ Type \\[isearch-occur] to run `occur' that shows\ the last search string. Type \\[isearch-highlight-regexp] to run `highlight-regexp'\ that highlights the last search string. +Type \\[isearch-highlight-lines-matching-regexp] to run + `highlight-lines-matching-regexp'\ that highlights lines + matching the last search string. Type \\[isearch-describe-bindings] to display all Isearch key bindings. Type \\[isearch-describe-key] to display documentation of Isearch key. @@ -829,21 +1125,26 @@ as a regexp. See the command `isearch-forward-regexp' for more information." (interactive "P\np") (isearch-mode nil (null not-regexp) nil (not no-recursive-edit))) -(defun isearch-forward-symbol-at-point () +(defun isearch-forward-symbol-at-point (&optional arg) "Do incremental search forward for a symbol found near point. Like ordinary incremental search except that the symbol found at point is added to the search string initially as a regexp surrounded by symbol boundary constructs \\_< and \\_>. -See the command `isearch-forward-symbol' for more information." - (interactive) +See the command `isearch-forward-symbol' for more information. +With a prefix argument, search for ARGth symbol forward if ARG is +positive, or search for ARGth symbol backward if ARG is negative." + (interactive "P") (isearch-forward-symbol nil 1) - (let ((bounds (find-tag-default-bounds))) + (let ((bounds (find-tag-default-bounds)) + (count (and arg (prefix-numeric-value arg)))) (cond (bounds (when (< (car bounds) (point)) (goto-char (car bounds))) (isearch-yank-string - (buffer-substring-no-properties (car bounds) (cdr bounds)))) + (buffer-substring-no-properties (car bounds) (cdr bounds))) + (when count + (isearch-repeat-forward count))) (t (setq isearch-error "No symbol at point") (isearch-push-state) @@ -915,11 +1216,18 @@ used to set the value of `isearch-regexp-function'." isearch-input-method-local-p (local-variable-p 'input-method-function) regexp-search-ring-yank-pointer nil + isearch-pre-scroll-point nil + isearch-pre-move-point nil + ;; Save the original value of `minibuffer-message-timeout', and ;; set it to nil so that isearch's messages don't get timed out. isearch-original-minibuffer-message-timeout minibuffer-message-timeout minibuffer-message-timeout nil) + (if (local-variable-p 'tool-bar-map) + (setq isearch-tool-bar-old-map tool-bar-map)) + (setq-local tool-bar-map isearch-tool-bar-map) + ;; We must bypass input method while reading key. When a user type ;; printable character, appropriate input method is turned on in ;; minibuffer to read multibyte characters. @@ -957,7 +1265,7 @@ used to set the value of `isearch-regexp-function'." (add-hook 'pre-command-hook 'isearch-pre-command-hook) (add-hook 'post-command-hook 'isearch-post-command-hook) - (add-hook 'mouse-leave-buffer-hook 'isearch-done) + (add-hook 'mouse-leave-buffer-hook 'isearch-mouse-leave-buffer) (add-hook 'kbd-macro-termination-hook 'isearch-done) ;; isearch-mode can be made modal (in the sense of not returning to @@ -1045,17 +1353,16 @@ For a failing search, NOPUSH is t. For going to the minibuffer to edit the search string, NOPUSH is t and EDIT is t." - (if isearch-resume-in-command-history - (let ((command `(isearch-resume ,isearch-string ,isearch-regexp - ,isearch-regexp-function ,isearch-forward - ,isearch-message - ',isearch-case-fold-search))) - (unless (equal (car command-history) command) - (setq command-history (cons command command-history))))) + (when isearch-resume-in-command-history + (add-to-history 'command-history + `(isearch-resume ,isearch-string ,isearch-regexp + ,isearch-regexp-function ,isearch-forward + ,isearch-message + ',isearch-case-fold-search))) (remove-hook 'pre-command-hook 'isearch-pre-command-hook) (remove-hook 'post-command-hook 'isearch-post-command-hook) - (remove-hook 'mouse-leave-buffer-hook 'isearch-done) + (remove-hook 'mouse-leave-buffer-hook 'isearch-mouse-leave-buffer) (remove-hook 'kbd-macro-termination-hook 'isearch-done) (setq isearch-lazy-highlight-start nil) (when (buffer-live-p isearch--current-buffer) @@ -1070,6 +1377,7 @@ NOPUSH is t and EDIT is t." (setq minibuffer-message-timeout isearch-original-minibuffer-message-timeout) (isearch-dehighlight) (lazy-highlight-cleanup lazy-highlight-cleanup) + (setq isearch-lazy-highlight-last-string nil) (let ((found-start (window-group-start)) (found-point (point))) (when isearch-window-configuration @@ -1087,6 +1395,12 @@ NOPUSH is t and EDIT is t." (setq input-method-function isearch-input-method-function) (kill-local-variable 'input-method-function)) + (if isearch-tool-bar-old-map + (progn + (setq-local tool-bar-map isearch-tool-bar-old-map) + (setq isearch-tool-bar-old-map nil)) + (kill-local-variable 'tool-bar-map)) + (force-mode-line-update) ;; If we ended in the middle of some intangible text, @@ -1119,22 +1433,45 @@ NOPUSH is t and EDIT is t." (and (not edit) isearch-recursive-edit (exit-recursive-edit))) +(defvar isearch-mouse-commands '(mouse-minor-mode-menu) + "List of mouse commands that are allowed during Isearch.") + +(defun isearch-mouse-leave-buffer () + "Exit Isearch unless the mouse command is allowed in Isearch. + +Mouse commands are allowed in Isearch if they have a non-nil +`isearch-scroll' property or if they are listed in +`isearch-mouse-commands'." + (unless (or (memq this-command isearch-mouse-commands) + (eq (get this-command 'isearch-scroll) t)) + (isearch-done))) + (defun isearch-update-ring (string &optional regexp) "Add STRING to the beginning of the search ring. REGEXP if non-nil says use the regexp search ring." - (add-to-history - (if regexp 'regexp-search-ring 'search-ring) - string - (if regexp regexp-search-ring-max search-ring-max))) - -;; Switching buffers should first terminate isearch-mode. -;; ;; For Emacs 19, the frame switch event is handled. -;; (defun isearch-switch-frame-handler () -;; (interactive) ;; Is this necessary? -;; ;; First terminate isearch-mode. -;; (isearch-done) -;; (isearch-clean-overlays) -;; (handle-switch-frame (car (cdr last-command-event)))) + (let ((history-delete-duplicates t)) + (add-to-history + (if regexp 'regexp-search-ring 'search-ring) + (isearch-string-propertize string) + (if regexp regexp-search-ring-max search-ring-max) + t))) + +(defun isearch-string-propertize (string &optional properties) + "Add isearch properties to the isearch string." + (unless properties + (setq properties `(isearch-case-fold-search ,isearch-case-fold-search)) + (unless isearch-regexp + (setq properties (append properties `(isearch-regexp-function ,isearch-regexp-function))))) + (apply 'propertize string properties)) + +(defun isearch-update-from-string-properties (string) + "Update isearch properties from the isearch string" + (when (plist-member (text-properties-at 0 string) 'isearch-case-fold-search) + (setq isearch-case-fold-search + (get-text-property 0 'isearch-case-fold-search string))) + (when (plist-member (text-properties-at 0 string) 'isearch-regexp-function) + (setq isearch-regexp-function + (get-text-property 0 'isearch-regexp-function string)))) ;; The search status structure and stack. @@ -1228,13 +1565,16 @@ If MSG is non-nil, use variable `isearch-message', otherwise `isearch-string'." (length succ-msg) 0)))) +(define-obsolete-variable-alias 'isearch-new-word + 'isearch-new-regexp-function "25.1") + (defvar isearch-new-regexp-function nil "Holds the next `isearch-regexp-function' inside `with-isearch-suspended'. If this is set inside code wrapped by the macro `with-isearch-suspended', then the value set will be used as the `isearch-regexp-function' once isearch resumes.") -(define-obsolete-variable-alias 'isearch-new-word - 'isearch-new-regexp-function "25.1") + +(defvar isearch-suspended nil) (defmacro with-isearch-suspended (&rest body) "Exit Isearch mode, run BODY, and reinvoke the pending search. @@ -1302,6 +1642,8 @@ You can update the global isearch variables by setting new values to isearch-original-minibuffer-message-timeout) old-point old-other-end) + (setq isearch-suspended t) + ;; Actually terminate isearching until editing is done. ;; This is so that the user can do anything without failure, ;; like switch buffers and start another isearch, and return. @@ -1316,6 +1658,8 @@ You can update the global isearch variables by setting new values to (unwind-protect (progn ,@body) + (setq isearch-suspended nil) + ;; Always resume isearching by restarting it. (isearch-mode isearch-forward isearch-regexp @@ -1334,6 +1678,8 @@ You can update the global isearch variables by setting new values to multi-isearch-file-list multi-isearch-file-list-new multi-isearch-buffer-list multi-isearch-buffer-list-new) + (isearch-update-from-string-properties isearch-string) + ;; Restore the minibuffer message before moving point. (funcall (or isearch-message-function #'isearch-message) nil t) @@ -1365,7 +1711,11 @@ You can update the global isearch variables by setting new values to ;; Reinvoke the pending search. (isearch-search) - (isearch-push-state) ; this pushes the correct state + ;; If no code has changed the search parameters, then pushing + ;; a new state of Isearch should not be necessary. + (unless (and isearch-cmds + (equal (car isearch-cmds) (isearch--get-state))) + (isearch-push-state)) ; this pushes the correct state (isearch-update) (if isearch-nonincremental (progn @@ -1377,6 +1727,7 @@ You can update the global isearch variables by setting new values to (message ""))))) (quit ; handle abort-recursive-edit + (setq isearch-suspended nil) (isearch-abort) ;; outside of let to restore outside global values ))) @@ -1399,7 +1750,9 @@ The following additional command keys are active while editing. (history-add-new-input nil) ;; Binding minibuffer-history-symbol to nil is a work-around ;; for some incompatibility with gmhist. - (minibuffer-history-symbol)) + (minibuffer-history-symbol) + ;; 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) @@ -1468,8 +1821,8 @@ Use `isearch-exit' to quit without signaling." (isearch-pop-state)) (isearch-update))) -(defun isearch-repeat (direction) - ;; Utility for isearch-repeat-forward and -backward. +(defun isearch-repeat (direction &optional count) + ;; Utility for isearch-repeat-forward and isearch-repeat-backward. (if (eq isearch-forward (eq direction 'forward)) ;; C-s in forward or C-r in reverse. (if (equal isearch-string "") @@ -1500,32 +1853,105 @@ Use `isearch-exit' to quit without signaling." (if (equal isearch-string "") (setq isearch-success t) - (if (and isearch-success - (equal (point) isearch-other-end) - (not isearch-just-started)) - ;; If repeating a search that found - ;; an empty string, ensure we advance. - (if (if isearch-forward (eobp) (bobp)) - ;; If there's nowhere to advance to, fail (and wrap next time). - (progn - (setq isearch-success nil) - (ding)) - (forward-char (if isearch-forward 1 -1)) + ;; For the case when count > 1, don't keep intermediate states + ;; added to isearch-cmds by isearch-push-state in this loop. + (let ((isearch-cmds isearch-cmds)) + (while (<= 0 (setq count (1- (or count 1)))) + (if (and isearch-success + (equal (point) isearch-other-end) + (not isearch-just-started)) + ;; If repeating a search that found + ;; an empty string, ensure we advance. + (if (if isearch-forward (eobp) (bobp)) + ;; If there's nowhere to advance to, fail (and wrap next time). + (progn + (setq isearch-success nil) + (ding)) + (forward-char (if isearch-forward 1 -1)) + (isearch-search)) (isearch-search)) - (isearch-search))) + (when (> count 0) + ;; Update isearch-cmds, so if isearch-search fails later, + ;; it can restore old successful state from isearch-cmds. + (isearch-push-state)) + ;; Stop looping on failure. + (when (or (not isearch-success) isearch-error) + (setq count 0))))) (isearch-push-state) (isearch-update)) -(defun isearch-repeat-forward () - "Repeat incremental search forwards." - (interactive) - (isearch-repeat 'forward)) - -(defun isearch-repeat-backward () - "Repeat incremental search backwards." - (interactive) - (isearch-repeat 'backward)) +(defun isearch-repeat-forward (&optional arg) + "Repeat incremental search forwards. +With a numeric argument, repeat the search ARG times. +A negative argument searches backwards. +\\<isearch-mode-map> +This command finds the next relative occurrence of the current +search string. To find the absolute occurrence from the beginning +of the buffer, type \\[isearch-beginning-of-buffer] with a numeric argument." + (interactive "P") + (if arg + (let ((count (prefix-numeric-value arg))) + (cond ((< count 0) + (isearch-repeat-backward (abs count)) + ;; Reverse the direction back + (isearch-repeat 'forward)) + (t + ;; Take into account one iteration to reverse direction + (when (not isearch-forward) (setq count (1+ count))) + (isearch-repeat 'forward count)))) + (isearch-repeat 'forward))) + +(defun isearch-repeat-backward (&optional arg) + "Repeat incremental search backwards. +With a numeric argument, repeat the search ARG times. +A negative argument searches forwards. +\\<isearch-mode-map> +This command finds the next relative occurrence of the current +search string. To find the absolute occurrence from the end +of the buffer, type \\[isearch-end-of-buffer] with a numeric argument." + (interactive "P") + (if arg + (let ((count (prefix-numeric-value arg))) + (cond ((< count 0) + (isearch-repeat-forward (abs count)) + ;; Reverse the direction back + (isearch-repeat 'backward)) + (t + ;; Take into account one iteration to reverse direction + (when isearch-forward (setq count (1+ count))) + (isearch-repeat 'backward count)))) + (isearch-repeat 'backward))) + +(defun isearch-beginning-of-buffer (&optional arg) + "Go to the first occurrence of the current search string. +Move point to the beginning of the buffer and search forwards from the top. +\\<isearch-mode-map> +With a numeric argument, go to the ARGth absolute occurrence counting from +the beginning of the buffer. To find the next relative occurrence forwards, +type \\[isearch-repeat-forward] with a numeric argument." + (interactive "p") + (if (and arg (< arg 0)) + (isearch-end-of-buffer (abs arg)) + ;; For the case when the match is at bobp, + ;; don't forward char in isearch-repeat + (setq isearch-just-started t) + (goto-char (point-min)) + (isearch-repeat 'forward arg))) + +(defun isearch-end-of-buffer (&optional arg) + "Go to the last occurrence of the current search string. +Move point to the end of the buffer and search backwards from the bottom. +\\<isearch-mode-map> +With a numeric argument, go to the ARGth absolute occurrence counting from +the end of the buffer. To find the next relative occurrence backwards, +type \\[isearch-repeat-backward] with a numeric argument." + (interactive "p") + (if (and arg (< arg 0)) + (isearch-beginning-of-buffer (abs arg)) + (setq isearch-just-started t) + (goto-char (point-max)) + (isearch-repeat 'backward arg))) ;;; Toggles for `isearch-regexp-function' and `search-default-mode'. @@ -1568,19 +1994,22 @@ Turning on word search turns off regexp mode.") Turning on symbol search turns off regexp mode.") (isearch-define-mode-toggle char-fold "'" char-fold-to-regexp "\ Turning on character-folding turns off regexp mode.") -(put 'char-fold-to-regexp 'isearch-message-prefix "char-fold ") (isearch-define-mode-toggle regexp "r" nil nil (setq isearch-regexp (not isearch-regexp)) (if isearch-regexp (setq isearch-regexp-function nil))) +(defvar isearch-message-properties minibuffer-prompt-properties + "Text properties that are added to the isearch prompt.") + (defun isearch--momentary-message (string) "Print STRING at the end of the isearch prompt for 1 second" (let ((message-log-max nil)) - (message "%s%s [%s]" + (message "%s%s%s" (isearch-message-prefix nil isearch-nonincremental) isearch-message - string)) + (apply #'propertize (format " [%s]" string) + isearch-message-properties))) (sit-for 1)) (isearch-define-mode-toggle lax-whitespace " " nil @@ -1767,8 +2196,6 @@ the beginning or the end of the string need not match a symbol boundary." (if (string-match-p (format "%s\\'" not-word-symbol-re) string) not-word-symbol-re (unless lax "\\_>"))))))) -(put 'isearch-symbol-regexp 'isearch-message-prefix "symbol ") - ;; Search with lax whitespace (defun search-forward-lax-whitespace (string &optional bound noerror count) @@ -1827,7 +2254,9 @@ replacements from Isearch is `M-s w ... M-%'." ;; `exit-recursive-edit' in `isearch-done' that terminates ;; the execution of this command when it is non-nil. ;; We call `exit-recursive-edit' explicitly at the end below. - (isearch-recursive-edit nil)) + (isearch-recursive-edit nil) + (isearch-string-propertized + (isearch-string-propertize isearch-string))) (isearch-done nil t) (isearch-clean-overlays) (if (and isearch-other-end @@ -1840,20 +2269,20 @@ replacements from Isearch is `M-s w ... M-%'." (< (mark) (point)))))) (goto-char isearch-other-end)) (set query-replace-from-history-variable - (cons isearch-string + (cons isearch-string-propertized (symbol-value query-replace-from-history-variable))) (perform-replace - isearch-string + isearch-string-propertized (query-replace-read-to - isearch-string + isearch-string-propertized (concat "Query replace" (isearch--describe-regexp-mode (or delimited isearch-regexp-function) t) (if backward " backward" "") - (if (and transient-mark-mode mark-active) " in region" "")) + (if (use-region-p) " in region" "")) isearch-regexp) t isearch-regexp (or delimited isearch-regexp-function) nil nil - (if (and transient-mark-mode mark-active) (region-beginning)) - (if (and transient-mark-mode mark-active) (region-end)) + (if (use-region-p) (region-beginning)) + (if (use-region-p) (region-end)) backward)) (and isearch-recursive-edit (exit-recursive-edit))) @@ -1916,16 +2345,17 @@ characters in that string." 'isearch-regexp-function-descr (isearch--describe-regexp-mode isearch-regexp-function)) regexp) - nlines))) + nlines + (if (use-region-p) (region-bounds))))) (declare-function hi-lock-read-face-name "hi-lock" ()) -(defun isearch-highlight-regexp () - "Run `highlight-regexp' with regexp from the current search string. -It exits Isearch mode and calls `hi-lock-face-buffer' with its regexp -argument from the last search regexp or a quoted search string, -and reads its face argument using `hi-lock-read-face-name'." - (interactive) +(defun isearch--highlight-regexp-or-lines (hi-lock-func) + "Run HI-LOCK-FUNC to exit isearch, leaving the matches highlighted. +This is the internal function used by `isearch-highlight-regexp' +and `isearch-highlight-lines-matching-regexp' to invoke +HI-LOCK-FUNC (either `highlight-regexp' or `highlight-lines-matching-regexp', +respectively)." (let ( ;; Set `isearch-recursive-edit' to nil to prevent calling ;; `exit-recursive-edit' in `isearch-done' that terminates @@ -1954,9 +2384,23 @@ and reads its face argument using `hi-lock-read-face-name'." (regexp-quote s)))) isearch-string "")) (t (regexp-quote isearch-string))))) - (hi-lock-face-buffer regexp (hi-lock-read-face-name))) + (funcall hi-lock-func regexp (hi-lock-read-face-name))) (and isearch-recursive-edit (exit-recursive-edit))) +(defun isearch-highlight-regexp () + "Exit Isearch mode and call `highlight-regexp'. +The arguments passed to `highlight-regexp' are the regexp from +the last search and the face from `hi-lock-read-face-name'." + (interactive) + (isearch--highlight-regexp-or-lines 'highlight-regexp)) + +(defun isearch-highlight-lines-matching-regexp () + "Exit Isearch mode and call `highlight-lines-matching-regexp'. +The arguments passed to `highlight-lines-matching-regexp' are the +regexp from the last search and the face from `hi-lock-read-face-name'." + (interactive) + (isearch--highlight-regexp-or-lines 'highlight-lines-matching-regexp)) + (defun isearch-delete-char () "Undo last input item during a search. @@ -2014,6 +2458,7 @@ If search string is empty, just beep." (defun isearch-yank-kill () "Pull string from kill ring into search string." (interactive) + (unless isearch-mode (isearch-mode t)) (isearch-yank-string (current-kill 0))) (defun isearch-yank-pop () @@ -2087,22 +2532,26 @@ If optional ARG is non-nil, pull in the next ARG characters." (interactive "p") (isearch-yank-internal (lambda () (forward-char arg) (point)))) -(declare-function subword-forward "subword" (&optional arg)) -(defun isearch-yank-word-or-char () - "Pull next character, subword or word from buffer into search string. -Subword is used when `subword-mode' is activated. " - (interactive) +(defun isearch--yank-char-or-syntax (syntax-list fn) (isearch-yank-internal (lambda () - (if (or (= (char-syntax (or (char-after) 0)) ?w) - (= (char-syntax (or (char-after (1+ (point))) 0)) ?w)) - (if (or (and (boundp 'subword-mode) subword-mode) - (and (boundp 'superword-mode) superword-mode)) - (subword-forward 1) - (forward-word 1)) + (if (or (memq (char-syntax (or (char-after) 0)) syntax-list) + (memq (char-syntax (or (char-after (1+ (point))) 0)) + syntax-list)) + (funcall fn 1) (forward-char 1)) (point)))) +(defun isearch-yank-word-or-char () + "Pull next character or word from buffer into search string." + (interactive) + (isearch--yank-char-or-syntax '(?w) 'forward-word)) + +(defun isearch-yank-symbol-or-char () + "Pull next character or symbol from buffer into search string." + (interactive) + (isearch--yank-char-or-syntax '(?w ?_) 'forward-symbol)) + (defun isearch-yank-word (&optional arg) "Pull next word from buffer into search string. If optional ARG is non-nil, pull in the next ARG words." @@ -2306,6 +2755,12 @@ to the barrier." (put 'split-window-right 'isearch-scroll t) (put 'split-window-below 'isearch-scroll t) (put 'enlarge-window 'isearch-scroll t) +(put 'enlarge-window-horizontally 'isearch-scroll t) +(put 'shrink-window-horizontally 'isearch-scroll t) +(put 'shrink-window 'isearch-scroll t) +;; The next two commands don't exit Isearch in isearch-mouse-leave-buffer +(put 'mouse-drag-mode-line 'isearch-scroll t) +(put 'mouse-drag-vertical-line 'isearch-scroll t) ;; Aliases for split-window-* (put 'split-window-vertically 'isearch-scroll t) @@ -2320,9 +2775,13 @@ to the barrier." (defcustom isearch-allow-scroll nil "Whether scrolling is allowed during incremental search. If non-nil, scrolling commands can be used in Isearch mode. -However, the current match will never scroll offscreen. -If nil, scrolling commands will first cancel Isearch mode." - :type 'boolean +However, you cannot scroll far enough that the current match is +no longer visible (is off screen). But if the value is `unlimited' +that limitation is removed and you can scroll any distance off screen. +If nil, scrolling commands exit Isearch mode." + :type '(choice (const :tag "Scrolling exits Isearch" nil) + (const :tag "Scrolling with current match on screen" t) + (const :tag "Scrolling with current match off screen" unlimited)) :group 'isearch) (defcustom isearch-allow-prefix t @@ -2384,6 +2843,22 @@ the bottom." (goto-char isearch-point)) (defvar isearch-pre-scroll-point nil) +(defvar isearch-pre-move-point nil) + +(defcustom isearch-yank-on-move nil + "Motion keys yank text to the search string while you move the cursor. +If `shift', extend the search string by motion commands while holding down +the shift key. The search string is extended by yanking text that +ends at the new position after moving point in the current buffer. +If t, extend the search string without the shift key pressed. +To enable motion commands, put the `isearch-move' property on their +symbols to `enabled', or to disable an automatically detected +shift-translated command, use the property value `disabled'." + :type '(choice (const :tag "Motion keys exit Isearch" nil) + (const :tag "Motion keys extend the search string" t) + (const :tag "Shifted motion keys extend the search string" shift)) + :group 'isearch + :version "27.1") (defun isearch-pre-command-hook () "Decide whether to exit Isearch mode before executing the command. @@ -2391,8 +2866,9 @@ Don't exit Isearch if the key sequence that invoked this command is bound in `isearch-mode-map', or if the invoked command is a prefix argument command (when `isearch-allow-prefix' is non-nil), or it is a scrolling command (when `isearch-allow-scroll' is non-nil). -Otherwise, exit Isearch (when `search-exit-option' is non-nil) -before the command is executed globally with terminated Isearch." +Otherwise, exit Isearch (when `search-exit-option' is t) +before the command is executed globally with terminated Isearch. +See more for options in `search-exit-option'." (let* ((key (this-single-command-keys)) (main-event (aref key 0))) (cond @@ -2400,7 +2876,12 @@ before the command is executed globally with terminated Isearch." ;; `set-transient-map' thingy like `universal-argument--mode'. ((not (eq overriding-terminal-local-map isearch--saved-overriding-local-map))) ;; Don't exit Isearch for isearch key bindings. - ((commandp (lookup-key isearch-mode-map key nil))) + ((or (commandp (lookup-key isearch-mode-map key nil)) + (commandp + (lookup-key + `(keymap (tool-bar menu-item nil ,isearch-tool-bar-map)) key)))) + ;; Allow key bindings that open a menubar. + ((memq this-command isearch-menu-bar-commands)) ;; Optionally edit the search string instead of exiting. ((eq search-exit-option 'edit) (setq this-command 'isearch-edit-string)) @@ -2413,29 +2894,63 @@ before the command is executed globally with terminated Isearch." (or (eq (get this-command 'isearch-scroll) t) (eq (get this-command 'scroll-command) t)))) (when isearch-allow-scroll - (setq isearch-pre-scroll-point (point)))) + (unless (eq isearch-allow-scroll 'unlimited) + (setq isearch-pre-scroll-point (point))))) ;; A mouse click on the isearch message starts editing the search string. ((and (eq (car-safe main-event) 'down-mouse-1) (window-minibuffer-p (posn-window (event-start main-event)))) ;; Swallow the up-event. (read-event) (setq this-command 'isearch-edit-string)) + ;; Don't terminate the search for motion commands. + ((and isearch-yank-on-move + (symbolp this-command) + (not (eq (get this-command 'isearch-move) 'disabled)) + (or (eq (get this-command 'isearch-move) 'enabled) + (and (eq isearch-yank-on-move t) + (stringp (nth 1 (interactive-form this-command))) + (string-match-p "^\\^" + (nth 1 (interactive-form this-command)))) + (and (eq isearch-yank-on-move 'shift) + this-command-keys-shift-translated))) + (setq this-command-keys-shift-translated nil) + (setq isearch-pre-move-point (point))) + ;; Append control characters to the search string + ((eq search-exit-option 'append) + (unless (memq nil (mapcar (lambda (k) (characterp k)) key)) + (isearch-process-search-string key key)) + (setq this-command 'ignore)) ;; Other characters terminate the search and are then executed normally. (search-exit-option (isearch-done) - (isearch-clean-overlays)) - ;; If search-exit-option is nil, run the command without exiting Isearch. - (t - (isearch-process-search-string key key))))) + (isearch-clean-overlays))))) (defun isearch-post-command-hook () - (when isearch-pre-scroll-point - (let ((ab-bel (isearch-string-out-of-window isearch-pre-scroll-point))) - (if ab-bel - (isearch-back-into-window (eq ab-bel 'above) isearch-pre-scroll-point) - (goto-char isearch-pre-scroll-point))) - (setq isearch-pre-scroll-point nil) - (isearch-update))) + (when isearch-pre-scroll-point + (let ((ab-bel (isearch-string-out-of-window isearch-pre-scroll-point))) + (if ab-bel + (isearch-back-into-window (eq ab-bel 'above) isearch-pre-scroll-point) + (goto-char isearch-pre-scroll-point))) + (setq isearch-pre-scroll-point nil) + (isearch-update)) + (when (eq isearch-allow-scroll 'unlimited) + (when isearch-lazy-highlight + (isearch-lazy-highlight-new-loop))) + (when isearch-pre-move-point + (when (not (eq isearch-pre-move-point (point))) + (let ((string (buffer-substring-no-properties + (or isearch-other-end isearch-opoint) (point)))) + (if isearch-regexp (setq string (regexp-quote string))) + (setq isearch-string string) + (setq isearch-message (mapconcat 'isearch-text-char-description + string "")) + (setq isearch-yank-flag t) + (setq isearch-forward (<= (or isearch-other-end isearch-opoint) (point))) + (when isearch-forward + (goto-char isearch-pre-move-point)) + (isearch-search-and-update))) + (setq isearch-pre-move-point nil)) + (force-mode-line-update)) (defun isearch-quote-char (&optional count) "Quote special characters for incremental search. @@ -2520,7 +3035,8 @@ Search is updated accordingly." length))) (setq isearch-string (nth yank-pointer ring) isearch-message (mapconcat 'isearch-text-char-description - isearch-string ""))))) + isearch-string "")) + (isearch-update-from-string-properties isearch-string)))) (defun isearch-ring-adjust (advance) ;; Helper for isearch-ring-advance and isearch-ring-retreat @@ -2634,12 +3150,16 @@ the word mode." (cond ;; 1. Do not use a description on the default search mode, ;; but only if the default search mode is non-nil. - ((or (and search-default-mode - (equal search-default-mode regexp-function)) - ;; Special case where `search-default-mode' is t - ;; (defaults to regexp searches). - (and (eq search-default-mode t) - (eq search-default-mode isearch-regexp))) "") + ((and (or (and search-default-mode + (equal search-default-mode regexp-function)) + ;; Special case where `search-default-mode' is t + ;; (defaults to regexp searches). + (and (eq search-default-mode t) + (eq search-default-mode isearch-regexp))) + ;; Also do not omit description in case of error + ;; in default non-literal search. + (or isearch-success (not (or regexp-function isearch-regexp)))) + "") ;; 2. Use the `isearch-message-prefix' set for ;; `regexp-function' if available. (regexp-function @@ -2682,6 +3202,8 @@ the word mode." (< (point) isearch-opoint))) "over") (if isearch-wrapped "wrapped ") + (if (and (not isearch-success) (not isearch-case-fold-search)) + "case-sensitive ") (let ((prefix "")) (advice-function-mapc (lambda (_ props) @@ -2705,15 +3227,41 @@ the word mode." (concat " [" current-input-method-title "]: ")) ": ") ))) - (propertize (concat (upcase (substring m 0 1)) (substring m 1)) - 'face 'minibuffer-prompt))) + (apply #'propertize (concat (isearch-lazy-count-format) + (upcase (substring m 0 1)) (substring m 1)) + isearch-message-properties))) (defun isearch-message-suffix (&optional c-q-hack) - (concat (if c-q-hack "^Q" "") - (if isearch-error - (concat " [" isearch-error "]") - "") - (or isearch-message-suffix-add ""))) + (apply #'propertize (concat (if c-q-hack "^Q" "") + (isearch-lazy-count-format 'suffix) + (if isearch-error + (concat " [" isearch-error "]") + "") + (or isearch-message-suffix-add "")) + isearch-message-properties)) + +(defun isearch-lazy-count-format (&optional suffix-p) + "Format the current match number and the total number of matches. +When SUFFIX-P is non-nil, the returned string is indended for +isearch-message-suffix prompt. Otherwise, for isearch-message-prefix." + (let ((format-string (if suffix-p + lazy-count-suffix-format + lazy-count-prefix-format))) + (if (and format-string + isearch-lazy-count + isearch-lazy-count-current + (not isearch-error) + (not isearch-suspended)) + (format format-string + (if isearch-forward + isearch-lazy-count-current + (if (eq isearch-lazy-count-current 0) + 0 + (- isearch-lazy-count-total + isearch-lazy-count-current + -1))) + (or isearch-lazy-count-total "?")) + ""))) ;; Searching @@ -2736,41 +3284,37 @@ Can be changed via `isearch-search-fun-function' for special needs." (defun isearch--lax-regexp-function-p () "Non-nil if next regexp-function call should be lax." - (not (or isearch-nonincremental - (null (car isearch-cmds)) - (eq (length isearch-string) - (length (isearch--state-string - (car isearch-cmds))))))) + (or (memq this-command '(isearch-printing-char isearch-del-char)) + isearch-yank-flag)) (defun isearch-search-fun-default () "Return default functions to use for the search." (lambda (string &optional bound noerror count) - ;; Use lax versions to not fail at the end of the word while - ;; the user adds and removes characters in the search string - ;; (or when using nonincremental word isearch) - (let ((search-spaces-regexp (when (cond - (isearch-regexp isearch-regexp-lax-whitespace) - (t isearch-lax-whitespace)) - search-whitespace-regexp))) - (condition-case er - (funcall - (if isearch-forward #'re-search-forward #'re-search-backward) + (let (;; Evaluate this before binding `search-spaces-regexp' which + ;; can break all sorts of regexp searches. In particular, + ;; calling `isearch-regexp-function' can trigger autoloading + ;; (Bug#35802). + (regexp (cond (isearch-regexp-function - (let ((lax (and (not bound) (isearch--lax-regexp-function-p)))) + (let ((lax (and (not bound) + (isearch--lax-regexp-function-p)))) (when lax (setq isearch-adjusted t)) (if (functionp isearch-regexp-function) (funcall isearch-regexp-function string lax) (word-search-regexp string lax)))) (isearch-regexp string) - (t (regexp-quote string))) - bound noerror count) - (search-failed - (signal (car er) - (let ((prefix (get isearch-regexp-function 'isearch-message-prefix))) - (if (and isearch-regexp-function (stringp prefix)) - (list (format "%s [using %ssearch]" string prefix)) - (cdr er))))))))) + (t (regexp-quote string)))) + ;; Use lax versions to not fail at the end of the word while + ;; the user adds and removes characters in the search string + ;; (or when using nonincremental word isearch) + (search-spaces-regexp (when (if isearch-regexp + isearch-regexp-lax-whitespace + isearch-lax-whitespace) + search-whitespace-regexp))) + (funcall + (if isearch-forward #'re-search-forward #'re-search-backward) + regexp bound noerror count)))) (defun isearch-search-string (string bound noerror) "Search for the first occurrence of STRING or its translation. @@ -2857,7 +3401,7 @@ Optional third argument, if t, means if fail just return nil (no error). (setq isearch-error (car (cdr lossage))) (cond ((string-match - "\\`Premature \\|\\`Unmatched \\|\\`Invalid " + "\\`Premature \\|\\`Unmatched " isearch-error) (setq isearch-error "incomplete input")) ((and (not isearch-regexp) @@ -2896,8 +3440,6 @@ Optional third argument, if t, means if fail just return nil (no error). (funcall (overlay-get ov 'isearch-open-invisible-temporary) ov nil) ;; Store the values for the `invisible' property, and then set it to nil. ;; This way the text hidden by this overlay becomes visible. - - ;; In 19.34 this does not exist so I cannot test it. (overlay-put ov 'isearch-invisible (overlay-get ov 'invisible)) (overlay-put ov 'invisible nil))) @@ -3127,15 +3669,23 @@ since they have special meaning in a regexp." (defvar isearch-lazy-highlight-window-group nil) (defvar isearch-lazy-highlight-window-start nil) (defvar isearch-lazy-highlight-window-end nil) +(defvar isearch-lazy-highlight-window-start-changed nil) +(defvar isearch-lazy-highlight-window-end-changed nil) +(defvar isearch-lazy-highlight-point-min nil) +(defvar isearch-lazy-highlight-point-max nil) +(defvar isearch-lazy-highlight-buffer nil) (defvar isearch-lazy-highlight-case-fold-search nil) (defvar isearch-lazy-highlight-regexp nil) (defvar isearch-lazy-highlight-lax-whitespace nil) (defvar isearch-lazy-highlight-regexp-lax-whitespace nil) -(defvar isearch-lazy-highlight-regexp-function nil) (define-obsolete-variable-alias 'isearch-lazy-highlight-word 'isearch-lazy-highlight-regexp-function "25.1") +(defvar isearch-lazy-highlight-regexp-function nil) (defvar isearch-lazy-highlight-forward nil) (defvar isearch-lazy-highlight-error nil) +(defvar isearch-lazy-count-current nil) +(defvar isearch-lazy-count-total nil) +(defvar isearch-lazy-count-hash (make-hash-table)) (defun lazy-highlight-cleanup (&optional force procrastinate) "Stop lazy highlighting and remove extra highlighting from current buffer. @@ -3153,10 +3703,6 @@ This function is called when exiting an incremental search if (cancel-timer isearch-lazy-highlight-timer) (setq isearch-lazy-highlight-timer nil))) -(define-obsolete-function-alias 'isearch-lazy-highlight-cleanup - 'lazy-highlight-cleanup - "22.1") - (defun isearch-lazy-highlight-new-loop (&optional beg end) "Cleanup any previous `lazy-highlight' loop and begin a new one. BEG and END specify the bounds within which highlighting should occur. @@ -3179,17 +3725,46 @@ by other Emacs features." isearch-lax-whitespace)) (not (eq isearch-lazy-highlight-regexp-lax-whitespace isearch-regexp-lax-whitespace)) - (not (= (window-group-start) - isearch-lazy-highlight-window-start)) - (not (= (window-group-end) ; Window may have been split/joined. - isearch-lazy-highlight-window-end)) (not (eq isearch-forward isearch-lazy-highlight-forward)) ;; In case we are recovering from an error. (not (equal isearch-error - isearch-lazy-highlight-error)))) + isearch-lazy-highlight-error)) + (if lazy-highlight-buffer + (not (= (point-min) + isearch-lazy-highlight-point-min)) + (setq isearch-lazy-highlight-window-start-changed + (not (= (window-group-start) + isearch-lazy-highlight-window-start)))) + (if lazy-highlight-buffer + (not (= (point-max) + isearch-lazy-highlight-point-max)) + (setq isearch-lazy-highlight-window-end-changed + (not (= (window-group-end) ; Window may have been split/joined. + isearch-lazy-highlight-window-end)))))) ;; something important did indeed change (lazy-highlight-cleanup t (not (equal isearch-string ""))) ;stop old timer + (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 + ;; reset the counter) + (and (not isearch-lazy-highlight-window-start-changed) + (not isearch-lazy-highlight-window-end-changed)) + ;; Also check for changes in buffer boundaries in + ;; a possibly narrowed buffer in case lazy-highlight-buffer + ;; is nil, thus the same check was not performed above + (not (= (point-min) + isearch-lazy-highlight-point-min)) + (not (= (point-max) + isearch-lazy-highlight-point-max))) + ;; Reset old counter before going to count new numbers + (clrhash isearch-lazy-count-hash) + (setq isearch-lazy-count-current nil + isearch-lazy-count-total nil) + (funcall (or isearch-message-function #'isearch-message)))) + (setq isearch-lazy-highlight-window-start-changed nil) + (setq isearch-lazy-highlight-window-end-changed nil) (setq isearch-lazy-highlight-error isearch-error) ;; It used to check for `(not isearch-error)' here, but actually ;; lazy-highlighting might find matches to highlight even when @@ -3200,6 +3775,9 @@ by other Emacs features." isearch-lazy-highlight-window-group (selected-window-group) isearch-lazy-highlight-window-start (window-group-start) isearch-lazy-highlight-window-end (window-group-end) + isearch-lazy-highlight-point-min (point-min) + isearch-lazy-highlight-point-max (point-max) + isearch-lazy-highlight-buffer lazy-highlight-buffer ;; Start lazy-highlighting at the beginning of the found ;; match (`isearch-other-end'). If no match, use point. ;; One of the next two variables (depending on search direction) @@ -3217,12 +3795,31 @@ by other Emacs features." isearch-lazy-highlight-regexp-lax-whitespace isearch-regexp-lax-whitespace isearch-lazy-highlight-regexp-function isearch-regexp-function isearch-lazy-highlight-forward isearch-forward) + ;; Extend start/end to match whole string at point (bug#19353) + (if isearch-lazy-highlight-forward + (setq isearch-lazy-highlight-start + (min (+ isearch-lazy-highlight-start + (1- (length isearch-lazy-highlight-last-string))) + (point-max))) + (setq isearch-lazy-highlight-end + (max (- isearch-lazy-highlight-end + (1- (length isearch-lazy-highlight-last-string))) + (point-min)))) (unless (equal isearch-string "") (setq isearch-lazy-highlight-timer (run-with-idle-timer lazy-highlight-initial-delay nil - 'isearch-lazy-highlight-start))))) - -(defun isearch-lazy-highlight-search () + '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)) + ;; 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)))) + +(defun isearch-lazy-highlight-search (string bound) "Search ahead for the next or previous match, for lazy highlighting. Attempt to do the search exactly the way the pending Isearch would." (condition-case nil @@ -3236,24 +3833,10 @@ Attempt to do the search exactly the way the pending Isearch would." (isearch-forward isearch-lazy-highlight-forward) (search-invisible nil) ; don't match invisible text (retry t) - (success nil) - (bound (if isearch-lazy-highlight-forward - (min (or isearch-lazy-highlight-end-limit (point-max)) - (if isearch-lazy-highlight-wrapped - (+ isearch-lazy-highlight-start - ;; Extend bound to match whole string at point - (1- (length isearch-lazy-highlight-last-string))) - (window-group-end))) - (max (or isearch-lazy-highlight-start-limit (point-min)) - (if isearch-lazy-highlight-wrapped - (- isearch-lazy-highlight-end - ;; Extend bound to match whole string at point - (1- (length isearch-lazy-highlight-last-string))) - (window-group-start)))))) + (success nil)) ;; Use a loop like in `isearch-search'. (while retry - (setq success (isearch-search-string - isearch-lazy-highlight-last-string bound t)) + (setq success (isearch-search-string string bound t)) ;; Clear RETRY unless the search predicate says ;; to skip this search hit. (if (or (not success) @@ -3265,6 +3848,17 @@ Attempt to do the search exactly the way the pending Isearch would." success) (error nil))) +(defun isearch-lazy-highlight-match (mb me) + (let ((ov (make-overlay mb me))) + (push ov isearch-lazy-highlight-overlays) + ;; 1000 is higher than ediff's 100+, + ;; but lower than isearch main overlay's 1001 + (overlay-put ov 'priority 1000) + (overlay-put ov 'face 'lazy-highlight) + (unless (or (eq isearch-lazy-highlight 'all-windows) + isearch-lazy-highlight-buffer) + (overlay-put ov 'window (selected-window))))) + (defun isearch-lazy-highlight-start () "Start a new lazy-highlight updating loop." (lazy-highlight-cleanup t) ;remove old overlays @@ -3274,19 +3868,32 @@ Attempt to do the search exactly the way the pending Isearch would." "Update highlighting of other matches for current search." (let ((max lazy-highlight-max-at-a-time) (looping t) - nomore) + nomore window-start window-end) (with-local-quit (save-selected-window (if (and (window-live-p isearch-lazy-highlight-window) (not (memq (selected-window) isearch-lazy-highlight-window-group))) (select-window isearch-lazy-highlight-window)) + (setq window-start (window-group-start)) + (setq window-end (window-group-end)) (save-excursion (save-match-data (goto-char (if isearch-lazy-highlight-forward isearch-lazy-highlight-end isearch-lazy-highlight-start)) (while looping - (let ((found (isearch-lazy-highlight-search))) + (let* ((bound (if isearch-lazy-highlight-forward + (min (or isearch-lazy-highlight-end-limit (point-max)) + (if isearch-lazy-highlight-wrapped + isearch-lazy-highlight-start + window-end)) + (max (or isearch-lazy-highlight-start-limit (point-min)) + (if isearch-lazy-highlight-wrapped + isearch-lazy-highlight-end + window-start)))) + (found (isearch-lazy-highlight-search + isearch-lazy-highlight-last-string + bound))) (when max (setq max (1- max)) (if (<= max 0) @@ -3298,24 +3905,17 @@ Attempt to do the search exactly the way the pending Isearch would." (if isearch-lazy-highlight-forward (if (= mb (if isearch-lazy-highlight-wrapped isearch-lazy-highlight-start - (window-group-end))) + window-end)) (setq found nil) (forward-char 1)) (if (= mb (if isearch-lazy-highlight-wrapped isearch-lazy-highlight-end - (window-group-start))) + window-start)) (setq found nil) (forward-char -1))) ;; non-zero-length match - (let ((ov (make-overlay mb me))) - (push ov isearch-lazy-highlight-overlays) - ;; 1000 is higher than ediff's 100+, - ;; but lower than isearch main overlay's 1001 - (overlay-put ov 'priority 1000) - (overlay-put ov 'face 'lazy-highlight) - (unless (eq isearch-lazy-highlight 'all-windows) - (overlay-put ov 'window (selected-window))))) + (isearch-lazy-highlight-match mb me)) ;; Remember the current position of point for ;; the next call of `isearch-lazy-highlight-update' ;; when `lazy-highlight-max-at-a-time' is too small. @@ -3331,17 +3931,100 @@ Attempt to do the search exactly the way the pending Isearch would." (setq isearch-lazy-highlight-wrapped t) (if isearch-lazy-highlight-forward (progn - (setq isearch-lazy-highlight-end (window-group-start)) + (setq isearch-lazy-highlight-end window-start) (goto-char (max (or isearch-lazy-highlight-start-limit (point-min)) - (window-group-start)))) - (setq isearch-lazy-highlight-start (window-group-end)) + window-start))) + (setq isearch-lazy-highlight-start window-end) (goto-char (min (or isearch-lazy-highlight-end-limit (point-max)) - (window-group-end)))))))) - (unless nomore + window-end))))))) + (if nomore + (when (or isearch-lazy-highlight-buffer + (and isearch-lazy-count (null isearch-lazy-count-current))) + (if isearch-lazy-highlight-forward + (setq isearch-lazy-highlight-end (point-min)) + (setq isearch-lazy-highlight-start (point-max))) + (run-at-time lazy-highlight-interval nil + 'isearch-lazy-highlight-buffer-update)) (setq isearch-lazy-highlight-timer (run-at-time lazy-highlight-interval nil 'isearch-lazy-highlight-update))))))))) +(defun isearch-lazy-highlight-buffer-update () + "Update highlighting of other matches in the full buffer." + (let ((max lazy-highlight-buffer-max-at-a-time) + (looping t) + nomore window-start window-end + (opoint (point))) + (with-local-quit + (save-selected-window + (if (and (window-live-p isearch-lazy-highlight-window) + (not (memq (selected-window) isearch-lazy-highlight-window-group))) + (select-window isearch-lazy-highlight-window)) + (setq window-start (window-group-start)) + (setq window-end (window-group-end)) + (save-excursion + (save-match-data + (goto-char (if isearch-lazy-highlight-forward + isearch-lazy-highlight-end + isearch-lazy-highlight-start)) + (while looping + (let* ((bound (if isearch-lazy-highlight-forward + (or isearch-lazy-highlight-end-limit (point-max)) + (or isearch-lazy-highlight-start-limit (point-min)))) + (found (isearch-lazy-highlight-search + isearch-lazy-highlight-last-string + bound))) + (when max + (setq max (1- max)) + (if (<= max 0) + (setq looping nil))) + (if found + (let ((mb (match-beginning 0)) + (me (match-end 0))) + (if (= mb me) ;zero-length match + (if isearch-lazy-highlight-forward + (if (= mb (point-max)) + (setq found nil) + (forward-char 1)) + (if (= mb (point-min)) + (setq found nil) + (forward-char -1))) + (when isearch-lazy-count + (setq isearch-lazy-count-total + (1+ (or isearch-lazy-count-total 0))) + (puthash (if isearch-lazy-highlight-forward me mb) + isearch-lazy-count-total + isearch-lazy-count-hash)) + ;; Don't highlight the match when this loop is used + ;; only to count matches or when matches were already + ;; highlighted within the current window boundaries + ;; by isearch-lazy-highlight-update + (unless (or (not isearch-lazy-highlight-buffer) + (and (>= mb window-start) (<= me window-end))) + ;; non-zero-length match + (isearch-lazy-highlight-match mb me))) + ;; Remember the current position of point for + ;; the next call of `isearch-lazy-highlight-update' + ;; when `lazy-highlight-buffer-max-at-a-time' is too small. + (if isearch-lazy-highlight-forward + (setq isearch-lazy-highlight-end (point)) + (setq isearch-lazy-highlight-start (point))))) + + ;; not found or zero-length match at the search bound + (if (not found) + (setq looping nil + nomore t)))) + (if nomore + (when (and isearch-lazy-count isearch-mode (null isearch-message-function)) + (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)) + (setq isearch-lazy-highlight-timer + (run-at-time lazy-highlight-interval nil + 'isearch-lazy-highlight-buffer-update))))))))) + (defun isearch-resume (string regexp word forward message case-fold) "Resume an incremental search. STRING is the string or regexp searched for. diff --git a/lisp/isearchb.el b/lisp/isearchb.el index ee392b349e8..3dcd7d0d7a9 100644 --- a/lisp/isearchb.el +++ b/lisp/isearchb.el @@ -77,7 +77,9 @@ ;;; Code: -(require 'iswitchb) ;FIXME: Don't rely on iswitchb! +;; FIXME: Don't rely on iswitchb! See bug#36260. +(with-suppressed-warnings ((obsolete iswitchb)) + (require 'iswitchb)) (defgroup isearchb nil "Switch between buffers using a mechanism like isearch." diff --git a/lisp/jit-lock.el b/lisp/jit-lock.el index 9f325c8259c..48998a81fe7 100644 --- a/lisp/jit-lock.el +++ b/lisp/jit-lock.el @@ -266,6 +266,7 @@ If you need to debug code run from jit-lock, see `jit-lock-debug-mode'." (define-minor-mode jit-lock-debug-mode "Minor mode to help debug code run from jit-lock. + When this minor mode is enabled, jit-lock runs as little code as possible during redisplay and moves the rest to a timer, where things like `debug-on-error' and Edebug can be used." diff --git a/lisp/jka-cmpr-hook.el b/lisp/jka-cmpr-hook.el index 1b6e5902b90..3aa84f45b0d 100644 --- a/lisp/jka-cmpr-hook.el +++ b/lisp/jka-cmpr-hook.el @@ -347,9 +347,6 @@ variables. Setting this through Custom does that automatically." (define-minor-mode auto-compression-mode "Toggle Auto Compression mode. -With a prefix argument ARG, enable Auto Compression mode if ARG -is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. Auto Compression mode is a global minor mode. When enabled, compressed files are automatically uncompressed for reading, and diff --git a/lisp/json.el b/lisp/json.el index 1a455e3851b..d664dae05e4 100644 --- a/lisp/json.el +++ b/lisp/json.el @@ -53,6 +53,7 @@ ;;; Code: (require 'map) +(require 'subr-x) ;; Parameters @@ -370,7 +371,7 @@ representation will be parsed correctly." (defun json--decode-utf-16-surrogates (high low) "Return the code point represented by the UTF-16 surrogates HIGH and LOW." - (+ (lsh (- high #xD800) 10) (- low #xDC00) #x10000)) + (+ (ash (- high #xD800) 10) (- low #xDC00) #x10000)) (defun json-read-escaped-char () "Read the JSON string escaped character at point." @@ -523,8 +524,8 @@ Please see the documentation of `json-object-type' and `json-key-type'." ;; Skip over the "}" (json-advance) (pcase json-object-type - (`alist (nreverse elements)) - (`plist (json--plist-reverse elements)) + ('alist (nreverse elements)) + ('plist (json--plist-reverse elements)) (_ elements)))) ;; Hash table encoding @@ -609,8 +610,7 @@ Please see the documentation of `json-object-type' and `json-key-type'." "Return a JSON representation of LIST. Tries to DWIM: simple lists become JSON arrays, while alists and plists become JSON objects." - (cond ((null list) "null") - ((json-alist-p list) (json-encode-alist list)) + (cond ((json-alist-p list) (json-encode-alist list)) ((json-plist-p list) (json-encode-plist list)) ((listp list) (json-encode-array list)) (t @@ -642,8 +642,8 @@ become JSON objects." ;; Skip over the "]" (json-advance) (pcase json-array-type - (`vector (nreverse (vconcat elements))) - (`list (nreverse elements))))) + ('vector (nreverse (vconcat elements))) + ('list (nreverse elements))))) ;; Array encoding @@ -689,7 +689,19 @@ become JSON objects." (defun json-read () "Parse and return the JSON object following point. -Advances point just past JSON object." +Advances point just past JSON object. + +If called with the following JSON after point + + {\"a\": [1, 2, {\"c\": false}], + \"b\": \"foo\"} + +you will get the following structure returned: + + ((a . + [1 2 + ((c . :json-false))]) + (b . \"foo\"))" (json-skip-whitespace) (let ((char (json-peek))) (if (zerop char) @@ -717,48 +729,67 @@ Advances point just past JSON object." ;;; JSON encoder (defun json-encode (object) - "Return a JSON representation of OBJECT as a string." + "Return a JSON representation of OBJECT as a string. + +OBJECT should have a structure like one returned by `json-read'. +If an error is detected during encoding, an error based on +`json-error' is signalled." (cond ((memq object (list t json-null json-false)) (json-encode-keyword object)) ((stringp object) (json-encode-string object)) ((keywordp object) (json-encode-string (substring (symbol-name object) 1))) + ((listp object) (json-encode-list object)) ((symbolp object) (json-encode-string (symbol-name object))) ((numberp object) (json-encode-number object)) ((arrayp object) (json-encode-array object)) ((hash-table-p object) (json-encode-hash-table object)) - ((listp object) (json-encode-list object)) (t (signal 'json-error (list object))))) -;; Pretty printing - -(defun json-pretty-print-buffer () - "Pretty-print current buffer." - (interactive) - (json-pretty-print (point-min) (point-max))) - -(defun json-pretty-print (begin end) - "Pretty-print selected region." - (interactive "r") - (atomic-change-group - (let ((json-encoding-pretty-print t) - ;; Ensure that ordering is maintained - (json-object-type 'alist) - (txt (delete-and-extract-region begin end))) - (insert (json-encode (json-read-from-string txt)))))) - -(defun json-pretty-print-buffer-ordered () - "Pretty-print current buffer with object keys ordered." - (interactive) +;; Pretty printing & minimizing + +(defun json-pretty-print-buffer (&optional minimize) + "Pretty-print current buffer. +With prefix argument MINIMIZE, minimize it instead." + (interactive "P") + (json-pretty-print (point-min) (point-max) minimize)) + +(defun json-pretty-print (begin end &optional minimize) + "Pretty-print selected region. +With prefix argument MINIMIZE, minimize it instead." + (interactive "r\nP") + (let ((json-encoding-pretty-print (null minimize)) + ;; Distinguish an empty objects from 'null' + (json-null :json-null) + ;; Ensure that ordering is maintained + (json-object-type 'alist) + (err (gensym)) + json) + (save-restriction + (narrow-to-region begin end) + (goto-char begin) + (while (not (eq (setq json (condition-case _ + (json-read) + (json-error err))) + err)) + (delete-region begin (point)) + (insert (json-encode json)) + (setq begin (point)))))) + +(defun json-pretty-print-buffer-ordered (&optional minimize) + "Pretty-print current buffer with object keys ordered. +With prefix argument MINIMIZE, minimize it instead." + (interactive "P") (let ((json-encoding-object-sort-predicate 'string<)) - (json-pretty-print-buffer))) + (json-pretty-print-buffer minimize))) -(defun json-pretty-print-ordered (begin end) - "Pretty-print the region with object keys ordered." - (interactive "r") +(defun json-pretty-print-ordered (begin end &optional minimize) + "Pretty-print the region with object keys ordered. +With prefix argument MINIMIZE, minimize it instead." + (interactive "r\nP") (let ((json-encoding-object-sort-predicate 'string<)) - (json-pretty-print begin end))) + (json-pretty-print begin end minimize))) (provide 'json) diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el new file mode 100644 index 00000000000..0fffee68664 --- /dev/null +++ b/lisp/jsonrpc.el @@ -0,0 +1,699 @@ +;;; jsonrpc.el --- JSON-RPC library -*- lexical-binding: t; -*- + +;; Copyright (C) 2018-2019 Free Software Foundation, Inc. + +;; Author: João Távora <joaotavora@gmail.com> +;; Keywords: processes, languages, extensions +;; Package-Requires: ((emacs "25.2")) +;; Version: 1.0.7 + +;; This is an Elpa :core package. Don't use functionality that is not +;; compatible with Emacs 25.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 +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library implements the JSONRPC 2.0 specification as described +;; in http://www.jsonrpc.org/. As the name suggests, JSONRPC is a +;; generic Remote Procedure Call protocol designed around JSON +;; objects. To learn how to write JSONRPC programs with this library, +;; see Info node `(elisp)JSONRPC'." +;; +;; This library was originally extracted from eglot.el, an Emacs LSP +;; client, which you should see for an example usage. +;; +;;; Code: + +(require 'cl-lib) +(require 'json) +(require 'eieio) +(eval-when-compile (require 'subr-x)) +(require 'warnings) +(require 'pcase) +(require 'ert) ; to escape a `condition-case-unless-debug' +(require 'array) ; xor + + +;;; Public API +;;; + +(defclass jsonrpc-connection () + ((name + :accessor jsonrpc-name + :initarg :name + :documentation "A name for the connection") + (-request-dispatcher + :accessor jsonrpc--request-dispatcher + :initform #'ignore + :initarg :request-dispatcher + :documentation "Dispatcher for remotely invoked requests.") + (-notification-dispatcher + :accessor jsonrpc--notification-dispatcher + :initform #'ignore + :initarg :notification-dispatcher + :documentation "Dispatcher for remotely invoked notifications.") + (last-error + :accessor jsonrpc-last-error + :documentation "Last JSONRPC error message received from endpoint.") + (-request-continuations + :initform (make-hash-table) + :accessor jsonrpc--request-continuations + :documentation "A hash table of request ID to continuation lambdas.") + (-events-buffer + :accessor jsonrpc--events-buffer + :documentation "A buffer pretty-printing the JSONRPC events") + (-events-buffer-scrollback-size + :initarg :events-buffer-scrollback-size + :accessor jsonrpc--events-buffer-scrollback-size + :documentation "Max size of events buffer. 0 disables, nil means infinite.") + (-deferred-actions + :initform (make-hash-table :test #'equal) + :accessor jsonrpc--deferred-actions + :documentation "Map (DEFERRED BUF) to (FN TIMER ID). FN is\ +a saved DEFERRED `async-request' from BUF, to be sent not later\ +than TIMER as ID.") + (-next-request-id + :initform 0 + :accessor jsonrpc--next-request-id + :documentation "Next number used for a request")) + :documentation "Base class representing a JSONRPC connection. +The following initargs are accepted: + +:NAME (mandatory), a string naming the connection + +:REQUEST-DISPATCHER (optional), a function of three +arguments (CONN METHOD PARAMS) for handling JSONRPC requests. +CONN is a `jsonrpc-connection' object, method is a symbol, and +PARAMS is a plist representing a JSON object. The function is +expected to return a JSONRPC result, a plist of (:result +RESULT) or signal an error of type `jsonrpc-error'. + +:NOTIFICATION-DISPATCHER (optional), a function of three +arguments (CONN METHOD PARAMS) for handling JSONRPC +notifications. CONN, METHOD and PARAMS are the same as in +:REQUEST-DISPATCHER.") + +;;; API mandatory +(cl-defgeneric jsonrpc-connection-send (conn &key id method params result error) + "Send a JSONRPC message to connection CONN. +ID, METHOD, PARAMS, RESULT and ERROR. ") + +;;; API optional +(cl-defgeneric jsonrpc-shutdown (conn) + "Shutdown the JSONRPC connection CONN.") + +;;; API optional +(cl-defgeneric jsonrpc-running-p (conn) + "Tell if the JSONRPC connection CONN is still running.") + +;;; API optional +(cl-defgeneric jsonrpc-connection-ready-p (connection what) + "Tell if CONNECTION is ready for WHAT in current buffer. +If it isn't, a request which was passed a value to the +`:deferred' keyword argument will be deferred to the future. +WHAT is whatever was passed the as the value to that argument. + +By default, all connections are ready for sending all requests +immediately." + (:method (_s _what) ;; by default all connections are ready + t)) + + +;;; Convenience +;;; +(cl-defmacro jsonrpc-lambda (cl-lambda-list &body body) + (declare (indent 1) (debug (sexp &rest form))) + (let ((e (cl-gensym "jsonrpc-lambda-elem"))) + `(lambda (,e) (apply (cl-function (lambda ,cl-lambda-list ,@body)) ,e)))) + +(defun jsonrpc-events-buffer (connection) + "Get or create JSONRPC events buffer for CONNECTION." + (let* ((probe (jsonrpc--events-buffer connection)) + (buffer (or (and (buffer-live-p probe) + probe) + (let ((buffer (get-buffer-create + (format "*%s events*" + (jsonrpc-name connection))))) + (with-current-buffer buffer + (buffer-disable-undo) + (read-only-mode t) + (setf (jsonrpc--events-buffer connection) buffer)) + buffer)))) + buffer)) + +(defun jsonrpc-forget-pending-continuations (connection) + "Stop waiting for responses from the current JSONRPC CONNECTION." + (clrhash (jsonrpc--request-continuations connection))) + +(defun jsonrpc-connection-receive (connection message) + "Process MESSAGE just received from CONNECTION. +This function will destructure MESSAGE and call the appropriate +dispatcher in CONNECTION." + (cl-destructuring-bind (&key method id error params result _jsonrpc) + message + (let (continuations) + (jsonrpc--log-event connection message 'server) + (setf (jsonrpc-last-error connection) error) + (cond + (;; A remote request + (and method id) + (let* ((debug-on-error (and debug-on-error (not (ert-running-test)))) + (reply + (condition-case-unless-debug _ignore + (condition-case oops + `(:result ,(funcall (jsonrpc--request-dispatcher connection) + connection (intern method) params)) + (jsonrpc-error + `(:error + (:code + ,(or (alist-get 'jsonrpc-error-code (cdr oops)) -32603) + :message ,(or (alist-get 'jsonrpc-error-message + (cdr oops)) + "Internal error"))))) + (error + '(:error (:code -32603 :message "Internal error")))))) + (apply #'jsonrpc--reply connection id reply))) + (;; A remote notification + method + (funcall (jsonrpc--notification-dispatcher connection) + connection (intern method) params)) + (;; A remote response + (setq continuations + (and id (gethash id (jsonrpc--request-continuations connection)))) + (let ((timer (nth 2 continuations))) + (when timer (cancel-timer timer))) + (remhash id (jsonrpc--request-continuations connection)) + (if error (funcall (nth 1 continuations) error) + (funcall (nth 0 continuations) result)))) + (jsonrpc--call-deferred connection)))) + + +;;; Contacting the remote endpoint +;;; +(defun jsonrpc-error (&rest args) + "Error out with FORMAT and ARGS. +If invoked inside a dispatcher function, this function is suitable +for replying to the remote endpoint with an error message. + +ARGS can be of the form (FORMAT-STRING . MOREARGS) for replying +with a -32603 error code and a message formed by formatting +FORMAT-STRING with MOREARGS. + +Alternatively ARGS can be plist representing a JSONRPC error +object, using the keywords `:code', `:message' and `:data'." + (if (stringp (car args)) + (let ((msg + (apply #'format-message (car args) (cdr args)))) + (signal 'jsonrpc-error + `(,msg + (jsonrpc-error-code . ,32603) + (jsonrpc-error-message . ,msg)))) + (cl-destructuring-bind (&key code message data) args + (signal 'jsonrpc-error + `(,(format "[jsonrpc] error ") + (jsonrpc-error-code . ,code) + (jsonrpc-error-message . ,message) + (jsonrpc-error-data . ,data)))))) + +(cl-defun jsonrpc-async-request (connection + method + params + &rest args + &key _success-fn _error-fn + _timeout-fn + _timeout _deferred) + "Make a request to CONNECTION, expecting a reply, return immediately. +The JSONRPC request is formed by METHOD, a symbol, and PARAMS a +JSON object. + +The caller can expect SUCCESS-FN or ERROR-FN to be called with a +JSONRPC `:result' or `:error' object, respectively. If this +doesn't happen after TIMEOUT seconds (defaults to +`jsonrpc-request-timeout'), the caller can expect TIMEOUT-FN to be +called with no arguments. The default values of SUCCESS-FN, +ERROR-FN and TIMEOUT-FN simply log the events into +`jsonrpc-events-buffer'. + +If DEFERRED is non-nil, maybe defer the request to a future time +when the server is thought to be ready according to +`jsonrpc-connection-ready-p' (which see). The request might +never be sent at all, in case it is overridden in the meantime by +a new request with identical DEFERRED and for the same buffer. +However, in that situation, the original timeout is kept. + +Returns nil." + (apply #'jsonrpc--async-request-1 connection method params args) + nil) + +(cl-defun jsonrpc-request (connection + method params &key + deferred timeout + cancel-on-input + cancel-on-input-retval) + "Make a request to CONNECTION, wait for a reply. +Like `jsonrpc-async-request' for CONNECTION, METHOD and PARAMS, +but synchronous. + +Except in the case of a non-nil CANCEL-ON-INPUT (explained +below), this function doesn't exit until anything interesting +happens (success reply, error reply, or timeout). Furthermore, +it only exits locally (returning the JSONRPC result object) if +the request is successful, otherwise it exits non-locally with an +error of type `jsonrpc-error'. + +DEFERRED is passed to `jsonrpc-async-request', which see. + +If CANCEL-ON-INPUT is non-nil and the user inputs something while +the functino is waiting, then it exits immediately, returning +CANCEL-ON-INPUT-RETVAL. Any future replies (normal or error) are +ignored." + (let* ((tag (cl-gensym "jsonrpc-request-catch-tag")) id-and-timer + cancelled + (retval + (unwind-protect + (catch tag + (setq + id-and-timer + (jsonrpc--async-request-1 + connection method params + :success-fn (lambda (result) + (unless cancelled + (throw tag `(done ,result)))) + :error-fn + (jsonrpc-lambda + (&key code message data) + (unless cancelled + (throw tag `(error (jsonrpc-error-code . ,code) + (jsonrpc-error-message . ,message) + (jsonrpc-error-data . ,data))))) + :timeout-fn + (lambda () + (unless cancelled + (throw tag '(error (jsonrpc-error-message . "Timed out"))))) + :deferred deferred + :timeout timeout)) + (cond (cancel-on-input + (while (sit-for 30)) + (setq cancelled t) + `(cancelled ,cancel-on-input-retval)) + (t (while t (accept-process-output nil 30))))) + ;; In normal operation, cancellation is handled by the + ;; timeout function and response filter, but we still have + ;; to protect against user-quit (C-g) or the + ;; `cancel-on-input' case. + (pcase-let* ((`(,id ,timer) id-and-timer)) + (remhash id (jsonrpc--request-continuations connection)) + (remhash (list deferred (current-buffer)) + (jsonrpc--deferred-actions connection)) + (when timer (cancel-timer timer)))))) + (when (eq 'error (car retval)) + (signal 'jsonrpc-error + (cons + (format "request id=%s failed:" (car id-and-timer)) + (cdr retval)))) + (cadr retval))) + +(cl-defun jsonrpc-notify (connection method params) + "Notify CONNECTION of something, don't expect a reply." + (jsonrpc-connection-send connection + :method method + :params params)) + +(defconst jrpc-default-request-timeout 10 + "Time in seconds before timing out a JSONRPC request.") + + +;;; Specfic to `jsonrpc-process-connection' +;;; + +(defclass jsonrpc-process-connection (jsonrpc-connection) + ((-process + :initarg :process :accessor jsonrpc--process + :documentation "Process object wrapped by the this connection.") + (-expected-bytes + :accessor jsonrpc--expected-bytes + :documentation "How many bytes declared by server") + (-on-shutdown + :accessor jsonrpc--on-shutdown + :initform #'ignore + :initarg :on-shutdown + :documentation "Function run when the process dies.")) + :documentation "A JSONRPC connection over an Emacs process. +The following initargs are accepted: + +:PROCESS (mandatory), a live running Emacs process object or a +function of no arguments producing one such object. The process +represents either a pipe connection to locally running process or +a stream connection to a network host. The remote endpoint is +expected to understand JSONRPC messages with basic HTTP-style +enveloping headers such as \"Content-Length:\". + +:ON-SHUTDOWN (optional), a function of one argument, the +connection object, called when the process dies .") + +(cl-defmethod initialize-instance ((conn jsonrpc-process-connection) slots) + (cl-call-next-method) + (let* ((proc (plist-get slots :process)) + (proc (if (functionp proc) (funcall proc) proc)) + (buffer (get-buffer-create (format "*%s output*" (process-name proc)))) + (stderr (get-buffer-create (format "*%s stderr*" (process-name proc))))) + (setf (jsonrpc--process conn) proc) + (set-process-buffer proc buffer) + (process-put proc 'jsonrpc-stderr stderr) + (set-process-filter proc #'jsonrpc--process-filter) + (set-process-sentinel proc #'jsonrpc--process-sentinel) + (with-current-buffer (process-buffer proc) + (set-marker (process-mark proc) (point-min)) + (let ((inhibit-read-only t)) (erase-buffer) (read-only-mode t) proc)) + (process-put proc 'jsonrpc-connection conn))) + +(cl-defmethod jsonrpc-connection-send ((connection jsonrpc-process-connection) + &rest args + &key + _id + method + _params + _result + _error + _partial) + "Send MESSAGE, a JSON object, to CONNECTION." + (when method + (plist-put args :method + (cond ((keywordp method) (substring (symbol-name method) 1)) + ((and method (symbolp method)) (symbol-name method))))) + (let* ( (message `(:jsonrpc "2.0" ,@args)) + (json (jsonrpc--json-encode message)) + (headers + `(("Content-Length" . ,(format "%d" (string-bytes json))) + ;; ("Content-Type" . "application/vscode-jsonrpc; charset=utf-8") + ))) + (process-send-string + (jsonrpc--process connection) + (cl-loop for (header . value) in headers + concat (concat header ": " value "\r\n") into header-section + finally return (format "%s\r\n%s" header-section json))) + (jsonrpc--log-event connection message 'client))) + +(defun jsonrpc-process-type (conn) + "Return the `process-type' of JSONRPC connection CONN." + (process-type (jsonrpc--process conn))) + +(cl-defmethod jsonrpc-running-p ((conn jsonrpc-process-connection)) + "Return non-nil if JSONRPC connection CONN is running." + (process-live-p (jsonrpc--process conn))) + +(cl-defmethod jsonrpc-shutdown ((conn jsonrpc-process-connection) + &optional cleanup) + "Wait for JSONRPC connection CONN to shutdown. +With optional CLEANUP, kill any associated buffers. " + (unwind-protect + (cl-loop + with proc = (jsonrpc--process conn) for i from 0 + while (not (process-get proc 'jsonrpc-sentinel-cleanup-started)) + unless (zerop i) do + (jsonrpc--warn "Sentinel for %s still hasn't run, deleting it!" proc) + do + (delete-process proc) + (accept-process-output nil 0.1)) + (when cleanup + (kill-buffer (process-buffer (jsonrpc--process conn))) + (kill-buffer (jsonrpc-stderr-buffer conn))))) + +(defun jsonrpc-stderr-buffer (conn) + "Get CONN's standard error buffer, if any." + (process-get (jsonrpc--process conn) 'jsonrpc-stderr)) + + +;;; Private stuff +;;; +(define-error 'jsonrpc-error "jsonrpc-error") + +(defun jsonrpc--json-read () + "Read JSON object in buffer, move point to end of buffer." + ;; TODO: I guess we can make these macros if/when jsonrpc.el + ;; goes into Emacs core. + (cond ((fboundp 'json-parse-buffer) (json-parse-buffer + :object-type 'plist + :null-object nil + :false-object :json-false)) + (t (let ((json-object-type 'plist)) + (json-read))))) + +(defun jsonrpc--json-encode (object) + "Encode OBJECT into a JSON string." + (cond ((fboundp 'json-serialize) (json-serialize + object + :false-object :json-false + :null-object nil)) + (t (let ((json-false :json-false) + (json-null nil)) + (json-encode object))))) + +(cl-defun jsonrpc--reply (connection id &key (result nil result-supplied-p) error) + "Reply to CONNECTION's request ID with RESULT or ERROR." + (jsonrpc-connection-send connection :id id :result result :error error)) + +(defun jsonrpc--call-deferred (connection) + "Call CONNECTION's deferred actions, who may again defer themselves." + (when-let ((actions (hash-table-values (jsonrpc--deferred-actions connection)))) + (jsonrpc--debug connection `(:maybe-run-deferred + ,(mapcar (apply-partially #'nth 2) actions))) + (mapc #'funcall (mapcar #'car actions)))) + +(defun jsonrpc--process-sentinel (proc change) + "Called when PROC undergoes CHANGE." + (let ((connection (process-get proc 'jsonrpc-connection))) + (jsonrpc--debug connection `(:message "Connection state changed" :change ,change)) + (when (not (process-live-p proc)) + (with-current-buffer (jsonrpc-events-buffer connection) + (let ((inhibit-read-only t)) + (insert "\n----------b---y---e---b---y---e----------\n"))) + ;; Cancel outstanding timers + (maphash (lambda (_id triplet) + (pcase-let ((`(,_success ,_error ,timeout) triplet)) + (when timeout (cancel-timer timeout)))) + (jsonrpc--request-continuations connection)) + (process-put proc 'jsonrpc-sentinel-cleanup-started t) + (unwind-protect + ;; Call all outstanding error handlers + (maphash (lambda (_id triplet) + (pcase-let ((`(,_success ,error ,_timeout) triplet)) + (funcall error '(:code -1 :message "Server died")))) + (jsonrpc--request-continuations connection)) + (jsonrpc--message "Server exited with status %s" (process-exit-status proc)) + (delete-process proc) + (funcall (jsonrpc--on-shutdown connection) connection))))) + +(defun jsonrpc--process-filter (proc string) + "Called when new data STRING has arrived for PROC." + (when (buffer-live-p (process-buffer proc)) + (with-current-buffer (process-buffer proc) + (let* ((inhibit-read-only t) + (connection (process-get proc 'jsonrpc-connection)) + (expected-bytes (jsonrpc--expected-bytes connection))) + ;; Insert the text, advancing the process marker. + ;; + (save-excursion + (goto-char (process-mark proc)) + (insert string) + (set-marker (process-mark proc) (point))) + ;; Loop (more than one message might have arrived) + ;; + (unwind-protect + (let (done) + (while (not done) + (cond + ((not expected-bytes) + ;; Starting a new message + ;; + (setq expected-bytes + (and (search-forward-regexp + "\\(?:.*: .*\r\n\\)*Content-Length: \ +*\\([[:digit:]]+\\)\r\n\\(?:.*: .*\r\n\\)*\r\n" + (+ (point) 100) + t) + (string-to-number (match-string 1)))) + (unless expected-bytes + (setq done :waiting-for-new-message))) + (t + ;; Attempt to complete a message body + ;; + (let ((available-bytes (- (position-bytes (process-mark proc)) + (position-bytes (point))))) + (cond + ((>= available-bytes + expected-bytes) + (let* ((message-end (byte-to-position + (+ (position-bytes (point)) + expected-bytes)))) + (unwind-protect + (save-restriction + (narrow-to-region (point) message-end) + (let* ((json-message + (condition-case-unless-debug oops + (jsonrpc--json-read) + (error + (jsonrpc--warn "Invalid JSON: %s %s" + (cdr oops) (buffer-string)) + nil)))) + (when json-message + ;; Process content in another + ;; buffer, shielding proc buffer from + ;; tamper + (with-temp-buffer + (jsonrpc-connection-receive connection + json-message))))) + (goto-char message-end) + (delete-region (point-min) (point)) + (setq expected-bytes nil)))) + (t + ;; Message is still incomplete + ;; + (setq done :waiting-for-more-bytes-in-this-message)))))))) + ;; Saved parsing state for next visit to this filter + ;; + (setf (jsonrpc--expected-bytes connection) expected-bytes)))))) + +(cl-defun jsonrpc--async-request-1 (connection + method + params + &rest args + &key success-fn error-fn timeout-fn + (timeout jrpc-default-request-timeout) + (deferred nil)) + "Does actual work for `jsonrpc-async-request'. + +Return a list (ID TIMER). ID is the new request's ID, or nil if +the request was deferred. TIMER is a timer object set (or nil, if +TIMEOUT is nil)." + (pcase-let* ((buf (current-buffer)) (point (point)) + (`(,_ ,timer ,old-id) + (and deferred (gethash (list deferred buf) + (jsonrpc--deferred-actions connection)))) + (id (or old-id (cl-incf (jsonrpc--next-request-id connection)))) + (make-timer + (lambda ( ) + (when timeout + (run-with-timer + timeout nil + (lambda () + (remhash id (jsonrpc--request-continuations connection)) + (remhash (list deferred buf) + (jsonrpc--deferred-actions connection)) + (if timeout-fn (funcall timeout-fn) + (jsonrpc--debug + connection `(:timed-out ,method :id ,id + :params ,params))))))))) + (when deferred + (if (jsonrpc-connection-ready-p connection deferred) + ;; Server is ready, we jump below and send it immediately. + (remhash (list deferred buf) (jsonrpc--deferred-actions connection)) + ;; Otherwise, save in `eglot--deferred-actions' and exit non-locally + (unless old-id + (jsonrpc--debug connection `(:deferring ,method :id ,id :params + ,params))) + (puthash (list deferred buf) + (list (lambda () + (when (buffer-live-p buf) + (with-current-buffer buf + (save-excursion (goto-char point) + (apply #'jsonrpc-async-request + connection + method params args))))) + (or timer (setq timer (funcall make-timer))) id) + (jsonrpc--deferred-actions connection)) + (cl-return-from jsonrpc--async-request-1 (list id timer)))) + ;; Really send it + ;; + (jsonrpc-connection-send connection + :id id + :method method + :params params) + (puthash id + (list (or success-fn + (jsonrpc-lambda (&rest _ignored) + (jsonrpc--debug + connection (list :message "success ignored" + :id id)))) + (or error-fn + (jsonrpc-lambda (&key code message &allow-other-keys) + (jsonrpc--debug + connection (list + :message + (format "error ignored, status set (%s)" + message) + :id id :error code)))) + (setq timer (funcall make-timer))) + (jsonrpc--request-continuations connection)) + (list id timer))) + +(defun jsonrpc--message (format &rest args) + "Message out with FORMAT with ARGS." + (message "[jsonrpc] %s" (apply #'format format args))) + +(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))) + +(defun jsonrpc--warn (format &rest args) + "Warning message with FORMAT and ARGS." + (apply #'jsonrpc--message (concat "(warning) " format) args) + (let ((warning-minimum-level :error)) + (display-warning 'jsonrpc + (apply #'format format args) + :warning))) + +(defun jsonrpc--log-event (connection message &optional type) + "Log a JSONRPC-related event. +CONNECTION is the current connection. MESSAGE is a JSON-like +plist. TYPE is a symbol saying if this is a client or server +originated." + (let ((max (jsonrpc--events-buffer-scrollback-size connection))) + (when (or (null max) (cl-plusp max)) + (with-current-buffer (jsonrpc-events-buffer connection) + (cl-destructuring-bind (&key method id error &allow-other-keys) message + (let* ((inhibit-read-only t) + (subtype (cond ((and method id) 'request) + (method 'notification) + (id 'reply) + (t 'message))) + (type + (concat (format "%s" (or type 'internal)) + (if type + (format "-%s" subtype))))) + (goto-char (point-max)) + (prog1 + (let ((msg (format "%s%s%s %s:\n%s\n" + type + (if id (format " (id:%s)" id) "") + (if error " ERROR" "") + (current-time-string) + (pp-to-string message)))) + (when error + (setq msg (propertize msg 'face 'error))) + (insert-before-markers msg)) + ;; Trim the buffer if it's too large + (when max + (save-excursion + (goto-char (point-min)) + (while (> (buffer-size) max) + (delete-region (point) (progn (forward-line 1) + (forward-sexp 1) + (forward-line 2) + (point))))))))))))) + +(provide 'jsonrpc) +;;; jsonrpc.el ends here diff --git a/lisp/kermit.el b/lisp/kermit.el index f6ed1fbda1c..ec5d91749c4 100644 --- a/lisp/kermit.el +++ b/lisp/kermit.el @@ -77,7 +77,13 @@ (require 'shell) -(defvar kermit-esc-char "\C-\\" "*Kermit's escape char.") +(defgroup kermit nil + "Kermit support." + :group 'comm) + +(defcustom kermit-esc-char "\C-\\" + "Kermit's escape char." + :type 'string) (defun kermit-esc () "For sending escape sequences to a kermit running in shell mode." diff --git a/lisp/kmacro.el b/lisp/kmacro.el index 72d7091df17..e5d505662b5 100644 --- a/lisp/kmacro.el +++ b/lisp/kmacro.el @@ -112,6 +112,7 @@ ;; Customization: (require 'replace) +(require 'cl-lib) (defgroup kmacro nil "Simplified keyboard macro user interface." @@ -124,13 +125,11 @@ (defcustom kmacro-call-mouse-event 'S-mouse-3 "The mouse event used by kmacro to call a macro. Set to nil if no mouse binding is desired." - :type 'symbol - :group 'kmacro) + :type 'symbol) (defcustom kmacro-ring-max 8 "Maximum number of keyboard macros to save in macro ring." - :type 'integer - :group 'kmacro) + :type 'integer) (defcustom kmacro-execute-before-append t @@ -141,32 +140,27 @@ execute the macro. Otherwise, a single \\[universal-argument] prefix does not execute the macro, while more than one \\[universal-argument] prefix causes the macro to be executed before appending to it." - :type 'boolean - :group 'kmacro) + :type 'boolean) (defcustom kmacro-repeat-no-prefix t "Allow repeating certain macro commands without entering the C-x C-k prefix." - :type 'boolean - :group 'kmacro) + :type 'boolean) (defcustom kmacro-call-repeat-key t "Allow repeating macro call using last key or a specific key." :type '(choice (const :tag "Disabled" nil) (const :tag "Last key" t) (character :tag "Character" :value ?e) - (symbol :tag "Key symbol" :value RET)) - :group 'kmacro) + (symbol :tag "Key symbol" :value RET))) (defcustom kmacro-call-repeat-with-arg nil "Repeat macro call with original arg when non-nil; repeat once if nil." - :type 'boolean - :group 'kmacro) + :type 'boolean) (defcustom kmacro-step-edit-mini-window-height 0.75 "Override `max-mini-window-height' when step edit keyboard macro." - :type 'number - :group 'kmacro) + :type 'number) ;; Keymap @@ -271,7 +265,7 @@ the last increment." (if kmacro-initial-counter-value (setq kmacro-counter kmacro-initial-counter-value kmacro-initial-counter-value nil)) - (if (and arg (listp arg)) + (if (consp arg) (insert (format kmacro-counter-format kmacro-last-counter)) (insert (format kmacro-counter-format kmacro-counter)) (kmacro-add-counter (prefix-numeric-value arg)))) @@ -290,8 +284,8 @@ the last increment." (defun kmacro-display-counter (&optional value) "Display current counter value." (unless value (setq value kmacro-counter)) - (message "New macro counter value: %s (%d)" (format kmacro-counter-format value) value)) - + (message "New macro counter value: %s (%d)" + (format kmacro-counter-format value) value)) (defun kmacro-set-counter (arg) "Set the value of `kmacro-counter' to ARG, or prompt for value if no argument. @@ -783,6 +777,7 @@ If kbd macro currently being defined end it before activating it." ;; letters and digits, provided that we inhibit the keymap while ;; executing the macro later on (but that's controversial...) +;;;###autoload (defun kmacro-lambda-form (mac &optional counter format) "Create lambda form for macro bound to symbol or key." (if counter @@ -794,19 +789,18 @@ If kbd macro currently being defined end it before activating it." (defun kmacro-extract-lambda (mac) "Extract kmacro from a kmacro lambda form." - (and (consp mac) - (eq (car mac) 'lambda) + (and (eq (car-safe mac) 'lambda) (setq mac (assoc 'kmacro-exec-ring-item mac)) - (consp (cdr mac)) - (consp (car (cdr mac))) - (consp (cdr (car (cdr mac)))) - (setq mac (car (cdr (car (cdr mac))))) + (setq mac (car-safe (cdr-safe (car-safe (cdr-safe mac))))) (listp mac) (= (length mac) 3) (arrayp (car mac)) mac)) +(defalias 'kmacro-p #'kmacro-extract-lambda + "Return non-nil if MAC is a kmacro keyboard macro.") + (defun kmacro-bind-to-key (_arg) "When not defining or executing a macro, offer to bind last macro to a key. The key sequences [C-x C-k 0] through [C-x C-k 9] and [C-x C-k A] @@ -835,7 +829,7 @@ The ARG parameter is unused." (and (>= ch ?A) (<= ch ?Z)))) (setq key-seq (concat "\C-x\C-k" key-seq) ok t)))) - (when (and (not (equal key-seq "")) + (when (and (not (equal key-seq "\^G")) (or ok (not (setq cmd (key-binding key-seq))) (stringp cmd) @@ -847,6 +841,13 @@ The ARG parameter is unused." (kmacro-lambda-form (kmacro-ring-head))) (message "Keyboard macro bound to %s" (format-kbd-macro key-seq)))))) +(defun kmacro-keyboard-macro-p (symbol) + "Return non-nil if SYMBOL is the name of some sort of keyboard macro." + (let ((f (symbol-function symbol))) + (when f + (or (stringp f) + (vectorp f) + (kmacro-p f))))) (defun kmacro-name-last-macro (symbol) "Assign a name to the last keyboard macro defined. @@ -857,19 +858,35 @@ Such a \"function\" cannot be called from Lisp, but it is a valid editor command (or last-kbd-macro (error "No keyboard macro defined")) (and (fboundp symbol) - (not (get symbol 'kmacro)) - (not (stringp (symbol-function symbol))) - (not (vectorp (symbol-function symbol))) + (not (kmacro-keyboard-macro-p symbol)) (error "Function %s is already defined and not a keyboard macro" symbol)) (if (string-equal symbol "") (error "No command name given")) + ;; FIXME: Use plain old `last-kbd-macro' for kmacros where it doesn't + ;; make a difference? (fset symbol (kmacro-lambda-form (kmacro-ring-head))) + ;; This used to be used to detect when a symbol corresponds to a kmacro. + ;; Nowadays it's unused because we used `kmacro-p' instead to see if the + ;; symbol's function definition matches that of a kmacro, which is more + ;; reliable. (put symbol 'kmacro t)) -(defun kmacro-execute-from-register (k) - (kmacro-call-macro current-prefix-arg nil nil k)) +(cl-defstruct (kmacro-register + (:constructor nil) + (:constructor kmacro-make-register (macro))) + macro) + +(cl-defmethod register-val-jump-to ((data kmacro-register) _arg) + (kmacro-call-macro current-prefix-arg nil nil (kmacro-register-macro data))) + +(cl-defmethod register-val-describe ((data kmacro-register) _verbose) + (princ (format "a keyboard macro:\n %s" + (format-kbd-macro (kmacro-register-macro data))))) + +(cl-defmethod register-val-insert ((data kmacro-register)) + (insert (format-kbd-macro (kmacro-register-macro data)))) (defun kmacro-to-register (r) "Store the last keyboard macro in register R. @@ -879,14 +896,7 @@ Interactively, reads the register using `register-read-with-preview'." (progn (or last-kbd-macro (error "No keyboard macro defined")) (list (register-read-with-preview "Save to register: ")))) - (set-register r (registerv-make - last-kbd-macro - :jump-func 'kmacro-execute-from-register - :print-func (lambda (k) - (princ (format "a keyboard macro:\n %s" - (format-kbd-macro k)))) - :insert-func (lambda (k) - (insert (format-kbd-macro k)))))) + (set-register r (kmacro-make-register last-kbd-macro))) (defun kmacro-view-macro (&optional _arg) @@ -1223,7 +1233,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (setq kmacro-step-edit-key-index next-index))) (defun kmacro-step-edit-pre-command () - (remove-hook 'post-command-hook 'kmacro-step-edit-post-command) + (remove-hook 'post-command-hook #'kmacro-step-edit-post-command) (when kmacro-step-edit-active (cond ((eq kmacro-step-edit-active 'ignore) @@ -1243,17 +1253,17 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (setq kmacro-step-edit-appending nil kmacro-step-edit-active 'ignore))))) (when (eq kmacro-step-edit-active t) - (add-hook 'post-command-hook 'kmacro-step-edit-post-command t))) + (add-hook 'post-command-hook #'kmacro-step-edit-post-command t))) (defun kmacro-step-edit-minibuf-setup () - (remove-hook 'pre-command-hook 'kmacro-step-edit-pre-command t) + (remove-hook 'pre-command-hook #'kmacro-step-edit-pre-command t) (when kmacro-step-edit-active - (add-hook 'pre-command-hook 'kmacro-step-edit-pre-command nil t))) + (add-hook 'pre-command-hook #'kmacro-step-edit-pre-command nil t))) (defun kmacro-step-edit-post-command () - (remove-hook 'pre-command-hook 'kmacro-step-edit-pre-command) + (remove-hook 'pre-command-hook #'kmacro-step-edit-pre-command) (when kmacro-step-edit-active - (add-hook 'pre-command-hook 'kmacro-step-edit-pre-command nil nil) + (add-hook 'pre-command-hook #'kmacro-step-edit-pre-command nil nil) (if kmacro-step-edit-key-index (setq executing-kbd-macro-index kmacro-step-edit-key-index) (setq kmacro-step-edit-key-index executing-kbd-macro-index)))) @@ -1276,9 +1286,9 @@ To customize possible responses, change the \"bindings\" in `kmacro-step-edit-ma (pre-command-hook pre-command-hook) (post-command-hook post-command-hook) (minibuffer-setup-hook minibuffer-setup-hook)) - (add-hook 'pre-command-hook 'kmacro-step-edit-pre-command nil) - (add-hook 'post-command-hook 'kmacro-step-edit-post-command t) - (add-hook 'minibuffer-setup-hook 'kmacro-step-edit-minibuf-setup t) + (add-hook 'pre-command-hook #'kmacro-step-edit-pre-command nil) + (add-hook 'post-command-hook #'kmacro-step-edit-post-command t) + (add-hook 'minibuffer-setup-hook #'kmacro-step-edit-minibuf-setup t) (call-last-kbd-macro nil nil) (when (and kmacro-step-edit-replace kmacro-step-edit-new-macro diff --git a/lisp/language/china-util.el b/lisp/language/china-util.el index 70710bac18a..16385651335 100644 --- a/lisp/language/china-util.el +++ b/lisp/language/china-util.el @@ -168,7 +168,7 @@ Return the length of resulting text." ;; ESC ESC -> ESC (delete-char 1) (forward-char -1) - (if (looking-at iso2022-gb-designation) + (if (looking-at "\e\\$A") (progn (delete-region (match-beginning 0) (match-end 0)) (insert hz-gb-designation) diff --git a/lisp/language/cyrillic.el b/lisp/language/cyrillic.el index 7e714a43e3e..564ac5f5921 100644 --- a/lisp/language/cyrillic.el +++ b/lisp/language/cyrillic.el @@ -9,7 +9,7 @@ ;; National Institute of Advanced Industrial Science and Technology (AIST) ;; Registration Number H13PRO009 -;; Author: Kenichi Handa <handa@etl.go.jp> +;; Author: Kenichi Handa <handa@gnu.org> ;; Keywords: multilingual, Cyrillic, i18n ;; This file is part of GNU Emacs. @@ -95,7 +95,7 @@ (define-coding-system-alias 'cp878 'cyrillic-koi8) (set-language-info-alist - "Cyrillic-KOI8" `((charset koi8) + "Cyrillic-KOI8" '((charset koi8) (coding-system cyrillic-koi8) (coding-priority cyrillic-koi8 cyrillic-iso-8bit) (ctext-non-standard-encodings "koi8-r") @@ -131,7 +131,7 @@ Support for Russian using koi8-r and the russian-computer input method.") :mime-charset 'koi8-u) (set-language-info-alist - "Ukrainian" `((charset koi8-u) + "Ukrainian" '((charset koi8-u) (coding-system koi8-u) (coding-priority koi8-u) (nonascii-translation . koi8-u) @@ -151,7 +151,7 @@ Support for Russian using koi8-r and the russian-computer input method.") (define-coding-system-alias 'alternativnyj 'cyrillic-alternativnyj) (set-language-info-alist - "Cyrillic-ALT" `((charset alternativnyj) + "Cyrillic-ALT" '((charset alternativnyj) (coding-system cyrillic-alternativnyj) (coding-priority cyrillic-alternativnyj) (nonascii-translation . alternativnyj) @@ -229,7 +229,7 @@ Support for Russian using koi8-r and the russian-computer input method.") ;; '("Cyrillic")) (set-language-info-alist - "Tajik" `((coding-system koi8-t) + "Tajik" '((coding-system koi8-t) (coding-priority koi8-t) (nonascii-translation . cyrillic-koi8-t) (charset koi8-t) @@ -239,7 +239,7 @@ Support for Russian using koi8-r and the russian-computer input method.") '("Cyrillic")) (set-language-info-alist - "Bulgarian" `((coding-system windows-1251) + "Bulgarian" '((coding-system windows-1251) (coding-priority windows-1251) (nonascii-translation . windows-1251) (charset windows-1251) @@ -250,7 +250,7 @@ Support for Russian using koi8-r and the russian-computer input method.") '("Cyrillic")) (set-language-info-alist - "Belarusian" `((coding-system windows-1251) + "Belarusian" '((coding-system windows-1251) (coding-priority windows-1251) (nonascii-translation . windows-1251) (charset windows-1251) @@ -262,7 +262,7 @@ Support for Russian using koi8-r and the russian-computer input method.") '("Cyrillic")) (set-language-info-alist - "Ukrainian" `((coding-system koi8-u) + "Ukrainian" '((coding-system koi8-u) (coding-priority koi8-u) (input-method . "ukrainian-computer") (documentation diff --git a/lisp/language/english.el b/lisp/language/english.el index ee458760dab..09ed423f2cc 100644 --- a/lisp/language/english.el +++ b/lisp/language/english.el @@ -62,6 +62,14 @@ Nothing special is needed to handle English.") :mnemonic ?*) (define-coding-system-alias 'cp1047 'ibm1047) +(define-coding-system 'ibm038 + "International version of EBCDIC" + :coding-type 'charset + :charset-list '(ibm038) + :mnemonic ?*) +(define-coding-system-alias 'ebcdic-int 'ibm038) +(define-coding-system-alias 'cp038 'ibm038) + ;; Make "ASCII" an alias of "English" language environment. (set-language-info-alist "ASCII" (cdr (assoc "English" language-info-alist))) diff --git a/lisp/language/ethio-util.el b/lisp/language/ethio-util.el index afc2239fbf5..2741538e68a 100644 --- a/lisp/language/ethio-util.el +++ b/lisp/language/ethio-util.el @@ -804,7 +804,7 @@ The 2nd and 3rd arguments BEGIN and END specify the region." ;; Special Ethiopic punctuation. (goto-char (point-min)) - (while (re-search-forward "\\ce[»\\.\\?]\\|«\\ce" nil t) + (while (re-search-forward "\\ce[».?]\\|«\\ce" nil t) (cond ((= (setq ch (preceding-char)) ?\») (delete-char -1) @@ -1014,7 +1014,7 @@ With ARG, insert that many delimiters." ;; ;;;###autoload -(defun ethio-composition-function (pos to font-object string) +(defun ethio-composition-function (pos to font-object string _direction) (setq pos (1- pos)) (let ((pattern "\\ce\\(፟\\|\\)")) (if string diff --git a/lisp/language/european.el b/lisp/language/european.el index a5bec8cf017..fedbca4eb69 100644 --- a/lisp/language/european.el +++ b/lisp/language/european.el @@ -525,7 +525,7 @@ method and applying Turkish case rules for the characters i, I, ı, İ."))) (set-case-syntax ?ı "w" table))) ;; Polish ISO 8859-2 environment. -;; Maintainer: Wlodek Bzyl <matwb@univ.gda.pl> +;; Maintainer: Włodek Bzyl <matwb@univ.gda.pl> ;; Keywords: multilingual, Polish (set-language-info-alist @@ -541,7 +541,7 @@ method and applying Turkish case rules for the characters i, I, ı, İ."))) '("European")) (set-language-info-alist - "Welsh" `((coding-system utf-8 latin-8) ; the input method is Unicode-based + "Welsh" '((coding-system utf-8 latin-8) ; the input method is Unicode-based (coding-priority utf-8 latin-8) (nonascii-translation . iso-8859-14) (input-method . "welsh") @@ -558,7 +558,7 @@ method and applying Turkish case rules for the characters i, I, ı, İ."))) '("European")) (set-language-info-alist - "Latin-7" `((coding-system latin-7) + "Latin-7" '((coding-system latin-7) (coding-priority latin-7) (nonascii-translation . iso-8859-13) (input-method . "latin-prefix") @@ -566,7 +566,7 @@ method and applying Turkish case rules for the characters i, I, ı, İ."))) '("European")) (set-language-info-alist - "Lithuanian" `((coding-system latin-7 windows-1257) + "Lithuanian" '((coding-system latin-7 windows-1257) (coding-priority latin-7) (nonascii-translation . iso-8859-13) (input-method . "lithuanian-keyboard") @@ -574,7 +574,7 @@ method and applying Turkish case rules for the characters i, I, ı, İ."))) '("European")) (set-language-info-alist - "Latvian" `((coding-system latin-7 windows-1257) + "Latvian" '((coding-system latin-7 windows-1257) (coding-priority latin-7) (nonascii-translation . iso-8859-13) (input-method . "latvian-keyboard") diff --git a/lisp/language/georgian.el b/lisp/language/georgian.el index 41c1ead8ca3..2c3d3fbc87b 100644 --- a/lisp/language/georgian.el +++ b/lisp/language/georgian.el @@ -37,7 +37,7 @@ :charset-list '(georgian-academy)) (set-language-info-alist - "Georgian" `((coding-system georgian-ps) + "Georgian" '((coding-system georgian-ps) (coding-priority georgian-ps) (input-method . "georgian") (nonascii-translation . georgian-ps) diff --git a/lisp/language/hebrew.el b/lisp/language/hebrew.el index ca3058b8eed..cda5765c7f6 100644 --- a/lisp/language/hebrew.el +++ b/lisp/language/hebrew.el @@ -152,7 +152,7 @@ Bidirectional editing is supported."))) ;; (3) If the font has precomposed glyphs, use them as far as ;; possible. Adjust the remaining glyphs artificially. -(defun hebrew-shape-gstring (gstring) +(defun hebrew-shape-gstring (gstring direction) (let* ((font (lgstring-font gstring)) (otf (font-get font :otf)) (nchars (lgstring-char-len gstring)) @@ -172,7 +172,7 @@ Bidirectional editing is supported."))) ((or (assq 'hebr (car otf)) (assq 'hebr (cdr otf))) ;; FONT has OpenType features for Hebrew. - (font-shape-gstring gstring)) + (font-shape-gstring gstring direction)) (t ;; FONT doesn't have OpenType features for Hebrew. @@ -217,7 +217,7 @@ Bidirectional editing is supported."))) ;; Now IDX is an index to the first non-precomposed glyph. ;; Adjust positions of the remaining glyphs artificially. (if (font-get font :combining-capability) - (font-shape-gstring gstring) + (font-shape-gstring gstring direction) (setq base-width (lglyph-width (lgstring-glyph gstring 0))) (while (< idx nglyphs) (setq glyph (lgstring-glyph gstring idx)) @@ -238,8 +238,9 @@ Bidirectional editing is supported."))) (setq idx (1+ idx))))))) gstring)) -(let* ((base "[\u05D0-\u05F2]") - (combining "[\u0591-\u05BD\u05BF\u05C1-\u05C2\u05C4-\u05C5\u05C7]+") +(let* ((base "[\u05D0-\u05F2\uFB1D\uFB1F-\uFB28\uFB2A-\uFB4F]") + (combining + "[\u0591-\u05BD\u05BF\u05C1-\u05C2\u05C4-\u05C5\u05C7\uFB1E]+") (pattern1 (concat base combining)) (pattern2 (concat base "\u200D" combining))) (set-char-table-range diff --git a/lisp/language/ind-util.el b/lisp/language/ind-util.el index 9b4af199858..beba2df1aeb 100644 --- a/lisp/language/ind-util.el +++ b/lisp/language/ind-util.el @@ -2,7 +2,6 @@ ;; Copyright (C) 2001-2019 Free Software Foundation, Inc. -;; Maintainer: KAWABATA, Taichi <kawabata@m17n.org> ;; Keywords: multilingual, Indian, Devanagari ;; This file is part of GNU Emacs. @@ -776,13 +775,13 @@ (defvar is13194-to-ucs-kannada-hashtbl nil) (defvar is13194-to-ucs-kannada-regexp nil) -(defvar ucs-to-is13194-regexp +(defvar indian-ucs-to-is13194-regexp ;; only Devanagari is supported now. (concat "[" (char-to-string #x0900) "-" (char-to-string #x097f) "]") "Regexp that matches to conversion") -(defun ucs-to-iscii-region (from to) +(defun indian-ucs-to-iscii-region (from to) "Converts the indian UCS characters in the region to ISCII. Returns new end position." (interactive "r") @@ -792,13 +791,13 @@ Returns new end position." (narrow-to-region from to) (goto-char (point-min)) (let* ((current-repertory is13194-default-repertory)) - (while (re-search-forward ucs-to-is13194-regexp nil t) + (while (re-search-forward indian-ucs-to-is13194-regexp nil t) (replace-match (get-char-code-property (string-to-char (match-string 0)) 'iscii)))) (point-max)))) -(defun iscii-to-ucs-region (from to) +(defun indian-iscii-to-ucs-region (from to) "Converts the ISCII characters in the region to UCS. Returns new end position." (interactive "r") @@ -829,6 +828,9 @@ Returns new end position." (let ((pos from) newpos func (max to)) (narrow-to-region from to) (while (< pos max) + ;; FIXME: The below seems to assume + ;; composition-function-table holds functions? That is no + ;; longer true, since long ago. (setq func (aref composition-function-table (char-after pos))) (if (fboundp func) (setq newpos (funcall func pos nil) @@ -846,7 +848,7 @@ Returns new end position." ;;;###autoload (defun in-is13194-post-read-conversion (len) (let ((pos (point)) endpos) - (setq endpos (iscii-to-ucs-region pos (+ pos len))) + (setq endpos (indian-iscii-to-ucs-region pos (+ pos len))) (- endpos pos))) ;;;###autoload @@ -856,7 +858,7 @@ Returns new end position." (if (stringp from) (insert from) (insert-buffer-substring buf from to)) - (ucs-to-iscii-region (point-min) (point-max)) + (indian-ucs-to-iscii-region (point-min) (point-max)) nil)) diff --git a/lisp/language/indian.el b/lisp/language/indian.el index d63e9b465fa..f1e61a354c2 100644 --- a/lisp/language/indian.el +++ b/lisp/language/indian.el @@ -5,8 +5,6 @@ ;; National Institute of Advanced Industrial Science and Technology (AIST) ;; Registration Number H14PRO021 -;; Maintainer: Kenichi Handa <handa@m17n.org> -;; KAWABATA, Taichi <kawabata@m17n.org> ;; Keywords: multilingual, i18n, Indian ;; This file is part of GNU Emacs. diff --git a/lisp/language/japan-util.el b/lisp/language/japan-util.el index fd27ae220bd..b1eb3d9127b 100644 --- a/lisp/language/japan-util.el +++ b/lisp/language/japan-util.el @@ -1,4 +1,4 @@ -;;; japan-util.el --- utilities for Japanese -*- coding: iso-2022-7bit; -*- +;;; japan-util.el --- utilities for Japanese ;; Copyright (C) 2001-2019 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, @@ -29,36 +29,34 @@ ;;;###autoload (defun setup-japanese-environment-internal () - ;; By default, we use 'japanese-iso-8bit for file names. But, the - ;; following prefer-coding-system will override it. - (if (memq system-type '(windows-nt ms-dos cygwin)) - (prefer-coding-system 'japanese-shift-jis) - (prefer-coding-system 'japanese-iso-8bit)) + (prefer-coding-system (if (memq system-type '(windows-nt ms-dos cygwin)) + 'japanese-shift-jis + 'utf-8)) (use-cjk-char-width-table 'ja_JP)) (defconst japanese-kana-table - '((?$B$"(B ?$B%"(B ?(I1(B) (?$B$$(B ?$B%$(B ?(I2(B) (?$B$&(B ?$B%&(B ?(I3(B) (?$B$((B ?$B%((B ?(I4(B) (?$B$*(B ?$B%*(B ?(I5(B) - (?$B$+(B ?$B%+(B ?(I6(B) (?$B$-(B ?$B%-(B ?(I7(B) (?$B$/(B ?$B%/(B ?(I8(B) (?$B$1(B ?$B%1(B ?(I9(B) (?$B$3(B ?$B%3(B ?(I:(B) - (?$B$5(B ?$B%5(B ?(I;(B) (?$B$7(B ?$B%7(B ?(I<(B) (?$B$9(B ?$B%9(B ?(I=(B) (?$B$;(B ?$B%;(B ?(I>(B) (?$B$=(B ?$B%=(B ?(I?(B) - (?$B$?(B ?$B%?(B ?(I@(B) (?$B$A(B ?$B%A(B ?(IA(B) (?$B$D(B ?$B%D(B ?(IB(B) (?$B$F(B ?$B%F(B ?(IC(B) (?$B$H(B ?$B%H(B ?(ID(B) - (?$B$J(B ?$B%J(B ?(IE(B) (?$B$K(B ?$B%K(B ?(IF(B) (?$B$L(B ?$B%L(B ?(IG(B) (?$B$M(B ?$B%M(B ?(IH(B) (?$B$N(B ?$B%N(B ?(II(B) - (?$B$O(B ?$B%O(B ?(IJ(B) (?$B$R(B ?$B%R(B ?(IK(B) (?$B$U(B ?$B%U(B ?(IL(B) (?$B$X(B ?$B%X(B ?(IM(B) (?$B$[(B ?$B%[(B ?(IN(B) - (?$B$^(B ?$B%^(B ?(IO(B) (?$B$_(B ?$B%_(B ?(IP(B) (?$B$`(B ?$B%`(B ?(IQ(B) (?$B$a(B ?$B%a(B ?(IR(B) (?$B$b(B ?$B%b(B ?(IS(B) - (?$B$d(B ?$B%d(B ?(IT(B) (?$B$f(B ?$B%f(B ?(IU(B) (?$B$h(B ?$B%h(B ?(IV(B) - (?$B$i(B ?$B%i(B ?(IW(B) (?$B$j(B ?$B%j(B ?(IX(B) (?$B$k(B ?$B%k(B ?(IY(B) (?$B$l(B ?$B%l(B ?(IZ(B) (?$B$m(B ?$B%m(B ?(I[(B) - (?$B$o(B ?$B%o(B ?(I\(B) (?$B$p(B ?$B%p(B "(I2(B") (?$B$q(B ?$B%q(B "(I4(B") (?$B$r(B ?$B%r(B ?(I&(B) - (?$B$s(B ?$B%s(B ?(I](B) - (?$B$,(B ?$B%,(B "(I6^(B") (?$B$.(B ?$B%.(B "(I7^(B") (?$B$0(B ?$B%0(B "(I8^(B") (?$B$2(B ?$B%2(B "(I9^(B") (?$B$4(B ?$B%4(B "(I:^(B") - (?$B$6(B ?$B%6(B "(I;^(B") (?$B$8(B ?$B%8(B "(I<^(B") (?$B$:(B ?$B%:(B "(I=^(B") (?$B$<(B ?$B%<(B "(I>^(B") (?$B$>(B ?$B%>(B "(I?^(B") - (?$B$@(B ?$B%@(B "(I@^(B") (?$B$B(B ?$B%B(B "(IA^(B") (?$B$E(B ?$B%E(B "(IB^(B") (?$B$G(B ?$B%G(B "(IC^(B") (?$B$I(B ?$B%I(B "(ID^(B") - (?$B$P(B ?$B%P(B "(IJ^(B") (?$B$S(B ?$B%S(B "(IK^(B") (?$B$V(B ?$B%V(B "(IL^(B") (?$B$Y(B ?$B%Y(B "(IM^(B") (?$B$\(B ?$B%\(B "(IN^(B") - (?$B$Q(B ?$B%Q(B "(IJ_(B") (?$B$T(B ?$B%T(B "(IK_(B") (?$B$W(B ?$B%W(B "(IL_(B") (?$B$Z(B ?$B%Z(B "(IM_(B") (?$B$](B ?$B%](B "(IN_(B") - (?$B$!(B ?$B%!(B ?(I'(B) (?$B$#(B ?$B%#(B ?(I((B) (?$B$%(B ?$B%%(B ?(I)(B) (?$B$'(B ?$B%'(B ?(I*(B) (?$B$)(B ?$B%)(B ?(I+(B) - (?$B$C(B ?$B%C(B ?(I/(B) - (?$B$c(B ?$B%c(B ?(I,(B) (?$B$e(B ?$B%e(B ?(I-(B) (?$B$g(B ?$B%g(B ?(I.(B) - (?$B$n(B ?$B%n(B "(I\(B") - (?$B!5(B ?$B!3(B) (?$B!6(B ?$B!4(B) - ("$B$&!+(B" ?$B%t(B "(I3^(B") (nil ?$B%u(B "(I6(B") (nil ?$B%v(B "(I9(B")) + '((?あ ?ア ?ア) (?い ?イ ?イ) (?う ?ウ ?ウ) (?え ?エ ?エ) (?お ?オ ?オ) + (?か ?カ ?カ) (?き ?キ ?キ) (?く ?ク ?ク) (?け ?ケ ?ケ) (?こ ?コ ?コ) + (?さ ?サ ?サ) (?し ?シ ?シ) (?す ?ス ?ス) (?せ ?セ ?セ) (?そ ?ソ ?ソ) + (?た ?タ ?タ) (?ち ?チ ?チ) (?つ ?ツ ?ツ) (?て ?テ ?テ) (?と ?ト ?ト) + (?な ?ナ ?ナ) (?に ?ニ ?ニ) (?ぬ ?ヌ ?ヌ) (?ね ?ネ ?ネ) (?の ?ノ ?ノ) + (?は ?ハ ?ハ) (?ひ ?ヒ ?ヒ) (?ふ ?フ ?フ) (?へ ?ヘ ?ヘ) (?ほ ?ホ ?ホ) + (?ま ?マ ?マ) (?み ?ミ ?ミ) (?む ?ム ?ム) (?め ?メ ?メ) (?も ?モ ?モ) + (?や ?ヤ ?ヤ) (?ゆ ?ユ ?ユ) (?よ ?ヨ ?ヨ) + (?ら ?ラ ?ラ) (?り ?リ ?リ) (?る ?ル ?ル) (?れ ?レ ?レ) (?ろ ?ロ ?ロ) + (?わ ?ワ ?ワ) (?ゐ ?ヰ "イ") (?ゑ ?ヱ "エ") (?を ?ヲ ?ヲ) + (?ん ?ン ?ン) + (?が ?ガ "ガ") (?ぎ ?ギ "ギ") (?ぐ ?グ "グ") (?げ ?ゲ "ゲ") (?ご ?ゴ "ゴ") + (?ざ ?ザ "ザ") (?じ ?ジ "ジ") (?ず ?ズ "ズ") (?ぜ ?ゼ "ゼ") (?ぞ ?ゾ "ゾ") + (?だ ?ダ "ダ") (?ぢ ?ヂ "ヂ") (?づ ?ヅ "ヅ") (?で ?デ "デ") (?ど ?ド "ド") + (?ば ?バ "バ") (?び ?ビ "ビ") (?ぶ ?ブ "ブ") (?べ ?ベ "ベ") (?ぼ ?ボ "ボ") + (?ぱ ?パ "パ") (?ぴ ?ピ "ピ") (?ぷ ?プ "プ") (?ぺ ?ペ "ペ") (?ぽ ?ポ "ポ") + (?ぁ ?ァ ?ァ) (?ぃ ?ィ ?ィ) (?ぅ ?ゥ ?ゥ) (?ぇ ?ェ ?ェ) (?ぉ ?ォ ?ォ) + (?っ ?ッ ?ッ) + (?ゃ ?ャ ?ャ) (?ゅ ?ュ ?ュ) (?ょ ?ョ ?ョ) + (?ゎ ?ヮ "ワ") + (?ゝ ?ヽ) (?ゞ ?ヾ) + ("う゛" ?ヴ "ヴ") (nil ?ヵ "カ") (nil ?ヶ "ケ")) "Japanese JISX0208 Kana character table. Each element is of the form (HIRAGANA KATAKANA HANKAKU-KATAKANA), where HIRAGANA and KATAKANA belong to `japanese-jisx0208', @@ -98,15 +96,15 @@ HANKAKU-KATAKANA belongs to `japanese-jisx0201-kana'.") (put-char-code-property jisx0201 'jisx0208 katakana))))) (defconst japanese-symbol-table - '((?\$B!!(B ?\ ) (?$B!$(B ?, ?(I$(B) (?$B!%(B ?. ?(I!(B) (?$B!"(B ?, ?(I$(B) (?$B!#(B ?. ?(I!(B) (?$B!&(B nil ?(I%(B) - (?$B!'(B ?:) (?$B!((B ?\;) (?$B!)(B ??) (?$B!*(B ?!) (?$B!+(B nil ?(I^(B) (?$B!,(B nil ?(I_(B) - (?$B!-(B ?') (?$B!.(B ?`) (?$B!0(B ?^) (?$B!2(B ?_) (?$B!<(B ?- ?(I0(B) (?$B!=(B ?-) (?$B!>(B ?-) - (?$B!?(B ?/) (?$B!@(B ?\\) (?$B!A(B ?~) (?$B!C(B ?|) (?$B!F(B ?`) (?$B!G(B ?') (?$B!H(B ?\") (?$B!I(B ?\") - (?\$B!J(B ?\() (?\$B!K(B ?\)) (?\$B!N(B ?\[) (?\$B!O(B ?\]) (?\$B!P(B ?{) (?\$B!Q(B ?}) - (?$B!R(B ?<) (?$B!S(B ?>) (?\$B!V(B nil ?\(I"(B) (?\$B!W(B nil ?\(I#(B) - (?$B!\(B ?+) (?$B!](B ?-) (?$B!a(B ?=) (?$B!c(B ?<) (?$B!d(B ?>) - (?$B!l(B ?') (?$B!m(B ?\") (?$B!o(B ?\\) (?$B!p(B ?$) (?$B!s(B ?%) (?$B!t(B ?#) (?$B!u(B ?&) (?$B!v(B ?*) - (?$B!w(B ?@) + '((?\ ?\ ) (?, ?, ?、) (?. ?. ?。) (?、 ?, ?、) (?。 ?. ?。) (?・ nil ?・) + (?: ?:) (?; ?\;) (?? ??) (?! ?!) (?゛ nil ?゙) (?゜ nil ?゚) + (?´ ?') (?` ?`) (?^ ?^) (?_ ?_) (?ー ?- ?ー) (?— ?-) (?‐ ?-) + (?/ ?/) (?\ ?\\) (?〜 ?~) (?| ?|) (?‘ ?`) (?’ ?') (?“ ?\") (?” ?\") + (?\( ?\() (?\) ?\)) (?\[ ?\[) (?\] ?\]) (?\{ ?{) (?\} ?}) + (?〈 ?<) (?〉 ?>) (?\「 nil ?\「) (?\」 nil ?\」) + (?+ ?+) (?− ?-) (?= ?=) (?< ?<) (?> ?>) + (?′ ?') (?″ ?\") (?¥ ?\\) (?$ ?$) (?% ?%) (?# ?#) (?& ?&) (?* ?*) + (?@ ?@) ;; cp932-2-byte (#x2015 ?-) (#xFF5E ?~) (#xFF0D ?-)) "Japanese JISX0208 and CP932 symbol character table. @@ -134,18 +132,18 @@ and HANKAKU belongs to `japanese-jisx0201-kana'.") (put-char-code-property jisx0201 'jisx0208 jisx0208)))))) (defconst japanese-alpha-numeric-table - '((?$B#0(B . ?0) (?$B#1(B . ?1) (?$B#2(B . ?2) (?$B#3(B . ?3) (?$B#4(B . ?4) - (?$B#5(B . ?5) (?$B#6(B . ?6) (?$B#7(B . ?7) (?$B#8(B . ?8) (?$B#9(B . ?9) - (?$B#A(B . ?A) (?$B#B(B . ?B) (?$B#C(B . ?C) (?$B#D(B . ?D) (?$B#E(B . ?E) - (?$B#F(B . ?F) (?$B#G(B . ?G) (?$B#H(B . ?H) (?$B#I(B . ?I) (?$B#J(B . ?J) - (?$B#K(B . ?K) (?$B#L(B . ?L) (?$B#M(B . ?M) (?$B#N(B . ?N) (?$B#O(B . ?O) - (?$B#P(B . ?P) (?$B#Q(B . ?Q) (?$B#R(B . ?R) (?$B#S(B . ?S) (?$B#T(B . ?T) - (?$B#U(B . ?U) (?$B#V(B . ?V) (?$B#W(B . ?W) (?$B#X(B . ?X) (?$B#Y(B . ?Y) (?$B#Z(B . ?Z) - (?$B#a(B . ?a) (?$B#b(B . ?b) (?$B#c(B . ?c) (?$B#d(B . ?d) (?$B#e(B . ?e) - (?$B#f(B . ?f) (?$B#g(B . ?g) (?$B#h(B . ?h) (?$B#i(B . ?i) (?$B#j(B . ?j) - (?$B#k(B . ?k) (?$B#l(B . ?l) (?$B#m(B . ?m) (?$B#n(B . ?n) (?$B#o(B . ?o) - (?$B#p(B . ?p) (?$B#q(B . ?q) (?$B#r(B . ?r) (?$B#s(B . ?s) (?$B#t(B . ?t) - (?$B#u(B . ?u) (?$B#v(B . ?v) (?$B#w(B . ?w) (?$B#x(B . ?x) (?$B#y(B . ?y) (?$B#z(B . ?z)) + '((?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)) "Japanese JISX0208 alpha numeric character table. Each element is of the form (ALPHA-NUMERIC . ASCII), where ALPHA-NUMERIC belongs to `japanese-jisx0208', ASCII belongs to `ascii'.") diff --git a/lisp/language/japanese.el b/lisp/language/japanese.el index 9c41a26f36c..7a0fd740e8e 100644 --- a/lisp/language/japanese.el +++ b/lisp/language/japanese.el @@ -1,4 +1,4 @@ -;;; japanese.el --- support for Japanese -*- coding: iso-2022-7bit -*- +;;; japanese.el --- support for Japanese ;; Copyright (C) 1997, 2001-2019 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, @@ -210,7 +210,7 @@ eucJP-ms is defined in <http://www.opengroup.or.jp/jvc/cde/appendix.html>." iso-2022-jp-2) (input-method . "japanese") (features japan-util) - (sample-text . "Japanese ($BF|K\8l(B) $B$3$s$K$A$O(B, (I:]FAJ(B") + (sample-text . "Japanese (日本語) こんにちは, コンニチハ") (documentation . t))) (let ((map @@ -248,7 +248,7 @@ eucJP-ms is defined in <http://www.opengroup.or.jp/jvc/cde/appendix.html>." (define-translation-table 'unicode-to-jisx0213 (char-table-extra-slot table 0))) -(defun compose-gstring-for-variation-glyph (gstring) +(defun compose-gstring-for-variation-glyph (gstring _direction) "Compose glyph-string GSTRING for graphic display. GSTRING must have two glyphs; the first is a glyph for a han character, and the second is a glyph for a variation selector." diff --git a/lisp/language/lao-util.el b/lisp/language/lao-util.el index 92b41e4f801..d2532030ce5 100644 --- a/lisp/language/lao-util.el +++ b/lisp/language/lao-util.el @@ -489,10 +489,10 @@ syllable. In that case, FROM and TO are indexes to STR." lao-str))) ;;;###autoload -(defun lao-composition-function (gstring) +(defun lao-composition-function (gstring direction) (if (= (lgstring-char-len gstring) 1) - (compose-gstring-for-graphic gstring) - (or (font-shape-gstring gstring) + (compose-gstring-for-graphic gstring direction) + (or (font-shape-gstring gstring direction) (let ((glyph-len (lgstring-glyph-len gstring)) (i 0) glyph) diff --git a/lisp/language/misc-lang.el b/lisp/language/misc-lang.el index c1aa79cae45..e25e63b4c5c 100644 --- a/lisp/language/misc-lang.el +++ b/lisp/language/misc-lang.el @@ -101,8 +101,8 @@ thin (i.e. 1-dot width) space." ;; Record error in arabic-change-gstring. (defvar arabic-shape-log nil) -(defun arabic-shape-gstring (gstring) - (setq gstring (font-shape-gstring gstring)) +(defun arabic-shape-gstring (gstring direction) + (setq gstring (font-shape-gstring gstring direction)) (condition-case err (when arabic-shaper-ZWNJ-handling (let ((font (lgstring-font gstring)) diff --git a/lisp/language/romanian.el b/lisp/language/romanian.el index 0a5d0ca0f94..55549c7e86e 100644 --- a/lisp/language/romanian.el +++ b/lisp/language/romanian.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1998, 2001-2019 Free Software Foundation, Inc. -;; Author: Dan Nicolaescu <done@ece.arizona.edu> +;; Author: Dan Nicolaescu <done@ece.arizona.edu> ;; Keywords: multilingual, Romanian, i18n ;; This file is part of GNU Emacs. diff --git a/lisp/language/thai-util.el b/lisp/language/thai-util.el index ee2cf7398ad..e3303954c62 100644 --- a/lisp/language/thai-util.el +++ b/lisp/language/thai-util.el @@ -225,10 +225,10 @@ positions (integers or markers) specifying the region." (thai-compose-region (point-min) (point-max))) ;;;###autoload -(defun thai-composition-function (gstring) +(defun thai-composition-function (gstring direction) (if (= (lgstring-char-len gstring) 1) - (compose-gstring-for-graphic gstring) - (or (font-shape-gstring gstring) + (compose-gstring-for-graphic gstring direction) + (or (font-shape-gstring gstring direction) (let ((glyph-len (lgstring-glyph-len gstring)) (last-char (lgstring-char gstring (1- (lgstring-char-len gstring)))) @@ -256,11 +256,10 @@ positions (integers or markers) specifying the region." (define-minor-mode thai-word-mode "Minor mode to make word-oriented commands aware of Thai words. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. The commands affected are -\\[forward-word], \\[backward-word], \\[kill-word], \\[backward-kill-word], -\\[transpose-words], and \\[fill-paragraph]." + +The commands affected are \\[forward-word], \\[backward-word], +\\[kill-word], \\[backward-kill-word], \\[transpose-words], and +\\[fill-paragraph]." :global t :group 'mule (cond (thai-word-mode ;; This enables linebreak between Thai characters. diff --git a/lisp/language/thai-word.el b/lisp/language/thai-word.el index e67dd093430..94c6ab98979 100644 --- a/lisp/language/thai-word.el +++ b/lisp/language/thai-word.el @@ -4,7 +4,7 @@ ;; National Institute of Advanced Industrial Science and Technology (AIST) ;; Registration Number H14PRO021 -;; Author: Kenichi HANDA <handa@etl.go.jp> +;; Author: Kenichi Handa <handa@gnu.org> ;; Keywords: thai, word break, emacs diff --git a/lisp/language/tibetan.el b/lisp/language/tibetan.el index dac7a9519eb..4be25cecab9 100644 --- a/lisp/language/tibetan.el +++ b/lisp/language/tibetan.el @@ -451,7 +451,7 @@ ;;; (includes some punctuation conversion rules) ;;; (defconst tibetan-precomposition-rule-alist - `(("ཕྱྭ" . "") + '(("ཕྱྭ" . "") ("གྲྭ" . "") ("ཚྭ" . "") ("རྩྭ" . "") diff --git a/lisp/language/tv-util.el b/lisp/language/tv-util.el index a667956a060..7ce8ee1e500 100644 --- a/lisp/language/tv-util.el +++ b/lisp/language/tv-util.el @@ -128,7 +128,7 @@ ;;;###autoload -(defun tai-viet-composition-function (from to font-object string) +(defun tai-viet-composition-function (from to font-object string _direction) (if string (if (string-match tai-viet-re string from) (tai-viet-compose-string from (match-end 0) string)) diff --git a/lisp/language/utf-8-lang.el b/lisp/language/utf-8-lang.el index d31c1a8c5de..d4897c95964 100644 --- a/lisp/language/utf-8-lang.el +++ b/lisp/language/utf-8-lang.el @@ -25,24 +25,24 @@ ;;; Code: (set-language-info-alist - "UTF-8" `((coding-system utf-8) + "UTF-8" '((coding-system utf-8) (coding-priority utf-8) (charset unicode-bmp unicode) -;; Presumably not relevant now. -;; (setup-function -;; . (lambda () -;; ;; Use Unicode font under Windows. Jason Rumney fecit. -;; (if (and (fboundp 'w32-add-charset-info) -;; (not (boundp 'w32-unicode-charset-defined))) -;; (w32-add-charset-info "iso10646-1" 'w32-charset-ansi t)))) -;; Is this appropriate? -;; (exit-function -;; . (lambda () -;; (if (and (fboundp 'w32-add-charset-info) -;; (not (boundp 'w32-unicode-charset-defined))) -;; (setq w32-charset-info-alist -;; (delete (assoc "iso10646-1") -;; w32-charset-info-alist))))) + ;; Presumably not relevant now. + ;; (setup-function + ;; . (lambda () + ;; ;; Use Unicode font under Windows. Jason Rumney fecit. + ;; (if (and (fboundp 'w32-add-charset-info) + ;; (not (boundp 'w32-unicode-charset-defined))) + ;; (w32-add-charset-info "iso10646-1" 'w32-charset-ansi t)))) + ;; Is this appropriate? + ;; (exit-function + ;; . (lambda () + ;; (if (and (fboundp 'w32-add-charset-info) + ;; (not (boundp 'w32-unicode-charset-defined))) + ;; (setq w32-charset-info-alist + ;; (delete (assoc "iso10646-1") + ;; w32-charset-info-alist))))) (input-method . "rfc1345") ; maybe not the best choice (documentation . "\ This language environment is a generic one for the Unicode character set diff --git a/lisp/language/vietnamese.el b/lisp/language/vietnamese.el index bceefe04cc5..432dd3eb54e 100644 --- a/lisp/language/vietnamese.el +++ b/lisp/language/vietnamese.el @@ -72,9 +72,9 @@ (define-coding-system-alias 'viqr 'vietnamese-viqr) (set-language-info-alist - "Vietnamese" `((charset viscii) + "Vietnamese" '((charset viscii) (coding-system vietnamese-viscii vietnamese-vscii - vietnamese-tcvn vietnamese-viqr windows-1258) + vietnamese-tcvn vietnamese-viqr windows-1258) (nonascii-translation . viscii) (coding-priority vietnamese-viscii) (input-method . "vietnamese-viqr") diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index bb9991873df..ab235f6c7b9 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -33,25 +33,17 @@ Quit current game \\[5x5-quit-game] \(fn &optional SIZE)" t nil) (autoload '5x5-crack-randomly "5x5" "\ -Attempt to crack 5x5 using random solutions. - -\(fn)" t nil) +Attempt to crack 5x5 using random solutions." t nil) (autoload '5x5-crack-mutating-current "5x5" "\ -Attempt to crack 5x5 by mutating the current solution. - -\(fn)" t nil) +Attempt to crack 5x5 by mutating the current solution." t nil) (autoload '5x5-crack-mutating-best "5x5" "\ -Attempt to crack 5x5 by mutating the best solution. - -\(fn)" t nil) +Attempt to crack 5x5 by mutating the best solution." t nil) (autoload '5x5-crack-xor-mutate "5x5" "\ Attempt to crack 5x5 by xoring the current and best solution. -Mutate the result. - -\(fn)" t nil) +Mutate the result." t nil) (autoload '5x5-crack "5x5" "\ Attempt to find a solution for 5x5. @@ -99,9 +91,7 @@ Ada mode is the major mode for editing Ada code. ;;; Generated autoloads from progmodes/ada-stmt.el (autoload 'ada-header "ada-stmt" "\ -Insert a descriptive header at the top of the file. - -\(fn)" t nil) +Insert a descriptive header at the top of the file." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ada-stmt" '("ada-"))) @@ -149,9 +139,7 @@ ChangeLog entry, one element will be chosen at random.") (custom-autoload 'add-log-mailing-address "add-log" t) (autoload 'prompt-for-change-log-name "add-log" "\ -Prompt for a change log name. - -\(fn)" nil nil) +Prompt for a change log name." nil nil) (autoload 'find-change-log "add-log" "\ Find a change log file for \\[add-change-log-entry] and return the name. @@ -176,12 +164,18 @@ Optional arg BUFFER-FILE overrides `buffer-file-name'. \(fn &optional FILE-NAME BUFFER-FILE)" nil nil) (autoload 'add-change-log-entry "add-log" "\ -Find change log file, and add an entry for today and an item for this file. -Optional arg WHOAMI (interactive prefix) non-nil means prompt for user -name and email (stored in `add-log-full-name' and `add-log-mailing-address'). - -Second arg FILE-NAME is file name of the change log. -If nil, use the value of `change-log-default-name'. +Find ChangeLog buffer, add an entry for today and an item for this file. +Optional arg WHOAMI (interactive prefix) non-nil means prompt for +user name and email (stored in `add-log-full-name' +and `add-log-mailing-address'). + +Second arg CHANGELOG-FILE-NAME is the file name of the change log. +If nil, use the value of `change-log-default-name'. If the file +thus named exists, it is used for the new entry. If it doesn't +exist, it is created, unless `add-log-dont-create-changelog-file' is t, +in which case a suitably named buffer that doesn't visit any file +is used for keeping entries pertaining to CHANGELOG-FILE-NAME's +directory. Third arg OTHER-WINDOW non-nil means visit in other window. @@ -204,7 +198,7 @@ notices. Today's date is calculated according to `add-log-time-zone-rule' if non-nil, otherwise in local time. -\(fn &optional WHOAMI FILE-NAME OTHER-WINDOW NEW-ENTRY PUT-NEW-ENTRY-ON-NEW-LINE)" t nil) +\(fn &optional WHOAMI CHANGELOG-FILE-NAME OTHER-WINDOW NEW-ENTRY PUT-NEW-ENTRY-ON-NEW-LINE)" t nil) (autoload 'add-change-log-entry-other-window "add-log" "\ Find change log file in other window and add entry and item. @@ -236,9 +230,7 @@ identifiers followed by `:' or `='. See variables `add-log-current-defun-header-regexp' and `add-log-current-defun-function'. -Has a preference of looking backwards. - -\(fn)" nil nil) +Has a preference of looking backwards." nil nil) (autoload 'change-log-merge "add-log" "\ Merge the contents of change log file OTHER-LOG with this buffer. @@ -251,7 +243,7 @@ old-style time formats for entries are supported. \(fn OTHER-LOG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "add-log" '("change-log-" "add-log-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "add-log" '("add-log-" "change-log-"))) ;;;*** @@ -484,16 +476,12 @@ to be colored. \(fn BEG END TITLE &optional RULES EXCLUDE-RULES)" t nil) (autoload 'align-unhighlight-rule "align" "\ -Remove any highlighting that was added by `align-highlight-rule'. - -\(fn)" t nil) +Remove any highlighting that was added by `align-highlight-rule'." t nil) (autoload 'align-newline-and-indent "align" "\ A replacement function for `newline-and-indent', aligning as it goes. The alignment is done by calling `align' on the region that was -indented. - -\(fn)" t nil) +indented." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "align" '("align-"))) @@ -517,9 +505,7 @@ Establishes allout processing as part of visiting a file if `allout-auto-activation' is non-nil, or removes it otherwise. The proper way to use this is through customizing the setting of -`allout-auto-activation'. - -\(fn)" nil nil) +`allout-auto-activation'." nil nil) (defvar allout-auto-activation nil "\ Configure allout outline mode auto-activation. @@ -570,20 +556,16 @@ With value nil, inhibit any automatic allout-mode activation.") (put 'allout-layout 'safe-local-variable (lambda (x) (or (numberp x) (listp x) (memq x '(: * + -))))) -(put 'allout-passphrase-verifier-string 'safe-local-variable 'stringp) - -(put 'allout-passphrase-hint-string 'safe-local-variable 'stringp) - (autoload 'allout-mode-p "allout" "\ -Return t if `allout-mode' is active in current buffer. - -\(fn)" nil t) +Return t if `allout-mode' is active in current buffer." nil t) (autoload 'allout-mode "allout" "\ Toggle Allout outline mode. -With a prefix argument ARG, enable Allout outline mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Allout mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. \\<allout-mode-map-value> Allout outline mode is a minor mode that provides extensive @@ -894,9 +876,11 @@ See `allout-widgets-mode' for allout widgets mode features.") (autoload 'allout-widgets-mode "allout-widgets" "\ Toggle Allout Widgets mode. -With a prefix argument ARG, enable Allout Widgets mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Allout-Widgets mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Allout Widgets mode is an extension of Allout mode that provides graphical decoration of outline structure. It is meant to @@ -941,7 +925,7 @@ directory, so that Emacs will know its current contents. \(fn OPERATION &rest ARGS)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ange-ftp" '("ange-ftp-" "internal-ange-ftp-mode" "ftp-error"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ange-ftp" '("ange-ftp-" "ftp-error" "internal-ange-ftp-mode"))) ;;;*** @@ -984,9 +968,7 @@ the buffer *Birthday-Present-for-Name*. (push (purecopy '(ansi-color 3 4 2)) package--builtin-versions) (autoload 'ansi-color-for-comint-mode-on "ansi-color" "\ -Set `ansi-color-for-comint-mode' to t. - -\(fn)" t nil) +Set `ansi-color-for-comint-mode' to t." t nil) (autoload 'ansi-color-process-output "ansi-color" "\ Maybe translate SGR control sequences of comint output into text properties. @@ -1027,9 +1009,7 @@ the rules. If the file for a super-grammar cannot be determined, special file names are used according to variable `antlr-unknown-file-formats' and a commentary with value `antlr-help-unknown-file-text' is added. The -*Help* buffer always starts with the text in `antlr-help-rules-intro'. - -\(fn)" t nil) +*Help* buffer always starts with the text in `antlr-help-rules-intro'." t nil) (autoload 'antlr-mode "antlr-mode" "\ Major mode for editing ANTLR grammar files. @@ -1038,9 +1018,7 @@ Major mode for editing ANTLR grammar files. (autoload 'antlr-set-tabs "antlr-mode" "\ Use ANTLR's convention for TABs according to `antlr-tab-offset-alist'. -Used in `antlr-mode'. Also a useful function in `java-mode-hook'. - -\(fn)" nil nil) +Used in `antlr-mode'. Also a useful function in `java-mode-hook'." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "antlr-mode" '("antlr-"))) @@ -1221,7 +1199,7 @@ archive. \(fn &optional FORCE)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "arc-mode" '("archive-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "arc-mode" '("arc"))) ;;;*** @@ -1294,7 +1272,7 @@ Entering array mode calls the function `array-mode-hook'. \(fn)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "array" '("array-" "untabify-backward" "move-to-column-untabify" "current-line" "xor" "limit-index"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "array" '("array-" "current-line" "limit-index" "move-to-column-untabify" "untabify-backward" "xor"))) ;;;*** @@ -1304,7 +1282,12 @@ Entering array mode calls the function `array-mode-hook'. (autoload 'artist-mode "artist" "\ Toggle Artist mode. -With argument ARG, turn Artist mode on if ARG is positive. + +If called interactively, enable Artist mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + Artist lets you draw lines, squares, rectangles and poly-lines, ellipses and circles with your mouse and/or keyboard. @@ -1552,12 +1535,25 @@ let-binding.") ;;;### (autoloads nil "auth-source-pass" "auth-source-pass.el" (0 ;;;;;; 0 0 0)) ;;; Generated autoloads from auth-source-pass.el -(push (purecopy '(auth-source-pass 2 0 0)) package--builtin-versions) +(push (purecopy '(auth-source-pass 5 0 0)) package--builtin-versions) (autoload 'auth-source-pass-enable "auth-source-pass" "\ -Enable auth-source-password-store. +Enable auth-source-password-store." nil nil) -\(fn)" nil nil) +(autoload 'auth-source-pass-get "auth-source-pass" "\ +Return the value associated to KEY in the password-store entry ENTRY. + +ENTRY is the name of a password-store entry. +The key used to retrieve the password is the symbol `secret'. + +The convention used as the format for a password-store file is +the following (see http://www.passwordstore.org/#organization): + +secret +key1: value1 +key2: value2 + +\(fn KEY ENTRY)" nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "auth-source-pass" '("auth-source-pass-"))) @@ -1575,9 +1571,6 @@ for a description of this minor mode.") (autoload 'autoarg-mode "autoarg" "\ Toggle Autoarg mode, a global minor mode. -With a prefix argument ARG, enable Autoarg mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. \\<autoarg-mode-map> In Autoarg mode, digits are bound to `digit-argument', i.e. they @@ -1611,9 +1604,11 @@ or call the function `autoarg-kp-mode'.") (autoload 'autoarg-kp-mode "autoarg" "\ Toggle Autoarg-KP mode, a global minor mode. -With a prefix argument ARG, enable Autoarg-KP mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Autoarg-Kp mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. \\<autoarg-kp-mode-map> This is similar to `autoarg-mode' but rebinds the keypad keys @@ -1644,9 +1639,7 @@ Major mode for editing Autoconf configure.ac files. (autoload 'auto-insert "autoinsert" "\ Insert default contents into new files if variable `auto-insert' is non-nil. -Matches the visited file name against the elements of `auto-insert-alist'. - -\(fn)" t nil) +Matches the visited file name against the elements of `auto-insert-alist'." t nil) (autoload 'define-auto-insert "autoinsert" "\ Associate CONDITION with (additional) ACTION in `auto-insert-alist'. @@ -1667,9 +1660,11 @@ or call the function `auto-insert-mode'.") (autoload 'auto-insert-mode "autoinsert" "\ Toggle Auto-insert mode, a global minor mode. -With a prefix argument ARG, enable Auto-insert mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Auto-Insert mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. 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. @@ -1726,11 +1721,9 @@ write its autoloads into the specified file instead. Update loaddefs.el autoloads in batch mode. Calls `update-directory-autoloads' on the command line arguments. Definitions are written to `generated-autoload-file' (which -should be non-nil). - -\(fn)" nil nil) +should be non-nil)." nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "autoload" '("autoload-" "generate" "no-update-autoloads" "make-autoload"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "autoload" '("autoload-" "generate" "make-autoload" "no-update-autoloads"))) ;;;*** @@ -1739,9 +1732,11 @@ should be non-nil). (autoload 'auto-revert-mode "autorevert" "\ Toggle reverting buffer when the file changes (Auto-Revert Mode). -With a prefix argument ARG, enable Auto-Revert Mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Auto-Revert mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Auto-Revert Mode is a minor mode that affects only the current buffer. When enabled, it reverts the buffer when the file on @@ -1760,15 +1755,15 @@ without being changed in the part that is already in the buffer. Turn on Auto-Revert Mode. This function is designed to be added to hooks, for example: - (add-hook \\='c-mode-hook #\\='turn-on-auto-revert-mode) - -\(fn)" nil nil) + (add-hook \\='c-mode-hook #\\='turn-on-auto-revert-mode)" nil nil) (autoload 'auto-revert-tail-mode "autorevert" "\ Toggle reverting tail of buffer when the file grows. -With a prefix argument ARG, enable Auto-Revert Tail Mode if ARG -is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. + +If called interactively, enable Auto-Revert-Tail mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. When Auto-Revert Tail Mode is enabled, the tail of the file is constantly followed, as with the shell command `tail -f'. This @@ -1791,9 +1786,7 @@ Use `auto-revert-mode' for changes other than appends! Turn on Auto-Revert Tail Mode. This function is designed to be added to hooks, for example: - (add-hook \\='my-logfile-mode-hook #\\='turn-on-auto-revert-tail-mode) - -\(fn)" nil nil) + (add-hook \\='my-logfile-mode-hook #\\='turn-on-auto-revert-tail-mode)" nil nil) (defvar global-auto-revert-mode nil "\ Non-nil if Global Auto-Revert mode is enabled. @@ -1807,9 +1800,11 @@ or call the function `global-auto-revert-mode'.") (autoload 'global-auto-revert-mode "autorevert" "\ Toggle Global Auto-Revert Mode. -With a prefix argument ARG, enable Global Auto-Revert Mode if ARG -is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. + +If called interactively, enable Global Auto-Revert mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Global Auto-Revert Mode is a global minor mode that reverts any buffer associated with a file when the file changes on disk. Use @@ -1882,6 +1877,19 @@ definition of \"random distance\".) ;;;*** +;;;### (autoloads nil "backtrace" "emacs-lisp/backtrace.el" (0 0 +;;;;;; 0 0)) +;;; Generated autoloads from emacs-lisp/backtrace.el +(push (purecopy '(backtrace 1 0)) package--builtin-versions) + +(autoload 'backtrace "backtrace" "\ +Print a trace of Lisp function calls currently active. +Output stream used is value of `standard-output'." nil nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "backtrace" '("backtrace-"))) + +;;;*** + ;;;### (autoloads nil "bat-mode" "progmodes/bat-mode.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/bat-mode.el @@ -1909,9 +1917,7 @@ Run script using `bat-run' and `bat-run-args'. (autoload 'battery "battery" "\ Display battery status information in the echo area. The text being displayed in the echo area is controlled by the variables -`battery-echo-area-format' and `battery-status-function'. - -\(fn)" t nil) +`battery-echo-area-format' and `battery-status-function'." t nil) (defvar display-battery-mode nil "\ Non-nil if Display-Battery mode is enabled. @@ -1925,9 +1931,11 @@ or call the function `display-battery-mode'.") (autoload 'display-battery-mode "battery" "\ Toggle battery status display in mode line (Display Battery mode). -With a prefix argument ARG, enable Display Battery mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Display-Battery mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. The text displayed in the mode line is controlled by `battery-mode-line-format' and `battery-status-function'. @@ -1983,7 +1991,7 @@ For non-interactive use see also `benchmark-run' and ;;;### (autoloads nil "bib-mode" "textmodes/bib-mode.el" (0 0 0 0)) ;;; Generated autoloads from textmodes/bib-mode.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bib-mode" '("bib-" "unread-bib" "mark-bib" "return-key-bib" "addbib"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bib-mode" '("addbib" "bib-" "mark-bib" "return-key-bib" "unread-bib"))) ;;;*** @@ -2243,7 +2251,7 @@ a reflection. \(fn NUM)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "blackbox" '("blackbox-" "bb-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "blackbox" '("bb-" "blackbox-"))) ;;;*** @@ -2254,11 +2262,11 @@ 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 "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 "l" 'bookmark-load) (define-key map "w" 'bookmark-write) (define-key map "s" 'bookmark-save) map) "\ +(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 "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 `bookmark-map'. All interactive bookmark +key of your choice to variable `bookmark-map'. All interactive bookmark functions have a binding in this keymap.") (fset 'bookmark-map bookmark-map) @@ -2345,6 +2353,11 @@ Jump to BOOKMARK in another window. See `bookmark-jump' for more. \(fn BOOKMARK)" t nil) +(autoload 'bookmark-jump-other-frame "bookmark" "\ +Jump to BOOKMARK in another frame. See `bookmark-jump' for more. + +\(fn BOOKMARK)" t nil) + (autoload 'bookmark-relocate "bookmark" "\ Relocate BOOKMARK-NAME to another file, reading file name with minibuffer. @@ -2403,37 +2416,32 @@ probably because we were called from there. \(fn BOOKMARK-NAME &optional BATCH)" t nil) (autoload 'bookmark-write "bookmark" "\ -Write bookmarks to a file (reading the file name with the minibuffer). - -\(fn)" t nil) +Write bookmarks to a file (reading the file name with the minibuffer)." t nil) (function-put 'bookmark-write 'interactive-only 'bookmark-save) (autoload 'bookmark-save "bookmark" "\ -Save currently defined bookmarks. -Saves by default in the file defined by the variable -`bookmark-default-file'. With a prefix arg, save it in file FILE -\(second argument). - -If you are calling this from Lisp, the two arguments are PARG and -FILE, and if you just want it to write to the default file, then -pass no arguments. Or pass in nil and FILE, and it will save in FILE -instead. If you pass in one argument, and it is non-nil, then the -user will be interactively queried for a file to save in. +Save currently defined bookmarks in FILE. +FILE defaults to `bookmark-default-file'. +With prefix PARG, query user for a file to save in. +If MAKE-DEFAULT is non-nil (interactively with prefix C-u C-u) +the file we save in becomes the new default in the current Emacs +session (without affecting the value of `bookmark-default-file'.). When you want to load in the bookmarks from a file, use `bookmark-load', \\[bookmark-load]. That function will prompt you for a file, defaulting to the file defined by variable `bookmark-default-file'. -\(fn &optional PARG FILE)" t nil) +\(fn &optional PARG FILE MAKE-DEFAULT)" t nil) (autoload 'bookmark-load "bookmark" "\ Load bookmarks from FILE (which must be in bookmark format). -Appends loaded bookmarks to the front of the list of bookmarks. If -optional second argument OVERWRITE is non-nil, existing bookmarks are -destroyed. Optional third arg NO-MSG means don't display any messages -while loading. +Appends loaded bookmarks to the front of the list of bookmarks. +If argument OVERWRITE is non-nil, existing bookmarks are destroyed. +Optional third arg NO-MSG means don't display any messages while loading. +If DEFAULT is non-nil make FILE the new bookmark file to watch. +Interactively, a prefix arg makes OVERWRITE and DEFAULT non-nil. If you load a file that doesn't contain a proper bookmark alist, you will corrupt Emacs's bookmark list. Generally, you should only load @@ -2446,30 +2454,26 @@ If you load a file containing bookmarks with the same names as bookmarks already present in your Emacs, the new bookmarks will get unique numeric suffixes \"<2>\", \"<3>\", etc. -\(fn FILE &optional OVERWRITE NO-MSG)" t nil) +\(fn FILE &optional OVERWRITE NO-MSG DEFAULT)" t nil) (autoload 'bookmark-bmenu-list "bookmark" "\ Display a list of existing bookmarks. The list is displayed in a buffer named `*Bookmark List*'. The leftmost column displays a D if the bookmark is flagged for -deletion, or > if it is flagged for displaying. - -\(fn)" t nil) +deletion, or > if it is flagged for displaying." t nil) (defalias 'list-bookmarks 'bookmark-bmenu-list) (defalias 'edit-bookmarks 'bookmark-bmenu-list) (autoload 'bookmark-bmenu-search "bookmark" "\ -Incremental search of bookmarks, hiding the non-matches as we go. - -\(fn)" t nil) +Incremental search of bookmarks, hiding the non-matches as we go." t nil) (defvar menu-bar-bookmark-map (let ((map (make-sparse-keymap "Bookmark functions"))) (bindings--define-key map [load] '(menu-item "Load a Bookmark File..." bookmark-load :help "Load bookmarks from a bookmark file)")) (bindings--define-key map [write] '(menu-item "Save Bookmarks As..." bookmark-write :help "Write bookmarks to a file (reading the file name with the minibuffer)")) (bindings--define-key map [save] '(menu-item "Save Bookmarks" bookmark-save :help "Save currently defined bookmarks")) (bindings--define-key map [edit] '(menu-item "Edit Bookmark List" bookmark-bmenu-list :help "Display a list of existing bookmarks")) (bindings--define-key map [delete] '(menu-item "Delete Bookmark..." bookmark-delete :help "Delete a bookmark from the bookmark list")) (bindings--define-key map [rename] '(menu-item "Rename Bookmark..." bookmark-rename :help "Change the name of a bookmark")) (bindings--define-key map [locate] '(menu-item "Insert Location..." bookmark-locate :help "Insert the name of the file associated with a bookmark")) (bindings--define-key map [insert] '(menu-item "Insert Contents..." bookmark-insert :help "Insert the text of the file pointed to by a bookmark")) (bindings--define-key map [set] '(menu-item "Set Bookmark..." bookmark-set :help "Set a bookmark named inside a file.")) (bindings--define-key map [jump] '(menu-item "Jump to Bookmark..." bookmark-jump :help "Jump to a bookmark (a point in some file)")) map)) (defalias 'menu-bar-bookmark-map menu-bar-bookmark-map) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bookmark" '("bookmark" "with-buffer-modified-unmodified"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bookmark" '("bookmark-" "with-buffer-modified-unmodified"))) ;;;*** @@ -2507,9 +2511,7 @@ narrowed. \(fn &optional BUFFER)" t nil) (autoload 'browse-url-of-dired-file "browse-url" "\ -In Dired, ask a WWW browser to display the file named on this line. - -\(fn)" t nil) +In Dired, ask a WWW browser to display the file named on this line." t nil) (autoload 'browse-url-of-region "browse-url" "\ Ask a WWW browser to display the current region. @@ -2646,8 +2648,10 @@ used instead of `browse-url-new-window-flag'. (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 +currently selected window instead. -\(fn URL &optional NEW-WINDOW)" t nil) +\(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'. @@ -2830,21 +2834,15 @@ from `browse-url-elinks-wrapper'. (autoload 'bs-cycle-next "bs" "\ Select next buffer defined by buffer cycling. The buffers taking part in buffer cycling are defined -by buffer configuration `bs-cycle-configuration-name'. - -\(fn)" t nil) +by buffer configuration `bs-cycle-configuration-name'." t nil) (autoload 'bs-cycle-previous "bs" "\ Select previous buffer defined by buffer cycling. The buffers taking part in buffer cycling are defined -by buffer configuration `bs-cycle-configuration-name'. - -\(fn)" t nil) +by buffer configuration `bs-cycle-configuration-name'." t nil) (autoload 'bs-customize "bs" "\ -Customization of group bs for Buffer Selection Menu. - -\(fn)" t nil) +Customization of group bs for Buffer Selection Menu." t nil) (autoload 'bs-show "bs" "\ Make a menu of buffers so you can manipulate buffers or the buffer list. @@ -2881,9 +2879,7 @@ columns on its right towards the left. \\[bubbles-set-game-easy] sets the difficulty to easy. \\[bubbles-set-game-medium] sets the difficulty to medium. \\[bubbles-set-game-difficult] sets the difficulty to difficult. -\\[bubbles-set-game-hard] sets the difficulty to hard. - -\(fn)" t nil) +\\[bubbles-set-game-hard] sets the difficulty to hard." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bubbles" '("bubbles-"))) @@ -2899,15 +2895,22 @@ columns on its right towards the left. (autoload 'bug-reference-mode "bug-reference" "\ Toggle hyperlinking bug references in the buffer (Bug Reference mode). -With a prefix argument ARG, enable Bug Reference mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Bug-Reference mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. \(fn &optional ARG)" t nil) (autoload 'bug-reference-prog-mode "bug-reference" "\ Like `bug-reference-mode', but only buttonize in comments and strings. +If called interactively, enable Bug-Reference-Prog mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + \(fn &optional ARG)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bug-reference" '("bug-reference-"))) @@ -3016,9 +3019,7 @@ invoked interactively. (autoload 'batch-byte-compile-if-not-done "bytecomp" "\ Like `byte-compile-file' but doesn't recompile if already up to date. Use this from the command line, with `-batch'; -it won't work in an interactive Emacs. - -\(fn)" nil nil) +it won't work in an interactive Emacs." nil nil) (autoload 'batch-byte-compile "bytecomp" "\ Run `byte-compile-file' on the files remaining on the command line. @@ -3042,7 +3043,7 @@ and corresponding effects. \(fn &optional ARG)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bytecomp" '("batch-byte-compile-file" "byte-" "no-byte-compile" "displaying-byte-compile-warnings" "emacs-lisp-file-regexp"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bytecomp" '("batch-byte-compile-file" "byte-" "displaying-byte-compile-warnings" "emacs-lisp-" "no-byte-compile"))) ;;;*** @@ -3050,7 +3051,7 @@ and corresponding effects. ;;;;;; 0)) ;;; Generated autoloads from calendar/cal-bahai.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-bahai" '("diary-bahai-" "calendar-bahai-" "holiday-bahai"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-bahai" '("calendar-bahai-" "diary-bahai-" "holiday-bahai"))) ;;;*** @@ -3060,7 +3061,7 @@ and corresponding effects. (put 'calendar-chinese-time-zone 'risky-local-variable t) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-china" '("diary-chinese-" "calendar-chinese-" "holiday-chinese"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-china" '("calendar-chinese-" "diary-chinese-" "holiday-chinese"))) ;;;*** @@ -3068,7 +3069,7 @@ and corresponding effects. ;;;;;; 0 0)) ;;; Generated autoloads from calendar/cal-coptic.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-coptic" '("diary-" "calendar-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-coptic" '("calendar-" "diary-"))) ;;;*** @@ -3081,7 +3082,7 @@ and corresponding effects. (put 'calendar-current-time-zone-cache 'risky-local-variable t) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-dst" '("dst-" "calendar-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-dst" '("calendar-" "dst-"))) ;;;*** @@ -3089,7 +3090,7 @@ and corresponding effects. ;;;;;; 0 0)) ;;; Generated autoloads from calendar/cal-french.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-french" '("diary-french-date" "calendar-french-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-french" '("calendar-french-" "diary-french-date"))) ;;;*** @@ -3104,7 +3105,7 @@ from the cursor position. \(fn DEATH-DATE START-YEAR END-YEAR)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-hebrew" '("diary-hebrew-" "calendar-hebrew-" "holiday-hebrew"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-hebrew" '("calendar-hebrew-" "diary-hebrew-" "holiday-hebrew"))) ;;;*** @@ -3119,14 +3120,14 @@ from the cursor position. ;;;;;; 0)) ;;; Generated autoloads from calendar/cal-islam.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-islam" '("diary-islamic-" "calendar-islamic-" "holiday-islamic"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-islam" '("calendar-islamic-" "diary-islamic-" "holiday-islamic"))) ;;;*** ;;;### (autoloads nil "cal-iso" "calendar/cal-iso.el" (0 0 0 0)) ;;; Generated autoloads from calendar/cal-iso.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-iso" '("diary-iso-date" "calendar-iso-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-iso" '("calendar-iso-" "diary-iso-date"))) ;;;*** @@ -3134,7 +3135,7 @@ from the cursor position. ;;;;;; 0 0)) ;;; Generated autoloads from calendar/cal-julian.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-julian" '("diary-" "calendar-" "holiday-julian"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-julian" '("calendar-" "diary-" "holiday-julian"))) ;;;*** @@ -3142,7 +3143,7 @@ from the cursor position. ;;;;;; 0)) ;;; Generated autoloads from calendar/cal-mayan.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-mayan" '("diary-mayan-date" "calendar-mayan-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-mayan" '("calendar-mayan-" "diary-mayan-date"))) ;;;*** @@ -3164,7 +3165,7 @@ from the cursor position. ;;;;;; 0 0)) ;;; Generated autoloads from calendar/cal-persia.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-persia" '("diary-persian-date" "calendar-persian-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-persia" '("calendar-persian-" "diary-persian-date"))) ;;;*** @@ -3266,7 +3267,7 @@ See Info node `(calc)Defining Functions'. (function-put 'defmath 'doc-string-elt '3) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc" '("math-" "calc" "var-" "inexact-result" "defcalcmodevar"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc" '("calc" "defcalcmodevar" "inexact-result" "math-" "var-"))) ;;;*** @@ -3274,35 +3275,35 @@ See Info node `(calc)Defining Functions'. ;;;;;; (0 0 0 0)) ;;; Generated autoloads from calc/calc-aent.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-aent" '("math-" "calc"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-aent" '("calc" "math-"))) ;;;*** ;;;### (autoloads nil "calc-alg" "calc/calc-alg.el" (0 0 0 0)) ;;; Generated autoloads from calc/calc-alg.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-alg" '("math-" "calc"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-alg" '("calc" "math-"))) ;;;*** ;;;### (autoloads nil "calc-arith" "calc/calc-arith.el" (0 0 0 0)) ;;; Generated autoloads from calc/calc-arith.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-arith" '("math-" "calc"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-arith" '("calc" "math-"))) ;;;*** ;;;### (autoloads nil "calc-bin" "calc/calc-bin.el" (0 0 0 0)) ;;; Generated autoloads from calc/calc-bin.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-bin" '("math-" "calc"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-bin" '("calc" "math-"))) ;;;*** ;;;### (autoloads nil "calc-comb" "calc/calc-comb.el" (0 0 0 0)) ;;; Generated autoloads from calc/calc-comb.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-comb" '("math-" "calc"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-comb" '("calc" "math-"))) ;;;*** @@ -3338,7 +3339,7 @@ See Info node `(calc)Defining Functions'. ;;;### (autoloads nil "calc-forms" "calc/calc-forms.el" (0 0 0 0)) ;;; Generated autoloads from calc/calc-forms.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-forms" '("math-" "calc" "var-TimeZone"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-forms" '("calc" "math-" "var-TimeZone"))) ;;;*** @@ -3387,7 +3388,7 @@ See Info node `(calc)Defining Functions'. ;;;### (autoloads nil "calc-lang" "calc/calc-lang.el" (0 0 0 0)) ;;; Generated autoloads from calc/calc-lang.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-lang" '("math-" "calc-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-lang" '("calc-" "math-"))) ;;;*** @@ -3401,7 +3402,7 @@ See Info node `(calc)Defining Functions'. ;;;### (autoloads nil "calc-map" "calc/calc-map.el" (0 0 0 0)) ;;; Generated autoloads from calc/calc-map.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-map" '("math-" "calc"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-map" '("calc" "math-"))) ;;;*** @@ -3458,14 +3459,14 @@ See Info node `(calc)Defining Functions'. ;;;### (autoloads nil "calc-prog" "calc/calc-prog.el" (0 0 0 0)) ;;; Generated autoloads from calc/calc-prog.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-prog" '("math-" "calc" "var-q"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-prog" '("calc" "math-" "var-q"))) ;;;*** ;;;### (autoloads nil "calc-rewr" "calc/calc-rewr.el" (0 0 0 0)) ;;; Generated autoloads from calc/calc-rewr.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-rewr" '("math-" "calc"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-rewr" '("calc" "math-"))) ;;;*** @@ -3486,7 +3487,7 @@ See Info node `(calc)Defining Functions'. ;;;### (autoloads nil "calc-stat" "calc/calc-stat.el" (0 0 0 0)) ;;; Generated autoloads from calc/calc-stat.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-stat" '("math-" "calc"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-stat" '("calc" "math-"))) ;;;*** @@ -3500,7 +3501,7 @@ See Info node `(calc)Defining Functions'. ;;;### (autoloads nil "calc-stuff" "calc/calc-stuff.el" (0 0 0 0)) ;;; Generated autoloads from calc/calc-stuff.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-stuff" '("math-" "calc"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-stuff" '("calc" "math-"))) ;;;*** @@ -3533,7 +3534,7 @@ See Info node `(calc)Defining Functions'. ;;;### (autoloads nil "calc-vec" "calc/calc-vec.el" (0 0 0 0)) ;;; Generated autoloads from calc/calc-vec.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-vec" '("math-" "calc"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-vec" '("calc" "math-"))) ;;;*** @@ -3555,14 +3556,14 @@ See Info node `(calc)Defining Functions'. ;;;### (autoloads nil "calcalg3" "calc/calcalg3.el" (0 0 0 0)) ;;; Generated autoloads from calc/calcalg3.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calcalg3" '("math-" "calc"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calcalg3" '("calc" "math-"))) ;;;*** ;;;### (autoloads nil "calccomp" "calc/calccomp.el" (0 0 0 0)) ;;; Generated autoloads from calc/calccomp.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calccomp" '("math-" "calcFunc-c"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calccomp" '("calcFunc-c" "math-"))) ;;;*** @@ -3578,9 +3579,7 @@ See Info node `(calc)Defining Functions'. (autoload 'calculator "calculator" "\ Run the Emacs calculator. -See the documentation for `calculator-mode' for more information. - -\(fn)" t nil) +See the documentation for `calculator-mode' for more information." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calculator" '("calculator-"))) @@ -3626,7 +3625,7 @@ This function is suitable for execution in an init file. \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calendar" '("calendar-" "solar-sunrises-buffer" "lunar-phases-buffer" "diary-" "holiday-buffer"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calendar" '("calendar-" "diary-" "holiday-buffer" "lunar-phases-buffer" "solar-sunrises-buffer"))) ;;;*** @@ -3659,7 +3658,7 @@ it fails. ;;;### (autoloads nil "cc-awk" "progmodes/cc-awk.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/cc-awk.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-awk" '("c-awk-" "awk-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-awk" '("awk-" "c-awk-"))) ;;;*** @@ -3681,7 +3680,7 @@ it fails. ;;;### (autoloads nil "cc-defs" "progmodes/cc-defs.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/cc-defs.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-defs" '("cc-bytecomp-compiling-or-loading" "c-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-defs" '("c-" "cc-bytecomp-compiling-or-loading"))) ;;;*** @@ -3690,9 +3689,7 @@ it fails. ;;; Generated autoloads from progmodes/cc-engine.el (autoload 'c-guess-basic-syntax "cc-engine" "\ -Return the syntactic context of the current line. - -\(fn)" nil nil) +Return the syntactic context of the current line." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-engine" '("c-"))) @@ -3701,7 +3698,7 @@ Return the syntactic context of the current line. ;;;### (autoloads nil "cc-fonts" "progmodes/cc-fonts.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/cc-fonts.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-fonts" '("autodoc-" "java" "gtkdoc-font-lock-" "c++-font-lock-keywords" "c-" "pike-font-lock-keywords" "idl-font-lock-keywords" "objc-font-lock-keywords"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-fonts" '("autodoc-" "c++-font-lock-keywords" "c-" "gtkdoc-font-lock-" "idl-font-lock-keywords" "java" "objc-font-lock-keywords" "pike-font-lock-keywords"))) ;;;*** @@ -3821,6 +3818,7 @@ the absolute file name of the file if STYLE-NAME is nil. ;;;### (autoloads nil "cc-mode" "progmodes/cc-mode.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/cc-mode.el +(push (purecopy '(cc-mode 5 33 1)) package--builtin-versions) (autoload 'c-initialize-cc-mode "cc-mode" "\ Initialize CC Mode for use in the current buffer. @@ -3869,9 +3867,7 @@ should be used. This function attempts to use file contents to determine whether the code is C or C++ and based on that chooses whether to enable -`c-mode' or `c++-mode'. - -\(fn)" nil nil) +`c-mode' or `c++-mode'." nil nil) (autoload 'c++-mode "cc-mode" "\ Major mode for editing C++ code. @@ -3990,7 +3986,7 @@ Key bindings: \(fn)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-mode" '("c++-mode-" "c-" "awk-mode-map" "pike-mode-" "idl-mode-" "java-mode-" "objc-mode-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-mode" '("awk-mode-map" "c++-mode-" "c-" "idl-mode-" "java-mode-" "objc-mode-" "pike-mode-"))) ;;;*** @@ -4054,7 +4050,7 @@ and exists only for compatibility reasons. (put 'c-backslash-column 'safe-local-variable 'integerp) (put 'c-file-style 'safe-local-variable 'string-or-null-p) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-vars" '("c++-" "c-" "pike-" "idl-" "java-" "objc-" "awk-mode-hook" "defcustom-c-stylevar"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-vars" '("awk-mode-hook" "c++-" "c-" "defcustom-c-stylevar" "idl-" "java-" "objc-" "pike-"))) ;;;*** @@ -4444,9 +4440,7 @@ to the action header. \(fn)" t nil) (autoload 'cfengine-auto-mode "cfengine" "\ -Choose `cfengine2-mode' or `cfengine3-mode' by buffer contents. - -\(fn)" t nil) +Choose `cfengine2-mode' or `cfengine3-mode' by buffer contents." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cfengine" '("cfengine"))) @@ -4524,9 +4518,7 @@ Return t when OBJ is a list of strings. (autoload 'checkdoc "checkdoc" "\ Interactively check the entire buffer for style errors. The current status of the check will be displayed in a buffer which -the users will view as each check is completed. - -\(fn)" t nil) +the users will view as each check is completed." t nil) (autoload 'checkdoc-interactive "checkdoc" "\ Interactively check the current buffer for doc string errors. @@ -4554,9 +4546,7 @@ checkdoc status window instead of the usual behavior. Evaluate and check documentation for the current buffer. Evaluation is done first because good documentation for something that doesn't work is just not useful. Comments, doc strings, and rogue -spacing are all verified. - -\(fn)" t nil) +spacing are all verified." t nil) (autoload 'checkdoc-current-buffer "checkdoc" "\ Check current buffer for document, comment, error style, and rogue spaces. @@ -4614,9 +4604,7 @@ Optional argument TAKE-NOTES causes all errors to be logged. Evaluate the current form with `eval-defun' and check its documentation. Evaluation is done first so the form will be read before the documentation is checked. If there is a documentation error, then the display -of what was evaluated will be overwritten by the diagnostic message. - -\(fn)" t nil) +of what was evaluated will be overwritten by the diagnostic message." t nil) (autoload 'checkdoc-defun "checkdoc" "\ Examine the doc string of the function or variable under point. @@ -4630,71 +4618,55 @@ space at the end of each line. (autoload 'checkdoc-ispell "checkdoc" "\ Check the style and spelling of everything interactively. Calls `checkdoc' with spell-checking turned on. -Prefix argument is the same as for `checkdoc' - -\(fn)" t nil) +Prefix argument is the same as for `checkdoc'" t nil) (autoload 'checkdoc-ispell-current-buffer "checkdoc" "\ Check the style and spelling of the current buffer. Calls `checkdoc-current-buffer' with spell-checking turned on. -Prefix argument is the same as for `checkdoc-current-buffer' - -\(fn)" t nil) +Prefix argument is the same as for `checkdoc-current-buffer'" t nil) (autoload 'checkdoc-ispell-interactive "checkdoc" "\ Check the style and spelling of the current buffer interactively. Calls `checkdoc-interactive' with spell-checking turned on. -Prefix argument is the same as for `checkdoc-interactive' - -\(fn)" t nil) +Prefix argument is the same as for `checkdoc-interactive'" t nil) (autoload 'checkdoc-ispell-message-interactive "checkdoc" "\ Check the style and spelling of message text interactively. Calls `checkdoc-message-interactive' with spell-checking turned on. -Prefix argument is the same as for `checkdoc-message-interactive' - -\(fn)" t nil) +Prefix argument is the same as for `checkdoc-message-interactive'" t nil) (autoload 'checkdoc-ispell-message-text "checkdoc" "\ Check the style and spelling of message text interactively. Calls `checkdoc-message-text' with spell-checking turned on. -Prefix argument is the same as for `checkdoc-message-text' - -\(fn)" t nil) +Prefix argument is the same as for `checkdoc-message-text'" t nil) (autoload 'checkdoc-ispell-start "checkdoc" "\ Check the style and spelling of the current buffer. Calls `checkdoc-start' with spell-checking turned on. -Prefix argument is the same as for `checkdoc-start' - -\(fn)" t nil) +Prefix argument is the same as for `checkdoc-start'" t nil) (autoload 'checkdoc-ispell-continue "checkdoc" "\ Check the style and spelling of the current buffer after point. Calls `checkdoc-continue' with spell-checking turned on. -Prefix argument is the same as for `checkdoc-continue' - -\(fn)" t nil) +Prefix argument is the same as for `checkdoc-continue'" t nil) (autoload 'checkdoc-ispell-comments "checkdoc" "\ Check the style and spelling of the current buffer's comments. Calls `checkdoc-comments' with spell-checking turned on. -Prefix argument is the same as for `checkdoc-comments' - -\(fn)" t nil) +Prefix argument is the same as for `checkdoc-comments'" t nil) (autoload 'checkdoc-ispell-defun "checkdoc" "\ Check the style and spelling of the current defun with Ispell. Calls `checkdoc-defun' with spell-checking turned on. -Prefix argument is the same as for `checkdoc-defun' - -\(fn)" t nil) +Prefix argument is the same as for `checkdoc-defun'" t nil) (autoload 'checkdoc-minor-mode "checkdoc" "\ Toggle automatic docstring checking (Checkdoc minor mode). -With a prefix argument ARG, enable Checkdoc minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Checkdoc minor mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. 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 @@ -4705,9 +4677,7 @@ checking of documentation strings. \(fn &optional ARG)" t nil) (autoload 'checkdoc-package-keywords "checkdoc" "\ -Find package keywords that aren't in `finder-known-keywords'. - -\(fn)" t nil) +Find package keywords that aren't in `finder-known-keywords'." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "checkdoc" '("checkdoc-"))) @@ -4724,9 +4694,7 @@ Return the length of resulting text. \(fn BEG END)" t nil) (autoload 'decode-hz-buffer "china-util" "\ -Decode HZ/ZW encoded text in the current buffer. - -\(fn)" t nil) +Decode HZ/ZW encoded text in the current buffer." t nil) (autoload 'encode-hz-region "china-util" "\ Encode the text in the current region to HZ. @@ -4735,9 +4703,7 @@ Return the length of resulting text. \(fn BEG END)" t nil) (autoload 'encode-hz-buffer "china-util" "\ -Encode the text in the current buffer to HZ. - -\(fn)" t nil) +Encode the text in the current buffer to HZ." t nil) (autoload 'post-read-decode-hz "china-util" "\ @@ -4749,7 +4715,7 @@ Encode the text in the current buffer to HZ. \(fn FROM TO)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "china-util" '("hz/zw-start-gb" "hz-" "decode-hz-line-continuation" "zw-start-gb" "iso2022-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "china-util" '("decode-hz-line-continuation" "hz-" "hz/zw-start-gb" "iso2022-" "zw-start-gb"))) ;;;*** @@ -4771,9 +4737,7 @@ The number of commands listed is controlled by `list-command-history-max'. Calls value of `list-command-history-filter' (if non-nil) on each history element to judge if that element should be excluded from the list. -The buffer is left in Command History mode. - -\(fn)" t nil) +The buffer is left in Command History mode." t nil) (autoload 'command-history "chistory" "\ Examine commands from `command-history' in a buffer. @@ -4786,18 +4750,16 @@ and digits provide prefix arguments. Tab does not indent. \\{command-history-map} This command always recompiles the Command History listing -and runs the normal hook `command-history-hook'. +and runs the normal hook `command-history-hook'." t nil) -\(fn)" t nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "chistory" '("command-history-" "list-command-history-" "default-command-history-filter"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "chistory" '("command-history-" "default-command-history-filter" "list-command-history-"))) ;;;*** ;;;### (autoloads nil "cl" "emacs-lisp/cl.el" (0 0 0 0)) ;;; Generated autoloads from emacs-lisp/cl.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl" '("cl-" "defsetf" "define-" "lexical-let" "labels" "flet"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl" '("cl-" "define-" "defsetf" "flet" "labels" "lexical-let"))) ;;;*** @@ -4898,7 +4860,7 @@ instead. \(fn INDENT-POINT STATE)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-indent" '("lisp-" "common-lisp-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-indent" '("common-lisp-" "lisp-"))) ;;;*** @@ -4934,6 +4896,11 @@ 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. +If called interactively, enable Cl-Old-Struct-Compat mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + \(fn &optional ARG)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-lib" '("cl-"))) @@ -4961,6 +4928,13 @@ call other entry points instead, such as `cl-prin1'. \(fn OBJECT STREAM)" nil nil) +(autoload 'cl-print-expand-ellipsis "cl-print" "\ +Print the expansion of an ellipsis to STREAM. +VALUE should be the value of the `cl-print-ellipsis' text property +which was attached to the ellipsis by `cl-prin1'. + +\(fn VALUE STREAM)" nil nil) + (autoload 'cl-prin1 "cl-print" "\ Print OBJECT on STREAM according to its type. Output is further controlled by the variables @@ -4975,6 +4949,24 @@ Return a string containing the `cl-prin1'-printed representation of OBJECT. \(fn OBJECT)" nil nil) +(autoload 'cl-print-to-string-with-limit "cl-print" "\ +Return a string containing a printed representation of VALUE. +Attempt to get the length of the returned string under LIMIT +characters with appropriate settings of `print-level' and +`print-length.' Use PRINT-FUNCTION to print, which should take +the arguments VALUE and STREAM and which should respect +`print-length' and `print-level'. LIMIT may be nil or zero in +which case PRINT-FUNCTION will be called with `print-level' and +`print-length' bound to nil. + +Use this function with `cl-prin1' to print an object, +abbreviating it with ellipses to fit within a size limit. Use +this function with `cl-prin1-expand-ellipsis' to expand an +ellipsis, abbreviating the expansion to stay within a size +limit. + +\(fn PRINT-FUNCTION VALUE LIMIT)" nil nil) + (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-print" '("cl-print-" "help-byte-code"))) ;;;*** @@ -5027,7 +5019,7 @@ is run). \(fn CMD)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cmuscheme" '("cmuscheme-load-hook" "switch-to-scheme" "scheme-" "inferior-scheme-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cmuscheme" '("cmuscheme-load-hook" "inferior-scheme-" "scheme-" "switch-to-scheme"))) ;;;*** @@ -5151,7 +5143,7 @@ REGEXP-GROUP is the regular expression group in REGEXP to use. \(fn PROCESS COMMAND REGEXP REGEXP-GROUP)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "comint" '("comint-" "shell-strip-ctrl-m" "send-invisible"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "comint" '("comint-"))) ;;;*** @@ -5220,22 +5212,17 @@ If nil, use Emacs default.") (custom-autoload 'compilation-window-height "compile" t) -(defvar compilation-process-setup-function nil "\ +(defvar compilation-process-setup-function #'ignore "\ Function to call to customize the compilation process. This function is called immediately before the compilation process is started. It can be used to set any variables or functions that are used while processing the output of the compilation process.") -(defvar compilation-buffer-name-function nil "\ +(defvar compilation-buffer-name-function #'compilation--default-buffer-name "\ Function to compute the name of a compilation buffer. The function receives one argument, the name of the major mode of the compilation buffer. It should return a string. -If nil, compute the name with `(concat \"*\" (downcase major-mode) \"*\")'.") - -(defvar compilation-finish-function nil "\ -Function to call when a compilation process finishes. -It is called with two arguments: the compilation buffer, and a string -describing how the process finished.") +By default, it returns `(concat \"*\" (downcase name-of-mode) \"*\")'.") (defvar compilation-finish-functions nil "\ Functions to call when a compilation process finishes. @@ -5352,9 +5339,11 @@ Runs `compilation-mode-hook' with `run-mode-hooks' (which see). (autoload 'compilation-shell-minor-mode "compile" "\ Toggle Compilation Shell minor mode. -With a prefix argument ARG, enable Compilation Shell minor mode -if ARG is positive, and disable it otherwise. If called from -Lisp, enable the mode if ARG is omitted or nil. + +If called interactively, enable Compilation-Shell minor mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. When Compilation Shell minor mode is enabled, all the error-parsing commands of the Compilation major mode are @@ -5365,9 +5354,11 @@ See `compilation-mode'. (autoload 'compilation-minor-mode "compile" "\ Toggle Compilation minor mode. -With a prefix argument ARG, enable Compilation minor mode if ARG -is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. + +If called interactively, enable Compilation minor mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. When Compilation minor mode is enabled, all the error-parsing commands of Compilation major mode are available. See @@ -5381,7 +5372,7 @@ This is the value of `next-error-function' in Compilation buffers. \(fn N &optional RESET)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "compile" '("compil" "kill-compilation" "define-compilation-mode" "recompile"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "compile" '("compil" "define-compilation-mode" "kill-compilation" "recompile"))) ;;;*** @@ -5400,13 +5391,15 @@ or call the function `dynamic-completion-mode'.") (autoload 'dynamic-completion-mode "completion" "\ Toggle dynamic word-completion on or off. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. + +If called interactively, enable Dynamic-Completion mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "completion" '("inside-locate-completion-entry" "interactive-completion-string-reader" "initialize-completions" "current-completion-source" "cdabbrev-" "clear-all-completions" "check-completion-length" "complet" "cmpl-" "use-completion-" "list-all-completions" "symbol-" "set-c" "save" "kill-" "accept-completion" "add-" "*lisp-def-regexp*" "*c-def-regexp*" "delete-completion" "find-" "make-c" "num-cmpl-sources" "next-cdabbrev" "reset-cdabbrev" "enable-completion"))) +(if (fboundp 'register-definition-prefixes) (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-"))) ;;;*** @@ -5443,9 +5436,7 @@ doesn't have enough contents to decide, this is identical to See also `conf-space-mode', `conf-colon-mode', `conf-javaprop-mode', `conf-ppd-mode' and `conf-xdefaults-mode'. -\\{conf-mode-map} - -\(fn)" t nil) +\\{conf-mode-map}" t nil) (autoload 'conf-unix-mode "conf-mode" "\ Conf Mode starter for Unix style Conf files. @@ -5637,9 +5628,7 @@ interactively. Convert 2 digit years to 4 digit years. Uses heuristic: year >= 50 means 19xx, < 50 means 20xx. If `copyright-year-ranges' (which see) is non-nil, also -independently replaces consecutive years with a range. - -\(fn)" t nil) +independently replaces consecutive years with a range." t nil) (autoload 'copyright "copyright" "\ Insert a copyright by $ORGANIZATION notice at cursor. @@ -5764,7 +5753,7 @@ It is possible to show this help automatically after some idle time. This is regulated by variable `cperl-lazy-help-time'. Default with `cperl-hairy' (if the value of `cperl-lazy-help-time' is nil) is 5 secs idle time . It is also possible to switch this on/off from the -menu, or via \\[cperl-toggle-autohelp]. Requires `run-with-idle-timer'. +menu, or via \\[cperl-toggle-autohelp]. Use \\[cperl-lineup] to vertically lineup some construction - put the beginning of the region at the start of construction, and make region @@ -5849,9 +5838,7 @@ Run `perldoc' on WORD. \(fn WORD)" t nil) (autoload 'cperl-perldoc-at-point "cperl-mode" "\ -Run a `perldoc' on the word around point. - -\(fn)" t nil) +Run a `perldoc' on the word around point." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cperl-mode" '("cperl-" "pod2man-program"))) @@ -5869,9 +5856,7 @@ A prefix arg suppresses display of that buffer. \(fn ARG)" t nil) (autoload 'cpp-parse-edit "cpp" "\ -Edit display information for cpp conditionals. - -\(fn)" t nil) +Edit display information for cpp conditionals." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cpp" '("cpp-"))) @@ -5914,7 +5899,7 @@ Major mode to edit Cascading Style Sheets (CSS). This mode provides syntax highlighting, indentation, completion, and documentation lookup for CSS. -Use `\\[complete-symbol]' to complete CSS properties, property values, +Use `\\[completion-at-point]' to complete CSS properties, property values, pseudo-elements, pseudo-classes, at-rules, bang-rules, and HTML tags, classes and IDs. Completion candidates for HTML class names and IDs are found by looking through open HTML mode @@ -5965,9 +5950,11 @@ or call the function `cua-mode'.") (autoload 'cua-mode "cua-base" "\ Toggle Common User Access style editing (CUA mode). -With a prefix argument ARG, enable CUA mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. + +If called interactively, enable Cua mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. 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 @@ -6012,6 +5999,11 @@ Enable CUA selection mode without the C-z/C-x/C-c/C-v bindings. Toggle the region as rectangular. Activates the region if needed. Only lasts until the region is deactivated. +If called interactively, enable Cua-Rectangle-Mark mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + \(fn &optional ARG)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cua-rect" '("cua-"))) @@ -6030,6 +6022,11 @@ By convention, this is a list of symbols where each symbol stands for the (autoload 'cursor-intangible-mode "cursor-sensor" "\ Keep cursor outside of any `cursor-intangible' text property. +If called interactively, enable Cursor-Intangible mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + \(fn &optional ARG)" t nil) (autoload 'cursor-sensor-mode "cursor-sensor" "\ @@ -6040,6 +6037,11 @@ where WINDOW is the affected window, OLDPOS is the last known position of 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. +If called interactively, enable Cursor-Sensor mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + \(fn &optional ARG)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cursor-sensor" '("cursor-sensor-"))) @@ -6133,9 +6135,7 @@ the resulting list value now. Otherwise, add an entry to Select a customization buffer which you can use to set user options. User options are structured into \"groups\". Initially the top-level group `Emacs' and its immediate subgroups -are shown; the contents of those subgroups are initially hidden. - -\(fn)" t nil) +are shown; the contents of those subgroups are initially hidden." t nil) (autoload 'customize-mode "cus-edit" "\ Customize options related to a major or minor mode. @@ -6238,19 +6238,13 @@ suggest to customize that face, if it's customizable. \(fn &optional FACE)" t nil) (autoload 'customize-unsaved "cus-edit" "\ -Customize all options and faces set in this session but not saved. - -\(fn)" t nil) +Customize all options and faces set in this session but not saved." t nil) (autoload 'customize-rogue "cus-edit" "\ -Customize all user variables modified outside customize. - -\(fn)" t nil) +Customize all user variables modified outside customize." t nil) (autoload 'customize-saved "cus-edit" "\ -Customize all saved options and faces. - -\(fn)" t nil) +Customize all saved options and faces." t nil) (autoload 'customize-apropos "cus-edit" "\ Customize loaded options, faces and groups matching PATTERN. @@ -6283,9 +6277,7 @@ Customize all loaded groups matching REGEXP. (autoload 'custom-prompt-customize-unsaved-options "cus-edit" "\ Prompt user to customize any unsaved customization options. Return non-nil if user chooses to customize, for use in -`kill-emacs-query-functions'. - -\(fn)" nil nil) +`kill-emacs-query-functions'." nil nil) (autoload 'custom-buffer-create "cus-edit" "\ Create a buffer containing OPTIONS. @@ -6349,14 +6341,10 @@ and hence will not set `custom-file' to that file either.") (custom-autoload 'custom-file "cus-edit" t) (autoload 'custom-save-all "cus-edit" "\ -Save all customizations in `custom-file'. - -\(fn)" nil nil) +Save all customizations in `custom-file'." nil nil) (autoload 'customize-save-customized "cus-edit" "\ -Save all user options which have been set in this session. - -\(fn)" t nil) +Save all user options which have been set in this session." t nil) (autoload 'custom-menu-create "cus-edit" "\ Create menu for customization group SYMBOL. @@ -6430,16 +6418,17 @@ Mode used for cvs status output. (autoload 'cwarn-mode "cwarn" "\ Minor mode that highlights suspicious C and C++ constructions. +If called interactively, enable Cwarn mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + 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. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. - \(fn &optional ARG)" t nil) (define-obsolete-function-alias 'turn-on-cwarn-mode 'cwarn-mode "24.1") @@ -6466,7 +6455,7 @@ See `cwarn-mode' for more information on Cwarn mode. \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cwarn" '("turn-on-cwarn-mode-if-enabled" "cwarn-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cwarn" '("cwarn-" "turn-on-cwarn-mode-if-enabled"))) ;;;*** @@ -6532,7 +6521,7 @@ buffers accepted by the function pointed out by variable `dabbrev-friend-buffer-function', if `dabbrev-check-other-buffers' says so. Then, if `dabbrev-check-all-buffers' is non-nil, look in all the other buffers, subject to constraints specified -by `dabbrev-ignored-buffer-names' and `dabbrev-ignored-regexps'. +by `dabbrev-ignored-buffer-names' and `dabbrev-ignored-buffer-regexps'. A positive prefix argument, N, says to take the Nth backward *distinct* possibility. A negative argument says search forward. @@ -6560,7 +6549,7 @@ Create a new data-debug buffer with NAME. \(fn NAME)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "data-debug" '("data-debug-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "data-debug" '("data-debug-" "dd-propertize"))) ;;;*** @@ -6788,9 +6777,7 @@ To specify a nil argument interactively, exit with an empty minibuffer. ;;; Generated autoloads from play/decipher.el (autoload 'decipher "decipher" "\ -Format a buffer of ciphertext for cryptanalysis and enter Decipher mode. - -\(fn)" t nil) +Format a buffer of ciphertext for cryptanalysis and enter Decipher mode." t nil) (autoload 'decipher-mode "decipher" "\ Major mode for decrypting monoalphabetic substitution ciphers. @@ -6806,9 +6793,7 @@ The most useful commands are: \\[decipher-frequency-count] Display the frequency of each ciphertext letter \\[decipher-adjacency-list] Show adjacency list for current letter (lists letters appearing next to it) \\[decipher-make-checkpoint] Save the current cipher alphabet (checkpoint) -\\[decipher-restore-checkpoint] Restore a saved cipher alphabet (checkpoint) - -\(fn)" t nil) +\\[decipher-restore-checkpoint] Restore a saved cipher alphabet (checkpoint)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "decipher" '("decipher-"))) @@ -6819,21 +6804,19 @@ The most useful commands are: (push (purecopy '(delim-col 2 1)) package--builtin-versions) (autoload 'delimit-columns-customize "delim-col" "\ -Customization of `columns' group. - -\(fn)" t nil) +Customize the `columns' group." t nil) (autoload 'delimit-columns-region "delim-col" "\ Prettify all columns in a text region. -START and END delimits the text region. +START and END delimit the text region. \(fn START END)" t nil) (autoload 'delimit-columns-rectangle "delim-col" "\ Prettify all columns in a text rectangle. -START and END delimits the corners of text rectangle. +START and END delimit the corners of the text rectangle. \(fn START END)" t nil) @@ -6858,12 +6841,11 @@ or call the function `delete-selection-mode'.") (autoload 'delete-selection-mode "delsel" "\ Toggle Delete Selection mode. -Interactively, with a prefix argument, enable -Delete Selection mode if the prefix argument is positive, -and disable it otherwise. If called from Lisp, toggle -the mode if ARG is `toggle', disable the mode if ARG is -a non-positive integer, and enable the mode otherwise -\(including if ARG is omitted or nil or a positive integer). + +If called interactively, enable Delete-Selection mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. When Delete Selection mode is enabled, typed text replaces the selection if the selection is active. Otherwise, typed text is just inserted at @@ -7001,9 +6983,7 @@ of `eldoc-echo-area-use-multiline-p' variable and width of minibuffer window for width limit. This function is meant to be used as a value of -`eldoc-documentation-function' variable. - -\(fn)" nil nil) +`eldoc-documentation-function' variable." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "descr-text" '("describe-"))) @@ -7024,9 +7004,11 @@ or call the function `desktop-save-mode'.") (autoload 'desktop-save-mode "desktop" "\ Toggle desktop saving (Desktop Save mode). -With a prefix argument ARG, enable Desktop Save mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode if ARG -is omitted or nil. + +If called interactively, enable Desktop-Save mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. 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 @@ -7160,9 +7142,7 @@ a regular expression in the list `desktop-clear-preserve-buffers'. Furthermore, it clears the variables listed in `desktop-globals-to-clear'. When called interactively and `desktop-restore-frames' is non-nil, it also deletes all frames except the selected one (and its minibuffer frame, -if different). - -\(fn)" t nil) +if different)." t nil) (autoload 'desktop-save "desktop" "\ Save the desktop in a desktop file. @@ -7194,9 +7174,7 @@ without further confirmation. (autoload 'desktop-remove "desktop" "\ Delete desktop file in `desktop-dirname'. -This function also sets `desktop-dirname' to nil. - -\(fn)" t nil) +This function also sets `desktop-dirname' to nil." t nil) (autoload 'desktop-read "desktop" "\ Read and process the desktop file in directory DIRNAME. @@ -7209,14 +7187,6 @@ It returns t if a desktop file was loaded, nil otherwise. \(fn &optional DIRNAME)" t nil) -(autoload 'desktop-load-default "desktop" "\ -Load the `default' start-up library manually. -Also inhibit further loading of it. - -\(fn)" nil nil) - -(make-obsolete 'desktop-load-default 'desktop-save-mode '"22.1") - (autoload 'desktop-change-dir "desktop" "\ Change to desktop saved in DIRNAME. Kill the desktop as specified by variables `desktop-save-mode' and @@ -7226,14 +7196,10 @@ directory DIRNAME. \(fn DIRNAME)" t nil) (autoload 'desktop-save-in-desktop-dir "desktop" "\ -Save the desktop in directory `desktop-dirname'. - -\(fn)" t nil) +Save the desktop in directory `desktop-dirname'." t nil) (autoload 'desktop-revert "desktop" "\ -Revert to the last loaded desktop. - -\(fn)" t nil) +Revert to the last loaded desktop." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "desktop" '("desktop-"))) @@ -7265,9 +7231,7 @@ NODISPLAY is non-nil, don't redisplay the article buffer. \(fn &optional NODISPLAY)" t nil) (autoload 'gnus-article-outlook-deuglify-article "deuglify" "\ -Deuglify broken Outlook (Express) articles and redisplay. - -\(fn)" t nil) +Deuglify broken Outlook (Express) articles and redisplay." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "deuglify" '("gnus-"))) @@ -7321,7 +7285,7 @@ Major mode for editing the diary file. \(fn)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "diary-lib" '("diary-" "calendar-mark-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "diary-lib" '("calendar-mark-" "diary-"))) ;;;*** @@ -7391,15 +7355,17 @@ You can also switch between context diff and unified diff with \\[diff-context-> or vice versa with \\[diff-unified->context] and you can also reverse the direction of a diff with \\[diff-reverse-direction]. - \\{diff-mode-map} +\\{diff-mode-map} \(fn)" t nil) (autoload 'diff-minor-mode "diff-mode" "\ Toggle Diff minor mode. -With a prefix argument ARG, enable Diff minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Diff minor mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. \\{diff-minor-mode-map} @@ -7418,7 +7384,7 @@ Optional arguments are passed to `dig-invoke'. \(fn DOMAIN &optional QUERY-TYPE QUERY-CLASS QUERY-OPTION DIG-OPTION SERVER)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dig" '("query-dig" "dig-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dig" '("dig-" "query-dig"))) ;;;*** @@ -7575,9 +7541,11 @@ Keybindings: (autoload 'dirtrack-mode "dirtrack" "\ Toggle directory tracking in shell buffers (Dirtrack mode). -With a prefix argument ARG, enable Dirtrack mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Dirtrack mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. This method requires that your shell prompt contain the current working directory at all times, and that you set the variable @@ -7622,9 +7590,7 @@ redefine OBJECT if it is a symbol. ;;; Generated autoloads from disp-table.el (autoload 'make-display-table "disp-table" "\ -Return a new, empty display table. - -\(fn)" nil nil) +Return a new, empty display table." nil nil) (autoload 'display-table-slot "disp-table" "\ Return the value of the extra slot in DISPLAY-TABLE named SLOT. @@ -7648,9 +7614,7 @@ Describe the display table DT in a help buffer. \(fn DT)" nil nil) (autoload 'describe-current-display-table "disp-table" "\ -Describe the display table in use in the selected window and buffer. - -\(fn)" t nil) +Describe the display table in use in the selected window and buffer." t nil) (autoload 'standard-display-8bit "disp-table" "\ Display characters representing raw bytes in the range L to H literally. @@ -7680,14 +7644,14 @@ Display character C using printable string S. (autoload 'standard-display-g1 "disp-table" "\ Display character C as character SC in the g1 character set. This function assumes that your terminal uses the SO/SI characters; -it is meaningless for an X frame. +it is meaningless for a graphical frame. \(fn C SC)" nil nil) (autoload 'standard-display-graphic "disp-table" "\ Display character C as character GC in graphics character set. -This function assumes VT100-compatible escapes; it is meaningless for an -X frame. +This function assumes VT100-compatible escapes; it is meaningless +for a graphical frame. \(fn C GC)" nil nil) @@ -7741,6 +7705,51 @@ in `.emacs'. ;;;*** +;;;### (autoloads nil "display-fill-column-indicator" "display-fill-column-indicator.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from display-fill-column-indicator.el + +(autoload 'display-fill-column-indicator-mode "display-fill-column-indicator" "\ +Toggle display of fill-column indicator. +This uses `display-fill-column-indicator' internally. + +If called interactively, enable Display-Fill-Column-Indicator mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + +To change the position of the column displayed by default +customize `display-fill-column-indicator-column'. You can change the +character for the indicator setting `display-fill-column-indicator-character'. + +\(fn &optional ARG)" t nil) + +(defvar global-display-fill-column-indicator-mode nil "\ +Non-nil if Global Display-Fill-Column-Indicator mode is enabled. +See the `global-display-fill-column-indicator-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-display-fill-column-indicator-mode'.") + +(custom-autoload 'global-display-fill-column-indicator-mode "display-fill-column-indicator" nil) + +(autoload 'global-display-fill-column-indicator-mode "display-fill-column-indicator" "\ +Toggle Display-Fill-Column-Indicator mode in all buffers. +With prefix ARG, enable Global Display-Fill-Column-Indicator mode if ARG is positive; +otherwise, disable it. If called from Lisp, enable the mode if +ARG is omitted or nil. + +Display-Fill-Column-Indicator mode is enabled in all buffers where +`display-fill-column-indicator--turn-on' would do it. +See `display-fill-column-indicator-mode' for more information on Display-Fill-Column-Indicator mode. + +\(fn &optional ARG)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "display-fill-column-indicator" '("display-fill-column-indicator--turn-on"))) + +;;;*** + ;;;### (autoloads nil "display-line-numbers" "display-line-numbers.el" ;;;;;; (0 0 0 0)) ;;; Generated autoloads from display-line-numbers.el @@ -7749,6 +7758,11 @@ in `.emacs'. Toggle display of line numbers in the buffer. This uses `display-line-numbers' internally. +If called interactively, enable Display-Line-Numbers mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + 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. @@ -7843,9 +7857,7 @@ Turning on DNS mode runs `dns-mode-hook'. (defalias 'zone-mode 'dns-mode) (autoload 'dns-mode-soa-increment-serial "dns-mode" "\ -Locate SOA record and increment the serial field. - -\(fn)" t nil) +Locate SOA record and increment the serial field." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dns-mode" '("dns-mode-"))) @@ -7869,22 +7881,20 @@ and DVI files (as PNG images) in Emacs buffers. You can use \\<doc-view-mode-map>\\[doc-view-toggle-display] to toggle between displaying the document or editing it as text. -\\{doc-view-mode-map} - -\(fn)" t nil) +\\{doc-view-mode-map}" t nil) (autoload 'doc-view-mode-maybe "doc-view" "\ Switch to `doc-view-mode' if possible. If the required external tools are not available, then fallback -to the next best mode. - -\(fn)" nil nil) +to the next best mode." nil nil) (autoload 'doc-view-minor-mode "doc-view" "\ Toggle displaying buffer via Doc View (Doc View minor mode). -With a prefix argument ARG, enable Doc View minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Doc-View minor mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. See the command `doc-view-mode' for more information on this mode. @@ -7903,9 +7913,7 @@ See the command `doc-view-mode' for more information on this mode. ;;; Generated autoloads from play/doctor.el (autoload 'doctor "doctor" "\ -Switch to *doctor* buffer and start giving psychotherapy. - -\(fn)" t nil) +Switch to *doctor* buffer and start giving psychotherapy." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "doctor" '("doc" "make-doctor-variables"))) @@ -7935,7 +7943,7 @@ Switch to *doctor* buffer and start giving psychotherapy. ;;;### (autoloads nil "dos-w32" "dos-w32.el" (0 0 0 0)) ;;; Generated autoloads from dos-w32.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dos-w32" '("w32-" "file-name-buffer-file-type-alist" "find-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dos-w32" '("file-name-buffer-file-type-alist" "find-" "w32-"))) ;;;*** @@ -7944,9 +7952,11 @@ Switch to *doctor* buffer and start giving psychotherapy. (autoload 'double-mode "double" "\ Toggle special insertion on double keypresses (Double mode). -With a prefix argument ARG, enable Double mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Double mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. When Double mode is enabled, some keys will insert different strings when pressed twice. See `double-map' for details. @@ -7962,9 +7972,7 @@ strings when pressed twice. See `double-map' for details. (push (purecopy '(dunnet 2 2)) package--builtin-versions) (autoload 'dunnet "dunnet" "\ -Switch to *dungeon* buffer and start game. - -\(fn)" t nil) +Switch to *dungeon* buffer and start game." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dunnet" '("dun" "obj-special"))) @@ -8001,7 +8009,9 @@ non-positive integer, and enables the mode otherwise (including if the argument is omitted or nil or a positive integer). If DOC is nil, give the mode command a basic doc-string -documenting what its argument does. +documenting what its argument does. If the word \"ARG\" does not +appear in DOC, a paragraph is added to DOC explaining +usage of the mode argument. Optional INIT-VALUE is the initial value of the mode's variable. Optional LIGHTER is displayed in the mode line when the mode is on. @@ -8114,12 +8124,16 @@ the constant's documentation. \(fn M BS DOC &rest ARGS)" nil t) +(function-put 'easy-mmode-defmap 'lisp-indent-function '1) + (autoload 'easy-mmode-defsyntax "easy-mmode" "\ Define variable ST as a syntax-table. 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 'lisp-indent-function '1) + (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "easy-mmode" '("easy-mmode-"))) ;;;*** @@ -8261,7 +8275,7 @@ To implement dynamic menus, either call this from \(fn PATH NAME ITEMS &optional BEFORE MAP)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "easymenu" '("easy-menu-" "add-submenu"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "easymenu" '("add-submenu" "easy-menu-"))) ;;;*** @@ -8319,9 +8333,7 @@ To implement dynamic menus, either call this from (push (purecopy '(ebnf2ps 4 4)) package--builtin-versions) (autoload 'ebnf-customize "ebnf2ps" "\ -Customization for ebnf group. - -\(fn)" t nil) +Customization for ebnf group." t nil) (autoload 'ebnf-print-directory "ebnf2ps" "\ Generate and print a PostScript syntactic chart image of DIRECTORY. @@ -8348,7 +8360,7 @@ See also `ebnf-print-buffer'. (autoload 'ebnf-print-buffer "ebnf2ps" "\ Generate and print a PostScript syntactic chart image of the buffer. -When called with a numeric prefix argument (C-u), prompts the user for +When called with a numeric prefix argument (\\[universal-argument]), prompts the user for the name of a file to save the PostScript image in, instead of sending it to the printer. @@ -8392,9 +8404,7 @@ Generate and spool a PostScript syntactic chart image of the buffer. Like `ebnf-print-buffer' except that the PostScript image is saved in a local buffer to be sent to the printer later. -Use the command `ebnf-despool' to send the spooled images to the printer. - -\(fn)" t nil) +Use the command `ebnf-despool' to send the spooled images to the printer." t nil) (autoload 'ebnf-spool-region "ebnf2ps" "\ Generate a PostScript syntactic chart image of the region and spool locally. @@ -8444,9 +8454,7 @@ The EPS file name has the following form: file name used in this case will be \"ebnf--A_B_+_C.eps\". WARNING: This function does *NOT* ask any confirmation to override existing - files. - -\(fn)" t nil) + files." t nil) (autoload 'ebnf-eps-region "ebnf2ps" "\ Generate a PostScript syntactic chart image of the region in an EPS file. @@ -8470,7 +8478,7 @@ WARNING: This function does *NOT* ask any confirmation to override existing \(fn FROM TO)" t nil) -(defalias 'ebnf-despool 'ps-despool) +(defalias 'ebnf-despool #'ps-despool) (autoload 'ebnf-syntax-directory "ebnf2ps" "\ Do a syntactic analysis of the files in DIRECTORY. @@ -8495,9 +8503,7 @@ See also `ebnf-syntax-buffer'. \(fn FILE &optional DO-NOT-KILL-BUFFER-WHEN-DONE)" t nil) (autoload 'ebnf-syntax-buffer "ebnf2ps" "\ -Do a syntactic analysis of the current buffer. - -\(fn)" t nil) +Do a syntactic analysis of the current buffer." t nil) (autoload 'ebnf-syntax-region "ebnf2ps" "\ Do a syntactic analysis of a region. @@ -8505,9 +8511,7 @@ Do a syntactic analysis of a region. \(fn FROM TO)" t nil) (autoload 'ebnf-setup "ebnf2ps" "\ -Return the current ebnf2ps setup. - -\(fn)" nil nil) +Return the current ebnf2ps setup." nil nil) (autoload 'ebnf-find-style "ebnf2ps" "\ Return style definition if NAME is already defined; otherwise, return nil. @@ -8573,9 +8577,7 @@ Returns the old style symbol. See also `ebnf-push-style'. -See `ebnf-style-database' documentation. - -\(fn)" t nil) +See `ebnf-style-database' documentation." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebnf2ps" '("ebnf-"))) @@ -8597,9 +8599,7 @@ Tree mode key bindings: \(fn)" t nil) (autoload 'ebrowse-electric-choose-tree "ebrowse" "\ -Return a buffer containing a tree or nil if no tree found or canceled. - -\(fn)" t nil) +Return a buffer containing a tree or nil if no tree found or canceled." t nil) (autoload 'ebrowse-member-mode "ebrowse" "\ Major mode for Ebrowse member buffers. @@ -8607,54 +8607,34 @@ Major mode for Ebrowse member buffers. \(fn)" t nil) (autoload 'ebrowse-tags-view-declaration "ebrowse" "\ -View declaration of member at point. - -\(fn)" t nil) +View declaration of member at point." t nil) (autoload 'ebrowse-tags-find-declaration "ebrowse" "\ -Find declaration of member at point. - -\(fn)" t nil) +Find declaration of member at point." t nil) (autoload 'ebrowse-tags-view-definition "ebrowse" "\ -View definition of member at point. - -\(fn)" t nil) +View definition of member at point." t nil) (autoload 'ebrowse-tags-find-definition "ebrowse" "\ -Find definition of member at point. - -\(fn)" t nil) +Find definition of member at point." t nil) (autoload 'ebrowse-tags-find-declaration-other-window "ebrowse" "\ -Find declaration of member at point in other window. - -\(fn)" t nil) +Find declaration of member at point in other window." t nil) (autoload 'ebrowse-tags-view-definition-other-window "ebrowse" "\ -View definition of member at point in other window. - -\(fn)" t nil) +View definition of member at point in other window." t nil) (autoload 'ebrowse-tags-find-definition-other-window "ebrowse" "\ -Find definition of member at point in other window. - -\(fn)" t nil) +Find definition of member at point in other window." t nil) (autoload 'ebrowse-tags-find-declaration-other-frame "ebrowse" "\ -Find definition of member at point in other frame. - -\(fn)" t nil) +Find definition of member at point in other frame." t nil) (autoload 'ebrowse-tags-view-definition-other-frame "ebrowse" "\ -View definition of member at point in other frame. - -\(fn)" t nil) +View definition of member at point in other frame." t nil) (autoload 'ebrowse-tags-find-definition-other-frame "ebrowse" "\ -Find definition of member at point in other frame. - -\(fn)" t nil) +Find definition of member at point in other frame." t nil) (autoload 'ebrowse-tags-complete-symbol "ebrowse" "\ Perform completion on the C++ symbol preceding point. @@ -8706,14 +8686,10 @@ Prefix arg ARG says how much. \(fn ARG)" t nil) (autoload 'ebrowse-electric-position-menu "ebrowse" "\ -List positions in the position stack in an electric buffer. - -\(fn)" t nil) +List positions in the position stack in an electric buffer." t nil) (autoload 'ebrowse-save-tree "ebrowse" "\ -Save current tree in same file it was loaded from. - -\(fn)" t nil) +Save current tree in same file it was loaded from." t nil) (autoload 'ebrowse-save-tree-as "ebrowse" "\ Write the current tree data structure to a file. @@ -8723,11 +8699,9 @@ Otherwise, FILE-NAME specifies the file to save the tree in. \(fn &optional FILE-NAME)" t nil) (autoload 'ebrowse-statistics "ebrowse" "\ -Display statistics for a class tree. +Display statistics for a class tree." t nil) -\(fn)" t nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebrowse" '("electric-buffer-menu-mode-hook" "ebrowse-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebrowse" '("ebrowse-" "electric-buffer-menu-mode-hook"))) ;;;*** @@ -8762,7 +8736,7 @@ Run hooks in `electric-buffer-menu-mode-hook' on entry. \(fn ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebuff-menu" '("electric-buffer-" "Electric-buffer-menu-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebuff-menu" '("Electric-buffer-menu-" "electric-buffer-"))) ;;;*** @@ -8783,9 +8757,7 @@ With prefix arg NOCONFIRM, execute current line as-is without editing. ;;; Generated autoloads from ecomplete.el (autoload 'ecomplete-setup "ecomplete" "\ -Read the .ecompleterc file. - -\(fn)" nil nil) +Read the .ecompleterc file." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ecomplete" '("ecomplete-"))) @@ -8807,16 +8779,18 @@ or call the function `global-ede-mode'.") (autoload 'global-ede-mode "ede" "\ Toggle global EDE (Emacs Development Environment) mode. -With a prefix argument ARG, enable global EDE mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Global Ede mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. This global minor mode enables `ede-minor-mode' in all buffers in an EDE controlled project. \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede" '("project-try-ede" "ede" "global-ede-mode-map"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede" '("ede" "global-ede-mode-map" "project-try-ede"))) ;;;*** @@ -8863,7 +8837,7 @@ an EDE controlled project. ;;;;;; (0 0 0 0)) ;;; Generated autoloads from cedet/ede/custom.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/custom" '("eieio-ede-old-variables" "ede-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/custom" '("ede-" "eieio-ede-old-variables"))) ;;;*** @@ -8979,7 +8953,7 @@ an EDE controlled project. ;;;;;; 0 0 0)) ;;; Generated autoloads from cedet/ede/proj-comp.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/proj-comp" '("proj-comp-insert-variable-once" "ede-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/proj-comp" '("ede-" "proj-comp-insert-variable-once"))) ;;;*** @@ -9141,27 +9115,21 @@ If the current defun is actually a call to `defvar' or `defcustom', evaluating it this way resets the variable using its initial value expression even if the variable already has some other value. \(Normally `defvar' and `defcustom' do not alter the value if there -already is one.) - -\(fn)" t nil) +already is one.)" t nil) (autoload 'edebug-all-defs "edebug" "\ -Toggle edebugging of all definitions. - -\(fn)" t nil) +Toggle edebugging of all definitions." t nil) (autoload 'edebug-all-forms "edebug" "\ -Toggle edebugging of all forms. - -\(fn)" t nil) +Toggle edebugging of all forms." t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "edebug" '("edebug" "get-edebug-spec" "global-edebug-" "cancel-edebug-on-entry"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "edebug" '("cancel-edebug-on-entry" "edebug" "get-edebug-spec" "global-edebug-"))) ;;;*** ;;;### (autoloads nil "ediff" "vc/ediff.el" (0 0 0 0)) ;;; Generated autoloads from vc/ediff.el -(push (purecopy '(ediff 2 81 4)) package--builtin-versions) +(push (purecopy '(ediff 2 81 6)) package--builtin-versions) (autoload 'ediff-files "ediff" "\ Run Ediff on a pair of files, FILE-A and FILE-B. @@ -9184,9 +9152,7 @@ arguments after setting up the Ediff buffers. (autoload 'ediff-current-file "ediff" "\ Start ediff between current buffer and its file on disk. This command can be used instead of `revert-buffer'. If there is -nothing to revert then this command fails. - -\(fn)" t nil) +nothing to revert then this command fails." t nil) (autoload 'ediff-backup "ediff" "\ Run Ediff on FILE and its backup file. @@ -9448,9 +9414,7 @@ arguments after setting up the Ediff buffers. (autoload 'ediff-version "ediff" "\ Return string describing the version of Ediff. -When called interactively, displays the version. - -\(fn)" t nil) +When called interactively, displays the version." t nil) (autoload 'ediff-documentation "ediff" "\ Display Ediff's manual. @@ -9459,44 +9423,28 @@ With optional NODE, goes to that node. \(fn &optional NODE)" t nil) (autoload 'ediff-files-command "ediff" "\ -Call `ediff-files' with the next two command line arguments. - -\(fn)" nil nil) +Call `ediff-files' with the next two command line arguments." nil nil) (autoload 'ediff3-files-command "ediff" "\ -Call `ediff3-files' with the next three command line arguments. - -\(fn)" nil nil) +Call `ediff3-files' with the next three command line arguments." nil nil) (autoload 'ediff-merge-command "ediff" "\ -Call `ediff-merge-files' with the next two command line arguments. - -\(fn)" nil nil) +Call `ediff-merge-files' with the next two command line arguments." nil nil) (autoload 'ediff-merge-with-ancestor-command "ediff" "\ -Call `ediff-merge-files-with-ancestor' with the next three command line arguments. - -\(fn)" nil nil) +Call `ediff-merge-files-with-ancestor' with the next three command line arguments." nil nil) (autoload 'ediff-directories-command "ediff" "\ -Call `ediff-directories' with the next three command line arguments. - -\(fn)" nil nil) +Call `ediff-directories' with the next three command line arguments." nil nil) (autoload 'ediff-directories3-command "ediff" "\ -Call `ediff-directories3' with the next four command line arguments. - -\(fn)" nil nil) +Call `ediff-directories3' with the next four command line arguments." nil nil) (autoload 'ediff-merge-directories-command "ediff" "\ -Call `ediff-merge-directories' with the next three command line arguments. - -\(fn)" nil nil) +Call `ediff-merge-directories' with the next three command line arguments." nil nil) (autoload 'ediff-merge-directories-with-ancestor-command "ediff" "\ -Call `ediff-merge-directories-with-ancestor' with the next four command line arguments. - -\(fn)" nil nil) +Call `ediff-merge-directories-with-ancestor' with the next four command line arguments." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ediff" '("ediff-"))) @@ -9512,10 +9460,7 @@ Call `ediff-merge-directories-with-ancestor' with the next four command line arg ;;;### (autoloads nil "ediff-help" "vc/ediff-help.el" (0 0 0 0)) ;;; Generated autoloads from vc/ediff-help.el -(autoload 'ediff-customize "ediff-help" "\ - - -\(fn)" t nil) +(autoload 'ediff-customize "ediff-help" nil t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ediff-help" '("ediff-"))) @@ -9539,9 +9484,7 @@ Call `ediff-merge-directories-with-ancestor' with the next four command line arg ;;; Generated autoloads from vc/ediff-mult.el (autoload 'ediff-show-registry "ediff-mult" "\ -Display Ediff's registry. - -\(fn)" t nil) +Display Ediff's registry." t nil) (defalias 'eregistry 'ediff-show-registry) @@ -9562,16 +9505,12 @@ Display Ediff's registry. (autoload 'ediff-toggle-multiframe "ediff-util" "\ Switch from multiframe display to single-frame display and back. To change the default, set the variable `ediff-window-setup-function', -which see. - -\(fn)" t nil) +which see." t nil) (autoload 'ediff-toggle-use-toolbar "ediff-util" "\ Enable or disable Ediff toolbar. Works only in versions of Emacs that support toolbars. -To change the default, set the variable `ediff-use-toolbar-p', which see. - -\(fn)" t nil) +To change the default, set the variable `ediff-use-toolbar-p', which see." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ediff-util" '("ediff-"))) @@ -9654,9 +9593,7 @@ Argument BOTTOM is the bottom margin in number of lines or percent of window. \(fn TOP BOTTOM)" t nil) (autoload 'edt-emulation-on "edt" "\ -Turn on EDT Emulation. - -\(fn)" t nil) +Turn on EDT Emulation." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "edt" '("edt-"))) @@ -9727,7 +9664,7 @@ BUFFER is put back into its original major mode. \(fn FUN &optional NAME)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ehelp" '("electric-" "ehelp-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ehelp" '("ehelp-" "electric-"))) ;;;*** @@ -9735,7 +9672,7 @@ BUFFER is put back into its original major mode. ;;; Generated autoloads from emacs-lisp/eieio.el (push (purecopy '(eieio 1 4)) package--builtin-versions) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio" '("eieio-" "oref" "oset" "obj" "find-class" "set-slot-value" "same-class-p" "slot-" "child-of-class-p" "with-slots" "defclass"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio" '("child-of-class-p" "defclass" "eieio-" "find-class" "obj" "oref" "oset" "same-class-p" "set-slot-value" "slot-" "with-slots"))) ;;;*** @@ -9751,7 +9688,7 @@ BUFFER is put back into its original major mode. ;;;;;; "emacs-lisp/eieio-compat.el" (0 0 0 0)) ;;; Generated autoloads from emacs-lisp/eieio-compat.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio-compat" '("no-" "next-method-p" "generic-p" "eieio--generic-static-symbol-specializers"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio-compat" '("eieio--generic-static-symbol-specializers" "generic-p" "next-method-p" "no-"))) ;;;*** @@ -9770,7 +9707,7 @@ It creates an autoload function for CNAME's constructor. \(fn CNAME SUPERCLASSES FILENAME DOC)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio-core" '("eieio-" "invalid-slot-" "inconsistent-class-hierarchy" "unbound-slot" "class-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio-core" '("class-" "eieio-" "inconsistent-class-hierarchy" "invalid-slot-" "unbound-slot"))) ;;;*** @@ -9821,9 +9758,11 @@ or call the function `electric-pair-mode'.") (autoload 'electric-pair-mode "elec-pair" "\ Toggle automatic parens pairing (Electric Pair mode). -With a prefix argument ARG, enable Electric Pair mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Electric-Pair mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Electric Pair mode is a global minor mode. When enabled, typing an open parenthesis automatically inserts the corresponding @@ -9838,6 +9777,11 @@ To toggle the mode in a single buffer, use `electric-pair-local-mode'. (autoload 'electric-pair-local-mode "elec-pair" "\ Toggle `electric-pair-mode' only in this buffer. +If called interactively, enable Electric-Pair-Local mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + \(fn &optional ARG)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "elec-pair" '("electric-pair-"))) @@ -9877,15 +9821,11 @@ A complicated directory may require a lot of memory. (autoload 'elint-current-buffer "elint" "\ Lint the current buffer. -If necessary, this first calls `elint-initialize'. - -\(fn)" t nil) +If necessary, this first calls `elint-initialize'." t nil) (autoload 'elint-defun "elint" "\ Lint the function at point. -If necessary, this first calls `elint-initialize'. - -\(fn)" t nil) +If necessary, this first calls `elint-initialize'." t nil) (autoload 'elint-initialize "elint" "\ Initialize elint. @@ -9927,9 +9867,7 @@ For example, to instrument all ELP functions, do the following: Display current profiling results. If `elp-reset-after-results' is non-nil, then current profiling information for all instrumented functions is reset after results are -displayed. - -\(fn)" t nil) +displayed." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "elp" '("elp-"))) @@ -10067,7 +10005,7 @@ displayed. ;;;;;; (0 0 0 0)) ;;; Generated autoloads from eshell/em-xtra.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-xtra" '("pcomplete/bcc" "eshell/"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-xtra" '("eshell/" "pcomplete/bcc"))) ;;;*** @@ -10077,9 +10015,7 @@ displayed. (autoload 'emacs-lock-mode "emacs-lock" "\ Toggle Emacs Lock mode in the current buffer. If called with a plain prefix argument, ask for the locking mode -to be used. With any other prefix ARG, turn mode on if ARG is -positive, off otherwise. If called from Lisp, enable the mode if -ARG is omitted or nil. +to be used. Initially, if the user does not pass an explicit locking mode, it defaults to `emacs-lock-default-locking-mode' (which see); @@ -10099,7 +10035,7 @@ some major modes from being locked under some circumstances. \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "emacs-lock" '("toggle-emacs-lock" "emacs-lock-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "emacs-lock" '("emacs-lock-" "toggle-emacs-lock"))) ;;;*** @@ -10141,15 +10077,9 @@ Run Emerge on two buffers, giving another buffer as the ancestor. \(fn BUFFER-A BUFFER-B BUFFER-ANCESTOR &optional STARTUP-HOOKS QUIT-HOOKS)" t nil) -(autoload 'emerge-files-command "emerge" "\ +(autoload 'emerge-files-command "emerge" nil nil nil) - -\(fn)" nil nil) - -(autoload 'emerge-files-with-ancestor-command "emerge" "\ - - -\(fn)" nil nil) +(autoload 'emerge-files-with-ancestor-command "emerge" nil nil nil) (autoload 'emerge-files-remote "emerge" "\ @@ -10188,9 +10118,10 @@ Minor mode for editing text/enriched files. These are files with embedded formatting information in the MIME standard text/enriched format. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. +If called interactively, enable Enriched mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Turning the mode on or off runs `enriched-mode-hook'. @@ -10411,24 +10342,16 @@ Insert selected KEYS after the point. ;;; Generated autoloads from epa-dired.el (autoload 'epa-dired-do-decrypt "epa-dired" "\ -Decrypt marked files. - -\(fn)" t nil) +Decrypt marked files." t nil) (autoload 'epa-dired-do-verify "epa-dired" "\ -Verify marked files. - -\(fn)" t nil) +Verify marked files." t nil) (autoload 'epa-dired-do-sign "epa-dired" "\ -Sign marked files. - -\(fn)" t nil) +Sign marked files." t nil) (autoload 'epa-dired-do-encrypt "epa-dired" "\ -Encrypt marked files. - -\(fn)" t nil) +Encrypt marked files." t nil) ;;;*** @@ -10440,15 +10363,9 @@ Encrypt marked files. \(fn OPERATION &rest ARGS)" nil nil) -(autoload 'epa-file-enable "epa-file" "\ - - -\(fn)" t nil) - -(autoload 'epa-file-disable "epa-file" "\ - +(autoload 'epa-file-enable "epa-file" nil t nil) -\(fn)" t nil) +(autoload 'epa-file-disable "epa-file" nil t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "epa-file" '("epa-"))) @@ -10459,25 +10376,23 @@ Encrypt marked files. (autoload 'epa-mail-mode "epa-mail" "\ A minor-mode for composing encrypted/clearsigned mails. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. + +If called interactively, enable epa-mail mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. \(fn &optional ARG)" t nil) (autoload 'epa-mail-decrypt "epa-mail" "\ Decrypt OpenPGP armors in the current buffer. -The buffer is expected to contain a mail message. - -\(fn)" t nil) +The buffer is expected to contain a mail message." t nil) (function-put 'epa-mail-decrypt 'interactive-only 't) (autoload 'epa-mail-verify "epa-mail" "\ Verify OpenPGP cleartext signed messages in the current buffer. -The buffer is expected to contain a mail message. - -\(fn)" t nil) +The buffer is expected to contain a mail message." t nil) (function-put 'epa-mail-verify 'interactive-only 't) @@ -10506,9 +10421,7 @@ SIGNERS is a list of keys to sign the message with. (autoload 'epa-mail-import-keys "epa-mail" "\ Import keys in the OpenPGP armor format in the current buffer. -The buffer is expected to contain a mail message. - -\(fn)" t nil) +The buffer is expected to contain a mail message." t nil) (function-put 'epa-mail-import-keys 'interactive-only 't) @@ -10524,9 +10437,11 @@ or call the function `epa-global-mail-mode'.") (autoload 'epa-global-mail-mode "epa-mail" "\ Minor mode to hook EasyPG into Mail mode. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. + +If called interactively, enable Epa-Global-Mail mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. \(fn &optional ARG)" t nil) @@ -10564,16 +10479,19 @@ version requirement is met. \(fn PROTOCOL &optional NO-CACHE PROGRAM-ALIST)" nil nil) (autoload 'epg-configuration "epg-config" "\ -Return a list of internal configuration parameters of `epg-gpg-program'. - -\(fn)" nil nil) +Return a list of internal configuration parameters of `epg-gpg-program'." nil nil) (make-obsolete 'epg-configuration 'epg-find-configuration '"25.1") (autoload 'epg-check-configuration "epg-config" "\ Verify that a sufficient version of GnuPG is installed. +CONFIG should be a `epg-configuration' object (a plist). +REQ-VERSIONS should be a list with elements of the form (MIN +. MAX) where MIN and MAX are version strings indicating a +semi-open range of acceptable versions. REQ-VERSIONS may also be +a single minimum version string. -\(fn CONFIG &optional MINIMUM-VERSION)" nil nil) +\(fn CONFIG &optional REQ-VERSIONS)" nil nil) (autoload 'epg-expand-group "epg-config" "\ Look at CONFIG and try to expand GROUP. @@ -10589,9 +10507,7 @@ Look at CONFIG and try to expand GROUP. (push (purecopy '(erc 5 3)) package--builtin-versions) (autoload 'erc-select-read-args "erc" "\ -Prompt the user for values of nick, server, port, and password. - -\(fn)" nil nil) +Prompt the user for values of nick, server, port, and password." nil nil) (autoload 'erc "erc" "\ ERC is a powerful, modular, and extensible IRC client. @@ -10631,14 +10547,13 @@ Otherwise, connect to HOST:PORT as USER and /join CHANNEL. \(fn HOST PORT CHANNEL USER PASSWORD)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc" '("erc-" "define-erc-module"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc" '("define-erc-module" "erc-"))) ;;;*** -;;;### (autoloads nil "erc-autoaway" "erc/erc-autoaway.el" (0 0 0 -;;;;;; 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-autoaway" +;;;;;; "erc/erc-autoaway.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-autoaway.el - (autoload 'erc-autoaway-mode "erc-autoaway") (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-autoaway" '("erc-auto"))) @@ -10651,144 +10566,57 @@ Otherwise, connect to HOST:PORT as USER and /join CHANNEL. ;;;*** -;;;### (autoloads nil "erc-button" "erc/erc-button.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-button" "erc/erc-button.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-button.el - (autoload 'erc-button-mode "erc-button" nil t) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-button" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-capab" "erc/erc-capab.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-capab" "erc/erc-capab.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-capab.el - (autoload 'erc-capab-identify-mode "erc-capab" nil t) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-capab" '("erc-capab-identify-"))) ;;;*** -;;;### (autoloads nil "erc-compat" "erc/erc-compat.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-compat" "erc/erc-compat.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-compat.el - (autoload 'erc-define-minor-mode "erc-compat") (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-compat" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-dcc" "erc/erc-dcc.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-dcc" "erc/erc-dcc.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-dcc.el - (autoload 'erc-dcc-mode "erc-dcc") - -(autoload 'erc-cmd-DCC "erc-dcc" "\ -Parser for /dcc command. -This figures out the dcc subcommand and calls the appropriate routine to -handle it. The function dispatched should be named \"erc-dcc-do-FOO-command\", -where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc. - -\(fn CMD &rest ARGS)" nil nil) - -(autoload 'pcomplete/erc-mode/DCC "erc-dcc" "\ -Provides completion for the /DCC command. - -\(fn)" nil nil) - -(defvar erc-ctcp-query-DCC-hook '(erc-ctcp-query-DCC) "\ -Hook variable for CTCP DCC queries.") - -(autoload 'erc-ctcp-query-DCC "erc-dcc" "\ -The function called when a CTCP DCC request is detected by the client. -It examines the DCC subcommand, and calls the appropriate routine for -that subcommand. - -\(fn PROC NICK LOGIN HOST TO QUERY)" nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-dcc" '("erc-" "pcomplete/erc-mode/"))) ;;;*** -;;;### (autoloads nil "erc-desktop-notifications" "erc/erc-desktop-notifications.el" -;;;;;; (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-desktop-notifications" +;;;;;; "erc/erc-desktop-notifications.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-desktop-notifications.el -(autoload 'erc-notifications-mode "erc-desktop-notifications" "" t) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-desktop-notifications" '("erc-notifications-"))) ;;;*** -;;;### (autoloads nil "erc-ezbounce" "erc/erc-ezbounce.el" (0 0 0 -;;;;;; 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-ezbounce" +;;;;;; "erc/erc-ezbounce.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-ezbounce.el -(autoload 'erc-cmd-ezb "erc-ezbounce" "\ -Send EZB commands to the EZBouncer verbatim. - -\(fn LINE &optional FORCE)" nil nil) - -(autoload 'erc-ezb-get-login "erc-ezbounce" "\ -Return an appropriate EZBounce login for SERVER and PORT. -Look up entries in `erc-ezb-login-alist'. If the username or password -in the alist is nil, prompt for the appropriate values. - -\(fn SERVER PORT)" nil nil) - -(autoload 'erc-ezb-lookup-action "erc-ezbounce" "\ - - -\(fn MESSAGE)" nil nil) - -(autoload 'erc-ezb-notice-autodetect "erc-ezbounce" "\ -React on an EZBounce NOTICE request. - -\(fn PROC PARSED)" nil nil) - -(autoload 'erc-ezb-identify "erc-ezbounce" "\ -Identify to the EZBouncer server. - -\(fn MESSAGE)" nil nil) - -(autoload 'erc-ezb-init-session-list "erc-ezbounce" "\ -Reset the EZBounce session list to nil. - -\(fn MESSAGE)" nil nil) - -(autoload 'erc-ezb-end-of-session-list "erc-ezbounce" "\ -Indicate the end of the EZBounce session listing. - -\(fn MESSAGE)" nil nil) - -(autoload 'erc-ezb-add-session "erc-ezbounce" "\ -Add an EZBounce session to the session list. - -\(fn MESSAGE)" nil nil) - -(autoload 'erc-ezb-select "erc-ezbounce" "\ -Select an IRC server to use by EZBounce, in ERC style. - -\(fn MESSAGE)" nil nil) - -(autoload 'erc-ezb-select-session "erc-ezbounce" "\ -Select a detached EZBounce session. - -\(fn)" nil nil) - -(autoload 'erc-ezb-initialize "erc-ezbounce" "\ -Add EZBouncer convenience functions to ERC. - -\(fn)" nil nil) - (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-ezbounce" '("erc-ezb-"))) ;;;*** -;;;### (autoloads nil "erc-fill" "erc/erc-fill.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-fill" "erc/erc-fill.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-fill.el - (autoload 'erc-fill-mode "erc-fill" nil t) - -(autoload 'erc-fill "erc-fill" "\ -Fill a region using the function referenced in `erc-fill-function'. -You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'. - -\(fn)" nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-fill" '("erc-"))) @@ -10808,44 +10636,25 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'. ;;;*** -;;;### (autoloads nil "erc-identd" "erc/erc-identd.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-identd" "erc/erc-identd.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-identd.el - (autoload 'erc-identd-mode "erc-identd") - -(autoload 'erc-identd-start "erc-identd" "\ -Start an identd server listening to port 8113. -Port 113 (auth) will need to be redirected to port 8113 on your -machine -- using iptables, or a program like redir which can be -run from inetd. The idea is to provide a simple identd server -when you need one, without having to install one globally on your -system. - -\(fn &optional PORT)" t nil) - -(autoload 'erc-identd-stop "erc-identd" "\ - - -\(fn &rest IGNORE)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-identd" '("erc-identd-"))) ;;;*** -;;;### (autoloads nil "erc-imenu" "erc/erc-imenu.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-imenu" "erc/erc-imenu.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-imenu.el -(autoload 'erc-create-imenu-index "erc-imenu" "\ - - -\(fn)" nil nil) - (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-imenu" '("erc-unfill-notice"))) ;;;*** -;;;### (autoloads nil "erc-join" "erc/erc-join.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-join" "erc/erc-join.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-join.el - (autoload 'erc-autojoin-mode "erc-join" nil t) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-join" '("erc-"))) @@ -10854,114 +10663,45 @@ system. ;;;### (autoloads nil "erc-lang" "erc/erc-lang.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-lang.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-lang" '("erc-cmd-LANG" "language" "iso-638-languages"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-lang" '("erc-cmd-LANG" "iso-638-languages" "language"))) ;;;*** -;;;### (autoloads nil "erc-list" "erc/erc-list.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-list" "erc/erc-list.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-list.el - (autoload 'erc-list-mode "erc-list") (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-list" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-log" "erc/erc-log.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-log" "erc/erc-log.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-log.el - (autoload 'erc-log-mode "erc-log" nil t) - -(autoload 'erc-logging-enabled "erc-log" "\ -Return non-nil if logging is enabled for BUFFER. -If BUFFER is nil, the value of `current-buffer' is used. -Logging is enabled if `erc-log-channels-directory' is non-nil, the directory -is writable (it will be created as necessary) and -`erc-enable-logging' returns a non-nil value. - -\(fn &optional BUFFER)" nil nil) - -(autoload 'erc-save-buffer-in-logs "erc-log" "\ -Append BUFFER contents to the log file, if logging is enabled. -If BUFFER is not provided, current buffer is used. -Logging is enabled if `erc-logging-enabled' returns non-nil. - -This is normally done on exit, to save the unsaved portion of the -buffer, since only the text that runs off the buffer limit is logged -automatically. - -You can save every individual message by putting this function on -`erc-insert-post-hook'. - -\(fn &optional BUFFER)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-log" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-match" "erc/erc-match.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-match" "erc/erc-match.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-match.el - (autoload 'erc-match-mode "erc-match") - -(autoload 'erc-add-pal "erc-match" "\ -Add pal interactively to `erc-pals'. - -\(fn)" t nil) - -(autoload 'erc-delete-pal "erc-match" "\ -Delete pal interactively to `erc-pals'. - -\(fn)" t nil) - -(autoload 'erc-add-fool "erc-match" "\ -Add fool interactively to `erc-fools'. - -\(fn)" t nil) - -(autoload 'erc-delete-fool "erc-match" "\ -Delete fool interactively to `erc-fools'. - -\(fn)" t nil) - -(autoload 'erc-add-keyword "erc-match" "\ -Add keyword interactively to `erc-keywords'. - -\(fn)" t nil) - -(autoload 'erc-delete-keyword "erc-match" "\ -Delete keyword interactively to `erc-keywords'. - -\(fn)" t nil) - -(autoload 'erc-add-dangerous-host "erc-match" "\ -Add dangerous-host interactively to `erc-dangerous-hosts'. - -\(fn)" t nil) - -(autoload 'erc-delete-dangerous-host "erc-match" "\ -Delete dangerous-host interactively to `erc-dangerous-hosts'. - -\(fn)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-match" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-menu" "erc/erc-menu.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-menu" "erc/erc-menu.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-menu.el - (autoload 'erc-menu-mode "erc-menu" nil t) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-menu" '("erc-menu-"))) ;;;*** -;;;### (autoloads nil "erc-netsplit" "erc/erc-netsplit.el" (0 0 0 -;;;;;; 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-netsplit" +;;;;;; "erc/erc-netsplit.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-netsplit.el - (autoload 'erc-netsplit-mode "erc-netsplit") - -(autoload 'erc-cmd-WHOLEFT "erc-netsplit" "\ -Show who's gone. - -\(fn)" nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-netsplit" '("erc-"))) @@ -10974,189 +10714,114 @@ Show who's gone. (autoload 'erc-determine-network "erc-networks" "\ Return the name of the network or \"Unknown\" as a symbol. Use the server parameter NETWORK if provided, otherwise parse the server name and -search for a match in `erc-networks-alist'. - -\(fn)" nil nil) +search for a match in `erc-networks-alist'." nil nil) (autoload 'erc-server-select "erc-networks" "\ -Interactively select a server to connect to using `erc-server-alist'. - -\(fn)" t nil) +Interactively select a server to connect to using `erc-server-alist'." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-networks" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-notify" "erc/erc-notify.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-notify" "erc/erc-notify.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-notify.el - (autoload 'erc-notify-mode "erc-notify" nil t) - -(autoload 'erc-cmd-NOTIFY "erc-notify" "\ -Change `erc-notify-list' or list current notify-list members online. -Without args, list the current list of notified people online, -with args, toggle notify status of people. - -\(fn &rest ARGS)" nil nil) - -(autoload 'pcomplete/erc-mode/NOTIFY "erc-notify" "\ - - -\(fn)" nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-notify" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-page" "erc/erc-page.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-page" "erc/erc-page.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-page.el - (autoload 'erc-page-mode "erc-page") (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-page" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-pcomplete" "erc/erc-pcomplete.el" (0 0 -;;;;;; 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-pcomplete" +;;;;;; "erc/erc-pcomplete.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-pcomplete.el - (autoload 'erc-completion-mode "erc-pcomplete" nil t) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-pcomplete" '("pcomplete" "erc-pcomplet"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-pcomplete" '("erc-pcomplet" "pcomplete"))) ;;;*** -;;;### (autoloads nil "erc-replace" "erc/erc-replace.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-replace" +;;;;;; "erc/erc-replace.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-replace.el - (autoload 'erc-replace-mode "erc-replace") (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-replace" '("erc-replace-"))) ;;;*** -;;;### (autoloads nil "erc-ring" "erc/erc-ring.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-ring" "erc/erc-ring.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-ring.el - (autoload 'erc-ring-mode "erc-ring" nil t) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-ring" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-services" "erc/erc-services.el" (0 0 0 -;;;;;; 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-services" +;;;;;; "erc/erc-services.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-services.el - (autoload 'erc-services-mode "erc-services" nil t) - -(autoload 'erc-nickserv-identify-mode "erc-services" "\ -Set up hooks according to which MODE the user has chosen. - -\(fn MODE)" t nil) - -(autoload 'erc-nickserv-identify "erc-services" "\ -Send an \"identify <PASSWORD>\" message to NickServ. -When called interactively, read the password using `read-passwd'. - -\(fn PASSWORD)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-services" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-sound" "erc/erc-sound.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-sound" "erc/erc-sound.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-sound.el - (autoload 'erc-sound-mode "erc-sound") (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-sound" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-speedbar" "erc/erc-speedbar.el" (0 0 0 -;;;;;; 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-speedbar" +;;;;;; "erc/erc-speedbar.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-speedbar.el -(autoload 'erc-speedbar-browser "erc-speedbar" "\ -Initialize speedbar to display an ERC browser. -This will add a speedbar major display mode. - -\(fn)" t nil) - (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-speedbar" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-spelling" "erc/erc-spelling.el" (0 0 0 -;;;;;; 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-spelling" +;;;;;; "erc/erc-spelling.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-spelling.el - (autoload 'erc-spelling-mode "erc-spelling" nil t) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-spelling" '("erc-spelling-"))) ;;;*** -;;;### (autoloads nil "erc-stamp" "erc/erc-stamp.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-stamp" "erc/erc-stamp.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-stamp.el - (autoload 'erc-timestamp-mode "erc-stamp" nil t) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-stamp" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-track" "erc/erc-track.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-track" "erc/erc-track.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-track.el -(defvar erc-track-minor-mode nil "\ -Non-nil if Erc-Track minor mode is enabled. -See the `erc-track-minor-mode' command -for a description of this minor mode.") - -(custom-autoload 'erc-track-minor-mode "erc-track" nil) - -(autoload 'erc-track-minor-mode "erc-track" "\ -Toggle mode line display of ERC activity (ERC Track minor mode). -With a prefix argument ARG, enable ERC Track minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. - -ERC Track minor mode is a global minor mode. It exists for the -sole purpose of providing the C-c C-SPC and C-c C-@ keybindings. -Make sure that you have enabled the track module, otherwise the -keybindings will not do anything useful. - -\(fn &optional ARG)" t nil) - (autoload 'erc-track-mode "erc-track" nil t) - (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-track" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-truncate" "erc/erc-truncate.el" (0 0 0 -;;;;;; 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-truncate" +;;;;;; "erc/erc-truncate.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-truncate.el - (autoload 'erc-truncate-mode "erc-truncate" nil t) - -(autoload 'erc-truncate-buffer-to-size "erc-truncate" "\ -Truncates the buffer to the size SIZE. -If BUFFER is not provided, the current buffer is assumed. The deleted -region is logged if `erc-logging-enabled' returns non-nil. - -\(fn SIZE &optional BUFFER)" nil nil) - -(autoload 'erc-truncate-buffer "erc-truncate" "\ -Truncates the current buffer to `erc-max-buffer-size'. -Meant to be used in hooks, like `erc-insert-post-hook'. - -\(fn)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-truncate" '("erc-max-buffer-size"))) ;;;*** -;;;### (autoloads nil "erc-xdcc" "erc/erc-xdcc.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-xdcc" "erc/erc-xdcc.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-xdcc.el - (autoload 'erc-xdcc-mode "erc-xdcc") - -(autoload 'erc-xdcc-add-file "erc-xdcc" "\ -Add a file to `erc-xdcc-files'. - -\(fn FILE)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-xdcc" '("erc-"))) @@ -11239,9 +10904,7 @@ Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test). (put 'ert-with-test-buffer 'lisp-indent-function 1) (autoload 'ert-kill-all-test-buffers "ert-x" "\ -Kill all test buffers that are still live. - -\(fn)" t nil) +Kill all test buffers that are still live." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ert-x" '("ert-"))) @@ -11455,14 +11118,9 @@ Returns t if it visits a tags table, or nil if there are no more in the list. Return a list of files in the current tags table. Assumes the tags table is the current buffer. The file names are returned as they appeared in the `etags' command that created the table, usually -without directory names. - -\(fn)" nil nil) +without directory names." nil nil) -(autoload 'tags-lazy-completion-table "etags" "\ - - -\(fn)" nil nil) +(autoload 'tags-lazy-completion-table "etags" nil nil nil) (defun tags-completion-at-point-function () (if (or tags-table-list tags-file-name) (progn @@ -11586,7 +11244,9 @@ See documentation of variable `tags-file-name'. (defalias 'pop-tag-mark 'xref-pop-marker-stack) -(autoload 'next-file "etags" "\ +(defalias 'next-file 'tags-next-file) + +(autoload 'tags-next-file "etags" "\ Select next file among files in current tags table. A first argument of t (prefix arg, if interactive) initializes to the @@ -11606,40 +11266,32 @@ Continue last \\[tags-search] or \\[tags-query-replace] command. Used noninteractively with non-nil argument to begin such a command (the argument is passed to `next-file', which see). -Two variables control the processing we do on each file: the value of -`tags-loop-scan' is a form to be executed on each file to see if it is -interesting (it returns non-nil if so) and `tags-loop-operate' is a form to -evaluate to operate on an interesting file. If the latter evaluates to -nil, we exit; otherwise we scan the next file. - \(fn &optional FIRST-TIME)" t nil) +(make-obsolete 'tags-loop-continue 'fileloop-continue '"27.1") + (autoload 'tags-search "etags" "\ Search through all files listed in tags table for match for REGEXP. Stops when a match is found. To continue searching for next match, use command \\[tags-loop-continue]. -If FILE-LIST-FORM is non-nil, it should be a form that, when -evaluated, will return a list of file names. The search will be -restricted to these files. +If FILES if non-nil should be a list or an iterator returning the files to search. +The search will be restricted to these files. Also see the documentation of the `tags-file-name' variable. -\(fn REGEXP &optional FILE-LIST-FORM)" t nil) +\(fn REGEXP &optional FILES)" t nil) (autoload 'tags-query-replace "etags" "\ 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 \\[tags-loop-continue]. -Fourth arg FILE-LIST-FORM non-nil means initialize the replacement loop. +For non-interactive use, superceded by `fileloop-initialize-replace'. -If FILE-LIST-FORM is non-nil, it is a form to evaluate to -produce the list of files to search. +\(fn FROM TO &optional DELIMITED FILES)" t nil) -See also the documentation of the variable `tags-file-name'. - -\(fn FROM TO &optional DELIMITED FILE-LIST-FORM)" t nil) +(set-advertised-calling-convention 'tags-query-replace '(from to &optional delimited) '"27.1") (autoload 'list-tags "etags" "\ Display list of tags in file FILE. @@ -11659,24 +11311,17 @@ Display list of all tags in tags table REGEXP matches. (autoload 'select-tags-table "etags" "\ Select a tags table file from a menu of those you have already used. The list of tags tables to select from is stored in `tags-table-set-list'; -see the doc of that variable if you want to add names to the list. - -\(fn)" t nil) +see the doc of that variable if you want to add names to the list." t nil) (autoload 'complete-tag "etags" "\ Perform tags completion on the text around point. Completes to the set of names listed in the current tags table. The string to complete is chosen in the same way as the default -for \\[find-tag] (which see). - -\(fn)" t nil) - -(autoload 'etags--xref-backend "etags" "\ +for \\[find-tag] (which see)." t nil) +(autoload 'etags--xref-backend "etags" nil nil nil) -\(fn)" nil nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "etags" '("xref-" "etags-" "snarf-tag-function" "select-tags-table-" "tag" "file-of-tag" "find-tag-" "list-tags-function" "last-tag" "initialize-new-tags-table" "verify-tags-table-function" "goto-tag-location-function" "next-file-list" "default-tags-table-function"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "etags" '("default-tags-table-function" "etags-" "file-of-tag" "find-tag-" "goto-tag-location-function" "initialize-new-tags-table" "last-tag" "list-tags-function" "select-tags-table-" "snarf-tag-function" "tag" "verify-tags-table-function" "xref-"))) ;;;*** @@ -11684,10 +11329,7 @@ for \\[find-tag] (which see). ;;;;;; 0 0)) ;;; Generated autoloads from language/ethio-util.el -(autoload 'setup-ethiopic-environment-internal "ethio-util" "\ - - -\(fn)" nil nil) +(autoload 'setup-ethiopic-environment-internal "ethio-util" nil nil nil) (autoload 'ethio-sera-to-fidel-buffer "ethio-util" "\ Convert the current buffer from SERA to FIDEL. @@ -11776,9 +11418,7 @@ The markers \"<sera>\" and \"</sera>\" themselves are not deleted. \(fn &optional FORCE)" t nil) (autoload 'ethio-modify-vowel "ethio-util" "\ -Modify the vowel of the FIDEL that is under the cursor. - -\(fn)" t nil) +Modify the vowel of the FIDEL that is under the cursor." t nil) (autoload 'ethio-replace-space "ethio-util" "\ Replace ASCII spaces with Ethiopic word separators in the region. @@ -11801,14 +11441,10 @@ This function is deprecated. \(fn ARG)" t nil) (autoload 'ethio-fidel-to-tex-buffer "ethio-util" "\ -Convert each fidel characters in the current buffer into a fidel-tex command. - -\(fn)" t nil) +Convert each fidel characters in the current buffer into a fidel-tex command." t nil) (autoload 'ethio-tex-to-fidel-buffer "ethio-util" "\ -Convert fidel-tex commands in the current buffer into fidel chars. - -\(fn)" t nil) +Convert fidel-tex commands in the current buffer into fidel chars." t nil) (autoload 'ethio-fidel-to-java-buffer "ethio-util" "\ Convert Ethiopic characters into the Java escape sequences. @@ -11817,24 +11453,16 @@ Each escape sequence is of the form \\uXXXX, where XXXX is the character's codepoint (in hex) in Unicode. If `ethio-java-save-lowercase' is non-nil, use [0-9a-f]. -Otherwise, [0-9A-F]. - -\(fn)" nil nil) +Otherwise, [0-9A-F]." nil nil) (autoload 'ethio-java-to-fidel-buffer "ethio-util" "\ -Convert the Java escape sequences into corresponding Ethiopic characters. - -\(fn)" nil nil) +Convert the Java escape sequences into corresponding Ethiopic characters." nil nil) (autoload 'ethio-find-file "ethio-util" "\ -Transliterate file content into Ethiopic depending on filename suffix. - -\(fn)" nil nil) +Transliterate file content into Ethiopic depending on filename suffix." nil nil) (autoload 'ethio-write-file "ethio-util" "\ -Transliterate Ethiopic characters in ASCII depending on the file extension. - -\(fn)" nil nil) +Transliterate Ethiopic characters in ASCII depending on the file extension." nil nil) (autoload 'ethio-insert-ethio-space "ethio-util" "\ Insert the Ethiopic word delimiter (the colon-like character). @@ -11845,9 +11473,9 @@ With ARG, insert that many delimiters. (autoload 'ethio-composition-function "ethio-util" "\ -\(fn POS TO FONT-OBJECT STRING)" nil nil) +\(fn POS TO FONT-OBJECT STRING DIRECTION)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ethio-util" '("exit-ethiopic-environment" "ethio-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ethio-util" '("ethio-" "exit-ethiopic-environment"))) ;;;*** @@ -11897,11 +11525,11 @@ queries the server for the existing fields and displays a corresponding form. (autoload 'eudc-load-eudc "eudc" "\ Load the Emacs Unified Directory Client. -This does nothing except loading eudc by autoload side-effect. +This does nothing except loading eudc by autoload side-effect." t nil) -\(fn)" t nil) +(defvar eudc-tools-menu (let ((map (make-sparse-keymap "Directory Servers"))) (define-key map [phone] `(menu-item ,(purecopy "Get Phone") eudc-get-phone :help ,(purecopy "Get the phone field of name from the directory server"))) (define-key map [email] `(menu-item ,(purecopy "Get Email") eudc-get-email :help ,(purecopy "Get the email field of NAME from the directory server"))) (define-key map [separator-eudc-email] menu-bar-separator) (define-key map [expand-inline] `(menu-item ,(purecopy "Expand Inline Query") eudc-expand-inline :help ,(purecopy "Query the directory server, and expand the query string before point"))) (define-key map [query] `(menu-item ,(purecopy "Query with Form") eudc-query-form :help ,(purecopy "Display a form to query the directory server"))) (define-key map [separator-eudc-query] menu-bar-separator) (define-key map [new] `(menu-item ,(purecopy "New Server") eudc-set-server :help ,(purecopy "Set the directory server to SERVER using PROTOCOL"))) (define-key map [load] `(menu-item ,(purecopy "Load Hotlist of Servers") eudc-load-eudc :help ,(purecopy "Load the Emacs Unified Directory Client"))) map)) -(cond ((not (featurep 'xemacs)) (defvar eudc-tools-menu (let ((map (make-sparse-keymap "Directory Servers"))) (define-key map [phone] `(menu-item ,(purecopy "Get Phone") eudc-get-phone :help ,(purecopy "Get the phone field of name from the directory server"))) (define-key map [email] `(menu-item ,(purecopy "Get Email") eudc-get-email :help ,(purecopy "Get the email field of NAME from the directory server"))) (define-key map [separator-eudc-email] menu-bar-separator) (define-key map [expand-inline] `(menu-item ,(purecopy "Expand Inline Query") eudc-expand-inline :help ,(purecopy "Query the directory server, and expand the query string before point"))) (define-key map [query] `(menu-item ,(purecopy "Query with Form") eudc-query-form :help ,(purecopy "Display a form to query the directory server"))) (define-key map [separator-eudc-query] menu-bar-separator) (define-key map [new] `(menu-item ,(purecopy "New Server") eudc-set-server :help ,(purecopy "Set the directory server to SERVER using PROTOCOL"))) (define-key map [load] `(menu-item ,(purecopy "Load Hotlist of Servers") eudc-load-eudc :help ,(purecopy "Load the Emacs Unified Directory Client"))) map)) (fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu))) (t (let ((menu '("Directory Servers" ["Load Hotlist of Servers" eudc-load-eudc t] ["New Server" eudc-set-server t] ["---" nil nil] ["Query with Form" eudc-query-form t] ["Expand Inline Query" eudc-expand-inline t] ["---" nil nil] ["Get Email" eudc-get-email t] ["Get Phone" eudc-get-phone t]))) (if (not (featurep 'eudc-autoloads)) (if (featurep 'xemacs) (if (and (featurep 'menubar) (not (featurep 'infodock))) (add-submenu '("Tools") menu)) (require 'easymenu) (cond ((fboundp 'easy-menu-add-item) (easy-menu-add-item nil '("tools") (easy-menu-create-menu (car menu) (cdr menu)))) ((fboundp 'easy-menu-create-keymaps) (define-key global-map [menu-bar tools eudc] (cons "Directory Servers" (easy-menu-create-keymaps "Directory Servers" (cdr menu))))))))))) +(fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu)) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eudc" '("eudc-"))) @@ -11949,14 +11577,10 @@ Display a button for the JPEG DATA. (autoload 'eudc-insert-record-at-point-into-bbdb "eudc-export" "\ Insert record at point into the BBDB database. -This function can only be called from a directory query result buffer. - -\(fn)" t nil) +This function can only be called from a directory query result buffer." t nil) (autoload 'eudc-try-bbdb-insert "eudc-export" "\ -Call `eudc-insert-record-at-point-into-bbdb' if on a record. - -\(fn)" t nil) +Call `eudc-insert-record-at-point-into-bbdb' if on a record." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eudc-export" '("eudc-"))) @@ -11967,9 +11591,7 @@ Call `eudc-insert-record-at-point-into-bbdb' if on a record. ;;; Generated autoloads from net/eudc-hotlist.el (autoload 'eudc-edit-hotlist "eudc-hotlist" "\ -Edit the hotlist of directory servers in a specialized buffer. - -\(fn)" t nil) +Edit the hotlist of directory servers in a specialized buffer." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eudc-hotlist" '("eudc-hotlist-"))) @@ -12034,7 +11656,7 @@ fourth arg NOSEP non-nil inhibits this. ;;;### (autoloads nil "eww" "net/eww.el" (0 0 0 0)) ;;; Generated autoloads from net/eww.el -(defvar eww-suggest-uris '(eww-links-at-point url-get-url-at-point eww-current-url) "\ +(defvar eww-suggest-uris '(eww-links-at-point thing-at-point-url-at-point eww-current-url) "\ List of functions called to form the list of default URIs for `eww'. Each of the elements is a function returning either a string or a list of strings. The results will be joined into a single list with @@ -12047,7 +11669,10 @@ 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'. -\(fn URL)" t nil) +If called with a prefix ARG, use a new buffer instead of reusing +the default EWW buffer. + +\(fn URL &optional ARG)" t nil) (defalias 'browse-web 'eww) (autoload 'eww-open-file "eww" "\ @@ -12060,9 +11685,7 @@ Search the web for the text between BEG and END. If region is active (and not whitespace), search the web for the text between BEG and END. Else, prompt the user for a search string. See the `eww-search-prefix' variable for the search -engine used. - -\(fn)" t nil) +engine used." t nil) (autoload 'eww-mode "eww" "\ Mode for browsing the web. @@ -12075,9 +11698,7 @@ Mode for browsing the web. \(fn URL &optional NEW-WINDOW)" nil nil) (autoload 'eww-list-bookmarks "eww" "\ -Display the bookmarks. - -\(fn)" t nil) +Display the bookmarks." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eww" '("eww-"))) @@ -12113,9 +11734,7 @@ executable. (autoload 'executable-make-buffer-file-executable-if-script-p "executable" "\ Make file executable according to umask if not already executable. If file already has any execute bits set at all, do not change existing -file modes. - -\(fn)" nil nil) +file modes." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "executable" '("executable-"))) @@ -12150,21 +11769,15 @@ If ARG is omitted, point is placed at the end of the expanded text. (autoload 'expand-abbrev-hook "expand" "\ Abbrev hook used to do the expansion job of expand abbrevs. -See `expand-add-abbrevs'. Value is non-nil if expansion was done. - -\(fn)" nil nil) +See `expand-add-abbrevs'. Value is non-nil if expansion was done." nil nil) (autoload 'expand-jump-to-previous-slot "expand" "\ Move the cursor to the previous slot in the last abbrev expansion. -This is used only in conjunction with `expand-add-abbrevs'. - -\(fn)" t nil) +This is used only in conjunction with `expand-add-abbrevs'." t nil) (autoload 'expand-jump-to-next-slot "expand" "\ Move the cursor to the next slot in the last abbrev expansion. -This is used only in conjunction with `expand-add-abbrevs'. - -\(fn)" t nil) +This is used only in conjunction with `expand-add-abbrevs'." t nil) (define-key abbrev-map "p" 'expand-jump-to-previous-slot) (define-key abbrev-map "n" 'expand-jump-to-next-slot) @@ -12361,10 +11974,14 @@ a top-level keymap, `text-scale-increase' or (autoload 'buffer-face-mode "face-remap" "\ Minor mode for a buffer-specific default face. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. When enabled, the face specified by the -variable `buffer-face-mode-face' is used to display the buffer text. + +If called interactively, enable Buffer-Face mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + +When enabled, the face specified by the variable +`buffer-face-mode-face' is used to display the buffer text. \(fn &optional ARG)" t nil) @@ -12405,7 +12022,46 @@ Besides the choice of face, it is the same as `buffer-face-mode'. \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "face-remap" '("buffer-face-mode-" "text-scale-m" "face-" "internal-lisp-face-attributes"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "face-remap" '("buffer-face-mode-" "face-" "internal-lisp-face-attributes" "text-scale-m"))) + +;;;*** + +;;;### (autoloads nil "faceup" "emacs-lisp/faceup.el" (0 0 0 0)) +;;; Generated autoloads from emacs-lisp/faceup.el +(push (purecopy '(faceup 0 0 6)) package--builtin-versions) + +(autoload 'faceup-view-buffer "faceup" "\ +Display the faceup representation of the current buffer." t nil) + +(autoload 'faceup-write-file "faceup" "\ +Save the faceup representation of the current buffer to the file FILE-NAME. + +Unless a name is given, the file will be named xxx.faceup, where +xxx is the file name associated with the buffer. + +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. + +\(fn &optional FILE-NAME CONFIRM)" t nil) + +(autoload 'faceup-render-view-buffer "faceup" "\ +Convert BUFFER containing Faceup markup to a new buffer and display it. + +\(fn &optional BUFFER)" t nil) + +(autoload 'faceup-clean-buffer "faceup" "\ +Remove faceup markup from buffer." t nil) + +(autoload 'faceup-defexplainer "faceup" "\ +Define an Ert explainer function for FUNCTION. + +FUNCTION must return an explanation when the test fails and +`faceup-test-explain' is set. + +\(fn FUNCTION)" nil t) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "faceup" '("faceup-"))) ;;;*** @@ -12416,9 +12072,7 @@ Besides the choice of face, it is the same as `buffer-face-mode'. (autoload 'feedmail-send-it "feedmail" "\ Send the current mail buffer using the Feedmail package. This is a suitable value for `send-mail-function'. It can be used -with various lower-level mechanisms to provide features such as queueing. - -\(fn)" nil nil) +with various lower-level mechanisms to provide features such as queueing." nil nil) (autoload 'feedmail-run-the-queue-no-prompts "feedmail" "\ Like `feedmail-run-the-queue', but suppress confirmation prompts. @@ -12518,16 +12172,12 @@ If `dired-at-point-require-prefix' is set, the prefix meaning is reversed. (autoload 'ffap-guess-file-name-at-point "ffap" "\ Try to get a file name at point. -This hook is intended to be put in `file-name-at-point-functions'. - -\(fn)" nil nil) +This hook is intended to be put in `file-name-at-point-functions'." nil nil) (autoload 'ffap-bindings "ffap" "\ -Evaluate the forms in variable `ffap-bindings'. - -\(fn)" t nil) +Evaluate the forms in variable `ffap-bindings'." t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ffap" '("find-file-literally-at-point" "ffap-" "dired-at-point-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ffap" '("dired-at-point-" "ffap-" "find-file-literally-at-point"))) ;;;*** @@ -12568,7 +12218,7 @@ STRING is passed as an argument to the locate command. \(fn STRING)" t nil) (autoload 'file-cache-add-directory-recursively "filecache" "\ -Adds DIR and any subdirectories to the file-cache. +Add DIR and any subdirectories to the file-cache. This function does not use any external programs. If the optional REGEXP argument is non-nil, only files which match it will be added to the cache. Note that the REGEXP is applied to the @@ -12590,6 +12240,41 @@ the name is considered already unique; only the second substitution ;;;*** +;;;### (autoloads nil "fileloop" "fileloop.el" (0 0 0 0)) +;;; Generated autoloads from fileloop.el + +(autoload 'fileloop-initialize "fileloop" "\ +Initialize a new round of operation on several files. +FILES can be either a list of file names, or an iterator (used with `iter-next') +which returns a file name at each step. +SCAN-FUNCTION is a function called with no argument inside a buffer +and it should return non-nil if that buffer has something on which to operate. +OPERATE-FUNCTION is a function called with no argument; it is expected +to perform the operation on the current file buffer and when done +should return non-nil to mean that we should immediately continue +operating on the next file and nil otherwise. + +\(fn FILES SCAN-FUNCTION OPERATE-FUNCTION)" nil nil) + +(autoload 'fileloop-initialize-search "fileloop" "\ + + +\(fn REGEXP FILES CASE-FOLD)" nil nil) + +(autoload 'fileloop-initialize-replace "fileloop" "\ +Initialize a new round of query&replace on several files. +FROM is a regexp and TO is the replacement to use. +FILES describes the file, as in `fileloop-initialize'. +CASE-FOLD can be t, nil, or `default', the latter one meaning to obey +the default setting of `case-fold-search'. +DELIMITED if non-nil means replace only word-delimited matches. + +\(fn FROM TO FILES CASE-FOLD &optional DELIMITED)" nil nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "fileloop" '("fileloop-"))) + +;;;*** + ;;;### (autoloads nil "filenotify" "filenotify.el" (0 0 0 0)) ;;; Generated autoloads from filenotify.el @@ -12656,19 +12341,13 @@ Delete all MODE settings of file-local VARIABLE from .dir-locals.el. \(fn MODE VARIABLE)" t nil) (autoload 'copy-file-locals-to-dir-locals "files-x" "\ -Copy file-local variables to .dir-locals.el. - -\(fn)" t nil) +Copy file-local variables to .dir-locals.el." t nil) (autoload 'copy-dir-locals-to-file-locals "files-x" "\ -Copy directory-local variables to the Local Variables list. - -\(fn)" t nil) +Copy directory-local variables to the Local Variables list." t nil) (autoload 'copy-dir-locals-to-file-locals-prop-line "files-x" "\ -Copy directory-local variables to the -*- line. - -\(fn)" t nil) +Copy directory-local variables to the -*- line." t nil) (defvar enable-connection-local-variables t "\ Non-nil means enable use of connection-local variables.") @@ -12709,15 +12388,13 @@ will not be changed. \(fn CRITERIA)" nil nil) -(autoload 'with-connection-local-profiles "files-x" "\ -Apply connection-local variables according to PROFILES in current buffer. +(autoload 'with-connection-local-variables "files-x" "\ +Apply connection-local variables according to `default-directory'. Execute BODY, and unwind connection-local variables. -\(fn PROFILES &rest BODY)" nil t) +\(fn &rest BODY)" nil t) -(function-put 'with-connection-local-profiles 'lisp-indent-function '1) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "files-x" '("hack-connection-local-variables" "connection-local-" "modify-" "read-file-local-variable"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "files-x" '("connection-local-" "dir-locals-to-string" "hack-connection-local-variables" "modify-" "read-file-local-variable"))) ;;;*** @@ -12726,9 +12403,7 @@ Execute BODY, and unwind connection-local variables. (autoload 'filesets-init "filesets" "\ Filesets initialization. -Set up hooks, load the cache file -- if existing -- and build the menu. - -\(fn)" nil nil) +Set up hooks, load the cache file -- if existing -- and build the menu." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "filesets" '("filesets-"))) @@ -12794,7 +12469,7 @@ specifies what to use in place of \"-ls\" as the final argument. \(fn DIR REGEXP)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-dired" '("find-" "lookfor-dired" "kill-find"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-dired" '("find-" "kill-find" "lookfor-dired"))) ;;;*** @@ -12886,7 +12561,7 @@ Visit the file you click on in another window. \(fn EVENT)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-file" '("ff-" "modula2-other-file-alist" "cc-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-file" '("cc-" "ff-" "modula2-other-file-alist"))) ;;;*** @@ -13060,19 +12735,13 @@ See `find-function-on-key'. \(fn KEY)" t nil) (autoload 'find-function-at-point "find-func" "\ -Find directly the function at point in the other window. - -\(fn)" t nil) +Find directly the function at point in the other window." t nil) (autoload 'find-variable-at-point "find-func" "\ -Find directly the variable at point in the other window. - -\(fn)" t nil) +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. - -\(fn)" nil nil) +Define some key bindings for the find-function family of functions." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-func" '("find-" "read-library-name"))) @@ -13105,9 +12774,7 @@ Change the filter on a `find-lisp-find-dired' buffer to REGEXP. (push (purecopy '(finder 1 0)) package--builtin-versions) (autoload 'finder-list-keywords "finder" "\ -Display descriptions of the keywords in the Finder buffer. - -\(fn)" t nil) +Display descriptions of the keywords in the Finder buffer." t nil) (autoload 'finder-commentary "finder" "\ Display FILE's commentary section. @@ -13116,9 +12783,7 @@ FILE should be in a form suitable for passing to `locate-library'. \(fn FILE)" t nil) (autoload 'finder-by-keyword "finder" "\ -Find packages matching a given keyword. - -\(fn)" t nil) +Find packages matching a given keyword." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "finder" '("finder-" "generated-finder-keywords-file"))) @@ -13166,7 +12831,7 @@ to get the effect of a C-q. ;;;### (autoloads nil "flymake" "progmodes/flymake.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/flymake.el -(push (purecopy '(flymake 0 3)) package--builtin-versions) +(push (purecopy '(flymake 1 0 6)) package--builtin-versions) (autoload 'flymake-log "flymake" "\ Log, at level LEVEL, the message MSG formatted with ARGS. @@ -13179,10 +12844,16 @@ generated it. (autoload 'flymake-make-diagnostic "flymake" "\ Make a Flymake diagnostic for BUFFER's region from BEG to END. -TYPE is a key to `flymake-diagnostic-types-alist' and TEXT is a -description of the problem detected in this region. +TYPE is a key to symbol and TEXT is a description of the problem +detected in this region. DATA is any object that the caller +wishes to attach to the created diagnostic for later retrieval. + +OVERLAY-PROPERTIES is an an alist of properties attached to the +created diagnostic, overriding the default properties and any +properties of `flymake-overlay-control' of the diagnostic's +type. -\(fn BUFFER BEG END TYPE TEXT)" nil nil) +\(fn BUFFER BEG END TYPE TEXT &optional DATA OVERLAY-PROPERTIES)" nil nil) (autoload 'flymake-diagnostics "flymake" "\ Get Flymake diagnostics in region determined by BEG and END. @@ -13202,28 +12873,30 @@ region is invalid. (autoload 'flymake-mode "flymake" "\ Toggle Flymake mode on or off. -With a prefix argument ARG, enable Flymake mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'. + +If called interactively, enable Flymake mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. 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 results. -Flymake performs these checks while the user is editing. The -customization variables `flymake-start-on-flymake-mode', -`flymake-no-changes-timeout' and -`flymake-start-syntax-check-on-newline' determine the exact -circumstances whereupon Flymake decides to initiate a check of -the buffer. +Flymake performs these checks while the user is editing. +The customization variables `flymake-start-on-flymake-mode', +`flymake-no-changes-timeout' determine the exact circumstances +whereupon Flymake decides to initiate a check of the buffer. The commands `flymake-goto-next-error' and `flymake-goto-prev-error' can be used to navigate among Flymake diagnostics annotated in the buffer. The visual appearance of each type of diagnostic can be changed -in the variable `flymake-diagnostic-types-alist'. +by setting properties `flymake-overlay-control', `flymake-bitmap' +and `flymake-severity' on the symbols of diagnostic types (like +`:error', `:warning' and `:note'). Activation or deactivation of backends used by Flymake in each buffer happens via the special hook @@ -13239,23 +12912,35 @@ special *Flymake log* buffer. \(fn &optional ARG)" t nil) (autoload 'flymake-mode-on "flymake" "\ -Turn Flymake mode on. - -\(fn)" nil nil) +Turn Flymake mode on." nil nil) (autoload 'flymake-mode-off "flymake" "\ -Turn Flymake mode off. - -\(fn)" nil nil) +Turn Flymake mode off." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "flymake" '("flymake-"))) ;;;*** +;;;### (autoloads nil "flymake-cc" "progmodes/flymake-cc.el" (0 0 +;;;;;; 0 0)) +;;; Generated autoloads from progmodes/flymake-cc.el + +(autoload 'flymake-cc "flymake-cc" "\ +Flymake backend for GNU-style C compilers. +This backend uses `flymake-cc-command' (which see) to launch a +process that is passed the current buffer's contents via stdin. +REPORT-FN is Flymake's callback. + +\(fn REPORT-FN &rest ARGS)" nil nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "flymake-cc" '("flymake-cc-"))) + +;;;*** + ;;;### (autoloads nil "flymake-proc" "progmodes/flymake-proc.el" ;;;;;; (0 0 0 0)) ;;; Generated autoloads from progmodes/flymake-proc.el -(push (purecopy '(flymake-proc 0 3)) package--builtin-versions) +(push (purecopy '(flymake-proc 1 0)) package--builtin-versions) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "flymake-proc" '("flymake-proc-"))) @@ -13265,16 +12950,16 @@ Turn Flymake mode off. ;;; Generated autoloads from textmodes/flyspell.el (autoload 'flyspell-prog-mode "flyspell" "\ -Turn on `flyspell-mode' for comments and strings. - -\(fn)" t nil) +Turn on `flyspell-mode' for comments and strings." t nil) (defvar flyspell-mode nil "Non-nil if Flyspell mode is enabled.") (autoload 'flyspell-mode "flyspell" "\ Toggle on-the-fly spell checking (Flyspell mode). -With a prefix argument ARG, enable Flyspell mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Flyspell mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Flyspell mode is a buffer-local minor mode. When enabled, it spawns a single Ispell process and checks each word. The default @@ -13305,19 +12990,13 @@ in your init file. \(fn &optional ARG)" t nil) (autoload 'turn-on-flyspell "flyspell" "\ -Unconditionally turn on Flyspell mode. - -\(fn)" nil nil) +Unconditionally turn on Flyspell mode." nil nil) (autoload 'turn-off-flyspell "flyspell" "\ -Unconditionally turn off Flyspell mode. - -\(fn)" nil nil) +Unconditionally turn off Flyspell mode." nil nil) (autoload 'flyspell-mode-off "flyspell" "\ -Turn Flyspell mode off. - -\(fn)" nil nil) +Turn Flyspell mode off." nil nil) (autoload 'flyspell-region "flyspell" "\ Flyspell text between BEG and END. @@ -13328,9 +13007,7 @@ of a misspelled word removed when you've corrected it. \(fn BEG END)" t nil) (autoload 'flyspell-buffer "flyspell" "\ -Flyspell whole buffer. - -\(fn)" t nil) +Flyspell whole buffer." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "flyspell" '("flyspell-" "mail-mode-flyspell-verify" "make-flyspell-overlay" "sgml-mode-flyspell-verify" "tex"))) @@ -13348,20 +13025,18 @@ Flyspell whole buffer. ;;; Generated autoloads from follow.el (autoload 'turn-on-follow-mode "follow" "\ -Turn on Follow mode. Please see the function `follow-mode'. - -\(fn)" nil nil) +Turn on Follow mode. Please see the function `follow-mode'." nil nil) (autoload 'turn-off-follow-mode "follow" "\ -Turn off Follow mode. Please see the function `follow-mode'. - -\(fn)" nil nil) +Turn off Follow mode. Please see the function `follow-mode'." nil nil) (autoload 'follow-mode "follow" "\ Toggle Follow mode. -With a prefix argument ARG, enable Follow mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Follow mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Follow mode is a minor mode that combines windows into one tall virtual window. This is accomplished by two main techniques: @@ -13472,7 +13147,7 @@ selected if the original window is the first one in the frame. ;;;;;; 0)) ;;; Generated autoloads from international/fontset.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "fontset" '("charset-script-alist" "create-" "set" "standard-fontset-spec" "fontset-" "generate-fontset-menu" "xlfd-" "x-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "fontset" '("charset-script-alist" "create-" "fontset-" "generate-fontset-menu" "set" "standard-fontset-spec" "x-" "xlfd-"))) ;;;*** @@ -13482,9 +13157,11 @@ selected if the original window is the first one in the frame. (autoload 'footnote-mode "footnote" "\ Toggle Footnote mode. -With a prefix argument ARG, enable Footnote mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Footnote mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Footnote mode is a buffer-local minor mode. If enabled, it provides footnote support for `message-mode'. To get started, @@ -13493,7 +13170,7 @@ play around with the following keys: \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "footnote" '("footnote-" "Footnote-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "footnote" '("footnote-"))) ;;;*** @@ -13841,18 +13518,6 @@ All keyword parameters default to nil. \(fn FRAMESET &key PREDICATE FILTERS REUSE-FRAMES FORCE-DISPLAY FORCE-ONSCREEN CLEANUP-FRAMES)" nil nil) -(autoload 'frameset--jump-to-register "frameset" "\ -Restore frameset from DATA stored in register. -Called from `jump-to-register'. Internal use only. - -\(fn DATA)" nil nil) - -(autoload 'frameset--print-register "frameset" "\ -Print basic info about frameset stored in DATA. -Called from `list-registers' and `view-register'. Internal use only. - -\(fn DATA)" nil nil) - (autoload 'frameset-to-register "frameset" "\ Store the current frameset in register REGISTER. Use \\[jump-to-register] to restore the frameset. @@ -13869,6 +13534,8 @@ 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.")) + (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "fringe" '("fringe-" "set-fringe-"))) ;;;*** @@ -13906,6 +13573,11 @@ 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). +If called interactively, enable Gdb-Enable-Debug mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + \(fn &optional ARG)" t nil) (autoload 'gdb "gdb-mi" "\ @@ -13968,7 +13640,7 @@ detailed description of this mode. \(fn COMMAND-LINE)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gdb-mi" '("gdb" "gud-" "def-gdb-" "breakpoint-" "nil"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gdb-mi" '("breakpoint" "def-gdb-" "gdb" "gud-" "hollow-right-triangle" "nil"))) ;;;*** @@ -14065,7 +13737,7 @@ regular expression that can be used as an element of ;;;### (autoloads nil "generic-x" "generic-x.el" (0 0 0 0)) ;;; Generated autoloads from generic-x.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "generic-x" '("generic-" "default-generic-mode"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "generic-x" '("default-generic-mode" "generic-"))) ;;;*** @@ -14074,10 +13746,14 @@ regular expression that can be used as an element of (autoload 'glasses-mode "glasses" "\ Minor mode for making identifiers likeThis readable. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. When this mode is active, it tries to -add virtual separators (like underscores) at places they belong to. + +If called interactively, enable Glasses mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + +When this mode is active, it tries to add virtual +separators (like underscores) at places they belong to. \(fn &optional ARG)" t nil) @@ -14137,7 +13813,7 @@ DEFAULT-MAP specifies the default key map for ICON-LIST. \(fn ICON-LIST ZAP-LIST DEFAULT-MAP)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gmm-utils" '("gmm-" "defun-gmm"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gmm-utils" '("defun-gmm" "gmm-"))) ;;;*** @@ -14197,14 +13873,10 @@ prompt the user for the name of an NNTP server to use. ;;; Generated autoloads from gnus/gnus-agent.el (autoload 'gnus-unplugged "gnus-agent" "\ -Start Gnus unplugged. - -\(fn)" t nil) +Start Gnus unplugged." t nil) (autoload 'gnus-plugged "gnus-agent" "\ -Start Gnus plugged. - -\(fn)" t nil) +Start Gnus plugged." t nil) (autoload 'gnus-slave-unplugged "gnus-agent" "\ Read news as a slave unplugged. @@ -14220,14 +13892,10 @@ customize gnus-agent to nil. This will modify the `gnus-setup-news-hook', and `message-send-mail-real-function' variables, and install the Gnus agent -minor mode in all Gnus buffers. - -\(fn)" t nil) +minor mode in all Gnus buffers." t nil) (autoload 'gnus-agent-possibly-save-gcc "gnus-agent" "\ -Save GCC if Gnus is unplugged. - -\(fn)" nil nil) +Save GCC if Gnus is unplugged." nil nil) (autoload 'gnus-agent-rename-group "gnus-agent" "\ Rename fully-qualified OLD-GROUP as NEW-GROUP. @@ -14248,9 +13916,7 @@ supported. \(fn GROUP)" nil nil) (autoload 'gnus-agent-get-undownloaded-list "gnus-agent" "\ -Construct list of articles that have not been downloaded. - -\(fn)" nil nil) +Construct list of articles that have not been downloaded." nil nil) (autoload 'gnus-agent-possibly-alter-active "gnus-agent" "\ Possibly expand a group's active range to include articles @@ -14266,14 +13932,10 @@ variables. Returns the first non-nil value found. \(fn GROUP SYMBOL)" nil nil) (autoload 'gnus-agent-batch-fetch "gnus-agent" "\ -Start Gnus and fetch session. - -\(fn)" t nil) +Start Gnus and fetch session." t nil) (autoload 'gnus-agent-batch "gnus-agent" "\ -Start Gnus, send queue and fetch session. - -\(fn)" t nil) +Start Gnus, send queue and fetch session." t nil) (autoload 'gnus-agent-regenerate "gnus-agent" "\ Regenerate all agent covered files. @@ -14289,11 +13951,9 @@ CLEAN is obsolete and ignored. ;;; Generated autoloads from gnus/gnus-art.el (autoload 'gnus-article-prepare-display "gnus-art" "\ -Make the current buffer look like a nice article. - -\(fn)" nil nil) +Make the current buffer look like a nice article." nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-art" '("gnus-" "article-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-art" '("article-" "gnus-"))) ;;;*** @@ -14316,9 +13976,7 @@ Make the current buffer look like a nice article. ;;; Generated autoloads from gnus/gnus-bookmark.el (autoload 'gnus-bookmark-set "gnus-bookmark" "\ -Set a bookmark for this article. - -\(fn)" t nil) +Set a bookmark for this article." t nil) (autoload 'gnus-bookmark-jump "gnus-bookmark" "\ Jump to a Gnus bookmark (BMK-NAME). @@ -14329,9 +13987,7 @@ Jump to a Gnus bookmark (BMK-NAME). Display a list of existing Gnus bookmarks. The list is displayed in a buffer named `*Gnus Bookmark List*'. The leftmost column displays a D if the bookmark is flagged for -deletion, or > if it is flagged for displaying. - -\(fn)" t nil) +deletion, or > if it is flagged for displaying." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-bookmark" '("gnus-bookmark-"))) @@ -14344,9 +14000,7 @@ deletion, or > if it is flagged for displaying. Go through all groups and put the articles into the cache. Usage: -$ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache - -\(fn)" t nil) +$ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache" t nil) (autoload 'gnus-cache-generate-active "gnus-cache" "\ Generate the cache active file. @@ -14383,7 +14037,7 @@ supported. ;;;### (autoloads nil "gnus-cite" "gnus/gnus-cite.el" (0 0 0 0)) ;;; Generated autoloads from gnus/gnus-cite.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-cite" '("turn-o" "gnus-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-cite" '("gnus-" "turn-o"))) ;;;*** @@ -14397,7 +14051,7 @@ supported. ;;;### (autoloads nil "gnus-cus" "gnus/gnus-cus.el" (0 0 0 0)) ;;; Generated autoloads from gnus/gnus-cus.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-cus" '("gnus-" "category-fields"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-cus" '("category-fields" "gnus-"))) ;;;*** @@ -14420,9 +14074,7 @@ DELAY is a string, giving the length of the time. Possible values are: \(fn DELAY)" t nil) (autoload 'gnus-delay-send-queue "gnus-delay" "\ -Send all the delayed messages that are due now. - -\(fn)" t nil) +Send all the delayed messages that are due now." t nil) (autoload 'gnus-delay-initialize "gnus-delay" "\ Initialize the gnus-delay package. @@ -14466,9 +14118,7 @@ Checking delayed messages is skipped if optional arg NO-CHECK is non-nil. ;;; Generated autoloads from gnus/gnus-dired.el (autoload 'turn-on-gnus-dired-mode "gnus-dired" "\ -Convenience method to turn on gnus-dired-mode. - -\(fn)" t nil) +Convenience method to turn on gnus-dired-mode." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-dired" '("gnus-dired-"))) @@ -14478,9 +14128,7 @@ Convenience method to turn on gnus-dired-mode. ;;; Generated autoloads from gnus/gnus-draft.el (autoload 'gnus-draft-reminder "gnus-draft" "\ -Reminder user if there are unsent drafts. - -\(fn)" t nil) +Reminder user if there are unsent drafts." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-draft" '("gnus-"))) @@ -14513,14 +14161,10 @@ Return file from DIR with extension EXT, omitting matches of OMIT, processed by (autoload 'gnus-random-x-face "gnus-fun" "\ Return X-Face header data chosen randomly from `gnus-x-face-directory'. -Files matching `gnus-x-face-omit-files' are not considered. - -\(fn)" t nil) +Files matching `gnus-x-face-omit-files' are not considered." t nil) (autoload 'gnus-insert-random-x-face-header "gnus-fun" "\ -Insert a random X-Face header from `gnus-x-face-directory'. - -\(fn)" t nil) +Insert a random X-Face header from `gnus-x-face-directory'." t nil) (autoload 'gnus-x-face-from-file "gnus-fun" "\ Insert an X-Face header based on an image FILE. @@ -14554,14 +14198,10 @@ FILE should be a PNG file that's 48x48 and smaller than or equal to (autoload 'gnus-random-face "gnus-fun" "\ Return randomly chosen Face from `gnus-face-directory'. -Files matching `gnus-face-omit-files' are not considered. - -\(fn)" t nil) +Files matching `gnus-face-omit-files' are not considered." t nil) (autoload 'gnus-insert-random-face-header "gnus-fun" "\ -Insert a random Face header from `gnus-face-directory'. - -\(fn)" nil nil) +Insert a random Face header from `gnus-face-directory'." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-fun" '("gnus-"))) @@ -14627,6 +14267,11 @@ Pop up a frame and enter GROUP. ;;;;;; 0 0 0)) ;;; Generated autoloads from gnus/gnus-icalendar.el +(autoload 'gnus-icalendar-mm-inline "gnus-icalendar" "\ + + +\(fn HANDLE)" nil nil) + (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-icalendar" '("gnus-icalendar"))) ;;;*** @@ -14645,9 +14290,7 @@ Pop up a frame and enter GROUP. (autoload 'gnus-batch-score "gnus-kill" "\ Run batched scoring. -Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score - -\(fn)" t nil) +Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-kill" '("gnus-"))) @@ -14670,10 +14313,7 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score ;;;### (autoloads nil "gnus-ml" "gnus/gnus-ml.el" (0 0 0 0)) ;;; Generated autoloads from gnus/gnus-ml.el -(autoload 'turn-on-gnus-mailing-list-mode "gnus-ml" "\ - - -\(fn)" nil nil) +(autoload 'turn-on-gnus-mailing-list-mode "gnus-ml" nil nil nil) (autoload 'gnus-mailing-list-insinuate "gnus-ml" "\ Setup group parameters from List-Post header. @@ -14684,6 +14324,11 @@ If FORCE is non-nil, replace the old ones. (autoload 'gnus-mailing-list-mode "gnus-ml" "\ Minor mode for providing mailing-list commands. +If called interactively, enable Gnus-Mailing-List mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + \\{gnus-mailing-list-mode-map} \(fn &optional ARG)" t nil) @@ -14732,9 +14377,7 @@ instead. This variable is set by `gnus-group-split-setup'. Use information from group parameters in order to split mail. See `gnus-group-split-fancy' for more information. -`gnus-group-split' is a valid value for `nnmail-split-methods'. - -\(fn)" nil nil) +`gnus-group-split' is a valid value for `nnmail-split-methods'." nil nil) (autoload 'gnus-group-split-fancy "gnus-mlspl" "\ Uses information from group parameters in order to split mail. @@ -14832,9 +14475,7 @@ or equal to `gnus-notifications-minimum-level' and send a notification using `notifications-notify' for it. This is typically a function to add in -`gnus-after-getting-new-news-hook' - -\(fn)" nil nil) +`gnus-after-getting-new-news-hook'" nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-notifications" '("gnus-notifications-"))) @@ -14845,21 +14486,15 @@ This is typically a function to add in (autoload 'gnus-treat-from-picon "gnus-picon" "\ Display picons in the From header. -If picons are already displayed, remove them. - -\(fn)" t nil) +If picons are already displayed, remove them." t nil) (autoload 'gnus-treat-mail-picon "gnus-picon" "\ Display picons in the Cc and To headers. -If picons are already displayed, remove them. - -\(fn)" t nil) +If picons are already displayed, remove them." t nil) (autoload 'gnus-treat-newsgroups-picon "gnus-picon" "\ Display picons in the Newsgroups and Followup-To headers. -If picons are already displayed, remove them. - -\(fn)" t nil) +If picons are already displayed, remove them." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-picon" '("gnus-picon-"))) @@ -14939,14 +14574,10 @@ Add NUM into sorted LIST by side effect. ;;; Generated autoloads from gnus/gnus-registry.el (autoload 'gnus-registry-initialize "gnus-registry" "\ -Initialize the Gnus registry. - -\(fn)" t nil) +Initialize the Gnus registry." t nil) (autoload 'gnus-registry-install-hooks "gnus-registry" "\ -Install the registry hooks. - -\(fn)" t nil) +Install the registry hooks." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-registry" '("gnus-"))) @@ -14982,22 +14613,15 @@ Update the Sieve script in gnus-sieve-file, by replacing the region between gnus-sieve-region-start and gnus-sieve-region-end with \(gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost), then execute gnus-sieve-update-shell-command. -See the documentation for these variables and functions for details. - -\(fn)" t nil) +See the documentation for these variables and functions for details." t nil) (autoload 'gnus-sieve-generate "gnus-sieve" "\ Generate the Sieve script in gnus-sieve-file, by replacing the region between gnus-sieve-region-start and gnus-sieve-region-end with \(gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost). -See the documentation for these variables and functions for details. - -\(fn)" t nil) - -(autoload 'gnus-sieve-article-add-rule "gnus-sieve" "\ - +See the documentation for these variables and functions for details." t nil) -\(fn)" t nil) +(autoload 'gnus-sieve-article-add-rule "gnus-sieve" nil t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-sieve" '("gnus-sieve-"))) @@ -15150,8 +14774,6 @@ Use \\[describe-mode] for more info. ;;;### (autoloads nil "goto-addr" "net/goto-addr.el" (0 0 0 0)) ;;; Generated autoloads from net/goto-addr.el -(define-obsolete-function-alias 'goto-address-at-mouse 'goto-address-at-point "22.1") - (autoload 'goto-address-at-point "goto-addr" "\ Send to the e-mail address or load the URL at point. Send mail to address at point. See documentation for @@ -15168,22 +14790,27 @@ By default, goto-address binds `goto-address-at-point' to mouse-2 and C-c RET only on URLs and e-mail addresses. Also fontifies the buffer appropriately (see `goto-address-fontify-p' and -`goto-address-highlight-p' for more information). - -\(fn)" t nil) +`goto-address-highlight-p' for more information)." t nil) (put 'goto-address 'safe-local-eval-function t) (autoload 'goto-address-mode "goto-addr" "\ Minor mode to buttonize URLs and e-mail addresses in the current buffer. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. + +If called interactively, enable Goto-Address mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. \(fn &optional ARG)" t nil) (autoload 'goto-address-prog-mode "goto-addr" "\ Like `goto-address-mode', but only for comments and strings. +If called interactively, enable Goto-Address-Prog mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + \(fn &optional ARG)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "goto-addr" '("goto-address-"))) @@ -15241,7 +14868,7 @@ List of hook functions run by `grep-process-setup' (see `run-hooks').") (custom-autoload 'grep-setup-hook "grep" t) -(defconst grep-regexp-alist `((,(concat "^\\(?:" "\\(?1:[^ +(defconst grep-regexp-alist `((,(concat "^\\(?:" "\\(?1:[^\0\n]+\\)\\(?3:\0\\)\\(?2:[0-9]+\\):" "\\|" "\\(?1:" "\\(?:[a-zA-Z]:\\)?" "[^\n:]+?[^\n/:]\\):[\11 ]*\\(?2:[1-9][0-9]*\\)[\11 ]*:" "\\)") 1 2 (,(lambda nil (when grep-highlight-matches (let* ((beg (match-end 0)) (end (save-excursion (goto-char beg) (line-end-position))) (mbeg (text-property-any beg end 'font-lock-face grep-match-face))) (when mbeg (- mbeg beg))))) \, (lambda nil (when grep-highlight-matches (let* ((beg (match-end 0)) (end (save-excursion (goto-char beg) (line-end-position))) (mbeg (text-property-any beg end 'font-lock-face grep-match-face)) (mend (and mbeg (next-single-property-change mbeg 'font-lock-face nil end)))) (when mend (- mend beg)))))) nil nil (3 '(face nil display ":"))) ("^Binary file \\(.+\\) matches$" 1 nil nil 0 1)) "\ Regexp used to match grep hits. See `compilation-error-regexp-alist' for format details.") @@ -15264,10 +14891,13 @@ How to invoke find and grep. If `exec', use `find -exec {} ;'. If `exec-plus' use `find -exec {} +'. If `gnu', use `find -print0' and `xargs -0'. +If `gnu-sort', use `find -print0', `sort -z' and `xargs -0'. Any other value means to use `find -print' and `xargs'. This variable's value takes effect when `grep-compute-defaults' is called.") +(custom-autoload 'grep-find-use-xargs "grep" nil) + (defvar grep-history nil "\ History list for grep.") @@ -15276,14 +14906,9 @@ History list for grep-find.") (autoload 'grep-process-setup "grep" "\ Setup compilation variables and buffer for `grep'. -Set up `compilation-exit-message-function' and run `grep-setup-hook'. - -\(fn)" nil nil) - -(autoload 'grep-compute-defaults "grep" "\ +Set up `compilation-exit-message-function' and run `grep-setup-hook'." nil nil) - -\(fn)" nil nil) +(autoload 'grep-compute-defaults "grep" nil nil nil) (autoload 'grep-mode "grep" "\ Sets `grep-last-buffer' and `compilation-window-height'. @@ -15378,14 +15003,14 @@ file name to `*.gz', and sets `grep-highlight-matches' to `always'. (defalias 'rzgrep 'zrgrep) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "grep" '("rgrep-" "grep-" "kill-grep"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "grep" '("grep-" "kill-grep" "rgrep-"))) ;;;*** ;;;### (autoloads nil "gssapi" "gnus/gssapi.el" (0 0 0 0)) ;;; Generated autoloads from gnus/gssapi.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gssapi" '("open-gssapi-stream" "gssapi-program"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gssapi" '("gssapi-program" "open-gssapi-stream"))) ;;;*** @@ -15483,9 +15108,11 @@ or call the function `gud-tooltip-mode'.") (autoload 'gud-tooltip-mode "gud" "\ Toggle the display of GUD tooltips. -With a prefix argument ARG, enable the feature if ARG is -positive, and disable it otherwise. If called from Lisp, enable -it if ARG is omitted or nil. + +If called interactively, enable Gud-Tooltip mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. \(fn &optional ARG)" t nil) @@ -15608,9 +15235,7 @@ and `handwrite-13pt' set up for various sizes of output. Variables: `handwrite-linespace' (default 12) `handwrite-fontsize' (default 11) `handwrite-numlines' (default 60) - `handwrite-pagenumbering' (default nil) - -\(fn)" t nil) + `handwrite-pagenumbering' (default nil)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "handwrite" '("handwrite-" "menu-bar-handwrite-map"))) @@ -15637,17 +15262,13 @@ Towers of Hanoi, UNIX doomsday version. Displays 32-ring towers that have been progressing at one move per second since 1970-01-01 00:00:00 GMT. -Repent before ring 31 moves. - -\(fn)" t nil) +Repent before ring 31 moves." t nil) (autoload 'hanoi-unix-64 "hanoi" "\ Like hanoi-unix, but pretend to have a 64-bit clock. This is, necessarily (as of Emacs 20.3), a crock. When the current-time interface is made s2G-compliant, hanoi.el will need -to be updated. - -\(fn)" t nil) +to be updated." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hanoi" '("hanoi-"))) @@ -15714,9 +15335,7 @@ can also be t, if that is the value of the `kbd-help' property. Return the keyboard help string at point. If the `kbd-help' text or overlay property at point produces a string, return it. Otherwise, use the `help-echo' property. -If this produces no string either, return nil. - -\(fn)" nil nil) +If this produces no string either, return nil." nil nil) (autoload 'display-local-help "help-at-pt" "\ Display local help in the echo area. @@ -15733,15 +15352,11 @@ mainly meant for use from Lisp. (autoload 'help-at-pt-cancel-timer "help-at-pt" "\ Cancel any timer set by `help-at-pt-set-timer'. -This disables `help-at-pt-display-when-idle'. - -\(fn)" t nil) +This disables `help-at-pt-display-when-idle'." t nil) (autoload 'help-at-pt-set-timer "help-at-pt" "\ Enable `help-at-pt-display-when-idle'. -This is done by setting a timer, if none is currently active. - -\(fn)" t nil) +This is done by setting a timer, if none is currently active." t nil) (defvar help-at-pt-display-when-idle 'never "\ Automatically show local help on point-over. @@ -15822,7 +15437,7 @@ different regions. With numeric argument ARG, behaves like \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "help-at-pt" '("scan-buf-move-hook" "help-at-pt-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "help-at-pt" '("help-at-pt-" "scan-buf-move-hook"))) ;;;*** @@ -15838,6 +15453,7 @@ When called from lisp, FUNCTION may also be a function object. (autoload 'help-C-file-name "help-fns" "\ Return the name of the C file where SUBR-OR-VAR is defined. KIND should be `var' for a variable or `subr' for a subroutine. +If we can't find the file name, nil is returned. \(fn SUBR-OR-VAR KIND)" nil nil) @@ -15912,7 +15528,7 @@ Produce a texinfo buffer with sorted doc-strings from the DOC file. \(fn FILE)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "help-fns" '("help-" "describe-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "help-fns" '("describe-" "help-"))) ;;;*** @@ -15944,14 +15560,10 @@ Commands: \(fn)" t nil) (autoload 'help-mode-setup "help-mode" "\ -Enter Help Mode in the current buffer. - -\(fn)" nil nil) +Enter Help Mode in the current buffer." nil nil) (autoload 'help-mode-finish "help-mode" "\ -Finalize Help Mode setup in current buffer. - -\(fn)" nil nil) +Finalize Help Mode setup in current buffer." nil nil) (autoload 'help-setup-xref "help-mode" "\ Invoked from commands using the \"*Help*\" buffer to install some xref info. @@ -15973,9 +15585,7 @@ If `help-xref-following' is non-nil, this is the name of the current buffer. Signal an error if this buffer is not derived from `help-mode'. Otherwise, return \"*Help*\", creating a buffer with that name if -it does not already exist. - -\(fn)" nil nil) +it does not already exist." nil nil) (autoload 'help-make-xrefs "help-mode" "\ Parse and hyperlink documentation cross-references in the given BUFFER. @@ -16031,7 +15641,7 @@ BOOKMARK is a bookmark name or a bookmark record. \(fn BOOKMARK)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "help-mode" '("help-" "describe-symbol-backends"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "help-mode" '("describe-symbol-backends" "help-"))) ;;;*** @@ -16039,14 +15649,10 @@ BOOKMARK is a bookmark name or a bookmark record. ;;; Generated autoloads from emacs-lisp/helper.el (autoload 'Helper-describe-bindings "helper" "\ -Describe local key bindings of current mode. - -\(fn)" t nil) +Describe local key bindings of current mode." t nil) (autoload 'Helper-help "helper" "\ -Provide help for current mode. - -\(fn)" t nil) +Provide help for current mode." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "helper" '("Helper-"))) @@ -16055,7 +15661,7 @@ Provide help for current mode. ;;;### (autoloads nil "hex-util" "hex-util.el" (0 0 0 0)) ;;; Generated autoloads from hex-util.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hex-util" '("encode-hex-string" "decode-hex-string"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hex-util" '("decode-hex-string" "encode-hex-string"))) ;;;*** @@ -16147,11 +15753,9 @@ and edit the file in `hexl-mode'. (autoload 'hexlify-buffer "hexl" "\ Convert a binary buffer to hexl format. -This discards the buffer's undo information. +This discards the buffer's undo information." t nil) -\(fn)" t nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hexl" '("hexl-" "dehexlify-buffer"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hexl" '("dehexlify-buffer" "hexl-"))) ;;;*** @@ -16168,9 +15772,11 @@ This discards the buffer's undo information. (autoload 'hi-lock-mode "hi-lock" "\ Toggle selective highlighting of patterns (Hi Lock mode). -With a prefix argument ARG, enable Hi Lock mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Hi-Lock mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Hi Lock mode is automatically enabled when you invoke any of the highlighting commands listed below, such as \\[highlight-regexp]. @@ -16271,13 +15877,15 @@ highlighting will not update as you type. (autoload 'hi-lock-face-buffer "hi-lock" "\ Set face of each match of REGEXP to FACE. Interactively, prompt for REGEXP using `read-regexp', then FACE. -Use the global history list for FACE. +Use the global history list for FACE. Limit face setting to the +corresponding SUBEXP (interactively, the prefix argument) of REGEXP. +If SUBEXP is omitted or nil, the entire REGEXP is highlighted. Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, use overlays for highlighting. If overlays are used, the highlighting will not update as you type. -\(fn REGEXP &optional FACE)" t nil) +\(fn REGEXP &optional FACE SUBEXP)" t nil) (defalias 'highlight-phrase 'hi-lock-face-phrase-buffer) @@ -16305,9 +15913,7 @@ unless you use a prefix argument. Uses `find-tag-default-as-symbol-regexp' to retrieve the symbol at point. This uses Font lock mode if it is enabled; otherwise it uses overlays, -in which case the highlighting will not update as you type. - -\(fn)" t nil) +in which case the highlighting will not update as you type." t nil) (defalias 'unhighlight-regexp 'hi-lock-unface-buffer) @@ -16325,9 +15931,7 @@ Write interactively added patterns, if any, into buffer at point. Interactively added patterns are those normally specified using `highlight-regexp' and `highlight-lines-matching-regexp'; they can -be found in variable `hi-lock-interactive-patterns'. - -\(fn)" t nil) +be found in variable `hi-lock-interactive-patterns'." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hi-lock" '("hi-lock-" "turn-on-hi-lock-if-enabled"))) @@ -16338,9 +15942,11 @@ be found in variable `hi-lock-interactive-patterns'. (autoload 'hide-ifdef-mode "hideif" "\ Toggle features to hide/show #ifdef blocks (Hide-Ifdef mode). -With a prefix argument ARG, enable Hide-Ifdef mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Hide-Ifdef mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Hide-Ifdef mode is a buffer-local minor mode for use with C and C-like major modes. When enabled, code within #ifdef constructs @@ -16378,7 +15984,7 @@ Several variables affect how the hiding is done: \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hideif" '("hif-" "hide-ifdef" "show-ifdef" "previous-ifdef" "next-ifdef" "up-ifdef" "down-ifdef" "backward-ifdef" "forward-ifdef" "intern-safe"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hideif" '("backward-ifdef" "down-ifdef" "forward-ifdef" "hide-ifdef" "hif-" "intern-safe" "next-ifdef" "previous-ifdef" "show-ifdef" "up-ifdef"))) ;;;*** @@ -16415,9 +16021,11 @@ whitespace. Case does not matter.") (autoload 'hs-minor-mode "hideshow" "\ Minor mode to selectively hide/show code and comment blocks. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. + +If called interactively, enable Hs minor mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. When hideshow minor mode is on, the menu bar is augmented with hideshow commands and the hideshow commands are enabled. @@ -16425,7 +16033,7 @@ The value (hs . t) is added to `buffer-invisibility-spec'. The main commands are: `hs-hide-all', `hs-show-all', `hs-hide-block', `hs-show-block', `hs-hide-level' and `hs-toggle-hiding'. There is also -`hs-hide-initial-comment-block' and `hs-mouse-toggle-hiding'. +`hs-hide-initial-comment-block'. Turning hideshow minor mode off reverts the menu bar and the variables to default values and disables the hideshow commands. @@ -16438,9 +16046,7 @@ Key bindings: \(fn &optional ARG)" t nil) (autoload 'turn-off-hideshow "hideshow" "\ -Unconditionally turn off `hs-minor-mode'. - -\(fn)" nil nil) +Unconditionally turn off `hs-minor-mode'." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hideshow" '("hs-"))) @@ -16451,9 +16057,11 @@ Unconditionally turn off `hs-minor-mode'. (autoload 'highlight-changes-mode "hilit-chg" "\ Toggle highlighting changes in this buffer (Highlight Changes mode). -With a prefix argument ARG, enable Highlight Changes mode if ARG -is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. + +If called interactively, enable Highlight-Changes mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. When Highlight Changes is enabled, changes are marked with a text property. Normally they are displayed in a distinctive face, but @@ -16474,9 +16082,11 @@ buffer with the contents of a file (autoload 'highlight-changes-visible-mode "hilit-chg" "\ Toggle visibility of highlighting due to Highlight Changes mode. -With a prefix argument ARG, enable Highlight Changes Visible mode -if ARG is positive, and disable it otherwise. If called from -Lisp, enable the mode if ARG is omitted or nil. + +If called interactively, enable Highlight-Changes-Visible mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Highlight Changes Visible mode only has an effect when Highlight Changes mode is on. When enabled, the changed text is displayed @@ -16496,14 +16106,10 @@ This allows you to manually remove highlighting from uninteresting changes. \(fn BEG END)" t nil) (autoload 'highlight-changes-next-change "hilit-chg" "\ -Move to the beginning of the next change, if in Highlight Changes mode. - -\(fn)" t nil) +Move to the beginning of the next change, if in Highlight Changes mode." t nil) (autoload 'highlight-changes-previous-change "hilit-chg" "\ -Move to the beginning of the previous change, if in Highlight Changes mode. - -\(fn)" t nil) +Move to the beginning of the previous change, if in Highlight Changes mode." t nil) (autoload 'highlight-changes-rotate-faces "hilit-chg" "\ Rotate the faces if in Highlight Changes mode and the changes are visible. @@ -16517,9 +16123,7 @@ You can automatically rotate colors when the buffer is saved by adding this function to `write-file-functions' as a buffer-local value. To do this, eval the following in the buffer to be saved: - (add-hook \\='write-file-functions \\='highlight-changes-rotate-faces nil t) - -\(fn)" t nil) + (add-hook \\='write-file-functions \\='highlight-changes-rotate-faces nil t)" t nil) (autoload 'highlight-compare-buffers "hilit-chg" "\ Compare two buffers and highlight the differences. @@ -16576,7 +16180,7 @@ See `highlight-changes-mode' for more information on Highlight-Changes mode. \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hilit-chg" '("highlight-" "hilit-chg-" "global-highlight-changes"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hilit-chg" '("global-highlight-changes" "highlight-" "hilit-chg-"))) ;;;*** @@ -16610,7 +16214,7 @@ argument VERBOSE non-nil makes the function verbose. \(fn TRY-LIST &optional VERBOSE)" nil t) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hippie-exp" '("hippie-expand-" "he-" "try-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hippie-exp" '("he-" "hippie-expand-" "try-"))) ;;;*** @@ -16619,9 +16223,11 @@ argument VERBOSE non-nil makes the function verbose. (autoload 'hl-line-mode "hl-line" "\ Toggle highlighting of the current line (Hl-Line mode). -With a prefix argument ARG, enable Hl-Line mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Hl-Line mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Hl-Line mode is a buffer-local minor mode. If `hl-line-sticky-flag' is non-nil, Hl-Line mode highlights the @@ -16649,9 +16255,11 @@ 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). -With a prefix argument ARG, enable Global Hl-Line mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Global Hl-Line mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. 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 @@ -16662,7 +16270,7 @@ and `global-hl-line-maybe-unhighlight' on `post-command-hook'. \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hl-line" '("hl-line-" "global-hl-line-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hl-line" '("global-hl-line-" "hl-line-"))) ;;;*** @@ -16788,7 +16396,7 @@ The optional LABEL is used to label the buffer created. (defalias 'holiday-list 'list-holidays) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "holidays" '("holiday-" "calendar-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "holidays" '("calendar-" "holiday-"))) ;;;*** @@ -16832,7 +16440,7 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'. ;;;;;; (0 0 0 0)) ;;; Generated autoloads from ibuf-ext.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ibuf-ext" '("ibuffer-" "file" "shell-command-" "starred-name" "size" "alphabetic" "major-mode" "mod" "print" "predicate" "content" "view-and-eval" "visiting-file" "derived-mode" "directory" "basename" "name" "used-mode" "query-replace" "rename-uniquely" "revert" "replace-regexp" "eval"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ibuf-ext" '("alphabetic" "basename" "content" "derived-mode" "directory" "eval" "file" "ibuffer-" "major-mode" "mod" "name" "predicate" "print" "process" "query-replace" "rename-uniquely" "replace-regexp" "revert" "shell-command-" "size" "starred-name" "used-mode" "view-and-eval" "visiting-file"))) ;;;*** @@ -16931,6 +16539,9 @@ Define a filter named NAME. DOCUMENTATION is the documentation of the function. READER is a form which should read a qualifier from the user. DESCRIPTION is a short string describing the filter. +ACCEPT-LIST is a boolean; if non-nil, the filter accepts either +a single condition or a list of them; in the latter +case the filter is the `or' composition of the conditions. BODY should contain forms which will be evaluated to test whether or not a particular buffer should be displayed or not. The forms in BODY @@ -16990,7 +16601,7 @@ If optional arg OTHER-WINDOW is non-nil, then use another window. \(fn &optional OTHER-WINDOW)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ibuffer" '("ibuffer-" "filename" "process" "mark" "mod" "size" "name" "locked" "read-only"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ibuffer" '("filename" "ibuffer-" "locked" "mark" "mod" "name" "process" "read-only" "size"))) ;;;*** @@ -17031,7 +16642,7 @@ Extract iCalendar events from current buffer. This function searches the current buffer for the first iCalendar object, reads it and adds all VEVENT elements to the diary -DIARY-FILE. +DIARY-FILENAME. It will ask for each appointment whether to add it to the diary unless DO-NOT-ASK is non-nil. When called interactively, @@ -17044,7 +16655,7 @@ Return code t means that importing worked well, return code nil means that an error has occurred. Error messages will be in the buffer `*icalendar-errors*'. -\(fn &optional DIARY-FILE DO-NOT-ASK NON-MARKING)" t nil) +\(fn &optional DIARY-FILENAME DO-NOT-ASK NON-MARKING)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "icalendar" '("icalendar-"))) @@ -17065,9 +16676,11 @@ or call the function `icomplete-mode'.") (autoload 'icomplete-mode "icomplete" "\ Toggle incremental minibuffer completion (Icomplete mode). -With a prefix argument ARG, enable Icomplete mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Icomplete mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. When this global minor mode is enabled, typing in the minibuffer continuously displays a list of possible completions that match @@ -17130,7 +16743,7 @@ with no args, if that value is non-nil. \(fn)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "icon" '("indent-icon-exp" "icon-" "electric-icon-brace" "end-of-icon-defun" "beginning-of-icon-defun" "mark-icon-function" "calculate-icon-indent"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "icon" '("beginning-of-icon-defun" "calculate-icon-indent" "electric-icon-brace" "end-of-icon-defun" "icon-" "indent-icon-exp" "mark-icon-function"))) ;;;*** @@ -17172,7 +16785,7 @@ See also the variable `idlwave-shell-prompt-pattern'. \(Type \\[describe-mode] in the shell buffer for a list of commands.) -\(fn &optional ARG QUICK)" t nil) +\(fn &optional ARG)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "idlw-shell" '("idlwave-"))) @@ -17377,51 +16990,37 @@ RET Select the buffer at the front of the list of matches. \\[ido-completion-help] Show list of matching buffers in separate window. \\[ido-enter-find-file] Drop into `ido-find-file'. \\[ido-kill-buffer-at-head] Kill buffer at head of buffer list. -\\[ido-toggle-ignore] Toggle ignoring buffers listed in `ido-ignore-buffers'. - -\(fn)" t nil) +\\[ido-toggle-ignore] Toggle ignoring buffers listed in `ido-ignore-buffers'." t nil) (autoload 'ido-switch-buffer-other-window "ido" "\ Switch to another buffer and show it in another window. The buffer name is selected interactively by typing a substring. -For details of keybindings, see `ido-switch-buffer'. - -\(fn)" t nil) +For details of keybindings, see `ido-switch-buffer'." t nil) (autoload 'ido-display-buffer "ido" "\ Display a buffer in another window but don't select it. The buffer name is selected interactively by typing a substring. -For details of keybindings, see `ido-switch-buffer'. - -\(fn)" t nil) +For details of keybindings, see `ido-switch-buffer'." t nil) (autoload 'ido-display-buffer-other-frame "ido" "\ Display a buffer preferably in another frame. The buffer name is selected interactively by typing a substring. -For details of keybindings, see `ido-switch-buffer'. - -\(fn)" t nil) +For details of keybindings, see `ido-switch-buffer'." t nil) (autoload 'ido-kill-buffer "ido" "\ Kill a buffer. The buffer name is selected interactively by typing a substring. -For details of keybindings, see `ido-switch-buffer'. - -\(fn)" t nil) +For details of keybindings, see `ido-switch-buffer'." t nil) (autoload 'ido-insert-buffer "ido" "\ Insert contents of a buffer in current buffer after point. The buffer name is selected interactively by typing a substring. -For details of keybindings, see `ido-switch-buffer'. - -\(fn)" t nil) +For details of keybindings, see `ido-switch-buffer'." t nil) (autoload 'ido-switch-buffer-other-frame "ido" "\ Switch to another buffer and show it in another frame. The buffer name is selected interactively by typing a substring. -For details of keybindings, see `ido-switch-buffer'. - -\(fn)" t nil) +For details of keybindings, see `ido-switch-buffer'." t nil) (autoload 'ido-find-file-in-dir "ido" "\ Switch to another file starting from DIR. @@ -17469,100 +17068,72 @@ RET Select the file at the front of the list of matches. \\[ido-toggle-case] Toggle case-sensitive searching of file names. \\[ido-toggle-literal] Toggle literal reading of this file. \\[ido-completion-help] Show list of matching files in separate window. -\\[ido-toggle-ignore] Toggle ignoring files listed in `ido-ignore-files'. - -\(fn)" t nil) +\\[ido-toggle-ignore] Toggle ignoring files listed in `ido-ignore-files'." t nil) (autoload 'ido-find-file-other-window "ido" "\ Switch to another file and show it in another window. The file name is selected interactively by typing a substring. -For details of keybindings, see `ido-find-file'. - -\(fn)" t nil) +For details of keybindings, see `ido-find-file'." t nil) (autoload 'ido-find-alternate-file "ido" "\ Find another file, select its buffer, kill previous buffer. The file name is selected interactively by typing a substring. -For details of keybindings, see `ido-find-file'. - -\(fn)" t nil) +For details of keybindings, see `ido-find-file'." t nil) (autoload 'ido-find-alternate-file-other-window "ido" "\ Find file as a replacement for the file in the next window. The file name is selected interactively by typing a substring. -For details of keybindings, see `ido-find-file'. - -\(fn)" t nil) +For details of keybindings, see `ido-find-file'." t nil) (autoload 'ido-find-file-read-only "ido" "\ Edit file read-only with name obtained via minibuffer. The file name is selected interactively by typing a substring. -For details of keybindings, see `ido-find-file'. - -\(fn)" t nil) +For details of keybindings, see `ido-find-file'." t nil) (autoload 'ido-find-file-read-only-other-window "ido" "\ Edit file read-only in other window with name obtained via minibuffer. The file name is selected interactively by typing a substring. -For details of keybindings, see `ido-find-file'. - -\(fn)" t nil) +For details of keybindings, see `ido-find-file'." t nil) (autoload 'ido-find-file-read-only-other-frame "ido" "\ Edit file read-only in other frame with name obtained via minibuffer. The file name is selected interactively by typing a substring. -For details of keybindings, see `ido-find-file'. - -\(fn)" t nil) +For details of keybindings, see `ido-find-file'." t nil) (autoload 'ido-display-file "ido" "\ Display a file in another window but don't select it. The file name is selected interactively by typing a substring. -For details of keybindings, see `ido-find-file'. - -\(fn)" t nil) +For details of keybindings, see `ido-find-file'." t nil) (autoload 'ido-find-file-other-frame "ido" "\ Switch to another file and show it in another frame. The file name is selected interactively by typing a substring. -For details of keybindings, see `ido-find-file'. - -\(fn)" t nil) +For details of keybindings, see `ido-find-file'." t nil) (autoload 'ido-write-file "ido" "\ Write current buffer to a file. The file name is selected interactively by typing a substring. -For details of keybindings, see `ido-find-file'. - -\(fn)" t nil) +For details of keybindings, see `ido-find-file'." t nil) (autoload 'ido-insert-file "ido" "\ Insert contents of file in current buffer. The file name is selected interactively by typing a substring. -For details of keybindings, see `ido-find-file'. - -\(fn)" t nil) +For details of keybindings, see `ido-find-file'." t nil) (autoload 'ido-dired "ido" "\ Call `dired' the Ido way. The directory is selected interactively by typing a substring. -For details of keybindings, see `ido-find-file'. - -\(fn)" t nil) +For details of keybindings, see `ido-find-file'." t nil) (autoload 'ido-dired-other-window "ido" "\ \"Edit\" a directory. Like `ido-dired' but selects in another window. The directory is selected interactively by typing a substring. -For details of keybindings, see `ido-find-file'. - -\(fn)" t nil) +For details of keybindings, see `ido-find-file'." t nil) (autoload 'ido-dired-other-frame "ido" "\ \"Edit\" a directory. Like `ido-dired' but makes a new frame. The directory is selected interactively by typing a substring. -For details of keybindings, see `ido-find-file'. - -\(fn)" t nil) +For details of keybindings, see `ido-find-file'." t nil) (autoload 'ido-read-buffer "ido" "\ Ido replacement for the built-in `read-buffer'. @@ -17570,6 +17141,8 @@ Return the name of a buffer selected. PROMPT is the prompt to give to the user. DEFAULT if given is the default buffer to be selected, which will go to the front of the list. If REQUIRE-MATCH is non-nil, an existing buffer must be selected. +Optional arg PREDICATE if non-nil is a function limiting the +buffers that can be considered. \(fn PROMPT &optional DEFAULT REQUIRE-MATCH PREDICATE)" nil nil) @@ -17614,12 +17187,13 @@ DEF, if non-nil, is the default value. (autoload 'ielm "ielm" "\ Interactively evaluate Emacs Lisp expressions. -Switches to the buffer `*ielm*', or creates it if it does not exist. +Switches to the buffer named BUF-NAME if provided (`*ielm*' by default), +or creates it if it does not exist. See `inferior-emacs-lisp-mode' for details. -\(fn)" t nil) +\(fn &optional BUF-NAME)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ielm" '("inferior-emacs-lisp-mode" "ielm-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ielm" '("ielm-" "inferior-emacs-lisp-mode"))) ;;;*** @@ -17637,9 +17211,12 @@ See `inferior-emacs-lisp-mode' for details. (autoload 'iimage-mode "iimage" "\ Toggle Iimage mode on or off. -With a prefix argument ARG, enable Iimage mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'. + +If called interactively, enable Iimage mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + \\{iimage-mode-map} \(fn &optional ARG)" t nil) @@ -17661,9 +17238,7 @@ be determined. (autoload 'image-type-from-buffer "image" "\ Determine the image type from data in the current buffer. Value is a symbol specifying the image type or nil if type cannot -be determined. - -\(fn)" nil nil) +be determined." nil nil) (autoload 'image-type-from-file-header "image" "\ Determine the type of image file FILE from its first few bytes. @@ -17704,9 +17279,7 @@ The buffer is considered to contain an auto-detectable image if its beginning matches an image type in `image-type-header-regexps', and that image type is present in `image-type-auto-detectable' with a non-nil value. If that value is non-nil, but not t, then the image type -must be available. - -\(fn)" nil nil) +must be available." nil nil) (autoload 'create-image "image" "\ Create an image. @@ -17842,9 +17415,7 @@ Emacs visits them in Image mode. They are also added to `image-type-file-name-regexps', so that the `image-type' function recognizes these files as having image type `imagemagick'. -If Emacs is compiled without ImageMagick support, this does nothing. - -\(fn)" nil nil) +If Emacs is compiled without ImageMagick support, this does nothing." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "image" '("image"))) @@ -17930,33 +17501,30 @@ With prefix argument ARG, remove tag from file at point. \(fn ARG)" t nil) (autoload 'image-dired-jump-thumbnail-buffer "image-dired" "\ -Jump to thumbnail buffer. - -\(fn)" t nil) +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'. +If called interactively, enable Image-Dired minor mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + \(fn &optional ARG)" t nil) (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'. - -\(fn)" t nil) +Append thumbnails to `image-dired-thumbnail-buffer'." t nil) (autoload 'image-dired-display-thumb "image-dired" "\ -Shorthand for `image-dired-display-thumbs' with prefix argument. - -\(fn)" t nil) +Shorthand for `image-dired-display-thumbs' with prefix argument." t nil) (autoload 'image-dired-dired-display-external "image-dired" "\ -Display file at point using an external viewer. - -\(fn)" t nil) +Display file at point using an external viewer." t nil) (autoload 'image-dired-dired-display-image "image-dired" "\ Display current image file. @@ -17966,9 +17534,7 @@ With prefix argument ARG, display image in its original size. \(fn &optional ARG)" t nil) (autoload 'image-dired-dired-comment-files "image-dired" "\ -Add comment to current or marked files in dired. - -\(fn)" t nil) +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. @@ -17976,16 +17542,12 @@ 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. - -\(fn)" t nil) +matching tag will be marked in the dired buffer." 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. - -\(fn)" t nil) +easy-to-use form." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "image-dired" '("image-dired-"))) @@ -18019,9 +17581,7 @@ the variable is set using \\[customize].") (custom-autoload 'image-file-name-regexps "image-file" nil) (autoload 'image-file-name-regexp "image-file" "\ -Return a regular expression matching image-file filenames. - -\(fn)" nil nil) +Return a regular expression matching image-file filenames." nil nil) (autoload 'insert-image-file "image-file" "\ Insert the image file FILE into the current buffer. @@ -18043,9 +17603,11 @@ 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). -With a prefix argument ARG, enable Auto Image File mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Auto-Image-File mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. An image file is one whose name has an extension in `image-file-name-extensions', or matches a regexp in @@ -18066,15 +17628,15 @@ You can use \\<image-mode-map>\\[image-toggle-display] or \\<image-mode-map>\\[i to toggle between display as an image and display as text or hex. Key bindings: -\\{image-mode-map} - -\(fn)" t nil) +\\{image-mode-map}" t nil) (autoload 'image-minor-mode "image-mode" "\ Toggle Image minor mode in this buffer. -With a prefix argument ARG, enable Image minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Image minor mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. 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 @@ -18085,9 +17647,7 @@ actual image. (autoload 'image-mode-to-text "image-mode" "\ Set a non-image mode as major mode in combination with image minor mode. A non-mage major mode found from `auto-mode-alist' or fundamental mode -displays an image file as text. - -\(fn)" nil nil) +displays an image file as text." nil nil) (autoload 'image-bookmark-jump "image-mode" "\ @@ -18230,9 +17790,7 @@ See the command `imenu' for more information. (autoload 'imenu-add-menubar-index "imenu" "\ Add an Imenu \"Index\" entry on the menu bar for the current buffer. -A trivial interface to `imenu-add-to-menubar' suitable for use in a hook. - -\(fn)" t nil) +A trivial interface to `imenu-add-to-menubar' suitable for use in a hook." t nil) (autoload 'imenu "imenu" "\ Jump to a place in the buffer chosen using a buffer menu or mouse menu. @@ -18273,7 +17831,7 @@ Convert old Emacs Devanagari characters to UCS. \(fn FROM TO)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ind-util" '("indian-" "ucs-to-is"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ind-util" '("indian-" "is13194-"))) ;;;*** @@ -18317,7 +17875,7 @@ 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 (quote custom-initialize-delay) :type (quote (repeat directory)) :group (quote info)) +`Info-additional-directory-list', rather than changing this variable." :initialize 'custom-initialize-delay :type '(repeat directory) :group 'info) (autoload 'info-other-window "info" "\ Like `info' but show the Info buffer in another window. @@ -18350,21 +17908,15 @@ See a list of available Info commands in `Info-mode'. \(fn &optional FILE-OR-NODE BUFFER)" t nil) (autoload 'info-emacs-manual "info" "\ -Display the Emacs manual in Info mode. - -\(fn)" t nil) +Display the Emacs manual in Info mode." t nil) (autoload 'info-emacs-bug "info" "\ -Display the \"Reporting Bugs\" section of the Emacs manual in Info mode. - -\(fn)" t nil) +Display the \"Reporting Bugs\" section of the Emacs manual in Info mode." t nil) (autoload 'info-standalone "info" "\ Run Emacs as a standalone Info reader. Usage: emacs -f info-standalone [filename] -In standalone mode, \\<Info-mode-map>\\[Info-exit] exits Emacs itself. - -\(fn)" nil nil) +In standalone mode, \\<Info-mode-map>\\[Info-exit] exits Emacs itself." nil nil) (autoload 'Info-on-current-buffer "info" "\ Use Info mode to browse the current Info buffer. @@ -18374,9 +17926,7 @@ otherwise, that defaults to `Top'. \(fn &optional NODENAME)" t nil) (autoload 'Info-directory "info" "\ -Go to the Info directory node. - -\(fn)" t nil) +Go to the Info directory node." t nil) (autoload 'Info-index "info" "\ Look up a string TOPIC in the index for this manual and go to that entry. @@ -18488,9 +18038,7 @@ the variable `Info-file-list-for-emacs'. (autoload 'Info-speedbar-browser "info" "\ Initialize speedbar to display an Info node browser. -This will add a speedbar major display mode. - -\(fn)" t nil) +This will add a speedbar major display mode." t nil) (autoload 'Info-bookmark-jump "info" "\ This implements the `handler' function interface for the record @@ -18507,7 +18055,7 @@ completion alternatives to currently visited manuals. \(fn MANUAL)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "info" '("info-" "Info-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "info" '("Info-" "info-"))) ;;;*** @@ -18518,9 +18066,7 @@ completion alternatives to currently visited manuals. Throw away all cached data. This command is useful if the user wants to start at the beginning without quitting Emacs, for example, after some Info documents were updated on the -system. - -\(fn)" t nil) +system." t nil) (put 'info-lookup-symbol 'info-file "emacs") (autoload 'info-lookup-symbol "info-look" "\ @@ -18603,9 +18149,7 @@ info files don't necessarily have a \".info\" extension and in particular the Emacs manuals normally don't. If you have a source code directory in `Info-directory-list' then a lot of extraneous files might be read. This will be time consuming but -should be harmless. - -\(fn)" t nil) +should be harmless." t nil) (autoload 'info-xref-check-all-custom "info-xref" "\ Check info references in all customize groups and variables. @@ -18614,9 +18158,7 @@ of the `custom-links' for a variable. Any `custom-load' autoloads in variables are loaded in order to get full link information. This will be a lot of Lisp packages -and can take a long time. - -\(fn)" t nil) +and can take a long time." t nil) (autoload 'info-xref-docstrings "info-xref" "\ Check docstring info node references in source files. @@ -18670,23 +18212,17 @@ should be saved in place of the original visited file. The subfiles are written in the same directory the original file is in, with names generated by appending `-' and a number to the original file name. The indirect file still functions as an Info file, but it -contains just the tag table and a directory of subfiles. - -\(fn)" t nil) +contains just the tag table and a directory of subfiles." t nil) (autoload 'Info-validate "informat" "\ Check current buffer for validity as an Info file. -Check that every node pointer points to an existing node. - -\(fn)" t nil) +Check that every node pointer points to an existing node." t nil) (autoload 'batch-info-validate "informat" "\ Runs `Info-validate' on the files remaining on the command line. Must be used only with -batch, and kills Emacs on completion. Each file will be processed even if an error occurred previously. -For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\" - -\(fn)" nil nil) +For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\"" nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "informat" '("Info-validate-"))) @@ -18730,14 +18266,10 @@ Only checks one based on which kind of Emacs is being run. ;;; Generated autoloads from international/isearch-x.el (autoload 'isearch-toggle-specified-input-method "isearch-x" "\ -Select an input method and turn it on in interactive search. - -\(fn)" t nil) +Select an input method and turn it on in interactive search." t nil) (autoload 'isearch-toggle-input-method "isearch-x" "\ -Toggle input method in interactive search. - -\(fn)" t nil) +Toggle input method in interactive search." t nil) (autoload 'isearch-process-search-multibyte-characters "isearch-x" "\ @@ -18756,9 +18288,7 @@ Toggle input method in interactive search. Active isearchb mode for subsequent alphanumeric keystrokes. Executing this command again will terminate the search; or, if the search has not yet begun, will toggle to the last buffer -accessed via isearchb. - -\(fn)" t nil) +accessed via isearchb." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "isearchb" '("isearchb"))) @@ -18857,9 +18387,7 @@ Warn that format is write-only. \(fn &rest IGNORE)" t nil) (autoload 'iso-cvt-define-menu "iso-cvt" "\ -Add submenus to the File menu, to convert to and from various formats. - -\(fn)" t nil) +Add submenus to the File menu, to convert to and from various formats." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "iso-cvt" '("iso-"))) @@ -18888,18 +18416,12 @@ If nil, the default personal dictionary for your spelling checker is used.") (put 'ispell-local-dictionary 'safe-local-variable 'string-or-null-p) -(defvar ispell-menu-map nil "\ +(defconst ispell-menu-map (let ((map (make-sparse-keymap "Spell"))) (define-key map [ispell-change-dictionary] `(menu-item ,(purecopy "Change Dictionary...") ispell-change-dictionary :help ,(purecopy "Supply explicit dictionary file name"))) (define-key map [ispell-kill-ispell] `(menu-item ,(purecopy "Kill Process") (lambda nil (interactive) (ispell-kill-ispell nil 'clear)) :enable (and (boundp 'ispell-process) ispell-process (eq (ispell-process-status) 'run)) :help ,(purecopy "Terminate Ispell subprocess"))) (define-key map [ispell-pdict-save] `(menu-item ,(purecopy "Save Dictionary") (lambda nil (interactive) (ispell-pdict-save t t)) :help ,(purecopy "Save personal dictionary"))) (define-key map [ispell-customize] `(menu-item ,(purecopy "Customize...") (lambda nil (interactive) (customize-group 'ispell)) :help ,(purecopy "Customize spell checking options"))) (define-key map [ispell-help] `(menu-item ,(purecopy "Help") (lambda nil (interactive) (describe-function 'ispell-help)) :help ,(purecopy "Show standard Ispell keybindings and commands"))) (define-key map [flyspell-mode] `(menu-item ,(purecopy "Automatic spell checking (Flyspell)") flyspell-mode :help ,(purecopy "Check spelling while you edit the text") :button (:toggle bound-and-true-p flyspell-mode))) (define-key map [ispell-complete-word] `(menu-item ,(purecopy "Complete Word") ispell-complete-word :help ,(purecopy "Complete word at cursor using dictionary"))) (define-key map [ispell-complete-word-interior-frag] `(menu-item ,(purecopy "Complete Word Fragment") ispell-complete-word-interior-frag :help ,(purecopy "Complete word fragment at cursor"))) (define-key map [ispell-continue] `(menu-item ,(purecopy "Continue Spell-Checking") ispell-continue :enable (and (boundp 'ispell-region-end) (marker-position ispell-region-end) (equal (marker-buffer ispell-region-end) (current-buffer))) :help ,(purecopy "Continue spell checking last region"))) (define-key map [ispell-word] `(menu-item ,(purecopy "Spell-Check Word") ispell-word :help ,(purecopy "Spell-check word at cursor"))) (define-key map [ispell-comments-and-strings] `(menu-item ,(purecopy "Spell-Check Comments") ispell-comments-and-strings :help ,(purecopy "Spell-check only comments and strings"))) (define-key map [ispell-region] `(menu-item ,(purecopy "Spell-Check Region") ispell-region :enable mark-active :help ,(purecopy "Spell-check text in marked region"))) (define-key map [ispell-message] `(menu-item ,(purecopy "Spell-Check Message") ispell-message :visible (eq major-mode 'mail-mode) :help ,(purecopy "Skip headers and included message text"))) (define-key map [ispell-buffer] `(menu-item ,(purecopy "Spell-Check Buffer") ispell-buffer :help ,(purecopy "Check spelling of selected buffer"))) map) "\ Key map for ispell menu.") -(defvar ispell-menu-map-needed (unless ispell-menu-map 'reload)) - -(if ispell-menu-map-needed (progn (setq ispell-menu-map (make-sparse-keymap "Spell")) (define-key ispell-menu-map [ispell-change-dictionary] `(menu-item ,(purecopy "Change Dictionary...") ispell-change-dictionary :help ,(purecopy "Supply explicit dictionary file name"))) (define-key ispell-menu-map [ispell-kill-ispell] `(menu-item ,(purecopy "Kill Process") (lambda nil (interactive) (ispell-kill-ispell nil 'clear)) :enable (and (boundp 'ispell-process) ispell-process (eq (ispell-process-status) 'run)) :help ,(purecopy "Terminate Ispell subprocess"))) (define-key ispell-menu-map [ispell-pdict-save] `(menu-item ,(purecopy "Save Dictionary") (lambda nil (interactive) (ispell-pdict-save t t)) :help ,(purecopy "Save personal dictionary"))) (define-key ispell-menu-map [ispell-customize] `(menu-item ,(purecopy "Customize...") (lambda nil (interactive) (customize-group 'ispell)) :help ,(purecopy "Customize spell checking options"))) (define-key ispell-menu-map [ispell-help] `(menu-item ,(purecopy "Help") (lambda nil (interactive) (describe-function 'ispell-help)) :help ,(purecopy "Show standard Ispell keybindings and commands"))) (define-key ispell-menu-map [flyspell-mode] `(menu-item ,(purecopy "Automatic spell checking (Flyspell)") flyspell-mode :help ,(purecopy "Check spelling while you edit the text") :button (:toggle bound-and-true-p flyspell-mode))) (define-key ispell-menu-map [ispell-complete-word] `(menu-item ,(purecopy "Complete Word") ispell-complete-word :help ,(purecopy "Complete word at cursor using dictionary"))) (define-key ispell-menu-map [ispell-complete-word-interior-frag] `(menu-item ,(purecopy "Complete Word Fragment") ispell-complete-word-interior-frag :help ,(purecopy "Complete word fragment at cursor"))))) - -(if ispell-menu-map-needed (progn (define-key ispell-menu-map [ispell-continue] `(menu-item ,(purecopy "Continue Spell-Checking") ispell-continue :enable (and (boundp 'ispell-region-end) (marker-position ispell-region-end) (equal (marker-buffer ispell-region-end) (current-buffer))) :help ,(purecopy "Continue spell checking last region"))) (define-key ispell-menu-map [ispell-word] `(menu-item ,(purecopy "Spell-Check Word") ispell-word :help ,(purecopy "Spell-check word at cursor"))) (define-key ispell-menu-map [ispell-comments-and-strings] `(menu-item ,(purecopy "Spell-Check Comments") ispell-comments-and-strings :help ,(purecopy "Spell-check only comments and strings"))))) +(fset 'ispell-menu-map (symbol-value 'ispell-menu-map)) -(if ispell-menu-map-needed (progn (define-key ispell-menu-map [ispell-region] `(menu-item ,(purecopy "Spell-Check Region") ispell-region :enable mark-active :help ,(purecopy "Spell-check text in marked region"))) (define-key ispell-menu-map [ispell-message] `(menu-item ,(purecopy "Spell-Check Message") ispell-message :visible (eq major-mode 'mail-mode) :help ,(purecopy "Skip headers and included message text"))) (define-key ispell-menu-map [ispell-buffer] `(menu-item ,(purecopy "Spell-Check Buffer") ispell-buffer :help ,(purecopy "Check spelling of selected buffer"))) (fset 'ispell-menu-map (symbol-value 'ispell-menu-map)))) - -(defvar ispell-skip-region-alist `((ispell-words-keyword forward-line) (ispell-dictionary-keyword forward-line) (ispell-pdict-keyword forward-line) (ispell-parsing-keyword forward-line) (,(purecopy "^---*BEGIN PGP [A-Z ]*--*") \, (purecopy "^---*END PGP [A-Z ]*--*")) (,(purecopy "^begin [0-9][0-9][0-9] [^ ]+$") \, (purecopy "\nend\n")) (,(purecopy "^%!PS-Adobe-[123].0") \, (purecopy "\n%%EOF\n")) (,(purecopy "^---* \\(Start of \\)?[Ff]orwarded [Mm]essage") \, (purecopy "^---* End of [Ff]orwarded [Mm]essage"))) "\ +(defvar ispell-skip-region-alist `((ispell-words-keyword forward-line) (ispell-dictionary-keyword forward-line) (ispell-pdict-keyword forward-line) (ispell-parsing-keyword forward-line) (,(purecopy "^---*BEGIN PGP [A-Z ]*--*") \, (purecopy "^---*END PGP [A-Z ]*--*")) (,(purecopy "^begin [0-9][0-9][0-9] [^ \11]+$") \, (purecopy "\nend\n")) (,(purecopy "^%!PS-Adobe-[123].0") \, (purecopy "\n%%EOF\n")) (,(purecopy "^---* \\(Start of \\)?[Ff]orwarded [Mm]essage") \, (purecopy "^---* End of [Ff]orwarded [Mm]essage"))) "\ Alist expressing beginning and end of regions not to spell check. The alist key must be a regular expression. Valid forms include: @@ -18908,7 +18430,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[ \n]*{[ \n]*document[ \n]*}")) (("\\(figure\\|table\\)\\*?" ispell-tex-arg-end 0) ("list" ispell-tex-arg-end 2) ("program" . "\\\\end[ \n]*{[ \n]*program[ \n]*}") ("verbatim\\*?" . "\\\\end[ \n]*{[ \n]*verbatim\\*?[ \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]*{[ \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]*}")))) "\ Lists of regions to be skipped in TeX mode. First list is used raw. Second list has key placed inside \\begin{}. @@ -18916,7 +18438,7 @@ Second list has key placed inside \\begin{}. Delete or add any regions you want to be automatically selected for skipping in latex mode.") -(defconst ispell-html-skip-alists '(("<[cC][oO][dD][eE]\\>[^>]*>" "</[cC][oO][dD][eE]*>") ("<[sS][cC][rR][iI][pP][tT]\\>[^>]*>" "</[sS][cC][rR][iI][pP][tT]>") ("<[aA][pP][pP][lL][eE][tT]\\>[^>]*>" "</[aA][pP][pP][lL][eE][tT]>") ("<[vV][eE][rR][bB]\\>[^>]*>" "<[vV][eE][rR][bB]\\>[^>]*>") ("<[tT][tT]/" "/") ("<[^ \n>]" ">") ("&[^ \n;]" "[; \n]")) "\ +(defconst ispell-html-skip-alists '(("<[cC][oO][dD][eE]\\>[^>]*>" "</[cC][oO][dD][eE]*>") ("<[sS][cC][rR][iI][pP][tT]\\>[^>]*>" "</[sS][cC][rR][iI][pP][tT]>") ("<[aA][pP][pP][lL][eE][tT]\\>[^>]*>" "</[aA][pP][pP][lL][eE][tT]>") ("<[vV][eE][rR][bB]\\>[^>]*>" "<[vV][eE][rR][bB]\\>[^>]*>") ("<[tT][tT]/" "/") ("<[^ \11\n>]" ">") ("&[^ \11\n;]" "[; \11\n]")) "\ Lists of start and end keys to skip in HTML buffers. Same format as `ispell-skip-region-alist'. Note - substrings of other matches must come last @@ -18984,9 +18506,7 @@ SPC: Accept word this time. `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. - -\(fn)" nil nil) +`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). @@ -19012,14 +18532,10 @@ amount for last line processed. \(fn REG-START REG-END &optional RECHECKP SHIFT)" t nil) (autoload 'ispell-comments-and-strings "ispell" "\ -Check comments and strings in the current buffer for spelling errors. - -\(fn)" t nil) +Check comments and strings in the current buffer for spelling errors." t nil) (autoload 'ispell-buffer "ispell" "\ -Check the current buffer for spelling errors interactively. - -\(fn)" t nil) +Check the current buffer for spelling errors interactively." t nil) (autoload 'ispell-buffer-with-debug "ispell" "\ `ispell-buffer' with some output sent to `ispell-debug-buffer' buffer. @@ -19028,9 +18544,7 @@ If APPEND is non-n il, append the info to previous buffer if exists. \(fn &optional APPEND)" t nil) (autoload 'ispell-continue "ispell" "\ -Continue a halted spelling session beginning with the current word. - -\(fn)" t nil) +Continue a halted spelling session beginning with the current word." t nil) (autoload 'ispell-complete-word "ispell" "\ Try to complete the word before or at point. @@ -19042,9 +18556,7 @@ Standard ispell choices are then available. \(fn &optional INTERIOR-FRAG)" t nil) (autoload 'ispell-complete-word-interior-frag "ispell" "\ -Completes word matching character sequence inside a word. - -\(fn)" t nil) +Completes word matching character sequence inside a word." t nil) (autoload 'ispell "ispell" "\ Interactively check a region or buffer for spelling errors. @@ -19054,15 +18566,15 @@ that region. Otherwise spell-check the buffer. Ispell dictionaries are not distributed with Emacs. If you are looking for a dictionary, please see the distribution of the GNU ispell program, or do an Internet search; there are various dictionaries -available on the net. - -\(fn)" t nil) +available on the net." t nil) (autoload 'ispell-minor-mode "ispell" "\ Toggle last-word spell checking (Ispell minor mode). -With a prefix argument ARG, enable Ispell minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable ISpell minor mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Ispell minor mode is a buffer-local minor mode. When enabled, typing SPC or RET warns you if the previous word is incorrectly @@ -19095,11 +18607,9 @@ in your init file: You can bind this to the key C-c i in GNUS or mail by adding to `news-reply-mode-hook' or `mail-mode-hook' the following lambda expression: - (function (lambda () (local-set-key \"\\C-ci\" \\='ispell-message))) - -\(fn)" t nil) + (function (lambda () (local-set-key \"\\C-ci\" \\='ispell-message)))" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ispell" '("ispell-" "check-ispell-version"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ispell" '("check-ispell-version" "ispell-"))) ;;;*** @@ -19107,7 +18617,7 @@ You can bind this to the key C-c i in GNUS or mail by adding to ;;;;;; (0 0 0 0)) ;;; Generated autoloads from international/ja-dic-cnv.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ja-dic-cnv" '("skkdic-" "batch-skkdic-convert" "ja-dic-filename"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ja-dic-cnv" '("batch-skkdic-convert" "ja-dic-filename" "skkdic-"))) ;;;*** @@ -19123,10 +18633,7 @@ You can bind this to the key C-c i in GNUS or mail by adding to ;;;;;; 0 0)) ;;; Generated autoloads from language/japan-util.el -(autoload 'setup-japanese-environment-internal "japan-util" "\ - - -\(fn)" nil nil) +(autoload 'setup-japanese-environment-internal "japan-util" nil nil nil) (autoload 'japanese-katakana "japan-util" "\ Convert argument to Katakana and return that. @@ -19216,11 +18723,9 @@ It is not recommended to set this variable permanently to anything but nil.") Uninstall jka-compr. This removes the entries in `file-name-handler-alist' and `auto-mode-alist' and `inhibit-local-variables-suffixes' that were added -by `jka-compr-installed'. +by `jka-compr-installed'." nil nil) -\(fn)" nil nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "jka-compr" '("jka-compr-" "compression-error"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "jka-compr" '("compression-error" "jka-compr-"))) ;;;*** @@ -19234,15 +18739,17 @@ Major mode for editing JavaScript. \(fn)" t nil) (autoload 'js-jsx-mode "js" "\ -Major mode for editing JSX. +Major mode for editing JavaScript+JSX. -To customize the indentation for this mode, set the SGML offset -variables (`sgml-basic-offset', `sgml-attribute-offset' et al.) -locally, like so: +Simply makes `js-jsx-syntax' buffer-local and sets it to t. - (defun set-jsx-indentation () - (setq-local sgml-basic-offset js-indent-level)) - (add-hook \\='js-jsx-mode-hook #\\='set-jsx-indentation) +`js-mode' may detect and enable support for JSX automatically if +it appears to be used in a JavaScript file. You could also +customize `js-jsx-regexps' to improve that detection; or, you +could set `js-jsx-syntax' to t in your init file, or in a +.dir-locals.el file, or using file variables; or, you could call +`js-jsx-enable' in `js-mode-hook'. You may be better served by +one of the aforementioned options instead of using this mode. \(fn)" t nil) (defalias 'javascript-mode 'js-mode) @@ -19261,6 +18768,14 @@ locally, like so: ;;;*** +;;;### (autoloads nil "jsonrpc" "jsonrpc.el" (0 0 0 0)) +;;; Generated autoloads from jsonrpc.el +(push (purecopy '(jsonrpc 1 0 7)) package--builtin-versions) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "jsonrpc" '("jrpc-default-request-timeout" "jsonrpc-"))) + +;;;*** + ;;;### (autoloads nil "kermit" "kermit.el" (0 0 0 0)) ;;; Generated autoloads from kermit.el @@ -19486,6 +19001,11 @@ If kbd macro currently being defined end it before activating it. \(fn EVENT)" t nil) +(autoload 'kmacro-lambda-form "kmacro" "\ +Create lambda form for macro bound to symbol or key. + +\(fn MAC &optional COUNTER FORMAT)" nil nil) + (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "kmacro" '("kmacro-"))) ;;;*** @@ -19498,12 +19018,9 @@ If kbd macro currently being defined end it before activating it. The kind of Korean keyboard for Korean input method. \"\" for 2, \"3\" for 3.") -(autoload 'setup-korean-environment-internal "korea-util" "\ - +(autoload 'setup-korean-environment-internal "korea-util" nil nil nil) -\(fn)" nil nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "korea-util" '("exit-korean-environment" "korean-key-bindings" "isearch-" "quail-hangul-switch-" "toggle-korean-input-method"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "korea-util" '("exit-korean-environment" "isearch-" "korean-key-bindings" "quail-hangul-switch-" "toggle-korean-input-method"))) ;;;*** @@ -19535,7 +19052,7 @@ Transcribe Romanized Lao string STR to Lao character string. (autoload 'lao-composition-function "lao-util" "\ -\(fn GSTRING)" nil nil) +\(fn GSTRING DIRECTION)" nil nil) (autoload 'lao-compose-region "lao-util" "\ @@ -19550,7 +19067,7 @@ Transcribe Romanized Lao string STR to Lao character string. ;;;;;; 0 0)) ;;; Generated autoloads from international/latexenc.el -(defvar latex-inputenc-coding-alist (purecopy '(("ansinew" . windows-1252) ("applemac" . mac-roman) ("ascii" . us-ascii) ("cp1250" . windows-1250) ("cp1252" . windows-1252) ("cp1257" . cp1257) ("cp437de" . cp437) ("cp437" . cp437) ("cp850" . cp850) ("cp852" . cp852) ("cp858" . cp858) ("cp865" . cp865) ("latin1" . iso-8859-1) ("latin2" . iso-8859-2) ("latin3" . iso-8859-3) ("latin4" . iso-8859-4) ("latin5" . iso-8859-5) ("latin9" . iso-8859-15) ("next" . next) ("utf8" . utf-8) ("utf8x" . utf-8))) "\ +(defvar latex-inputenc-coding-alist (purecopy '(("ansinew" . windows-1252) ("applemac" . mac-roman) ("ascii" . us-ascii) ("cp1250" . windows-1250) ("cp1252" . windows-1252) ("cp1257" . cp1257) ("cp437de" . cp437) ("cp437" . cp437) ("cp850" . cp850) ("cp852" . cp852) ("cp858" . cp858) ("cp865" . cp865) ("latin1" . iso-8859-1) ("latin2" . iso-8859-2) ("latin3" . iso-8859-3) ("latin4" . iso-8859-4) ("latin5" . iso-8859-9) ("latin9" . iso-8859-15) ("latin10" . iso-8859-16) ("next" . next) ("utf8" . utf-8) ("utf8x" . utf-8))) "\ Mapping from LaTeX encodings in \"inputenc.sty\" to Emacs coding systems. LaTeX encodings are specified with \"\\usepackage[encoding]{inputenc}\". Used by the function `latexenc-find-file-coding-system'.") @@ -19739,9 +19256,11 @@ generations (this defaults to 1). (autoload 'linum-mode "linum" "\ Toggle display of line numbers in the left margin (Linum mode). -With a prefix argument ARG, enable Linum mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. + +If called interactively, enable Linum mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Linum mode is a buffer-local minor mode. @@ -19810,7 +19329,7 @@ something strange, such as redefining an Emacs function. \(fn FEATURE &optional FORCE)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "loadhist" '("loadhist-" "unload-" "read-feature" "feature-" "file-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "loadhist" '("feature-" "file-" "loadhist-" "read-feature" "unload-"))) ;;;*** @@ -19963,9 +19482,7 @@ argument.") (autoload 'lpr-buffer "lpr" "\ Print buffer contents without pagination or page headers. See the variables `lpr-switches' and `lpr-command' -for customization of the printer command. - -\(fn)" t nil) +for customization of the printer command." t nil) (autoload 'print-buffer "lpr" "\ Paginate and print buffer contents. @@ -19979,9 +19496,7 @@ Otherwise, the switches in `lpr-headers-switches' are used in the print command itself; we expect them to request pagination. See the variables `lpr-switches' and `lpr-command' -for further customization of the printer command. - -\(fn)" t nil) +for further customization of the printer command." t nil) (autoload 'lpr-region "lpr" "\ Print region contents without pagination or page headers. @@ -20033,7 +19548,7 @@ This function is suitable for execution in an init file. \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "lunar" '("lunar-" "diary-lunar-phases" "calendar-lunar-phases"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "lunar" '("calendar-lunar-phases" "diary-lunar-phases" "lunar-"))) ;;;*** @@ -20052,13 +19567,7 @@ A major mode to edit m4 macro files. ;;;### (autoloads nil "macros" "macros.el" (0 0 0 0)) ;;; Generated autoloads from macros.el -(autoload 'name-last-kbd-macro "macros" "\ -Assign a name to the last keyboard macro defined. -Argument SYMBOL is the name to define. -The symbol's function definition becomes the keyboard macro string. -Such a \"function\" cannot be called from Lisp, but it is a valid editor command. - -\(fn SYMBOL)" t nil) +(defalias 'name-last-kbd-macro #'kmacro-name-last-macro) (autoload 'insert-kbd-macro "macros" "\ Insert in buffer the definition of kbd macro MACRONAME, as Lisp code. @@ -20136,6 +19645,8 @@ 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) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "macros" '("macros--insert-vector-macro"))) + ;;;*** ;;;### (autoloads nil "mail-extr" "mail/mail-extr.el" (0 0 0 0)) @@ -20160,6 +19671,12 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible \(This feature exists so that the clever caller might be able to avoid consing a string.) +This function is primarily meant for when you're displaying the +result to the user: Many prettifications are applied to the +result returned. If you want to decode an address for further +non-display use, you should probably use +`mail-header-parse-address' instead. + \(fn ADDRESS &optional ALL)" nil nil) (autoload 'what-domain "mail-extr" "\ @@ -20175,14 +19692,9 @@ Convert mail domain DOMAIN to the country it corresponds to. ;;; Generated autoloads from mail/mail-hist.el (autoload 'mail-hist-define-keys "mail-hist" "\ -Define keys for accessing mail header history. For use in hooks. - -\(fn)" nil nil) - -(autoload 'mail-hist-enable "mail-hist" "\ +Define keys for accessing mail header history. For use in hooks." nil nil) - -\(fn)" nil nil) +(autoload 'mail-hist-enable "mail-hist" nil nil nil) (defvar mail-hist-keep-history t "\ Non-nil means keep a history for headers and text of outgoing mail.") @@ -20194,9 +19706,7 @@ Put headers and contents of this message into mail header history. Each header has its own independent history, as does the body of the message. -This function normally would be called when the message is sent. - -\(fn)" nil nil) +This function normally would be called when the message is sent." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mail-hist" '("mail-hist-"))) @@ -20239,7 +19749,7 @@ Regexp specifying addresses to prune from a reply message. If this is nil, it is set the first time you compose a reply, to a value which excludes your own email address. -Matching addresses are excluded from the CC field in replies, and +Matching addresses are excluded from the Cc field in replies, and also the To field, unless this would leave an empty To field.") (custom-autoload 'mail-dont-reply-to-names "mail-utils" t) @@ -20315,9 +19825,11 @@ or call the function `mail-abbrevs-mode'.") (autoload 'mail-abbrevs-mode "mailabbrev" "\ Toggle abbrev expansion of mail aliases (Mail Abbrevs mode). -With a prefix argument ARG, enable Mail Abbrevs mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Mail-Abbrevs mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Mail Abbrevs mode is a global minor mode. When enabled, abbrev-like expansion is performed when editing certain mail @@ -20327,9 +19839,7 @@ the entries in your `mail-personal-alias-file'. \(fn &optional ARG)" t nil) (autoload 'mail-abbrevs-setup "mailabbrev" "\ -Initialize use of the `mailabbrev' package. - -\(fn)" nil nil) +Initialize use of the `mailabbrev' package." nil nil) (autoload 'build-mail-abbrevs "mailabbrev" "\ Read mail aliases from personal mail alias file and set `mail-abbrevs'. @@ -20348,7 +19858,7 @@ double-quotes. \(fn NAME DEFINITION &optional FROM-MAILRC-FILE)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mailabbrev" '("merge-mail-abbrevs" "mail-" "rebuild-mail-abbrevs"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mailabbrev" '("mail-" "merge-mail-abbrevs" "rebuild-mail-abbrevs"))) ;;;*** @@ -20369,7 +19879,7 @@ If `angles', they look like: (autoload 'expand-mail-aliases "mailalias" "\ Expand all mail aliases in suitable header fields found between BEG and END. If interactive, expand in header fields. -Suitable header fields are `To', `From', `CC' and `BCC', `Reply-to', and +Suitable header fields are `To', `From', `Cc' and `Bcc', `Reply-To', and their `Resent-' variants. Optional second arg EXCLUDE may be a regular expression defining text to be @@ -20390,9 +19900,7 @@ if it is quoted with double-quotes. (autoload 'mail-completion-at-point-function "mailalias" "\ Compute completion data for mail aliases. -For use on `completion-at-point-functions'. - -\(fn)" nil nil) +For use on `completion-at-point-functions'." nil nil) (autoload 'mail-complete "mailalias" "\ Perform completion on header field or word preceding point. @@ -20403,7 +19911,7 @@ current header, calls `mail-complete-function' and passes prefix ARG if any. (make-obsolete 'mail-complete 'mail-completion-at-point-function '"24.1") -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mailalias" '("mail-" "build-mail-aliases"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mailalias" '("build-mail-aliases" "mail-"))) ;;;*** @@ -20420,9 +19928,7 @@ current header, calls `mail-complete-function' and passes prefix ARG if any. (autoload 'mailclient-send-it "mailclient" "\ Pass current buffer on to the system's mail client. Suitable value for `send-mail-function'. -The mail client is taken to be the handler of mailto URLs. - -\(fn)" nil nil) +The mail client is taken to be the handler of mailto URLs." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mailclient" '("mailclient-"))) @@ -20574,9 +20080,7 @@ An adapted `makefile-mode' that knows about imake. (autoload 'make-command-summary "makesum" "\ Make a summary of current key bindings in the buffer *Summary*. -Previous contents of that buffer are killed first. - -\(fn)" t nil) +Previous contents of that buffer are killed first." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "makesum" '("double-column"))) @@ -20640,18 +20144,11 @@ Default bookmark handler for Man buffers. ;;;*** -;;;### (autoloads nil "mantemp" "progmodes/mantemp.el" (0 0 0 0)) -;;; Generated autoloads from progmodes/mantemp.el - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mantemp" '("mantemp-"))) - -;;;*** - ;;;### (autoloads nil "map" "emacs-lisp/map.el" (0 0 0 0)) ;;; Generated autoloads from emacs-lisp/map.el -(push (purecopy '(map 1 2)) package--builtin-versions) +(push (purecopy '(map 2 0)) package--builtin-versions) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "map" '("map"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "map" '("map-"))) ;;;*** @@ -20661,9 +20158,11 @@ Default bookmark handler for Man buffers. (autoload 'master-mode "master" "\ Toggle Master mode. -With a prefix argument ARG, enable Master mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Master mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. When Master mode is enabled, you can scroll the slave buffer using the following commands: @@ -20695,9 +20194,11 @@ or call the function `minibuffer-depth-indicate-mode'.") (autoload 'minibuffer-depth-indicate-mode "mb-depth" "\ Toggle Minibuffer Depth Indication mode. -With a prefix argument ARG, enable Minibuffer Depth Indication -mode if ARG is positive, and disable it otherwise. If called -from Lisp, enable the mode if ARG is omitted or nil. + +If called interactively, enable Minibuffer-Depth-Indicate mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Minibuffer Depth Indication mode is a global minor mode. When enabled, any recursive use of the minibuffer will show the @@ -20725,42 +20226,9 @@ recursion depth in the minibuffer prompt. This is only useful if (autoload 'message-mode "message" "\ Major mode for editing mail and news to be sent. -Like Text Mode but with these additional commands:\\<message-mode-map> -C-c C-s `message-send' (send the message) C-c C-c `message-send-and-exit' -C-c C-d Postpone sending the message C-c C-k Kill the message -C-c C-f move to a header field (and create it if there isn't): - C-c C-f C-t move to To C-c C-f C-s move to Subject - C-c C-f C-c move to Cc C-c C-f C-b move to Bcc - C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To - C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups - C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution - C-c C-f C-o move to From (\"Originator\") - C-c C-f C-f move to Followup-To - C-c C-f C-m move to Mail-Followup-To - C-c C-f C-e move to Expires - C-c C-f C-i cycle through Importance values - C-c C-f s change subject and append \"(was: <Old Subject>)\" - C-c C-f x crossposting with FollowUp-To header and note in body - C-c C-f t replace To: header with contents of Cc: or Bcc: - C-c C-f a Insert X-No-Archive: header and a note in the body -C-c C-t `message-insert-to' (add a To header to a news followup) -C-c C-l `message-to-list-only' (removes all but list address in to/cc) -C-c C-n `message-insert-newsgroups' (add a Newsgroup header to a news reply) -C-c C-b `message-goto-body' (move to beginning of message text). -C-c C-i `message-goto-signature' (move to the beginning of the signature). -C-c C-w `message-insert-signature' (insert `message-signature-file' file). -C-c C-y `message-yank-original' (insert current message, if any). -C-c C-q `message-fill-yanked-message' (fill what was yanked). -C-c C-e `message-elide-region' (elide the text between point and mark). -C-c C-v `message-delete-not-region' (remove the text outside the region). -C-c C-z `message-kill-to-signature' (kill the text up to the signature). -C-c C-r `message-caesar-buffer-body' (rot13 the message body). -C-c C-a `mml-attach-file' (attach a file as MIME). -C-c C-u `message-insert-or-toggle-importance' (insert or cycle importance). -C-c M-n `message-insert-disposition-notification-to' (request receipt). -C-c M-m `message-mark-inserted-region' (mark region with enclosing tags). -C-c M-f `message-mark-insert-file' (insert file marked with enclosing tags). -M-RET `message-newline-and-reformat' (break the line and reformat). +Like `text-mode', but with these additional commands: + +\\{message-mode-map} \(fn)" t nil) @@ -20802,14 +20270,10 @@ If ARG, allow editing of the cancellation message. (autoload 'message-supersede "message" "\ Start composing a message to supersede the current message. This is done simply by taking the old article and adding a Supersedes -header line with the old Message-ID. - -\(fn)" t nil) +header line with the old Message-ID." t nil) (autoload 'message-recover "message" "\ -Reread contents of current buffer from its last auto-save file. - -\(fn)" t nil) +Reread contents of current buffer from its last auto-save file." t nil) (autoload 'message-forward "message" "\ Forward the current message via mail. @@ -20829,9 +20293,7 @@ Optional DIGEST will use digest to forward. \(fn FORWARD-BUFFER)" nil nil) (autoload 'message-insinuate-rmail "message" "\ -Let RMAIL use message to forward. - -\(fn)" t nil) +Let RMAIL use message to forward." t nil) (autoload 'message-resend "message" "\ Resend the current article to ADDRESS. @@ -20842,9 +20304,7 @@ Resend the current article to ADDRESS. Re-mail the current message. This only makes sense if the current message is a bounce message that contains some mail you have written which has been bounced back to -you. - -\(fn)" t nil) +you." t nil) (autoload 'message-mail-other-window "message" "\ Like `message-mail' command, but display mail buffer in another window. @@ -20900,7 +20360,7 @@ Major mode for editing MetaPost sources. \(fn)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "meta-mode" '("meta" "font-lock-match-meta-declaration-item-and-skip-to-next"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "meta-mode" '("font-lock-match-meta-declaration-item-and-skip-to-next" "meta"))) ;;;*** @@ -20909,9 +20369,7 @@ Major mode for editing MetaPost sources. (autoload 'metamail-interpret-header "metamail" "\ Interpret a header part of a MIME message in current buffer. -Its body part is not interpreted at all. - -\(fn)" t nil) +Its body part is not interpreted at all." t nil) (autoload 'metamail-interpret-body "metamail" "\ Interpret a body part of a MIME message in current buffer. @@ -20952,7 +20410,7 @@ redisplayed as output is inserted. ;;;### (autoloads nil "mh-acros" "mh-e/mh-acros.el" (0 0 0 0)) ;;; Generated autoloads from mh-e/mh-acros.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-acros" '("mh-" "with-mh-folder-updating" "defun-mh" "defmacro-mh"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-acros" '("defmacro-mh" "defun-mh" "mh-" "with-mh-folder-updating"))) ;;;*** @@ -20975,15 +20433,11 @@ redisplayed as output is inserted. (autoload 'mh-smail "mh-comp" "\ Compose a message with the MH mail system. -See `mh-send' for more details on composing mail. - -\(fn)" t nil) +See `mh-send' for more details on composing mail." t nil) (autoload 'mh-smail-other-window "mh-comp" "\ Compose a message with the MH mail system in other window. -See `mh-send' for more details on composing mail. - -\(fn)" t nil) +See `mh-send' for more details on composing mail." t nil) (autoload 'mh-smail-batch "mh-comp" "\ Compose a message with the MH mail system. @@ -21054,9 +20508,7 @@ Quit editing and delete draft message. If for some reason you are not happy with the draft, you can use this command to kill the draft buffer and delete the draft message. Use the command \\[kill-buffer] if you don't want to -delete the draft message. - -\(fn)" t nil) +delete the draft message." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-comp" '("mh-"))) @@ -21080,11 +20532,9 @@ delete the draft message. (put 'mh-lib-progs 'risky-local-variable t) (autoload 'mh-version "mh-e" "\ -Display version information about MH-E and the MH mail handling system. - -\(fn)" t nil) +Display version information about MH-E and the MH mail handling system." t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-e" '("mh-" "defgroup-mh" "defcustom-mh" "defface-mh"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-e" '("defcustom-mh" "defface-mh" "defgroup-mh" "mh-"))) ;;;*** @@ -21325,6 +20775,11 @@ or call the function `midnight-mode'.") (autoload 'midnight-mode "midnight" "\ Non-nil means run `midnight-hook' at midnight. +If called interactively, enable Midnight mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + \(fn &optional ARG)" t nil) (autoload 'clean-buffer-list "midnight" "\ @@ -21337,9 +20792,7 @@ The relevant variables are `clean-buffer-list-delay-general', While processing buffers, this procedure displays messages containing 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. - -\(fn)" t nil) +lifetime, i.e., its \"age\" when it will be purged." t nil) (autoload 'midnight-delay-set "midnight" "\ Modify `midnight-timer' according to `midnight-delay'. @@ -21348,7 +20801,7 @@ to its second argument TM. \(fn SYMB TM)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "midnight" '("midnight-" "clean-buffer-list-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "midnight" '("clean-buffer-list-" "midnight-"))) ;;;*** @@ -21367,9 +20820,11 @@ or call the function `minibuffer-electric-default-mode'.") (autoload 'minibuffer-electric-default-mode "minibuf-eldef" "\ Toggle Minibuffer Electric Default mode. -With a prefix argument ARG, enable Minibuffer Electric Default -mode if ARG is positive, and disable it otherwise. If called -from Lisp, enable the mode if ARG is omitted or nil. + +If called interactively, enable Minibuffer-Electric-Default mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Minibuffer Electric Default mode is a global minor mode. When enabled, minibuffer prompts that show a default value only show @@ -21404,14 +20859,10 @@ Ignores CHAR at point. \(fn ARG CHAR)" t nil) (autoload 'mark-beginning-of-buffer "misc" "\ -Set mark at the beginning of the buffer. - -\(fn)" t nil) +Set mark at the beginning of the buffer." t nil) (autoload 'mark-end-of-buffer "misc" "\ -Set mark at the end of the buffer. - -\(fn)" t nil) +Set mark at the end of the buffer." t nil) (autoload 'upcase-char "misc" "\ Uppercasify ARG chars starting from point. Point doesn't move. @@ -21438,9 +20889,7 @@ upper atmosphere. These cause momentary pockets of higher-pressure air to form, which act as lenses that deflect incoming cosmic rays, focusing them to strike the drive platter and flip the desired bit. You can type `M-x butterfly C-M-c' to run it. This is a permuted -variation of `C-x M-c M-butterfly' from url `http://xkcd.com/378/'. - -\(fn)" t nil) +variation of `C-x M-c M-butterfly' from url `http://xkcd.com/378/'." t nil) (autoload 'list-dynamic-libraries "misc" "\ Display a list of all dynamic libraries known to Emacs. @@ -21501,9 +20950,7 @@ Sequence of files visited by multiple file buffers Isearch.") (autoload 'multi-isearch-setup "misearch" "\ Set up isearch to search multiple buffers. -Intended to be added to `isearch-mode-hook'. - -\(fn)" nil nil) +Intended to be added to `isearch-mode-hook'." nil nil) (autoload 'multi-isearch-buffers "misearch" "\ Start multi-buffer Isearch on a list of BUFFERS. @@ -21543,7 +20990,7 @@ whose file names match the specified wildcard. \(fn FILES)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "misearch" '("multi-isearch-" "misearch-unload-function"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "misearch" '("misearch-unload-function" "multi-isearch-"))) ;;;*** @@ -21686,9 +21133,7 @@ Assume text has been decoded if DECODED is non-nil. ;;; Generated autoloads from gnus/mml.el (autoload 'mml-to-mime "mml" "\ -Translate the current buffer from MML to MIME. - -\(fn)" nil nil) +Translate the current buffer from MML to MIME." nil nil) (autoload 'mml-attach-file "mml" "\ Attach a file to the outgoing MIME message. @@ -21777,10 +21222,7 @@ will be computed and used. \(fn CONT)" nil nil) -(autoload 'mml2015-self-encrypt "mml2015" "\ - - -\(fn)" nil nil) +(autoload 'mml2015-self-encrypt "mml2015" nil nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mml2015" '("mml2015-"))) @@ -21791,7 +21233,7 @@ will be computed and used. (put 'define-overloadable-function 'doc-string-elt 3) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mode-local" '("make-obsolete-overload" "mode-local-" "deactivate-mode-local-bindings" "def" "describe-mode-local-" "xref-mode-local-" "overload-" "fetch-overload" "function-overload-p" "set" "with-mode-local" "activate-mode-local-bindings" "new-mode-local-bindings" "get-mode-local-parent"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mode-local" '("activate-mode-local-bindings" "deactivate-mode-local-bindings" "def" "describe-mode-local-" "fetch-overload" "function-overload-p" "get-mode-local-parent" "make-obsolete-overload" "mode-local-" "new-mode-local-bindings" "overload-" "set" "with-mode-local" "xref-mode-local-"))) ;;;*** @@ -21826,7 +21268,7 @@ followed by the first character of the construct. \(fn)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "modula2" '("m3-font-lock-keywords" "m2-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "modula2" '("m2-" "m3-font-lock-keywords"))) ;;;*** @@ -21853,7 +21295,7 @@ Convert NATO phonetic alphabet in region to ordinary ASCII text. \(fn BEG END)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "morse" '("nato-alphabet" "morse-code"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "morse" '("morse-code" "nato-alphabet"))) ;;;*** @@ -21917,9 +21359,7 @@ To test this function, evaluate: ;;; Generated autoloads from mpc.el (autoload 'mpc "mpc" "\ -Main entry point for MPC. - -\(fn)" t nil) +Main entry point for MPC." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mpc" '("mpc-" "tag-browser-tagtypes"))) @@ -21929,9 +21369,7 @@ Main entry point for MPC. ;;; Generated autoloads from play/mpuz.el (autoload 'mpuz "mpuz" "\ -Multiplication puzzle with GNU Emacs. - -\(fn)" t nil) +Multiplication puzzle with GNU Emacs." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mpuz" '("mpuz-"))) @@ -21952,9 +21390,11 @@ or call the function `msb-mode'.") (autoload 'msb-mode "msb" "\ Toggle Msb mode. -With a prefix argument ARG, enable Msb mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. + +If called interactively, enable Msb mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. This mode overrides the binding(s) of `mouse-buffer-menu' to provide a different buffer menu using the function `msb'. @@ -22038,14 +21478,10 @@ in place of `..': `default-process-coding-system' for read eol-type of `default-process-coding-system' for read `default-process-coding-system' for write - eol-type of `default-process-coding-system' - -\(fn)" t nil) + eol-type of `default-process-coding-system'" t nil) (autoload 'describe-current-coding-system "mule-diag" "\ -Display coding systems currently used, in detail. - -\(fn)" t nil) +Display coding systems currently used, in detail." t nil) (autoload 'list-coding-systems "mule-diag" "\ Display a list of all coding systems. @@ -22057,9 +21493,7 @@ but still contains full information about each coding system. \(fn &optional ARG)" t nil) (autoload 'list-coding-categories "mule-diag" "\ -Display a list of all coding categories. - -\(fn)" nil nil) +Display a list of all coding categories." nil nil) (autoload 'describe-font "mule-diag" "\ Display information about a font whose name is FONTNAME. @@ -22082,9 +21516,7 @@ see the function `describe-fontset' for the format of the list. \(fn ARG)" t nil) (autoload 'list-input-methods "mule-diag" "\ -Display information about all input methods. - -\(fn)" t nil) +Display information about all input methods." t nil) (autoload 'mule-diag "mule-diag" "\ Display diagnosis of the multilingual environment (Mule). @@ -22092,9 +21524,7 @@ Display diagnosis of the multilingual environment (Mule). This shows various information related to the current multilingual environment, including lists of input methods, coding systems, character sets, and fontsets (if Emacs is running under a window -system which uses fontsets). - -\(fn)" t nil) +system which uses fontsets)." t nil) (autoload 'font-show-log "mule-diag" "\ Show log of font listing and opening. @@ -22103,7 +21533,7 @@ The default is 20. If LIMIT is negative, do not limit the listing. \(fn &optional LIMIT)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mule-diag" '("insert-section" "list-" "print-" "describe-font-internal" "charset-history" "non-iso-charset-alist" "sort-listed-character-sets"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mule-diag" '("charset-history" "describe-font-internal" "insert-section" "list-" "non-iso-charset-alist" "print-" "sort-listed-character-sets"))) ;;;*** @@ -22274,29 +21704,19 @@ QUALITY can be: ;;; Generated autoloads from net/net-utils.el (autoload 'ifconfig "net-utils" "\ -Run `ifconfig-program' and display diagnostic output. - -\(fn)" t nil) +Run `ifconfig-program' and display diagnostic output." t nil) (autoload 'iwconfig "net-utils" "\ -Run `iwconfig-program' and display diagnostic output. - -\(fn)" t nil) +Run `iwconfig-program' and display diagnostic output." t nil) (autoload 'netstat "net-utils" "\ -Run `netstat-program' and display diagnostic output. - -\(fn)" t nil) +Run `netstat-program' and display diagnostic output." t nil) (autoload 'arp "net-utils" "\ -Run `arp-program' and display diagnostic output. - -\(fn)" t nil) +Run `arp-program' and display diagnostic output." t nil) (autoload 'route "net-utils" "\ -Run `route-program' and display diagnostic output. - -\(fn)" t nil) +Run `route-program' and display diagnostic output." t nil) (autoload 'traceroute "net-utils" "\ Run `traceroute-program' for TARGET. @@ -22321,9 +21741,7 @@ This command uses `nslookup-program' for looking up the DNS information. \(fn HOST &optional NAME-SERVER)" t nil) (autoload 'nslookup "net-utils" "\ -Run `nslookup-program'. - -\(fn)" t nil) +Run `nslookup-program'." t nil) (autoload 'dns-lookup-host "net-utils" "\ Look up the DNS information for HOST (name or IP address). @@ -22365,10 +21783,7 @@ The port is deduced from `network-connection-service-alist'. \(fn ARG SEARCH-STRING)" t nil) -(autoload 'whois-reverse-lookup "net-utils" "\ - - -\(fn)" t nil) +(autoload 'whois-reverse-lookup "net-utils" nil t nil) (autoload 'network-connection-to-service "net-utils" "\ Open a network connection to SERVICE on HOST. @@ -22381,7 +21796,7 @@ Open a network connection to HOST on PORT. \(fn HOST PORT)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "net-utils" '("nslookup-" "net" "whois-" "ftp-" "finger-X.500-host-regexps" "route-program" "run-network-program" "smbclient" "ifconfig-program" "iwconfig-program" "ipconfig" "dig-program" "dns-lookup-program" "arp-program" "ping-program" "traceroute-program"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "net-utils" '("arp-program" "dig-program" "dns-lookup-program" "finger-X.500-host-regexps" "ftp-" "ifconfig-program" "ipconfig" "iwconfig-program" "net" "nslookup-" "ping-program" "route-program" "run-network-program" "smbclient" "traceroute-program" "whois-"))) ;;;*** @@ -22515,9 +21930,7 @@ gnutls-boot (as returned by `gnutls-boot-parameters'). (autoload 'newsticker-running-p "newst-backend" "\ Check whether newsticker is running. Return t if newsticker is running, nil otherwise. Newsticker is -considered to be running if the newsticker timer list is not empty. - -\(fn)" nil nil) +considered to be running if the newsticker timer list is not empty." nil nil) (autoload 'newsticker-start "newst-backend" "\ Start the newsticker. @@ -22537,9 +21950,7 @@ Run `newsticker-start-hook' if newsticker was not running already. ;;; Generated autoloads from net/newst-plainview.el (autoload 'newsticker-plainview "newst-plainview" "\ -Start newsticker plainview. - -\(fn)" t nil) +Start newsticker plainview." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "newst-plainview" '("newsticker-"))) @@ -22550,9 +21961,7 @@ Start newsticker plainview. ;;; Generated autoloads from net/newst-reader.el (autoload 'newsticker-show-news "newst-reader" "\ -Start reading news. You may want to bind this to a key. - -\(fn)" t nil) +Start reading news. You may want to bind this to a key." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "newst-reader" '("newsticker-"))) @@ -22566,16 +21975,12 @@ Start reading news. You may want to bind this to a key. Check whether newsticker's actual ticker is running. Return t if ticker is running, nil otherwise. Newsticker is considered to be running if the newsticker timer list is not -empty. - -\(fn)" nil nil) +empty." nil nil) (autoload 'newsticker-start-ticker "newst-ticker" "\ Start newsticker's ticker (but not the news retrieval). Start display timer for the actual ticker if wanted and not -running already. - -\(fn)" t nil) +running already." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "newst-ticker" '("newsticker-"))) @@ -22586,9 +21991,7 @@ running already. ;;; Generated autoloads from net/newst-treeview.el (autoload 'newsticker-treeview "newst-treeview" "\ -Start newsticker treeview. - -\(fn)" t nil) +Start newsticker treeview." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "newst-treeview" '("newsticker-"))) @@ -22669,9 +22072,7 @@ symbol in the alist. (autoload 'nnfolder-generate-active-file "nnfolder" "\ Look for mbox folders in the nnfolder directory and make them into groups. -This command does not work if you use short group names. - -\(fn)" t nil) +This command does not work if you use short group names." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnfolder" '("nnfolder-"))) @@ -22687,21 +22088,21 @@ This command does not work if you use short group names. ;;;### (autoloads nil "nnheader" "gnus/nnheader.el" (0 0 0 0)) ;;; Generated autoloads from gnus/nnheader.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnheader" '("nntp-" "nnheader-" "mail-header-" "make-" "gnus-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnheader" '("gnus-" "mail-header-" "make-mail-header" "nnheader-" "nntp-"))) ;;;*** ;;;### (autoloads nil "nnimap" "gnus/nnimap.el" (0 0 0 0)) ;;; Generated autoloads from gnus/nnimap.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnimap" '("nnimap"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnimap" '("nnimap-"))) ;;;*** ;;;### (autoloads nil "nnir" "gnus/nnir.el" (0 0 0 0)) ;;; Generated autoloads from gnus/nnir.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnir" '("nnir-" "gnus-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnir" '("gnus-" "nnir-"))) ;;;*** @@ -22762,7 +22163,7 @@ Generate NOV databases in all nnml directories. ;;;### (autoloads nil "nnoo" "gnus/nnoo.el" (0 0 0 0)) ;;; Generated autoloads from gnus/nnoo.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnoo" '("nnoo-" "defvoo" "deffoo"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnoo" '("deffoo" "defvoo" "nnoo-"))) ;;;*** @@ -22818,8 +22219,6 @@ Generate NOV databases in all nnml directories. ;;;### (autoloads nil "novice" "novice.el" (0 0 0 0)) ;;; Generated autoloads from novice.el -(define-obsolete-variable-alias 'disabled-command-hook 'disabled-command-function "22.1") - (defvar disabled-command-function 'disabled-command-function "\ Function to call to handle disabled commands. If nil, the feature is disabled, i.e., all commands work normally.") @@ -22869,7 +22268,7 @@ closing requests for requests that are used in matched pairs. ;;;### (autoloads nil "nsm" "net/nsm.el" (0 0 0 0)) ;;; Generated autoloads from net/nsm.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nsm" '("network-security-level" "nsm-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nsm" '("network-security-" "nsm-"))) ;;;*** @@ -22939,11 +22338,10 @@ The Emacs commands that normally operate on balanced expressions will operate on XML markup items. Thus \\[forward-sexp] will move forward across one markup item; \\[backward-sexp] will move backward across one markup item; \\[kill-sexp] will kill the following markup item; -\\[mark-sexp] will mark the following markup item. By default, each -tag each treated as a single markup item; to make the complete element -be treated as a single markup item, set the variable -`nxml-sexp-element-flag' to t. For more details, see the function -`nxml-forward-balanced-item'. +\\[mark-sexp] will mark the following markup item. By default, the +complete element is treated as a single markup item; to make each tag be +treated as a separate markup item, set the variable `nxml-sexp-element-flag' +to nil. For more details, see the function `nxml-forward-balanced-item'. \\[nxml-backward-up-element] and \\[nxml-down-element] move up and down the element structure. @@ -23060,7 +22458,7 @@ Many aspects this mode can be customized using ;;;### (autoloads nil "ob-coq" "org/ob-coq.el" (0 0 0 0)) ;;; Generated autoloads from org/ob-coq.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-coq" '("org-babel-" "coq-program-name"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-coq" '("coq-program-name" "org-babel-"))) ;;;*** @@ -23140,7 +22538,7 @@ Many aspects this mode can be customized using ;;;### (autoloads nil "ob-gnuplot" "org/ob-gnuplot.el" (0 0 0 0)) ;;; Generated autoloads from org/ob-gnuplot.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-gnuplot" '("org-babel-" "*org-babel-gnuplot-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-gnuplot" '("*org-babel-gnuplot-" "org-babel-"))) ;;;*** @@ -23211,7 +22609,7 @@ Many aspects this mode can be customized using ;;;### (autoloads nil "ob-lilypond" "org/ob-lilypond.el" (0 0 0 0)) ;;; Generated autoloads from org/ob-lilypond.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-lilypond" '("org-babel-" "lilypond-mode"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-lilypond" '("lilypond-mode" "org-babel-"))) ;;;*** @@ -23417,6 +22815,10 @@ Many aspects this mode can be customized using ;;;### (autoloads nil "octave" "progmodes/octave.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/octave.el + (add-to-list 'auto-mode-alist '("\\.m\\'" . octave-maybe-mode)) + +(autoload 'octave-maybe-mode "octave" "\ +Select `octave-mode' if the current buffer seems to hold Octave code." nil nil) (autoload 'octave-mode "octave" "\ Major mode for editing Octave code. @@ -23450,7 +22852,7 @@ startup file, `~/.emacs-octave'. (defalias 'run-octave 'inferior-octave) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "octave" '("octave-" "inferior-octave-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "octave" '("inferior-octave-" "octave-"))) ;;;*** @@ -23526,14 +22928,10 @@ FULL is given. \(fn &optional HERE FULL MESSAGE)" t nil) (autoload 'turn-on-orgtbl "org" "\ -Unconditionally turn on `orgtbl-mode'. - -\(fn)" nil nil) +Unconditionally turn on `orgtbl-mode'." nil nil) (autoload 'org-clock-persistence-insinuate "org" "\ -Set up hooks for clock persistence. - -\(fn)" nil nil) +Set up hooks for clock persistence." nil nil) (autoload 'org-mode "org" "\ Outline-based notes management and organizer, alias @@ -23623,17 +23021,18 @@ modes. The following keys behave as if Org mode were active, if the cursor is on a headline, or on a plain list item (both as defined by Org mode). +If called interactively, enable OrgStruct mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + \(fn &optional ARG)" t nil) (autoload 'turn-on-orgstruct "org" "\ -Unconditionally turn on `orgstruct-mode'. - -\(fn)" nil nil) +Unconditionally turn on `orgstruct-mode'." nil nil) (autoload 'turn-on-orgstruct++ "org" "\ -Unconditionally turn on `orgstruct++-mode'. - -\(fn)" nil nil) +Unconditionally turn on `orgstruct++-mode'." nil nil) (autoload 'org-run-like-in-org-mode "org" "\ Run a command, pretending that the current buffer is in Org mode. @@ -23663,18 +23062,14 @@ active region. (autoload 'org-insert-link-global "org" "\ Insert a link like Org mode does. -This command can be called in any mode to insert a link in Org syntax. - -\(fn)" t nil) +This command can be called in any mode to insert a link in Org syntax." t nil) (autoload 'org-open-at-point-global "org" "\ Follow a link or time-stamp like Org mode does. This command can be called in any mode to follow an external link or a time-stamp that has Org mode syntax. Its behavior is undefined when called on internal links (e.g., fuzzy links). -Raise an error when there is nothing to follow. - -\(fn)" t nil) +Raise an error when there is nothing to follow. " t nil) (autoload 'org-open-link-from-string "org" "\ Open a link in the string S, as if it was in Org mode. @@ -23693,9 +23088,7 @@ With `\\[universal-argument] \\[universal-argument]' prefix, restrict available (autoload 'org-cycle-agenda-files "org" "\ Cycle through the files in `org-agenda-files'. If the current buffer visits an agenda file, find the next one in the list. -If the current buffer does not, find the first agenda file. - -\(fn)" t nil) +If the current buffer does not, find the first agenda file." t nil) (autoload 'org-submit-bug-report "org" "\ Submit a bug report on Org via mail. @@ -23704,9 +23097,7 @@ Don't hesitate to report any problems or inaccurate documentation. If you don't have setup sending mail from (X)Emacs, please copy the output buffer into your mail program, as it gives us important -information about your Org version and configuration. - -\(fn)" t nil) +information about your Org version and configuration." t nil) (autoload 'org-reload "org" "\ Reload all Org Lisp files. @@ -23715,9 +23106,7 @@ With prefix arg UNCOMPILED, load the uncompiled versions. \(fn &optional UNCOMPILED)" t nil) (autoload 'org-customize "org" "\ -Call the customize function with org as argument. - -\(fn)" t nil) +Call the customize function with org as argument." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org" '("org" "turn-on-org-cdlatex"))) @@ -23955,9 +23344,7 @@ in the file. Otherwise, restriction will be to the current subtree. (autoload 'org-calendar-goto-agenda "org-agenda" "\ Compute the Org agenda for the calendar date displayed at the cursor. -This is a command that has to be installed in `calendar-mode-map'. - -\(fn)" t nil) +This is a command that has to be installed in `calendar-mode-map'." t nil) (autoload 'org-agenda-to-appt "org-agenda" "\ Activate appointments found in `org-agenda-files'. @@ -24069,9 +23456,7 @@ of the day at point (if any) or the current HH:MM time. \(fn &optional GOTO KEYS)" t nil) (autoload 'org-capture-import-remember-templates "org-capture" "\ -Set `org-capture-templates' to be similar to `org-remember-templates'. - -\(fn)" t nil) +Set `org-capture-templates' to be similar to `org-remember-templates'." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-capture" '("org-"))) @@ -24089,14 +23474,9 @@ Set `org-capture-templates' to be similar to `org-remember-templates'. ;;; Generated autoloads from org/org-colview.el (autoload 'org-columns-remove-overlays "org-colview" "\ -Remove all currently active column overlays. - -\(fn)" t nil) - -(autoload 'org-columns-get-format-and-top-level "org-colview" "\ +Remove all currently active column overlays." t nil) - -\(fn)" nil nil) +(autoload 'org-columns-get-format-and-top-level "org-colview" nil nil nil) (autoload 'org-columns "org-colview" "\ Turn on column view on an Org mode file. @@ -24142,14 +23522,10 @@ PARAMS is a property list of parameters: \(fn PARAMS)" nil nil) (autoload 'org-columns-insert-dblock "org-colview" "\ -Create a dynamic block capturing a column view table. - -\(fn)" t nil) +Create a dynamic block capturing a column view table." t nil) (autoload 'org-agenda-columns "org-colview" "\ -Turn on or update column view in the agenda. - -\(fn)" t nil) +Turn on or update column view in the agenda." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-colview" '("org-"))) @@ -24159,9 +23535,7 @@ Turn on or update column view in the agenda. ;;; Generated autoloads from org/org-compat.el (autoload 'org-check-version "org-compat" "\ -Try very hard to provide sensible version strings. - -\(fn)" nil t) +Try very hard to provide sensible version strings." nil t) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-compat" '("org-"))) @@ -24201,9 +23575,7 @@ Try very hard to provide sensible version strings. ;;; Generated autoloads from org/org-duration.el (autoload 'org-duration-set-regexps "org-duration" "\ -Set duration related regexps. - -\(fn)" t nil) +Set duration related regexps." t nil) (autoload 'org-duration-p "org-duration" "\ Non-nil when string S is a time duration. @@ -24484,15 +23856,11 @@ Load FILE with optional arguments NOERROR and MUSTSUFFIX. (autoload 'org-release "org-version" "\ The release version of Org. -Inserted by installing Org mode or when a release is made. - -\(fn)" nil nil) +Inserted by installing Org mode or when a release is made." nil nil) (autoload 'org-git-version "org-version" "\ The Git version of Org mode. -Inserted by installing Org or when a release is made. - -\(fn)" nil nil) +Inserted by installing Org or when a release is made." nil nil) ;;;*** @@ -24535,9 +23903,11 @@ Turning on outline mode calls the value of `text-mode-hook' and then of (autoload 'outline-minor-mode "outline" "\ Toggle Outline minor mode. -With a prefix argument ARG, enable Outline minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Outline minor mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. See the command `outline-mode' for more information on this mode. @@ -24649,13 +24019,17 @@ See the command `outline-mode' for more information on this mode. (push (purecopy '(package 1 1 0)) package--builtin-versions) (defvar package-enable-at-startup t "\ -Whether to activate installed packages when Emacs starts. -If non-nil, packages are activated after reading the init file -and before `after-init-hook'. Activation is not done if -`user-init-file' is nil (e.g. Emacs was started with \"-q\"). +Whether to make installed packages available when Emacs starts. +If non-nil, packages are made available before reading the init +file (but after reading the early init file). This means that if +you wish to set this variable, you must do so in the early init +file. Regardless of the value of this variable, packages are not +made available if `user-init-file' is nil (e.g. Emacs was started +with \"-q\"). Even if the value is nil, you can type \\[package-initialize] to -activate the package system at any time.") +make installed packages available at any time, or you can +call (package-initialize) in your init-file.") (custom-autoload 'package-enable-at-startup "package" t) @@ -24663,17 +24037,27 @@ activate the package system at any time.") Load Emacs Lisp packages, and activate them. The variable `package-load-list' controls which packages to load. If optional arg NO-ACTIVATE is non-nil, don't activate packages. -If `user-init-file' does not mention `(package-initialize)', add -it to the file. If called as part of loading `user-init-file', set `package-enable-at-startup' to nil, to prevent accidentally loading packages twice. + It is not necessary to adjust `load-path' or `require' the individual packages after calling `package-initialize' -- this is taken care of by `package-initialize'. +If `package-initialize' is called twice during Emacs startup, +signal a warning, since this is a bad idea except in highly +advanced use cases. To suppress the warning, remove the +superfluous call to `package-initialize' from your init-file. If +you have code which must run before `package-initialize', put +that code in the early init-file. + \(fn &optional NO-ACTIVATE)" t nil) +(autoload 'package-activate-all "package" "\ +Activate all installed packages. +The variable `package-load-list' controls which packages to load." nil nil) + (autoload 'package-import-keyring "package" "\ Import keys from FILE. @@ -24712,9 +24096,7 @@ Specially, if current buffer is a directory, the -pkg.el description file is not mandatory, in which case the information is derived from the main .el file in the directory. -Downloads and installs required packages as needed. - -\(fn)" t nil) +Downloads and installs required packages as needed." t nil) (autoload 'package-install-file "package" "\ Install a package from a file. @@ -24725,9 +24107,7 @@ directory. (autoload 'package-install-selected-packages "package" "\ Ensure packages in `package-selected-packages' are installed. -If some packages are not installed propose to install them. - -\(fn)" t nil) +If some packages are not installed propose to install them." t nil) (autoload 'package-reinstall "package" "\ Reinstall package PKG. @@ -24741,9 +24121,7 @@ Remove packages that are no more needed. Packages that are no more needed by other packages in `package-selected-packages' and their dependencies -will be deleted. - -\(fn)" t nil) +will be deleted." t nil) (autoload 'describe-package "package" "\ Display the full documentation of PACKAGE (a symbol). @@ -24762,7 +24140,15 @@ short description. (defalias 'package-list-packages 'list-packages) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "package" '("package-" "define-package" "describe-package-1" "bad-signature"))) +(autoload 'package-get-version "package" "\ +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) + +(function-put 'package-get-version 'pure 't) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "package" '("bad-signature" "define-package" "describe-package-1" "package-"))) ;;;*** @@ -24777,7 +24163,7 @@ short description. ;;;### (autoloads nil "page-ext" "textmodes/page-ext.el" (0 0 0 0)) ;;; Generated autoloads from textmodes/page-ext.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "page-ext" '("previous-page" "pages-" "sort-pages-" "original-page-delimiter" "add-new-page" "next-page" "ctl-x-ctl-p-map"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "page-ext" '("pages-"))) ;;;*** @@ -24796,9 +24182,11 @@ or call the function `show-paren-mode'.") (autoload 'show-paren-mode "paren" "\ Toggle visualization of matching parens (Show Paren mode). -With a prefix argument ARG, enable Show Paren mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Show-Paren mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Show Paren mode is a global minor mode. When enabled, any matching parenthesis is highlighted in `show-paren-style' after @@ -24822,7 +24210,8 @@ STRING should be something resembling an RFC 822 (or later) date-time, e.g., somewhat liberal in what format it accepts, and will attempt to return a \"likely\" value even for somewhat malformed strings. The values returned are identical to those of `decode-time', but -any values that are unknown are returned as nil. +any unknown values other than DST are returned as nil, and an +unknown DST value is returned as -1. \(fn STRING)" nil nil) @@ -24877,7 +24266,7 @@ See also the user variables `pascal-type-keywords', `pascal-start-keywords' and \(fn)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pascal" '("pascal-" "electric-pascal-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pascal" '("electric-pascal-" "pascal-"))) ;;;*** @@ -24952,6 +24341,10 @@ Emacs Lisp manual for more information and examples. (function-put 'pcase 'lisp-indent-function '1) +(put 'pcase 'function-documentation '(pcase--make-docstring)) + +(autoload 'pcase--make-docstring "pcase" nil nil nil) + (autoload 'pcase-exhaustive "pcase" "\ The exhaustive version of `pcase' (which see). If EXP fails to match any of the patterns in CASES, an error is signaled. @@ -25039,9 +24432,7 @@ for the result of evaluating EXP (first arg to `pcase'). ;;; Generated autoloads from pcmpl-cvs.el (autoload 'pcomplete/cvs "pcmpl-cvs" "\ -Completion rules for the `cvs' command. - -\(fn)" nil nil) +Completion rules for the `cvs' command." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcmpl-cvs" '("pcmpl-cvs-"))) @@ -25051,29 +24442,19 @@ Completion rules for the `cvs' command. ;;; Generated autoloads from pcmpl-gnu.el (autoload 'pcomplete/gzip "pcmpl-gnu" "\ -Completion for `gzip'. - -\(fn)" nil nil) +Completion for `gzip'." nil nil) (autoload 'pcomplete/bzip2 "pcmpl-gnu" "\ -Completion for `bzip2'. - -\(fn)" nil nil) +Completion for `bzip2'." nil nil) (autoload 'pcomplete/make "pcmpl-gnu" "\ -Completion for GNU `make'. - -\(fn)" nil nil) +Completion for GNU `make'." nil nil) (autoload 'pcomplete/tar "pcmpl-gnu" "\ -Completion for the GNU tar utility. - -\(fn)" nil nil) +Completion for the GNU tar utility." nil nil) (autoload 'pcomplete/find "pcmpl-gnu" "\ -Completion for the GNU find utility. - -\(fn)" nil nil) +Completion for the GNU find utility." nil nil) (defalias 'pcomplete/gdb 'pcomplete/xargs) @@ -25085,21 +24466,15 @@ Completion for the GNU find utility. ;;; Generated autoloads from pcmpl-linux.el (autoload 'pcomplete/kill "pcmpl-linux" "\ -Completion for GNU/Linux `kill', using /proc filesystem. - -\(fn)" nil nil) +Completion for GNU/Linux `kill', using /proc filesystem." nil nil) (autoload 'pcomplete/umount "pcmpl-linux" "\ -Completion for GNU/Linux `umount'. - -\(fn)" nil nil) +Completion for GNU/Linux `umount'." nil nil) (autoload 'pcomplete/mount "pcmpl-linux" "\ -Completion for GNU/Linux `mount'. +Completion for GNU/Linux `mount'." nil nil) -\(fn)" nil nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcmpl-linux" '("pcomplete-pare-list" "pcmpl-linux-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcmpl-linux" '("pcmpl-linux-" "pcomplete-pare-list"))) ;;;*** @@ -25107,9 +24482,7 @@ Completion for GNU/Linux `mount'. ;;; Generated autoloads from pcmpl-rpm.el (autoload 'pcomplete/rpm "pcmpl-rpm" "\ -Completion for the `rpm' command. - -\(fn)" nil nil) +Completion for the `rpm' command." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcmpl-rpm" '("pcmpl-rpm-"))) @@ -25119,54 +24492,36 @@ Completion for the `rpm' command. ;;; Generated autoloads from pcmpl-unix.el (autoload 'pcomplete/cd "pcmpl-unix" "\ -Completion for `cd'. - -\(fn)" nil nil) +Completion for `cd'." nil nil) (defalias 'pcomplete/pushd 'pcomplete/cd) (autoload 'pcomplete/rmdir "pcmpl-unix" "\ -Completion for `rmdir'. - -\(fn)" nil nil) +Completion for `rmdir'." nil nil) (autoload 'pcomplete/rm "pcmpl-unix" "\ -Completion for `rm'. - -\(fn)" nil nil) +Completion for `rm'." nil nil) (autoload 'pcomplete/xargs "pcmpl-unix" "\ -Completion for `xargs'. - -\(fn)" nil nil) +Completion for `xargs'." nil nil) (defalias 'pcomplete/time 'pcomplete/xargs) (autoload 'pcomplete/which "pcmpl-unix" "\ -Completion for `which'. - -\(fn)" nil nil) +Completion for `which'." nil nil) (autoload 'pcomplete/chown "pcmpl-unix" "\ -Completion for the `chown' command. - -\(fn)" nil nil) +Completion for the `chown' command." nil nil) (autoload 'pcomplete/chgrp "pcmpl-unix" "\ -Completion for the `chgrp' command. - -\(fn)" nil nil) +Completion for the `chgrp' command." nil nil) (autoload 'pcomplete/ssh "pcmpl-unix" "\ -Completion rules for the `ssh' command. - -\(fn)" nil nil) +Completion rules for the `ssh' command." nil nil) (autoload 'pcomplete/scp "pcmpl-unix" "\ Completion rules for the `scp' command. -Includes files as well as host names followed by a colon. - -\(fn)" nil nil) +Includes files as well as host names followed by a colon." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcmpl-unix" '("pcmpl-"))) @@ -25176,23 +24531,17 @@ Includes files as well as host names followed by a colon. ;;; Generated autoloads from pcmpl-x.el (autoload 'pcomplete/tlmgr "pcmpl-x" "\ -Completion for the `tlmgr' command. - -\(fn)" nil nil) +Completion for the `tlmgr' command." nil nil) (autoload 'pcomplete/ack "pcmpl-x" "\ Completion for the `ack' command. Start an argument with `-' to complete short options and `--' for -long options. - -\(fn)" nil nil) +long options." nil nil) (defalias 'pcomplete/ack-grep 'pcomplete/ack) (autoload 'pcomplete/ag "pcmpl-x" "\ -Completion for the `ag' command. - -\(fn)" nil nil) +Completion for the `ag' command." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcmpl-x" '("pcmpl-x-"))) @@ -25209,36 +24558,24 @@ completion functions list (it should occur fairly early in the list). \(fn &optional INTERACTIVELY)" t nil) (autoload 'pcomplete-reverse "pcomplete" "\ -If cycling completion is in use, cycle backwards. - -\(fn)" t nil) +If cycling completion is in use, cycle backwards." t nil) (autoload 'pcomplete-expand-and-complete "pcomplete" "\ Expand the textual value of the current argument. -This will modify the current buffer. - -\(fn)" t nil) +This will modify the current buffer." t nil) (autoload 'pcomplete-continue "pcomplete" "\ -Complete without reference to any cycling completions. - -\(fn)" t nil) +Complete without reference to any cycling completions." t nil) (autoload 'pcomplete-expand "pcomplete" "\ Expand the textual value of the current argument. -This will modify the current buffer. - -\(fn)" t nil) +This will modify the current buffer." t nil) (autoload 'pcomplete-help "pcomplete" "\ -Display any help information relative to the current argument. - -\(fn)" t nil) +Display any help information relative to the current argument." t nil) (autoload 'pcomplete-list "pcomplete" "\ -Show the list of possible completions for the current argument. - -\(fn)" t nil) +Show the list of possible completions for the current argument." t nil) (autoload 'pcomplete-comint-setup "pcomplete" "\ Setup a comint buffer to use pcomplete. @@ -25249,9 +24586,7 @@ this is `comint-dynamic-complete-functions'. \(fn COMPLETEF-SYM)" nil nil) (autoload 'pcomplete-shell-setup "pcomplete" "\ -Setup `shell-mode' to use pcomplete. - -\(fn)" nil nil) +Setup `shell-mode' to use pcomplete." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcomplete" '("pcomplete-"))) @@ -25328,7 +24663,7 @@ Anything else means to do it only if the prefix arg is equal to this value.") (defun cvs-dired-noselect (dir) "\ Run `cvs-examine' if DIR is a CVS administrative directory. -The exact behavior is determined also by `cvs-dired-use-hook'." (when (stringp dir) (setq dir (directory-file-name dir)) (when (and (string= "CVS" (file-name-nondirectory dir)) (file-readable-p (expand-file-name "Entries" dir)) cvs-dired-use-hook (if (eq cvs-dired-use-hook (quote always)) (not current-prefix-arg) (equal current-prefix-arg cvs-dired-use-hook))) (save-excursion (funcall cvs-dired-action (file-name-directory dir) t t))))) +The exact behavior is determined also by `cvs-dired-use-hook'." (when (stringp dir) (setq dir (directory-file-name dir)) (when (and (string= "CVS" (file-name-nondirectory dir)) (file-readable-p (expand-file-name "Entries" dir)) cvs-dired-use-hook (if (eq cvs-dired-use-hook 'always) (not current-prefix-arg) (equal current-prefix-arg cvs-dired-use-hook))) (save-excursion (funcall cvs-dired-action (file-name-directory dir) t t))))) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcvs" '("cvs-" "defun-cvs-mode"))) @@ -25433,7 +24768,7 @@ Turning on Perl mode runs the normal hook `perl-mode-hook'. \(fn)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "perl-mode" '("perl-" "mark-perl-function" "indent-perl-exp"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "perl-mode" '("indent-perl-exp" "mark-perl-function" "perl-"))) ;;;*** @@ -25509,9 +24844,7 @@ by supplying an argument. Entry to this mode calls the value of `picture-mode-hook' if non-nil. Note that Picture mode commands will work outside of Picture mode, but -they are not by default assigned to keys. - -\(fn)" t nil) +they are not by default assigned to keys." t nil) (defalias 'edit-picture 'picture-mode) @@ -25519,6 +24852,13 @@ they are not by default assigned to keys. ;;;*** +;;;### (autoloads nil "pinyin" "language/pinyin.el" (0 0 0 0)) +;;; Generated autoloads from language/pinyin.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pinyin" '("pinyin-character-map"))) + +;;;*** + ;;;### (autoloads nil "pixel-scroll" "pixel-scroll.el" (0 0 0 0)) ;;; Generated autoloads from pixel-scroll.el @@ -25534,9 +24874,11 @@ or call the function `pixel-scroll-mode'.") (autoload 'pixel-scroll-mode "pixel-scroll" "\ A minor mode to scroll text pixel-by-pixel. -With a prefix argument ARG, enable Pixel Scroll mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable Pixel Scroll mode -if ARG is omitted or nil. + +If called interactively, enable Pixel-Scroll mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. \(fn &optional ARG)" t nil) @@ -25584,9 +24926,7 @@ Move left and right bats and try to bounce the ball to your opponent. pong-mode keybindings:\\<pong-mode-map> -\\{pong-mode-map} - -\(fn)" t nil) +\\{pong-mode-map}" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pong" '("pong-"))) @@ -25616,9 +24956,7 @@ to make output that `read' can handle, whenever this is possible. \(fn OBJECT)" nil nil) (autoload 'pp-buffer "pp" "\ -Prettify the current buffer with printed representation of a Lisp object. - -\(fn)" nil nil) +Prettify the current buffer with printed representation of a Lisp object." nil nil) (autoload 'pp "pp" "\ Output the pretty-printed representation of OBJECT, any Lisp object. @@ -25880,16 +25218,12 @@ See also documentation for `pr-list-directory'. (autoload 'pr-printify-buffer "printing" "\ Replace nonprinting characters in buffer with printable representations. The printable representations use ^ (for ASCII control characters) or hex. -The characters tab, linefeed, space, return and formfeed are not affected. - -\(fn)" t nil) +The characters tab, linefeed, space, return and formfeed are not affected." t nil) (autoload 'pr-printify-region "printing" "\ Replace nonprinting characters in region with printable representations. The printable representations use ^ (for ASCII control characters) or hex. -The characters tab, linefeed, space, return and formfeed are not affected. - -\(fn)" t nil) +The characters tab, linefeed, space, return and formfeed are not affected." t nil) (autoload 'pr-txt-directory "printing" "\ Print directory using text printer. @@ -25905,19 +25239,13 @@ See also documentation for `pr-list-directory'. \(fn &optional DIR FILE-REGEXP)" t nil) (autoload 'pr-txt-buffer "printing" "\ -Print buffer using text printer. - -\(fn)" t nil) +Print buffer using text printer." t nil) (autoload 'pr-txt-region "printing" "\ -Print region using text printer. - -\(fn)" t nil) +Print region using text printer." t nil) (autoload 'pr-txt-mode "printing" "\ -Print major mode using text printer. - -\(fn)" t nil) +Print major mode using text printer." t nil) (autoload 'pr-despool-preview "printing" "\ Preview spooled PostScript. @@ -26015,9 +25343,7 @@ file name. \(fn N-UP IFILENAME &optional OFILENAME)" t nil) (autoload 'pr-toggle-file-duplex "printing" "\ -Toggle duplex for PostScript file. - -\(fn)" t nil) +Toggle duplex for PostScript file." t nil) (autoload 'pr-toggle-file-tumble "printing" "\ Toggle tumble for PostScript file. @@ -26025,34 +25351,22 @@ Toggle tumble for PostScript file. If tumble is off, produces a printing suitable for binding on the left or right. If tumble is on, produces a printing suitable for binding at the top or -bottom. - -\(fn)" t nil) +bottom." t nil) (autoload 'pr-toggle-file-landscape "printing" "\ -Toggle landscape for PostScript file. - -\(fn)" t nil) +Toggle landscape for PostScript file." t nil) (autoload 'pr-toggle-ghostscript "printing" "\ -Toggle printing using ghostscript. - -\(fn)" t nil) +Toggle printing using ghostscript." t nil) (autoload 'pr-toggle-faces "printing" "\ -Toggle printing with faces. - -\(fn)" t nil) +Toggle printing with faces." t nil) (autoload 'pr-toggle-spool "printing" "\ -Toggle spooling. - -\(fn)" t nil) +Toggle spooling." t nil) (autoload 'pr-toggle-duplex "printing" "\ -Toggle duplex. - -\(fn)" t nil) +Toggle duplex." t nil) (autoload 'pr-toggle-tumble "printing" "\ Toggle tumble. @@ -26060,54 +25374,34 @@ Toggle tumble. If tumble is off, produces a printing suitable for binding on the left or right. If tumble is on, produces a printing suitable for binding at the top or -bottom. - -\(fn)" t nil) +bottom." t nil) (autoload 'pr-toggle-landscape "printing" "\ -Toggle landscape. - -\(fn)" t nil) +Toggle landscape." t nil) (autoload 'pr-toggle-upside-down "printing" "\ -Toggle upside-down. - -\(fn)" t nil) +Toggle upside-down." t nil) (autoload 'pr-toggle-line "printing" "\ -Toggle line number. - -\(fn)" t nil) +Toggle line number." t nil) (autoload 'pr-toggle-zebra "printing" "\ -Toggle zebra stripes. - -\(fn)" t nil) +Toggle zebra stripes." t nil) (autoload 'pr-toggle-header "printing" "\ -Toggle printing header. - -\(fn)" t nil) +Toggle printing header." t nil) (autoload 'pr-toggle-header-frame "printing" "\ -Toggle printing header frame. - -\(fn)" t nil) +Toggle printing header frame." t nil) (autoload 'pr-toggle-lock "printing" "\ -Toggle menu lock. - -\(fn)" t nil) +Toggle menu lock." t nil) (autoload 'pr-toggle-region "printing" "\ -Toggle whether the region is automagically detected. - -\(fn)" t nil) +Toggle whether the region is automagically detected." t nil) (autoload 'pr-toggle-mode "printing" "\ -Toggle auto mode. - -\(fn)" t nil) +Toggle auto mode." t nil) (autoload 'pr-customize "printing" "\ Customization of the `printing' group. @@ -26125,19 +25419,13 @@ Help for the printing package. \(fn &rest IGNORE)" t nil) (autoload 'pr-ps-name "printing" "\ -Interactively select a PostScript printer. - -\(fn)" t nil) +Interactively select a PostScript printer." t nil) (autoload 'pr-txt-name "printing" "\ -Interactively select a text printer. - -\(fn)" t nil) +Interactively select a text printer." t nil) (autoload 'pr-ps-utility "printing" "\ -Interactively select a PostScript utility. - -\(fn)" t nil) +Interactively select a PostScript utility." t nil) (autoload 'pr-show-ps-setup "printing" "\ Show current ps-print settings. @@ -26243,7 +25531,7 @@ are both set to t. \(fn &optional SELECT-PRINTER)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "printing" '("pr-" "lpr-setup"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "printing" '("lpr-setup" "pr-"))) ;;;*** @@ -26330,16 +25618,26 @@ pattern to search for. (autoload 'project-find-file "project" "\ Visit a file (with completion) in the current project's roots. The completion default is the filename at point, if one is -recognized. - -\(fn)" t nil) +recognized." t nil) (autoload 'project-or-external-find-file "project" "\ Visit a file (with completion) in the current project's roots or external roots. The completion default is the filename at point, if one is -recognized. +recognized." t nil) -\(fn)" t nil) +(autoload 'project-search "project" "\ +Search for REGEXP in all the files of the project. +Stops when a match is found. +To continue searching for next match, use command \\[fileloop-continue]. + +\(fn REGEXP)" t nil) + +(autoload 'project-query-replace-regexp "project" "\ +Search for REGEXP in all the files of the project. +Stops when a match is found. +To continue searching for next match, use command \\[fileloop-continue]. + +\(fn FROM TO)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "project" '("project-"))) @@ -26376,7 +25674,7 @@ With prefix argument ARG, restart the Prolog process if running before. \(fn ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "prolog" '("prolog-" "mercury-mode-map"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "prolog" '("mercury-mode-map" "prolog-"))) ;;;*** @@ -26393,6 +25691,13 @@ The default value is (\"/usr/local/share/emacs/fonts/bdf\").") ;;;*** +;;;### (autoloads nil "ps-def" "ps-def.el" (0 0 0 0)) +;;; Generated autoloads from ps-def.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ps-def" '("ps-"))) + +;;;*** + ;;;### (autoloads nil "ps-mode" "progmodes/ps-mode.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/ps-mode.el (push (purecopy '(ps-mode 1 1 9)) package--builtin-versions) @@ -26466,7 +25771,7 @@ example `letter', `legal' or `a4'.") (custom-autoload 'ps-paper-type "ps-print" t) -(defvar ps-print-color-p (or (fboundp 'x-color-values) (fboundp 'color-instance-rgb-components)) "\ +(defvar ps-print-color-p (fboundp 'x-color-values) "\ Specify how buffer's text color is printed. Valid values are: @@ -26483,9 +25788,7 @@ Any other value is treated as t.") (custom-autoload 'ps-print-color-p "ps-print" t) (autoload 'ps-print-customize "ps-print" "\ -Customization of ps-print group. - -\(fn)" t nil) +Customization of ps-print group." t nil) (autoload 'ps-print-buffer "ps-print" "\ Generate and print a PostScript image of the buffer. @@ -26527,9 +25830,7 @@ Generate and spool a PostScript image of the buffer. Like `ps-print-buffer' except that the PostScript image is saved in a local buffer to be sent to the printer later. -Use the command `ps-despool' to send the spooled images to the printer. - -\(fn)" t nil) +Use the command `ps-despool' to send the spooled images to the printer." t nil) (autoload 'ps-spool-buffer-with-faces "ps-print" "\ Generate and spool a PostScript image of the buffer. @@ -26537,9 +25838,7 @@ Like the command `ps-spool-buffer', but includes font, color, and underline information in the generated image. This command works only if you are using a window system, so it has a way to determine color values. -Use the command `ps-despool' to send the spooled images to the printer. - -\(fn)" t nil) +Use the command `ps-despool' to send the spooled images to the printer." t nil) (autoload 'ps-spool-region "ps-print" "\ Generate a PostScript image of the region and spool locally. @@ -26576,9 +25875,7 @@ image in a file with that name. Display the correspondence between a line length and a font size. Done using the current ps-print setup. Try: pr -t file | awk \\='{printf \"%3d %s -\", length($0), $0}\\=' | sort -r | head - -\(fn)" t nil) +\", length($0), $0}\\=' | sort -r | head" t nil) (autoload 'ps-nb-pages-buffer "ps-print" "\ Display number of pages to print this buffer, for various font heights. @@ -26593,9 +25890,7 @@ The table depends on the current ps-print setup. \(fn NB-LINES)" t nil) (autoload 'ps-setup "ps-print" "\ -Return the current PostScript-generation setup. - -\(fn)" nil nil) +Return the current PostScript-generation setup." nil nil) (autoload 'ps-extend-face-list "ps-print" "\ Extend face in ALIST-SYM. @@ -26684,7 +25979,7 @@ Optional argument FACE specifies the face to do the highlighting. ;;;### (autoloads nil "python" "progmodes/python.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/python.el -(push (purecopy '(python 0 25 2)) package--builtin-versions) +(push (purecopy '(python 0 26 1)) package--builtin-versions) (add-to-list 'auto-mode-alist (cons (purecopy "\\.py[iw]?\\'") 'python-mode)) @@ -26717,7 +26012,7 @@ Major mode for editing Python files. \(fn)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "python" '("python-" "run-python-internal" "inferior-python-mode"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "python" '("inferior-python-mode" "python-" "run-python-internal"))) ;;;*** @@ -26746,9 +26041,7 @@ them into characters should be done separately. ;;; Generated autoloads from international/quail.el (autoload 'quail-title "quail" "\ -Return the title of the current Quail package. - -\(fn)" nil nil) +Return the title of the current Quail package." nil nil) (autoload 'quail-use-package "quail" "\ Start using Quail package PACKAGE-NAME. @@ -26993,7 +26286,7 @@ HELP-TEXT is a text set in `hangul-input-method-help-text'. \(fn INPUT-METHOD FUNC HELP-TEXT &rest ARGS)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/hangul" '("hangul" "alphabetp" "notzerop"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/hangul" '("alphabetp" "hangul" "notzerop"))) ;;;*** @@ -27084,7 +26377,7 @@ While this input method is active, the variable ;;;### (autoloads nil "quickurl" "net/quickurl.el" (0 0 0 0)) ;;; Generated autoloads from net/quickurl.el -(defconst quickurl-reread-hook-postfix "\n;; Local Variables:\n;; eval: (progn (require 'quickurl) (add-hook 'local-write-file-hooks (lambda () (quickurl-read) nil)))\n;; End:\n" "\ +(defconst quickurl-reread-hook-postfix "\n;; Local Variables:\n;; eval: (progn (require 'quickurl) (add-hook 'write-file-functions (lambda () (quickurl-read) nil) nil t))\n;; End:\n" "\ Example `quickurl-postfix' text that adds a local variable to the `quickurl-url-file' so that if you edit it by hand it will ensure that `quickurl-urls' is updated with the new URL list. @@ -27132,9 +26425,7 @@ Browse the URL, with `completing-read' prompt, associated with LOOKUP. \(fn LOOKUP)" t nil) (autoload 'quickurl-edit-urls "quickurl" "\ -Pull `quickurl-url-file' into a buffer for hand editing. - -\(fn)" t nil) +Pull `quickurl-url-file' into a buffer for hand editing." t nil) (autoload 'quickurl-list-mode "quickurl" "\ A mode for browsing the quickurl URL list. @@ -27146,9 +26437,7 @@ The key bindings for `quickurl-list-mode' are: \(fn)" t nil) (autoload 'quickurl-list "quickurl" "\ -Display `quickurl-list' as a formatted list using `quickurl-list-mode'. - -\(fn)" t nil) +Display `quickurl-list' as a formatted list using `quickurl-list-mode'." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quickurl" '("quickurl-"))) @@ -27193,13 +26482,15 @@ or call the function `rcirc-track-minor-mode'.") (autoload 'rcirc-track-minor-mode "rcirc" "\ Global minor mode for tracking activity in rcirc buffers. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. + +If called interactively, enable Rcirc-Track minor mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rcirc" '("rcirc-" "defun-rcirc-command" "set-rcirc-" "with-rcirc-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rcirc" '("defun-rcirc-command" "rcirc-" "set-rcirc-" "with-rcirc-"))) ;;;*** @@ -27216,11 +26507,9 @@ the regexp builder. It displays a buffer named \"*RE-Builder*\" in another window, initially containing an empty regexp. As you edit the regexp in the \"*RE-Builder*\" buffer, the -matching parts of the target buffer will be highlighted. +matching parts of the target buffer will be highlighted." t nil) -\(fn)" t nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "re-builder" '("reb-" "re-builder-unload-function"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "re-builder" '("re-builder-unload-function" "reb-"))) ;;;*** @@ -27239,9 +26528,11 @@ or call the function `recentf-mode'.") (autoload 'recentf-mode "recentf" "\ Toggle \"Open Recent\" menu (Recentf mode). -With a prefix argument ARG, enable Recentf mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -Recentf mode if ARG is omitted or nil. + +If called interactively, enable Recentf mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. When Recentf mode is enabled, a \"Open Recent\" submenu is displayed in the \"File\" menu, containing a list of files that @@ -27307,9 +26598,7 @@ Copy the region-rectangle and save it as the last killed one. \(fn START END)" t nil) (autoload 'yank-rectangle "rect" "\ -Yank the last killed rectangle with upper left corner at point. - -\(fn)" t nil) +Yank the last killed rectangle with upper left corner at point." t nil) (autoload 'insert-rectangle "rect" "\ Insert text of RECTANGLE with upper left corner at point. @@ -27391,11 +26680,17 @@ with a prefix argument, prompt for START-AT and FORMAT. (autoload 'rectangle-mark-mode "rect" "\ Toggle the region as rectangular. + +If called interactively, enable Rectangle-Mark mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + Activates the region if needed. Only lasts until the region is deactivated. \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rect" '("rectangle-" "clear-rectangle-line" "spaces-string" "string-rectangle-" "delete-" "ope" "killed-rectangle" "extract-rectangle-" "apply-on-rectangle"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rect" '("apply-on-rectangle" "clear-rectangle-line" "delete-" "extract-rectangle-" "killed-rectangle" "ope" "rectangle-" "spaces-string" "string-rectangle-"))) ;;;*** @@ -27418,9 +26713,11 @@ Activates the region if needed. Only lasts until the region is deactivated. (autoload 'refill-mode "refill" "\ Toggle automatic refilling (Refill mode). -With a prefix argument ARG, enable Refill mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Refill mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Refill mode is a buffer-local minor mode. When enabled, the current paragraph is refilled as you edit. Self-inserting @@ -27443,13 +26740,16 @@ For true \"word wrap\" behavior, use `visual-line-mode' instead. (autoload 'reftex-index-phrases-mode "reftex-index" nil t) (autoload 'turn-on-reftex "reftex" "\ -Turn on RefTeX mode. - -\(fn)" nil nil) +Turn on RefTeX mode." nil nil) (autoload 'reftex-mode "reftex" "\ Minor mode with distinct support for \\label, \\ref and \\cite in LaTeX. +If called interactively, enable Reftex mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + \\<reftex-mode-map>A Table of Contents of the entire (multifile) document with browsing capabilities is available with `\\[reftex-toc]'. @@ -27482,9 +26782,7 @@ on the menu bar. (autoload 'reftex-reset-scanning-information "reftex" "\ Reset the symbols containing information from buffer scanning. -This enforces rescanning the buffer on next use. - -\(fn)" nil nil) +This enforces rescanning the buffer on next use." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "reftex" '("reftex-"))) @@ -27580,9 +26878,12 @@ This enforces rescanning the buffer on next use. (autoload 'regexp-opt "regexp-opt" "\ Return a regexp to match a string in the list STRINGS. -Each string should be unique in STRINGS and should not contain -any regexps, quoted or not. Optional PAREN specifies how the -returned regexp is surrounded by grouping constructs. +Each member of STRINGS is treated as a fixed string, not as a regexp. +Optional PAREN specifies how the returned regexp is surrounded by +grouping constructs. + +If STRINGS is the empty list, the return value is a regexp that +never matches anything. The optional argument PAREN can be any of the following: @@ -27605,8 +26906,14 @@ nil necessary to ensure that a postfix operator appended to it will apply to the whole expression. -The resulting regexp is equivalent to but usually more efficient -than that of a simplified version: +The optional argument KEEP-ORDER, if nil or omitted, allows the +returned regexp to match the strings in any order. If non-nil, +the match is guaranteed to be performed in the order given, as if +the strings were made into a regexp by joining them with the +`\\|' operator. + +Up to reordering, the resulting regexp is equivalent to but +usually more efficient than that of a simplified version: (defun simplified-regexp-opt (strings &optional paren) (let ((parens @@ -27619,7 +26926,7 @@ than that of a simplified version: (mapconcat \\='regexp-quote strings \"\\\\|\") (cdr parens)))) -\(fn STRINGS &optional PAREN)" nil nil) +\(fn STRINGS &optional PAREN KEEP-ORDER)" nil nil) (autoload 'regexp-opt-depth "regexp-opt" "\ Return the depth of REGEXP. @@ -27667,14 +26974,10 @@ Call `remember' in another frame. (autoload 'remember-clipboard "remember" "\ Remember the contents of the current clipboard. -Most useful for remembering things from other applications. - -\(fn)" t nil) +Most useful for remembering things from other applications." t nil) (autoload 'remember-diary-extract-entries "remember" "\ -Extract diary entries from the region. - -\(fn)" nil nil) +Extract diary entries from the region." nil nil) (autoload 'remember-notes "remember" "\ Return the notes buffer, creating it if needed, and maybe switch to it. @@ -27794,9 +27097,11 @@ first comment line visible (if point is in a comment). (autoload 'reveal-mode "reveal" "\ Toggle uncloaking of invisible text near point (Reveal mode). -With a prefix argument ARG, enable Reveal mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -Reveal mode if ARG is omitted or nil. + +If called interactively, enable Reveal mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Reveal mode is a buffer-local minor mode. When enabled, it reveals invisible text around point. @@ -27817,9 +27122,10 @@ or call the function `global-reveal-mode'.") Toggle Reveal mode in all buffers (Global Reveal mode). Reveal mode renders invisible text around point visible again. -With a prefix argument ARG, enable Global Reveal mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. +If called interactively, enable Global Reveal mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. \(fn &optional ARG)" t nil) @@ -28121,9 +27427,7 @@ Instead, these commands are available: \\[rmail-summary-by-recipients] Summarize only messages with particular recipient(s). \\[rmail-summary-by-regexp] Summarize only messages with particular regexp(s). \\[rmail-summary-by-topic] Summarize only messages with subject line regexp(s). -\\[rmail-toggle-header] Toggle display of complete header. - -\(fn)" t nil) +\\[rmail-toggle-header] Toggle display of complete header." t nil) (autoload 'rmail-input "rmail" "\ Run Rmail on file FILENAME. @@ -28135,7 +27439,7 @@ Set PASSWORD to be used for retrieving mail from a POP or IMAP server. \(fn PASSWORD)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rmail" '("rmail-" "mail-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rmail" '("mail-" "rmail-"))) ;;;*** @@ -28192,9 +27496,15 @@ buffer, updates it accordingly. This command always outputs the complete message header, even if the header display is currently pruned. +If `rmail-output-reset-deleted-flag' is non-nil, the message's +deleted flag is reset in the message appended to the destination +file. Otherwise, the appended message will remain marked as +deleted if it was deleted before invoking this command. + Optional prefix argument COUNT (default 1) says to output that many consecutive messages, starting with the current one (ignoring -deleted messages). If `rmail-delete-after-output' is non-nil, deletes +deleted messages, unless `rmail-output-reset-deleted-flag' is +non-nil). If `rmail-delete-after-output' is non-nil, deletes messages after output. The optional third argument NOATTRIBUTE, if non-nil, says not to @@ -28340,9 +27650,7 @@ Return a pattern. (autoload 'rng-nxml-mode-init "rng-nxml" "\ Initialize `nxml-mode' to take advantage of `rng-validate-mode'. This is typically called from `nxml-mode-hook'. -Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil. - -\(fn)" t nil) +Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rng-nxml" '("rng-"))) @@ -28500,14 +27808,10 @@ To terminate the ROT13 display, delete that window. As long as that window is not deleted, any buffer displayed in it will become instantly encoded in ROT13. -See also `toggle-rot13-mode'. - -\(fn)" t nil) +See also `toggle-rot13-mode'." t nil) (autoload 'toggle-rot13-mode "rot13" "\ -Toggle the use of ROT13 encoding for the current window. - -\(fn)" t nil) +Toggle the use of ROT13 encoding for the current window." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rot13" '("rot13-"))) @@ -28531,9 +27835,11 @@ highlighting. (autoload 'rst-minor-mode "rst" "\ Toggle ReST minor mode. -With a prefix argument ARG, enable ReST minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Rst minor mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. When ReST minor mode is enabled, the ReST mode keybindings are installed on top of the major mode bindings. Use this @@ -28580,9 +27886,11 @@ Use the command `ruler-mode' to change this variable.") (autoload 'ruler-mode "ruler-mode" "\ Toggle display of ruler in header line (Ruler mode). -With a prefix argument ARG, enable Ruler mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. + +If called interactively, enable Ruler mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. \(fn &optional ARG)" t nil) @@ -28598,6 +27906,10 @@ Parse and produce code for regular expression FORM. FORM is a regular expression in sexp form. NO-GROUP non-nil means don't put shy groups around the result. +In contrast to the `rx' macro, subforms `literal' and `regexp' +will not accept non-string arguments, i.e., (literal STRING) +becomes just a more verbose version of STRING. + \(fn FORM &optional NO-GROUP)" nil nil) (autoload 'rx "rx" "\ @@ -28605,8 +27917,12 @@ Translate regular expressions REGEXPS in sexp form to a regexp string. REGEXPS is a non-empty sequence of forms of the sort listed below. Note that `rx' is a Lisp macro; when used in a Lisp program being -compiled, the translation is performed by the compiler. -See `rx-to-string' for how to do such a translation at run-time. +compiled, the translation is performed by the compiler. The +`literal' and `regexp' forms accept subforms that will evaluate +to strings, in addition to constant strings. If REGEXPS include +such forms, then the result is an expression which returns a +regexp string, rather than a regexp string directly. See +`rx-to-string' for performing translation completely at run time. The following are valid subforms of regular expressions in sexp notation. @@ -28629,6 +27945,7 @@ CHAR matches any character in SET .... SET may be a character or string. Ranges of characters can be specified as `A-Z' in strings. Ranges may also be specified as conses like `(?A . ?Z)'. + Reversed ranges like `Z-A' and `(?Z . ?A)' are not permitted. SET may also be the name of a character class: `digit', `control', `hex-digit', `blank', `graph', `print', `alnum', @@ -28689,7 +28006,7 @@ CHAR matches 0 through 9. `control', `cntrl' - matches ASCII control characters. + matches any character whose code is in the range 0-31. `hex-digit', `hex', `xdigit' matches 0 through 9, a through f and A through F. @@ -28776,7 +28093,9 @@ CHAR matches a character with category CATEGORY. CATEGORY must be either a character to use for C, or one of the following symbols. - `consonant' (\\c0 in string notation) + `space-for-indent' (\\c\\s in string notation) + `base' (\\c.) + `consonant' (\\c0) `base-vowel' (\\c1) `upper-diacritical-mark' (\\c2) `lower-diacritical-mark' (\\c3) @@ -28794,7 +28113,9 @@ CHAR `japanese-hiragana-two-byte' (\\cH) `indian-two-byte' (\\cI) `japanese-katakana-two-byte' (\\cK) + `strong-left-to-right' (\\cL) `korean-hangul-two-byte' (\\cN) + `strong-right-to-left' (\\cR) `cyrillic-two-byte' (\\cY) `combining-diacritic' (\\c^) `ascii' (\\ca) @@ -28824,6 +28145,7 @@ CHAR `(seq SEXP1 SEXP2 ...)' `(sequence SEXP1 SEXP2 ...)' matches what SEXP1 matches, followed by what SEXP2 matches, etc. + Without arguments, matches the empty string. `(submatch SEXP1 SEXP2 ...)' `(group SEXP1 SEXP2 ...)' @@ -28839,7 +28161,7 @@ CHAR `(| SEXP1 SEXP2 ...)' matches anything that matches SEXP1 or SEXP2, etc. If all args are strings, use `regexp-opt' to optimize the resulting - regular expression. + regular expression. Without arguments, never matches anything. `(minimal-match SEXP)' produce a non-greedy regexp for SEXP. Normally, regexps matching @@ -28900,12 +28222,19 @@ enclosed in `(and ...)'. `(backref N)' matches what was matched previously by submatch N. +`(literal STRING-EXPR)' + matches STRING-EXPR literally, where STRING-EXPR is any lisp + expression that evaluates to a string. + +`(regexp REGEXP-EXPR)' + include REGEXP-EXPR in string notation in the result, where + REGEXP-EXPR is any lisp expression that evaluates to a + string containing a valid regexp. + `(eval FORM)' evaluate FORM and insert result. If result is a string, - `regexp-quote' it. - -`(regexp REGEXP)' - include REGEXP in string notation in the result. + `regexp-quote' it. Note that FORM is evaluated during + macroexpansion. \(fn &rest REGEXPS)" nil t) @@ -28966,9 +28295,11 @@ or call the function `savehist-mode'.") (autoload 'savehist-mode "savehist" "\ Toggle saving of minibuffer history (Savehist mode). -With a prefix argument ARG, enable Savehist mode if ARG is -positive, and disable it otherwise. If called from Lisp, -also enable the mode if ARG is omitted or nil. + +If called interactively, enable Savehist mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. When Savehist mode is enabled, minibuffer history is saved to `savehist-file' periodically and when exiting Emacs. When @@ -29020,6 +28351,11 @@ 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. +If called interactively, enable Save-Place mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + \(fn &optional ARG)" t nil) (autoload 'save-place-local-mode "saveplace" "\ @@ -29028,8 +28364,10 @@ 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. -If called with a prefix arg, the mode is enabled if and only if -the argument is positive. +If called interactively, enable Save-Place-Local mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. To save places automatically in all files, put this in your init file: @@ -29038,14 +28376,14 @@ file: \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "saveplace" '("save-place" "load-save-place-alist-from-file"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "saveplace" '("load-save-place-alist-from-file" "save-place"))) ;;;*** ;;;### (autoloads nil "sb-image" "sb-image.el" (0 0 0 0)) ;;; Generated autoloads from sb-image.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sb-image" '("speedbar-" "defimage-speedbar"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sb-image" '("defimage-speedbar" "speedbar-"))) ;;;*** @@ -29086,7 +28424,7 @@ that variable's value is a string. \(fn)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "scheme" '("scheme-" "dsssl-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "scheme" '("dsssl-" "scheme-"))) ;;;*** @@ -29120,9 +28458,11 @@ or call the function `scroll-all-mode'.") (autoload 'scroll-all-mode "scroll-all" "\ Toggle shared scrolling in same-frame windows (Scroll-All mode). -With a prefix argument ARG, enable Scroll-All mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Scroll-All mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. When Scroll-All mode is enabled, scrolling commands invoked in one window apply to all visible windows in the same frame. @@ -29136,7 +28476,7 @@ one window apply to all visible windows in the same frame. ;;;### (autoloads nil "scroll-bar" "scroll-bar.el" (0 0 0 0)) ;;; Generated autoloads from scroll-bar.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "scroll-bar" '("set-scroll-bar-mode" "scroll-bar-" "toggle-" "horizontal-scroll-bar" "get-scroll-bar-mode" "previous-scroll-bar-mode"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "scroll-bar" '("get-scroll-bar-mode" "horizontal-scroll-bar" "previous-scroll-bar-mode" "scroll-bar-" "set-scroll-bar-mode" "toggle-"))) ;;;*** @@ -29145,12 +28485,16 @@ 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. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. 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. + +If called interactively, enable Scroll-Lock mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + +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. \(fn &optional ARG)" t nil) @@ -29209,9 +28553,11 @@ or call the function `semantic-mode'.") (autoload 'semantic-mode "semantic" "\ Toggle parser features (Semantic mode). -With a prefix argument ARG, enable Semantic mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -Semantic mode if ARG is omitted or nil. + +If called interactively, enable Semantic mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. In Semantic mode, Emacs parses the buffers you visit for their semantic content. This information is used by a variety of @@ -29223,7 +28569,7 @@ Semantic mode. \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic" '("semantic-" "bovinate"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic" '("bovinate" "semantic-"))) ;;;*** @@ -29279,7 +28625,7 @@ Semantic mode. ;;;;;; "cedet/semantic/bovine/c.el" (0 0 0 0)) ;;; Generated autoloads from cedet/semantic/bovine/c.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/c" '("semantic" "c++-mode" "c-mode"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/c" '("c++-mode" "c-mode" "semantic"))) ;;;*** @@ -29295,7 +28641,7 @@ Semantic mode. ;;;;;; "cedet/semantic/bovine/el.el" (0 0 0 0)) ;;; Generated autoloads from cedet/semantic/bovine/el.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/el" '("lisp-mode" "emacs-lisp-mode" "semantic-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/el" '("emacs-lisp-mode" "lisp-mode" "semantic-"))) ;;;*** @@ -29324,7 +28670,7 @@ Major mode for editing Bovine grammars. ;;;;;; "cedet/semantic/bovine/make.el" (0 0 0 0)) ;;; Generated autoloads from cedet/semantic/bovine/make.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/make" '("semantic-" "makefile-mode"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/make" '("makefile-mode" "semantic-"))) ;;;*** @@ -29380,7 +28726,7 @@ Major mode for editing Bovine grammars. ;;;;;; (0 0 0 0)) ;;; Generated autoloads from cedet/semantic/db-ebrowse.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-ebrowse" '("semanticdb-" "c++-mode"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-ebrowse" '("c++-mode" "semanticdb-"))) ;;;*** @@ -29388,7 +28734,7 @@ Major mode for editing Bovine grammars. ;;;;;; (0 0 0 0)) ;;; Generated autoloads from cedet/semantic/db-el.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-el" '("semanticdb-" "emacs-lisp-mode"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-el" '("emacs-lisp-mode" "semanticdb-"))) ;;;*** @@ -29420,7 +28766,7 @@ Major mode for editing Bovine grammars. ;;;;;; (0 0 0 0)) ;;; Generated autoloads from cedet/semantic/db-javascript.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-javascript" '("semanticdb-" "javascript-mode"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-javascript" '("javascript-mode" "semanticdb-"))) ;;;*** @@ -29476,7 +28822,7 @@ Major mode for editing Bovine grammars. ;;;;;; "cedet/semantic/decorate/mode.el" (0 0 0 0)) ;;; Generated autoloads from cedet/semantic/decorate/mode.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/decorate/mode" '("semantic-" "define-semantic-decoration-style"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/decorate/mode" '("define-semantic-decoration-style" "semantic-"))) ;;;*** @@ -29484,7 +28830,7 @@ Major mode for editing Bovine grammars. ;;;;;; "cedet/semantic/dep.el" (0 0 0 0)) ;;; Generated autoloads from cedet/semantic/dep.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/dep" '("semantic-" "defcustom-mode-local-semantic-dependency-system-include-path"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/dep" '("defcustom-mode-local-semantic-dependency-system-include-path" "semantic-"))) ;;;*** @@ -29580,7 +28926,7 @@ Major mode for editing Bovine grammars. ;;;;;; "cedet/semantic/idle.el" (0 0 0 0)) ;;; Generated autoloads from cedet/semantic/idle.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/idle" '("semantic-" "global-semantic-idle-summary-mode" "define-semantic-idle-service"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/idle" '("define-semantic-idle-service" "global-semantic-idle-summary-mode" "semantic-"))) ;;;*** @@ -29604,7 +28950,7 @@ Major mode for editing Bovine grammars. ;;;;;; "cedet/semantic/lex.el" (0 0 0 0)) ;;; Generated autoloads from cedet/semantic/lex.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/lex" '("semantic-" "define-lex"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/lex" '("define-lex" "semantic-"))) ;;;*** @@ -29612,7 +28958,7 @@ Major mode for editing Bovine grammars. ;;;;;; "cedet/semantic/lex-spp.el" (0 0 0 0)) ;;; Generated autoloads from cedet/semantic/lex-spp.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/lex-spp" '("semantic-lex-" "define-lex-spp-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/lex-spp" '("define-lex-spp-" "semantic-lex-"))) ;;;*** @@ -29620,7 +28966,7 @@ Major mode for editing Bovine grammars. ;;;;;; "cedet/semantic/mru-bookmark.el" (0 0 0 0)) ;;; Generated autoloads from cedet/semantic/mru-bookmark.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/mru-bookmark" '("semantic-" "global-semantic-mru-bookmark-mode"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/mru-bookmark" '("global-semantic-mru-bookmark-mode" "semantic-"))) ;;;*** @@ -29772,7 +29118,7 @@ Major mode for editing Bovine grammars. ;;;;;; (0 0 0 0)) ;;; Generated autoloads from cedet/semantic/wisent.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent" '("wisent-" "define-wisent-lexer"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent" '("define-wisent-lexer" "wisent-"))) ;;;*** @@ -29817,7 +29163,7 @@ Major mode for editing Wisent grammars. ;;;;;; "cedet/semantic/wisent/python.el" (0 0 0 0)) ;;; Generated autoloads from cedet/semantic/wisent/python.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent/python" '("wisent-python-" "semantic-" "python-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent/python" '("python-" "semantic-" "wisent-python-"))) ;;;*** @@ -29825,14 +29171,14 @@ Major mode for editing Wisent grammars. ;;;;;; (0 0 0 0)) ;;; Generated autoloads from cedet/semantic/wisent/wisent.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent/wisent" '("wisent-" "$region" "$nterm" "$action"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent/wisent" '("$action" "$nterm" "$region" "wisent-"))) ;;;*** ;;;### (autoloads nil "sendmail" "mail/sendmail.el" (0 0 0 0)) ;;; Generated autoloads from mail/sendmail.el -(defvar mail-from-style 'default "\ +(defvar mail-from-style 'angles "\ Specifies how \"From:\" fields look. If nil, they contain just the return address like: @@ -29860,9 +29206,9 @@ variable `feedmail-deduce-envelope-from'.") (custom-autoload 'mail-specify-envelope-from "sendmail" t) (defvar mail-self-blind nil "\ -Non-nil means insert BCC to self in messages to be sent. +Non-nil means insert Bcc to self in messages to be sent. This is done when the message is initialized, -so you can remove or alter the BCC field to override the default.") +so you can remove or alter the Bcc field to override the default.") (custom-autoload 'mail-self-blind "sendmail" t) @@ -29895,7 +29241,7 @@ be a Babyl file.") (custom-autoload 'mail-archive-file-name "sendmail" t) (defvar mail-default-reply-to nil "\ -Address to insert as default Reply-to field of outgoing messages. +Address to insert as default Reply-To field of outgoing messages. If nil, it will be initialized from the REPLYTO environment variable when you first send mail.") @@ -29947,7 +29293,7 @@ instead of no action.") (custom-autoload 'mail-citation-hook "sendmail" t) -(defvar mail-citation-prefix-regexp (purecopy "\\([ ]*\\(\\w\\|[_.]\\)+>+\\|[ ]*[]>|]\\)+") "\ +(defvar mail-citation-prefix-regexp (purecopy "\\([ \11]*\\(\\w\\|[_.]\\)+>+\\|[ \11]*[]>|]\\)+") "\ Regular expression to match a citation prefix plus whitespace. It should match whatever sort of citation prefixes you want to handle, with whitespace before and after; it should also match just whitespace. @@ -29957,6 +29303,7 @@ The default value matches citations like `foo-bar>' plus whitespace.") (defvar mail-signature t "\ Text inserted at end of mail buffer when a message is initialized. +If nil, no signature is inserted. If t, it means to insert the contents of the file `mail-signature-file'. If a string, that string is inserted. (To make a proper signature, the string should begin with \\n\\n-- \\n, @@ -29989,9 +29336,7 @@ before you edit the message, so you can edit or delete the lines.") (autoload 'sendmail-query-once "sendmail" "\ Query for `send-mail-function' and send mail with it. -This also saves the value of `send-mail-function' via Customize. - -\(fn)" nil nil) +This also saves the value of `send-mail-function' via Customize." nil nil) (define-mail-user-agent 'sendmail-user-agent 'sendmail-user-agent-compose 'mail-send-and-exit) @@ -30009,8 +29354,8 @@ Like Text Mode but with these additional commands: Here are commands that move to a header field (and create it if there isn't): \\[mail-to] move to To: \\[mail-subject] move to Subj: - \\[mail-bcc] move to BCC: \\[mail-cc] move to CC: - \\[mail-fcc] move to FCC: \\[mail-reply-to] move to Reply-To: + \\[mail-bcc] move to Bcc: \\[mail-cc] move to Cc: + \\[mail-fcc] move to Fcc: \\[mail-reply-to] move to Reply-To: \\[mail-mail-reply-to] move to Mail-Reply-To: \\[mail-mail-followup-to] move to Mail-Followup-To: \\[mail-text] move to message text. @@ -30063,13 +29408,13 @@ Various special commands starting with C-c are available in sendmail mode to move to message header fields: \\{mail-mode-map} -If `mail-self-blind' is non-nil, a BCC to yourself is inserted +If `mail-self-blind' is non-nil, a Bcc to yourself is inserted when the message is initialized. If `mail-default-reply-to' is non-nil, it should be an address (a string); -a Reply-to: field with that address is inserted. +a Reply-To: field with that address is inserted. -If `mail-archive-file-name' is non-nil, an FCC field with that file name +If `mail-archive-file-name' is non-nil, an Fcc field with that file name is inserted. The normal hook `mail-setup-hook' is run after the message is @@ -30114,7 +29459,7 @@ Like `mail' command, but display mail buffer in another frame. ;;;### (autoloads nil "seq" "emacs-lisp/seq.el" (0 0 0 0)) ;;; Generated autoloads from emacs-lisp/seq.el -(push (purecopy '(seq 2 20)) package--builtin-versions) +(push (purecopy '(seq 2 21)) package--builtin-versions) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "seq" '("seq-"))) @@ -30129,20 +29474,6 @@ Like `mail' command, but display mail buffer in another frame. (put 'server-auth-dir 'risky-local-variable t) -(defvar server-name "server" "\ -The name of the Emacs server, if this Emacs process creates one. -The command `server-start' makes use of this. It should not be -changed while a server is running. -If this is a file name with no leading directories, Emacs will -create a socket file by that name under `server-socket-dir' -if `server-use-tcp' is nil, else under `server-auth-dir'. -If this is an absolute file name, it specifies where the socket -file will be created. To have emacsclient connect to the same -socket, use the \"-s\" switch for local non-TCP sockets, and -the \"-f\" switch otherwise.") - -(custom-autoload 'server-name "server" t) - (autoload 'server-start "server" "\ Allow this Emacs process to be a server for client processes. This starts a server communications subprocess through which client @@ -30184,9 +29515,11 @@ or call the function `server-mode'.") (autoload 'server-mode "server" "\ Toggle Server mode. -With a prefix argument ARG, enable Server mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -Server mode if ARG is omitted or nil. + +If called interactively, enable Server mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Server mode runs a process that accepts commands from the `emacsclient' program. See Info node `Emacs server' and @@ -30245,11 +29578,9 @@ part): \\{ses-mode-print-map} These are active only in the minibuffer, when entering or editing a formula: -\\{ses-mode-edit-map} - -\(fn)" t nil) +\\{ses-mode-edit-map}" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ses" '("ses" "noreturn" "1value"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ses" '("1value" "noreturn" "ses"))) ;;;*** @@ -30457,9 +29788,7 @@ sites in the cluster. Declare a single file to be shared between sites. It may have different filenames on each site. When this file is edited, the new version will be copied to each of the other locations. Sites can be -specific hostnames, or names of clusters (see `shadow-define-cluster'). - -\(fn)" t nil) +specific hostnames, or names of clusters (see `shadow-define-cluster')." t nil) (autoload 'shadow-define-regexp-group "shadowfile" "\ Make each of a group of files be shared between hosts. @@ -30467,14 +29796,10 @@ Prompts for regular expression; files matching this are shared between a list of sites, which are also prompted for. The filenames must be identical on all hosts (if they aren't, use `shadow-define-literal-group' instead of this function). Each site can be either a hostname or the name of a cluster (see -`shadow-define-cluster'). - -\(fn)" t nil) +`shadow-define-cluster')." t nil) (autoload 'shadow-initialize "shadowfile" "\ -Set up file shadowing. - -\(fn)" t nil) +Set up file shadowing." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "shadowfile" '("shadow"))) @@ -30526,7 +29851,7 @@ Otherwise, one argument `-i' is passed to the shell. \(fn &optional BUFFER)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "shell" '("shell-" "dirs" "explicit-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "shell" '("dirs" "explicit-" "shell-"))) ;;;*** @@ -30809,18 +30134,19 @@ buffer names. (autoload 'smerge-mode "smerge-mode" "\ Minor mode to simplify editing output from the diff3 program. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. + +If called interactively, enable Smerge mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + \\{smerge-mode-map} \(fn &optional ARG)" t nil) (autoload 'smerge-start-session "smerge-mode" "\ Turn on `smerge-mode' and move point to first conflict marker. -If no conflict maker is found, turn off `smerge-mode'. - -\(fn)" t nil) +If no conflict maker is found, turn off `smerge-mode'." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "smerge-mode" '("smerge-"))) @@ -30848,7 +30174,7 @@ interactively. If there's no argument, do it at the current buffer. \(fn &optional BUFFER)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "smiley" '("smiley-" "gnus-smiley-file-types"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "smiley" '("gnus-smiley-file-types" "smiley-"))) ;;;*** @@ -30862,15 +30188,10 @@ interactively. If there's no argument, do it at the current buffer. ;;;### (autoloads nil "smtpmail" "mail/smtpmail.el" (0 0 0 0)) ;;; Generated autoloads from mail/smtpmail.el -(autoload 'smtpmail-send-it "smtpmail" "\ - - -\(fn)" nil nil) +(autoload 'smtpmail-send-it "smtpmail" nil nil nil) (autoload 'smtpmail-send-queued-mail "smtpmail" "\ -Send mail that was queued as a result of setting `smtpmail-queue-mail'. - -\(fn)" t nil) +Send mail that was queued as a result of setting `smtpmail-queue-mail'." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "smtpmail" '("smtpmail-"))) @@ -30893,9 +30214,7 @@ Snake mode keybindings: \\[snake-move-left] Makes the snake move left \\[snake-move-right] Makes the snake move right \\[snake-move-up] Makes the snake move up -\\[snake-move-down] Makes the snake move down - -\(fn)" t nil) +\\[snake-move-down] Makes the snake move down" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "snake" '("snake-"))) @@ -30912,9 +30231,7 @@ Comments start with -- and end with newline or another --. Delete converts tabs to spaces as it moves back. \\{snmp-mode-map} Turning on snmp-mode runs the hooks in `snmp-common-mode-hook', then -`snmp-mode-hook'. - -\(fn)" t nil) +`snmp-mode-hook'." t nil) (autoload 'snmpv2-mode "snmp-mode" "\ Major mode for editing SNMPv2 MIBs. @@ -30924,9 +30241,7 @@ Comments start with -- and end with newline or another --. Delete converts tabs to spaces as it moves back. \\{snmp-mode-map} Turning on snmp-mode runs the hooks in `snmp-common-mode-hook', -then `snmpv2-mode-hook'. - -\(fn)" t nil) +then `snmpv2-mode-hook'." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "snmp-mode" '("snmp"))) @@ -30934,7 +30249,7 @@ then `snmpv2-mode-hook'. ;;;### (autoloads nil "soap-client" "net/soap-client.el" (0 0 0 0)) ;;; Generated autoloads from net/soap-client.el -(push (purecopy '(soap-client 3 1 4)) package--builtin-versions) +(push (purecopy '(soap-client 3 1 5)) package--builtin-versions) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "soap-client" '("soap-"))) @@ -30968,7 +30283,7 @@ This function is suitable for execution in an init file. \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "solar" '("solar-" "diary-sunrise-sunset" "calendar-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "solar" '("calendar-" "diary-sunrise-sunset" "solar-"))) ;;;*** @@ -31279,16 +30594,12 @@ Customize `spam-report-url-ping-function' to use this function. Add spam-report support to the Agent. Spam reports will be queued with \\[spam-report-url-to-file] when the Agent is unplugged, and will be submitted in a batch when the -Agent is plugged. - -\(fn)" t nil) +Agent is plugged." t nil) (autoload 'spam-report-deagentize "spam-report" "\ Remove spam-report support from the Agent. Spam reports will be queued with the method used when -\\[spam-report-agentize] was run. - -\(fn)" t nil) +\\[spam-report-agentize] was run." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "spam-report" '("spam-report-"))) @@ -31326,9 +30637,7 @@ supported at a time. (autoload 'speedbar-get-focus "speedbar" "\ Change frame focus to or from the speedbar frame. If the selected frame is not speedbar, then speedbar frame is -selected. If the speedbar frame is active, then select the attached frame. - -\(fn)" t nil) +selected. If the speedbar frame is active, then select the attached frame." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "speedbar" '("speedbar-"))) @@ -31338,14 +30647,10 @@ selected. If the speedbar frame is active, then select the attached frame. ;;; Generated autoloads from play/spook.el (autoload 'spook "spook" "\ -Adds that special touch of class to your outgoing mail. - -\(fn)" t nil) +Adds that special touch of class to your outgoing mail." t nil) (autoload 'snarf-spooks "spook" "\ -Return a vector containing the lines from `spook-phrases-file'. - -\(fn)" nil nil) +Return a vector containing the lines from `spook-phrases-file'." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "spook" '("spook-phrase"))) @@ -31589,6 +30894,39 @@ The default comes from `process-coding-system-alist' and \(fn &optional BUFFER)" t nil) +(autoload 'sql-mariadb "sql" "\ +Run mysql by MariaDB as an inferior process. + +MariaDB is free software. + +If buffer `*SQL*' exists but no process is running, make a new process. +If buffer exists and a process is running, just switch to buffer +`*SQL*'. + +Interpreter used comes from variable `sql-mariadb-program'. Login uses +the variables `sql-user', `sql-password', `sql-database', and +`sql-server' as defaults, if set. Additional command line parameters +can be stored in the list `sql-mariadb-options'. + +The buffer is put in SQL interactive mode, giving commands for sending +input. See `sql-interactive-mode'. + +To set the buffer name directly, use \\[universal-argument] +before \\[sql-mariadb]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + +To specify a coding system for converting non-ASCII characters +in the input and output to the process, use \\[universal-coding-system-argument] +before \\[sql-mariadb]. You can also specify this with \\[set-buffer-process-coding-system] +in the SQL buffer, after you start the process. +The default comes from `process-coding-system-alist' and +`default-process-coding-system'. + +\(Type \\[describe-mode] in the SQL buffer for a list of commands.) + +\(fn &optional BUFFER)" t nil) + (autoload 'sql-solid "sql" "\ Run solsql by Solid as an inferior process. @@ -31708,8 +31046,7 @@ The default comes from `process-coding-system-alist' and your might try undecided-dos as a coding system. If this doesn't help, Try to set `comint-output-filter-functions' like this: -\(setq comint-output-filter-functions (append comint-output-filter-functions - \\='(comint-strip-ctrl-m))) +\(add-hook 'comint-output-filter-functions #\\='comint-strip-ctrl-m 'append) \(Type \\[describe-mode] in the SQL buffer for a list of commands.) @@ -31990,7 +31327,7 @@ Major-mode for writing SRecode macros. ;;;;;; 0 0 0)) ;;; Generated autoloads from cedet/srecode/table.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/table" '("srecode-" "object-sort-list"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/table" '("object-sort-list" "srecode-"))) ;;;*** @@ -32010,31 +31347,6 @@ Major-mode for writing SRecode macros. ;;;*** -;;;### (autoloads nil "starttls" "net/starttls.el" (0 0 0 0)) -;;; Generated autoloads from net/starttls.el - -(autoload 'starttls-open-stream "starttls" "\ -Open a TLS connection for a port to a host. -Returns a subprocess object to represent the connection. -Input and output work as for subprocesses; `delete-process' closes it. -Args are NAME BUFFER HOST PORT. -NAME is name for process. It is modified if necessary to make it unique. -BUFFER is the buffer (or `buffer-name') to associate with the process. - Process output goes at end of that buffer, unless you specify - a filter function to handle the output. - BUFFER may be also nil, meaning that this process is not associated - with any buffer -Third arg is name of the host to connect to, or its IP address. -Fourth arg PORT is an integer specifying a port to connect to. -If `starttls-use-gnutls' is nil, this may also be a service name, but -GnuTLS requires a port number. - -\(fn NAME BUFFER HOST PORT)" nil nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "starttls" '("starttls-"))) - -;;;*** - ;;;### (autoloads nil "strokes" "strokes.el" (0 0 0 0)) ;;; Generated autoloads from strokes.el @@ -32087,14 +31399,10 @@ Displays the command which STROKE maps to, reading STROKE interactively. \(fn STROKE)" t nil) (autoload 'strokes-help "strokes" "\ -Get instruction on using the Strokes package. - -\(fn)" t nil) +Get instruction on using the Strokes package." t nil) (autoload 'strokes-load-user-strokes "strokes" "\ -Load user-defined strokes from file named by `strokes-file'. - -\(fn)" t nil) +Load user-defined strokes from file named by `strokes-file'." t nil) (autoload 'strokes-list-strokes "strokes" "\ Pop up a buffer containing an alphabetical listing of strokes in STROKES-MAP. @@ -32116,9 +31424,11 @@ or call the function `strokes-mode'.") (autoload 'strokes-mode "strokes" "\ Toggle Strokes mode, a global minor mode. -With a prefix argument ARG, enable Strokes mode if ARG is -positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. + +If called interactively, enable Strokes mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. \\<strokes-mode-map> Strokes are pictographic mouse gestures which invoke commands. @@ -32143,9 +31453,7 @@ Optional FORCE non-nil will ignore the buffer's read-only status. \(fn &optional BUFFER FORCE)" t nil) (autoload 'strokes-compose-complex-stroke "strokes" "\ -Read a complex stroke and insert its glyph into the current buffer. - -\(fn)" t nil) +Read a complex stroke and insert its glyph into the current buffer." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "strokes" '("strokes-"))) @@ -32165,16 +31473,14 @@ Studlify-case the current word, or COUNT words if given an argument. \(fn COUNT)" t nil) (autoload 'studlify-buffer "studly" "\ -Studlify-case the current buffer. - -\(fn)" t nil) +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 -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "subr-x" '("string-" "hash-table-" "when-let" "internal--" "if-let" "and-let*" "thread-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "subr-x" '("and-let*" "hash-table-" "if-let" "internal--" "replace-region-contents" "string-" "thread-" "when-let"))) ;;;*** @@ -32185,9 +31491,11 @@ Studlify-case the current buffer. (autoload 'subword-mode "subword" "\ Toggle subword movement and editing (Subword mode). -With a prefix argument ARG, enable Subword mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Subword mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Subword mode is a buffer-local minor mode. Enabling it changes the definition of a word so that word-based commands stop inside @@ -32233,9 +31541,11 @@ See `subword-mode' for more information on Subword mode. (autoload 'superword-mode "subword" "\ Toggle superword movement and editing (Superword mode). -With a prefix argument ARG, enable Superword mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Superword mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Superword mode is a buffer-local minor mode. Enabling it changes the definition of words such that symbols characters are treated @@ -32268,7 +31578,7 @@ See `superword-mode' for more information on Superword mode. \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "subword" '("superword-mode-map" "subword-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "subword" '("subword-" "superword-mode-map"))) ;;;*** @@ -32298,9 +31608,7 @@ original message but it does require a few things: The region need not be active (and typically isn't when this function is called). Also, the hook `sc-pre-hook' is run before, -and `sc-post-hook' is run after the guts of this function. - -\(fn)" nil nil) +and `sc-post-hook' is run after the guts of this function." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "supercite" '("sc-"))) @@ -32308,6 +31616,7 @@ and `sc-post-hook' is run after the guts of this function. ;;;### (autoloads nil "svg" "svg.el" (0 0 0 0)) ;;; Generated autoloads from svg.el +(push (purecopy '(svg 1 0)) package--builtin-versions) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "svg" '("svg-"))) @@ -32330,9 +31639,11 @@ or call the function `gpm-mouse-mode'.") (autoload 'gpm-mouse-mode "t-mouse" "\ Toggle mouse support in GNU/Linux consoles (GPM Mouse mode). -With a prefix argument ARG, enable GPM Mouse mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Gpm-Mouse mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. 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. @@ -32538,10 +31849,7 @@ all the table specific features. \(fn &optional ARG)" t nil) -(autoload 'table-unrecognize "table" "\ - - -\(fn)" t nil) +(autoload 'table-unrecognize "table" nil t nil) (autoload 'table-recognize-region "table" "\ Recognize all tables within region. @@ -32565,10 +31873,7 @@ the table specific features. \(fn &optional ARG)" t nil) -(autoload 'table-unrecognize-table "table" "\ - - -\(fn)" t nil) +(autoload 'table-unrecognize-table "table" nil t nil) (autoload 'table-recognize-cell "table" "\ Recognize a table cell that contains current point. @@ -32580,10 +31885,7 @@ plain text and loses all the table specific features. \(fn &optional FORCE NO-COPY ARG)" t nil) -(autoload 'table-unrecognize-cell "table" "\ - - -\(fn)" t nil) +(autoload 'table-unrecognize-cell "table" nil t nil) (autoload 'table-heighten-cell "table" "\ Heighten the current cell by N lines by expanding the cell vertically. @@ -32674,15 +31976,11 @@ DIRECTION is one of symbols; right, left, above or below. (autoload 'table-split-cell-vertically "table" "\ Split current cell vertically. -Creates a cell above and a cell below the current point location. - -\(fn)" t nil) +Creates a cell above and a cell below the current point location." t nil) (autoload 'table-split-cell-horizontally "table" "\ Split current cell horizontally. -Creates a cell on the left and a cell on the right of the current point location. - -\(fn)" t nil) +Creates a cell on the left and a cell on the right of the current point location." t nil) (autoload 'table-split-cell "table" "\ Split current cell in ORIENTATION. @@ -32730,6 +32028,11 @@ location is indicated by `table-word-continuation-char'. This variable's value can be toggled by \\[table-fixed-width-mode] at run-time. +If called interactively, enable Table-Fixed-Width mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + \(fn &optional ARG)" t nil) (autoload 'table-query-dimension "table" "\ @@ -32944,11 +32247,9 @@ companion command to `table-capture' this way. Convert a table into plain text by removing the frame from a table. Remove the frame from a table and deactivate the table. This command converts a table into plain text without frames. It is a companion to -`table-capture' which does the opposite process. - -\(fn)" t nil) +`table-capture' which does the opposite process." t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "table" '("table-" "*table--"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "table" '("*table--" "table-"))) ;;;*** @@ -32968,9 +32269,7 @@ Connect to display DISPLAY for the Emacs talk group. \(fn DISPLAY)" t nil) (autoload 'talk "talk" "\ -Connect to the Emacs talk group from the current X display or tty frame. - -\(fn)" t nil) +Connect to the Emacs talk group from the current X display or tty frame." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "talk" '("talk-"))) @@ -33047,7 +32346,7 @@ Prefix argument means invert sense of `tcl-use-smart-word-finder'. \(fn COMMAND &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tcl" '("tcl-" "calculate-tcl-indent" "inferior-tcl-" "indent-tcl-exp" "add-log-tcl-defun" "run-tcl" "switch-to-tcl"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tcl" '("add-log-tcl-defun" "calculate-tcl-indent" "indent-tcl-exp" "inferior-tcl-" "run-tcl" "switch-to-tcl" "tcl-"))) ;;;*** @@ -33090,7 +32389,7 @@ Normally input is edited in Emacs and sent a line at a time. \(fn HOST)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "telnet" '("telnet-" "send-process-next-char"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "telnet" '("send-process-next-char" "telnet-"))) ;;;*** @@ -33143,7 +32442,7 @@ use in that buffer. \(fn PORT SPEED)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "term" '("serial-" "term-" "ansi-term-color-vector" "explicit-shell-file-name"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "term" '("ansi-term-color-vector" "explicit-shell-file-name" "serial-" "term-"))) ;;;*** @@ -33152,17 +32451,13 @@ use in that buffer. ;;; Generated autoloads from emacs-lisp/testcover.el (autoload 'testcover-start "testcover" "\ -Uses edebug to instrument all macros and functions in FILENAME, then -changes the instrumentation from edebug to testcover--much faster, no -problems with type-ahead or post-command-hook, etc. If BYTE-COMPILE is -non-nil, byte-compiles each function after instrumenting. +Use Edebug to instrument for coverage all macros and functions in FILENAME. +If BYTE-COMPILE is non-nil, byte compile each function after instrumenting. \(fn FILENAME &optional BYTE-COMPILE)" t nil) (autoload 'testcover-this-defun "testcover" "\ -Start coverage on function under point. - -\(fn)" t nil) +Start coverage on function under point." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "testcover" '("testcover-"))) @@ -33189,7 +32484,7 @@ tetris-mode keybindings: \\[tetris-rotate-next] Rotates the shape anticlockwise \\[tetris-move-bottom] Drops the shape to the bottom of the playing area -\(fn)" t nil) +" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tetris" '("tetris-"))) @@ -33344,9 +32639,7 @@ Tries to determine (by looking at the beginning of the file) whether this file is for plain TeX, LaTeX, or SliTeX and calls `plain-tex-mode', `latex-mode', or `slitex-mode', respectively. If it cannot be determined, such as if there are no commands in the file, the value of `tex-default-mode' -says which mode to use. - -\(fn)" t nil) +says which mode to use." t nil) (defalias 'TeX-mode 'tex-mode) @@ -33484,17 +32777,14 @@ Entering SliTeX mode runs the hook `text-mode-hook', then the hook \(fn)" t nil) -(autoload 'tex-start-shell "tex-mode" "\ - - -\(fn)" nil nil) +(autoload 'tex-start-shell "tex-mode" nil nil nil) (autoload 'doctex-mode "tex-mode" "\ Major mode to edit DocTeX files. \(fn)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tex-mode" '("tex-" "doctex-font-lock-" "latex-" "plain-tex-mode-map"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tex-mode" '("doctex-font-lock-" "latex-" "plain-tex-mode-map" "tex-"))) ;;;*** @@ -33633,6 +32923,14 @@ value of `texinfo-mode-hook'. ;;;*** +;;;### (autoloads nil "text-property-search" "emacs-lisp/text-property-search.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from emacs-lisp/text-property-search.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "text-property-search" '("text-property-"))) + +;;;*** + ;;;### (autoloads nil "thai-util" "language/thai-util.el" (0 0 0 ;;;;;; 0)) ;;; Generated autoloads from language/thai-util.el @@ -33650,14 +32948,12 @@ Compose Thai characters in STRING and return the resulting string. \(fn STRING)" nil nil) (autoload 'thai-compose-buffer "thai-util" "\ -Compose Thai characters in the current buffer. - -\(fn)" t nil) +Compose Thai characters in the current buffer." t nil) (autoload 'thai-composition-function "thai-util" "\ -\(fn GSTRING)" nil nil) +\(fn GSTRING DIRECTION)" nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "thai-util" '("exit-thai-language-environment-internal" "setup-thai-language-environment-internal" "thai-"))) @@ -33678,7 +32974,7 @@ Compose Thai characters in the current buffer. 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', -`filename', `url', `email', `word', `sentence', `whitespace', +`filename', `url', `email', `uuid', `word', `sentence', `whitespace', `line', and `page'. \(fn THING &optional N)" nil nil) @@ -33687,7 +32983,7 @@ Possibilities include `symbol', `list', `sexp', `defun', 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', -`filename', `url', `email', `word', `sentence', `whitespace', +`filename', `url', `email', `uuid', `word', `sentence', `whitespace', `line', and `page'. See the file `thingatpt.el' for documentation on how to define a @@ -33702,7 +32998,7 @@ positions of the thing found. Return the THING at point. THING should be a symbol specifying a type of syntactic entity. Possibilities include `symbol', `list', `sexp', `defun', -`filename', `url', `email', `word', `sentence', `whitespace', +`filename', `url', `email', `uuid', `word', `sentence', `whitespace', `line', `number', and `page'. When the optional argument NO-PROPERTIES is non-nil, @@ -33714,19 +33010,13 @@ a symbol as a valid THING. \(fn THING &optional NO-PROPERTIES)" nil nil) (autoload 'sexp-at-point "thingatpt" "\ -Return the sexp at point, or nil if none is found. - -\(fn)" nil nil) +Return the sexp at point, or nil if none is found." nil nil) (autoload 'symbol-at-point "thingatpt" "\ -Return the symbol at point, or nil if none is found. - -\(fn)" nil nil) +Return the symbol at point, or nil if none is found." nil nil) (autoload 'number-at-point "thingatpt" "\ -Return the number at point, or nil if none is found. - -\(fn)" nil nil) +Return the number at point, or nil if none is found." nil nil) (autoload 'list-at-point "thingatpt" "\ Return the Lisp list at point, or nil if none is found. @@ -33735,7 +33025,25 @@ treated as white space. \(fn &optional IGNORE-COMMENT-OR-STRING)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "thingatpt" '("form-at-point" "thing-at-point-" "sentence-at-point" "word-at-point" "in-string-p" "end-of-thing" "beginning-of-thing"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "thingatpt" '("beginning-of-thing" "define-thing-chars" "end-of-thing" "filename" "form-at-point" "in-string-p" "sentence-at-point" "thing-at-point-" "word-at-point"))) + +;;;*** + +;;;### (autoloads nil "thread" "thread.el" (0 0 0 0)) +;;; Generated autoloads from thread.el + +(autoload 'thread-handle-event "thread" "\ +Handle thread events, propagated by `thread-signal'. +An EVENT has the format + (thread-event THREAD ERROR-SYMBOL DATA) + +\(fn EVENT)" t nil) + +(autoload 'list-threads "thread" "\ +Display a list of threads." t nil) + (put 'list-threads 'disabled "Beware: manually canceling threads can ruin your Emacs session.") + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "thread" '("thread-list-"))) ;;;*** @@ -33755,21 +33063,15 @@ and SAME-WINDOW to show thumbs in the same window. \(fn DIR &optional REG SAME-WINDOW)" t nil) (autoload 'thumbs-dired-show-marked "thumbs" "\ -In dired, make a thumbs buffer with marked files. - -\(fn)" t nil) +In dired, make a thumbs buffer with marked files." t nil) (autoload 'thumbs-dired-show "thumbs" "\ -In dired, make a thumbs buffer with all files in current directory. - -\(fn)" t nil) +In dired, make a thumbs buffer with all files in current directory." t nil) (defalias 'thumbs 'thumbs-show-from-dir) (autoload 'thumbs-dired-setroot "thumbs" "\ -In dired, call the setroot program on the image at point. - -\(fn)" t nil) +In dired, call the setroot program on the image at point." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "thumbs" '("thumbs-"))) @@ -33830,15 +33132,11 @@ are decomposed into normal Tibetan character sequences. (autoload 'tibetan-decompose-buffer "tibet-util" "\ Decomposes Tibetan characters in the buffer into their components. -See also the documentation of the function `tibetan-decompose-region'. - -\(fn)" t nil) +See also the documentation of the function `tibetan-decompose-region'." t nil) (autoload 'tibetan-compose-buffer "tibet-util" "\ Composes Tibetan character components in the buffer. -See also docstring of the function tibetan-compose-region. - -\(fn)" t nil) +See also docstring of the function tibetan-compose-region." t nil) (autoload 'tibetan-post-read-conversion "tibet-util" "\ @@ -33905,13 +33203,16 @@ Otherwise, if `tildify-space-string' variable, remove the hard space and leave only the space character. -This function is meant to be used as a `post-self-insert-hook'. - -\(fn)" t nil) +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. +If called interactively, enable Tildify mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + 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 @@ -33941,9 +33242,7 @@ Enable display of time, load level, and mail flag in mode lines. This display updates automatically every minute. 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. - -\(fn)" t nil) +This runs the normal hook `display-time-hook' after each update." t nil) (defvar display-time-mode nil "\ Non-nil if Display-Time mode is enabled. @@ -33957,9 +33256,11 @@ or call the function `display-time-mode'.") (autoload 'display-time-mode "time" "\ Toggle display of time, load level, and mail flag in mode lines. -With a prefix argument ARG, enable Display Time mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -it if ARG is omitted or nil. + +If called interactively, enable Display-Time mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. When Display Time mode is enabled, it updates every minute (you can control the number of seconds between updates by customizing @@ -33972,9 +33273,7 @@ runs the normal hook `display-time-hook' after each update. (autoload 'display-time-world "time" "\ Enable updating display of times in various time zones. `display-time-world-list' specifies the zones. -To turn off the world time display, go to that window and type `q'. - -\(fn)" t nil) +To turn off the world time display, go to that window and type `q'." t nil) (autoload 'emacs-uptime "time" "\ Return a string giving the uptime of this instance of Emacs. @@ -33984,11 +33283,9 @@ For example, the Unix uptime command format is \"%D, %z%2h:%.2m\". \(fn &optional FORMAT)" t nil) (autoload 'emacs-init-time "time" "\ -Return a string giving the duration of the Emacs initialization. - -\(fn)" t nil) +Return a string giving the duration of the Emacs initialization." t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "time" '("display-time-" "time--display-world-list" "legacy-style-world-list" "zoneinfo-style-world-list"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "time" '("display-time-" "legacy-style-world-list" "time--display-world-list" "zoneinfo-style-world-list"))) ;;;*** @@ -34005,10 +33302,7 @@ If DATE lacks timezone information, GMT is assumed. (defalias 'time-to-seconds 'float-time) -(autoload 'seconds-to-time "time-date" "\ -Convert SECONDS to a time value. - -\(fn SECONDS)" nil nil) +(defalias 'seconds-to-time 'encode-time) (autoload 'days-to-time "time-date" "\ Convert DAYS into a time value. @@ -34080,8 +33374,6 @@ 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. -This function does not work for SECONDS greater than `most-positive-fixnum'. - \(fn STRING SECONDS)" nil nil) (autoload 'seconds-to-string "time-date" "\ @@ -34089,7 +33381,7 @@ Convert the time interval in seconds to a short string. \(fn DELAY)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "time-date" '("seconds-to-string" "time-" "encode-time-value" "with-decoded-time-value"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "time-date" '("encode-time-value" "seconds-to-string" "time-" "with-decoded-time-value"))) ;;;*** @@ -34121,9 +33413,7 @@ The format of the time stamp is set by the variable `time-stamp-pattern' or `time-stamp-format'. The variables `time-stamp-pattern', `time-stamp-line-limit', `time-stamp-start', `time-stamp-end', `time-stamp-count', and `time-stamp-inserts-lines' control finding -the template. - -\(fn)" t nil) +the template." t nil) (autoload 'time-stamp-toggle-active "time-stamp" "\ Toggle `time-stamp-active', setting whether \\[time-stamp] updates a buffer. @@ -34209,15 +33499,11 @@ working on. (autoload 'timeclock-query-out "timeclock" "\ Ask the user whether to clock out. -This is a useful function for adding to `kill-emacs-query-functions'. - -\(fn)" nil nil) +This is a useful function for adding to `kill-emacs-query-functions'." nil nil) (autoload 'timeclock-reread-log "timeclock" "\ Re-read the timeclock, to account for external changes. -Returns the new value of `timeclock-discrepancy'. - -\(fn)" t nil) +Returns the new value of `timeclock-discrepancy'." t nil) (autoload 'timeclock-workday-remaining-string "timeclock" "\ Return a string representing the amount of time left today. @@ -34290,14 +33576,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\". \(fn &optional FORCE)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "titdic-cnv" '("batch-miscdic-convert" "miscdic-convert" "ctlau-" "ziranma-converter" "py-converter" "quail-" "quick-" "tit-" "tsang-"))) - -;;;*** - -;;;### (autoloads nil "tls" "net/tls.el" (0 0 0 0)) -;;; Generated autoloads from net/tls.el - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tls" '("open-tls-stream" "tls-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "titdic-cnv" '("batch-miscdic-convert" "ctlau-" "miscdic-convert" "pinyin-convert" "py-converter" "quail-" "quick-" "tit-" "tsang-" "ziranma-converter"))) ;;;*** @@ -34338,8 +33617,10 @@ MENU is like the MENU argument to `x-popup-menu': either a keymap or an alist of alists. DEFAULT-ITEM, if non-nil, specifies an initial default choice. Its value should be an event that has a binding in MENU. +NO-EXECUTE, if non-nil, means to return the command the user selects +instead of executing it. -\(fn MENU &optional IN-POPUP DEFAULT-ITEM)" nil nil) +\(fn MENU &optional IN-POPUP DEFAULT-ITEM NO-EXECUTE)" nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tmm" '("tmm-"))) @@ -34550,12 +33831,13 @@ the output buffer or changing the window configuration. (defalias 'trace-function 'trace-function-foreground) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "trace" '("untrace-" "trace-" "inhibit-trace"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "trace" '("inhibit-trace" "trace-" "untrace-"))) ;;;*** ;;;### (autoloads nil "tramp" "net/tramp.el" (0 0 0 0)) ;;; Generated autoloads from net/tramp.el +(push (purecopy '(tramp 2 4 2)) package--builtin-versions) (defvar tramp-mode t "\ Whether Tramp is enabled. @@ -34573,6 +33855,11 @@ This regexp should match Tramp file names but no other file names. When calling `tramp-register-file-name-handlers', the initial value is overwritten by the car of `tramp-file-name-structure'.") +(defvar tramp-ignored-file-name-regexp nil "\ +Regular expression matching file names that are not under Tramp’s control.") + +(custom-autoload 'tramp-ignored-file-name-regexp "tramp" t) + (defconst tramp-autoload-file-name-regexp (concat "\\`/" (if (memq system-type '(cygwin windows-nt)) "\\(-\\|[^/|:]\\{2,\\}\\)" "[^/|:]+") ":") "\ Regular expression matching file names handled by Tramp autoload. It must match the initial `tramp-syntax' settings. It should not @@ -34580,22 +33867,20 @@ match file names at root of the underlying local file system, like \"/sys\" or \"/C:\".") (defun tramp-autoload-file-name-handler (operation &rest args) "\ -Load Tramp file name handler, and perform OPERATION." (if tramp-mode (let ((default-directory temporary-file-directory)) (load "tramp" (quote noerror) (quote nomessage))) (tramp-unload-file-name-handlers)) (apply operation args)) +Load Tramp file name handler, and perform OPERATION." (tramp-unload-file-name-handlers) (if tramp-mode (let ((default-directory temporary-file-directory)) (load "tramp" 'noerror 'nomessage))) (apply operation args)) (defun tramp-register-autoload-file-name-handlers nil "\ -Add Tramp file name handlers to `file-name-handler-alist' during autoload." (add-to-list (quote file-name-handler-alist) (cons tramp-autoload-file-name-regexp (quote tramp-autoload-file-name-handler))) (put (quote tramp-autoload-file-name-handler) (quote safe-magic) t)) +Add Tramp file name handlers to `file-name-handler-alist' during autoload." (add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp 'tramp-autoload-file-name-handler)) (put 'tramp-autoload-file-name-handler 'safe-magic t)) (tramp-register-autoload-file-name-handlers) (defun tramp-unload-file-name-handlers nil "\ -Unload Tramp file name handlers from `file-name-handler-alist'." (dolist (fnh (quote (tramp-file-name-handler tramp-completion-file-name-handler tramp-autoload-file-name-handler))) (let ((a1 (rassq fnh file-name-handler-alist))) (setq file-name-handler-alist (delq a1 file-name-handler-alist))))) +Unload Tramp file name handlers from `file-name-handler-alist'." (dolist (fnh file-name-handler-alist) (when (and (symbolp (cdr fnh)) (string-prefix-p "tramp-" (symbol-name (cdr fnh)))) (setq file-name-handler-alist (delq fnh file-name-handler-alist))))) (defvar tramp-completion-mode nil "\ If non-nil, external packages signal that they are in file name completion.") (autoload 'tramp-unload-tramp "tramp" "\ -Discard Tramp from loading remote files. - -\(fn)" t nil) +Discard Tramp from loading remote files." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp" '("tramp-" "with-"))) @@ -34608,6 +33893,37 @@ Discard Tramp from loading remote files. ;;;*** +;;;### (autoloads nil "tramp-archive" "net/tramp-archive.el" (0 0 +;;;;;; 0 0)) +;;; Generated autoloads from net/tramp-archive.el + +(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") "\ +List of suffixes which indicate a file archive. +It must be supported by libarchive(3).") + +(defconst tramp-archive-compression-suffixes '("bz2" "gz" "lrz" "lz" "lz4" "lzma" "lzo" "uu" "xz" "Z" "zst") "\ +List of suffixes which indicate a compressed file. +It must be supported by libarchive(3).") + +(defmacro tramp-archive-autoload-file-name-regexp nil "\ +Regular expression matching archive file names." '(concat "\\`" "\\(" ".+" "\\." (regexp-opt tramp-archive-suffixes) "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*" "\\)" "\\(" "/" ".*" "\\)" "\\'")) + +(defalias 'tramp-archive-autoload-file-name-handler #'tramp-autoload-file-name-handler) + +(defun tramp-register-archive-file-name-handler nil "\ +Add archive file name handler to `file-name-handler-alist'." (when tramp-archive-enabled (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) (put 'tramp-archive-autoload-file-name-handler 'safe-magic t))) + +(add-hook 'after-init-hook #'tramp-register-archive-file-name-handler) + +(add-hook 'tramp-archive-unload-hook (lambda nil (remove-hook 'after-init-hook #'tramp-register-archive-file-name-handler))) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-archive" '("tramp-" "with-parsed-tramp-archive-file-name"))) + +;;;*** + ;;;### (autoloads nil "tramp-cache" "net/tramp-cache.el" (0 0 0 0)) ;;; Generated autoloads from net/tramp-cache.el @@ -34633,11 +33949,6 @@ Discard Tramp from loading remote files. ;;;### (autoloads nil "tramp-ftp" "net/tramp-ftp.el" (0 0 0 0)) ;;; Generated autoloads from net/tramp-ftp.el -(autoload 'tramp-ftp-enable-ange-ftp "tramp-ftp" "\ -Reenable Ange-FTP, when Tramp is unloaded. - -\(fn)" nil nil) - (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-ftp" '("tramp-"))) ;;;*** @@ -34645,7 +33956,23 @@ Reenable Ange-FTP, when Tramp is unloaded. ;;;### (autoloads nil "tramp-gvfs" "net/tramp-gvfs.el" (0 0 0 0)) ;;; Generated autoloads from net/tramp-gvfs.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-gvfs" '("tramp-" "with-tramp-dbus-call-method"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-gvfs" '("tramp-" "with-tramp-dbus-"))) + +;;;*** + +;;;### (autoloads nil "tramp-integration" "net/tramp-integration.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from net/tramp-integration.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-integration" '("tramp-"))) + +;;;*** + +;;;### (autoloads nil "tramp-rclone" "net/tramp-rclone.el" (0 0 0 +;;;;;; 0)) +;;; Generated autoloads from net/tramp-rclone.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-rclone" '("tramp-rclone-"))) ;;;*** @@ -34663,6 +33990,14 @@ Reenable Ange-FTP, when Tramp is unloaded. ;;;*** +;;;### (autoloads nil "tramp-sudoedit" "net/tramp-sudoedit.el" (0 +;;;;;; 0 0 0)) +;;; Generated autoloads from net/tramp-sudoedit.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-sudoedit" '("tramp-sudoedit-"))) + +;;;*** + ;;;### (autoloads nil "tramp-uu" "net/tramp-uu.el" (0 0 0 0)) ;;; Generated autoloads from net/tramp-uu.el @@ -34672,7 +34007,6 @@ Reenable Ange-FTP, when Tramp is unloaded. ;;;### (autoloads nil "trampver" "net/trampver.el" (0 0 0 0)) ;;; Generated autoloads from net/trampver.el -(push (purecopy '(tramp 2 3 5 26 3)) package--builtin-versions) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "trampver" '("tramp-"))) @@ -34717,7 +34051,7 @@ resumed later. (autoload 'tai-viet-composition-function "tv-util" "\ -\(fn FROM TO FONT-OBJECT STRING)" nil nil) +\(fn FROM TO FONT-OBJECT STRING DIRECTION)" nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tv-util" '("tai-viet-"))) @@ -34745,9 +34079,7 @@ Associate another buffer with this one in two-column minor mode. Can also be used to associate a just previously visited file, by accepting the proposed default buffer. -\(See \\[describe-mode] .) - -\(fn)" t nil) +\(See \\[describe-mode] .)" t nil) (autoload '2C-split "two-column" "\ Split a two-column text at point, into two buffers in two-column minor mode. @@ -34790,6 +34122,11 @@ or call the function `type-break-mode'.") Enable or disable typing-break mode. This is a minor mode, but it is global to all buffers by default. +If called interactively, enable Type-Break mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + 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 user has exceeded a keystroke threshold. When the time arrives, the user @@ -34798,9 +34135,6 @@ again in a short period of time. The idea is to give the user enough time to find a good breaking point in his or her work, but be sufficiently annoying to discourage putting typing breaks off indefinitely. -A negative prefix argument disables this mode. -No argument or any non-negative argument enables it. - The user may enable or disable this mode by setting the variable of the same name, though setting it in that way doesn't reschedule a break or reset the keystroke counter. @@ -34869,16 +34203,12 @@ During the break, a demo selected from the functions listed in `type-break-demo-functions' is run. After the typing break is finished, the next break is scheduled -as per the function `type-break-schedule'. - -\(fn)" t nil) +as per the function `type-break-schedule'." t nil) (autoload 'type-break-statistics "type-break" "\ Print statistics about typing breaks in a temporary buffer. This includes the last time a typing break was taken, when the next one is -scheduled, the keystroke thresholds and the current keystroke count, etc. - -\(fn)" t nil) +scheduled, the keystroke thresholds and the current keystroke count, etc." t nil) (autoload 'type-break-guesstimate-keystroke-threshold "type-break" "\ Guess values for the minimum/maximum keystroke threshold for typing breaks. @@ -35028,9 +34358,7 @@ Convert old-style Rmail Babyl files to mbox format. Specify the input Rmail Babyl file names as command line arguments. For each Rmail file, the corresponding output file name is made by adding `.mail' at the end. -For example, invoke `emacs -batch -f batch-unrmail RMAIL'. - -\(fn)" nil nil) +For example, invoke `emacs -batch -f batch-unrmail RMAIL'." nil nil) (autoload 'unrmail "unrmail" "\ Convert old-style Rmail Babyl file FILE to mbox format file TO-FILE. @@ -35052,7 +34380,7 @@ UNSAFEP-VARS is a list of symbols with local bindings. \(fn FORM &optional UNSAFEP-VARS)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "unsafep" '("unsafep-" "safe-functions"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "unsafep" '("safe-functions" "unsafep-"))) ;;;*** @@ -35072,9 +34400,11 @@ STATUS is a plist representing what happened during the request, with most recent events first, or an empty list if no events have occurred. Each pair is one of: -\(:redirect REDIRECTED-TO) - the request was redirected to this URL -\(:error (ERROR-SYMBOL . DATA)) - an error occurred. The error can be -signaled with (signal ERROR-SYMBOL DATA). +\(:redirect REDIRECTED-TO) - the request was redirected to this URL. + +\(:error (error type . DATA)) - an error occurred. TYPE is a +symbol that says something about where the error occurred, and +DATA is a list (possibly nil) that describes the error further. Return the buffer URL will load into, or nil if the process has already completed (i.e. URL was a mailto URL or similar; in this case @@ -35324,31 +34654,29 @@ or call the function `url-handler-mode'.") (autoload 'url-handler-mode "url-handlers" "\ Toggle using `url' library for URL filenames (URL Handler mode). -With a prefix argument ARG, enable URL Handler mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Url-Handler mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. \(fn &optional ARG)" t nil) (autoload 'url-file-handler "url-handlers" "\ Function called from the `file-name-handler-alist' routines. -OPERATION is what needs to be done (`file-exists-p', etc). ARGS are -the arguments that would have been passed to OPERATION. +OPERATION is what needs to be done (`file-exists-p', etc.). +ARGS are the arguments that would have been passed to OPERATION. \(fn OPERATION &rest ARGS)" nil nil) (autoload 'url-copy-file "url-handlers" "\ -Copy URL to NEWNAME. Both args must be strings. -Signal a `file-already-exists' error if file NEWNAME already exists, -unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil. -A number as third arg means request confirmation if NEWNAME already exists. -This is what happens in interactive use with M-x. -Fourth arg KEEP-TIME non-nil means give the new file the same -last-modified time as the old one. (This works on only some systems.) -Args PRESERVE-UID-GID and PRESERVE-PERMISSIONS are ignored. -A prefix arg makes KEEP-TIME non-nil. - -\(fn URL NEWNAME &optional OK-IF-ALREADY-EXISTS KEEP-TIME PRESERVE-UID-GID PRESERVE-PERMISSIONS)" nil nil) +Copy URL to NEWNAME. Both arguments must be strings. +Signal a `file-already-exists' error if file NEWNAME already +exists, unless a third argument OK-IF-ALREADY-EXISTS is supplied +and non-nil. An integer as third argument means request +confirmation if NEWNAME already exists. + +\(fn URL NEWNAME &optional OK-IF-ALREADY-EXISTS &rest IGNORED)" nil nil) (autoload 'url-file-local-copy "url-handlers" "\ Copy URL into a temporary file on this machine. @@ -35608,9 +34936,7 @@ parses to ;;; Generated autoloads from url/url-privacy.el (autoload 'url-setup-privacy-info "url-privacy" "\ -Setup variables that expose info about you and your system. - -\(fn)" t nil) +Setup variables that expose info about you and your system." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-privacy" '("url-device-type"))) @@ -35825,6 +35151,15 @@ This uses `url-current-object', set locally to the buffer. \(fn &optional NO-SHOW)" t nil) +(autoload 'url-domain "url-util" "\ +Return the domain of the host of the URL. +Return nil if this can't be determined. + +For instance, this function will return \"fsf.co.uk\" if the host in URL +is \"www.fsf.co.uk\". + +\(fn URL)" nil nil) + (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-util" '("url-"))) ;;;*** @@ -35867,7 +35202,7 @@ The buffer in question is current when this function is called. \(fn FN)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "userlock" '("ask-user-about-" "userlock--check-content-unchanged" "file-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "userlock" '("ask-user-about-" "file-" "userlock--check-content-unchanged"))) ;;;*** @@ -36021,6 +35356,11 @@ state of each file in the fileset. \(fn FILES REV1 REV2)" t nil) +(autoload 'vc-root-version-diff "vc" "\ +Report diffs between REV1 and REV2 revisions of the whole tree. + +\(fn FILES REV1 REV2)" t nil) + (autoload 'vc-diff "vc" "\ Display diffs between file revisions. Normally this compares the currently selected fileset with their @@ -36032,6 +35372,12 @@ saving the buffer. \(fn &optional HISTORIC NOT-URGENT)" t nil) +(autoload 'vc-diff-mergebase "vc" "\ +Report diffs between the merge base of REV1 and REV2 revisions. +The merge base is a common ancestor between REV1 and REV2 revisions. + +\(fn FILES REV1 REV2)" t nil) + (autoload 'vc-version-ediff "vc" "\ Show differences between REV1 and REV2 of FILES using ediff. This compares two revisions of the files in FILES. Currently, @@ -36069,9 +35415,7 @@ saving the buffer. (autoload 'vc-root-dir "vc" "\ Return the root directory for the current VC tree. -Return nil if the root directory cannot be identified. - -\(fn)" nil nil) +Return nil if the root directory cannot be identified." nil nil) (autoload 'vc-revision-other-window "vc" "\ Visit revision REV of the current file in another window. @@ -36083,9 +35427,7 @@ If `F.~REV~' already exists, use it instead of checking it out again. (autoload 'vc-insert-headers "vc" "\ Insert headers into a file for use with a version control system. Headers desired are inserted at point, and are pulled from -the variable `vc-BACKEND-header'. - -\(fn)" t nil) +the variable `vc-BACKEND-header'." t nil) (autoload 'vc-merge "vc" "\ Perform a version control merge operation. @@ -36099,9 +35441,7 @@ between two revisions into the current fileset. This asks for two revisions to merge from in the minibuffer. If the first revision is a branch number, then merge all changes from that branch. If the first revision is empty, merge the most recent -changes from the current branch. - -\(fn)" t nil) +changes from the current branch." t nil) (autoload 'vc-message-unresolved-conflicts "vc" "\ Display a message indicating unresolved conflicts in FILENAME. @@ -36110,6 +35450,9 @@ Display a message indicating unresolved conflicts in FILENAME. (defalias 'vc-resolve-conflicts 'smerge-ediff) +(autoload 'vc-find-conflicted-file "vc" "\ +Visit the next conflicted file in the current project." t nil) + (autoload 'vc-create-tag "vc" "\ Descending recursively from DIR, make a tag called NAME. For each registered file, the working revision becomes part of @@ -36129,6 +35472,7 @@ If NAME is empty, it refers to the latest revisions of the current branch. If locking is used for the files in DIR, then there must not be any locked files at or below DIR (but if NAME is empty, locked files are allowed and simply skipped). +This function runs the hook `vc-retrieve-tag-hook' when finished. \(fn DIR NAME)" t nil) @@ -36168,6 +35512,12 @@ When called interactively with a prefix argument, prompt for REMOTE-LOCATION. \(fn &optional REMOTE-LOCATION)" t nil) +(autoload 'vc-log-mergebase "vc" "\ +Show a log of changes between the merge base of REV1 and REV2 revisions. +The merge base is a common ancestor between REV1 and REV2 revisions. + +\(fn FILES REV1 REV2)" t nil) + (autoload 'vc-region-history "vc" "\ Show the history of the region between FROM and TO. @@ -36179,9 +35529,7 @@ mark. (autoload 'vc-revert "vc" "\ Revert working copies of the selected fileset to their repository contents. This asks for confirmation if the buffer contents are not identical -to the working revision (except for keyword expansion). - -\(fn)" t nil) +to the working revision (except for keyword expansion)." t nil) (define-obsolete-function-alias 'vc-revert-buffer 'vc-revert "23.1") @@ -36488,7 +35836,7 @@ For a description of possible values, see `vc-check-master-templates'.") (defun vc-sccs-search-project-dir (_dirname basename) "\ Return the name of a master file in the SCCS project directory. Does not check whether the file exists but returns nil if it does not -find any project directory." (let ((project-dir (getenv "PROJECTDIR")) dirs dir) (when project-dir (if (file-name-absolute-p project-dir) (setq dirs (quote ("SCCS" ""))) (setq dirs (quote ("src/SCCS" "src" "source/SCCS" "source"))) (setq project-dir (expand-file-name (concat "~" project-dir)))) (while (and (not dir) dirs) (setq dir (expand-file-name (car dirs) project-dir)) (unless (file-directory-p dir) (setq dir nil) (setq dirs (cdr dirs)))) (and dir (expand-file-name (concat "s." basename) dir))))) +find any project directory." (let ((project-dir (getenv "PROJECTDIR")) dirs dir) (when project-dir (if (file-name-absolute-p project-dir) (setq dirs '("SCCS" "")) (setq dirs '("src/SCCS" "src" "source/SCCS" "source")) (setq project-dir (expand-file-name (concat "~" project-dir)))) (while (and (not dir) dirs) (setq dir (expand-file-name (car dirs) project-dir)) (unless (file-directory-p dir) (setq dir nil) (setq dirs (cdr dirs)))) (and dir (expand-file-name (concat "s." basename) dir))))) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc-sccs" '("vc-sccs-"))) @@ -36730,7 +36078,7 @@ Key bindings specific to `verilog-mode-map' are: \(fn)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "verilog-mode" '("vl-" "verilog-" "electric-verilog-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "verilog-mode" '("electric-verilog-" "verilog-" "vl-"))) ;;;*** @@ -37308,9 +36656,7 @@ positions (integers or markers) specifying the stretch of the region. \(fn FROM TO)" t nil) (autoload 'viet-decode-viqr-buffer "viet-util" "\ -Convert `VIQR' mnemonics of the current buffer to Vietnamese characters. - -\(fn)" t nil) +Convert `VIQR' mnemonics of the current buffer to Vietnamese characters." t nil) (autoload 'viet-encode-viqr-region "viet-util" "\ Convert Vietnamese characters of the current region to `VIQR' mnemonics. @@ -37320,9 +36666,7 @@ positions (integers or markers) specifying the stretch of the region. \(fn FROM TO)" t nil) (autoload 'viet-encode-viqr-buffer "viet-util" "\ -Convert Vietnamese characters of the current buffer to `VIQR' mnemonics. - -\(fn)" t nil) +Convert Vietnamese characters of the current buffer to `VIQR' mnemonics." t nil) (autoload 'viqr-post-read-conversion "viet-util" "\ @@ -37473,9 +36817,11 @@ own View-like bindings. (autoload 'view-mode "view" "\ Toggle View mode, a minor mode for viewing text but not editing it. -With a prefix argument ARG, enable View mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable View mode -if ARG is omitted or nil. + +If called interactively, enable View mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. When View mode is enabled, commands that do not change the buffer contents are available as usual. Kill commands insert text in @@ -37588,11 +36934,9 @@ This function runs the normal hook `view-mode-hook'. \(fn &optional QUIT-RESTORE EXIT-ACTION)" nil nil) (autoload 'View-exit-and-edit "view" "\ -Exit View mode and make the current buffer editable. - -\(fn)" t nil) +Exit View mode and make the current buffer editable." t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "view" '("view-" "View-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "view" '("View-" "view-"))) ;;;*** @@ -37602,16 +36946,12 @@ Exit View mode and make the current buffer editable. (autoload 'toggle-viper-mode "viper" "\ Toggle Viper on/off. -If Viper is enabled, turn it off. Otherwise, turn it on. - -\(fn)" t nil) +If Viper is enabled, turn it off. Otherwise, turn it on." t nil) (autoload 'viper-mode "viper" "\ -Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'. - -\(fn)" t nil) +Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'." t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper" '("viper-" "set-viper-state-in-major-mode" "this-major-mode-requires-vi-state"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper" '("set-viper-state-in-major-mode" "this-major-mode-requires-vi-state" "viper-"))) ;;;*** @@ -37642,7 +36982,7 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'. ;;;;;; 0 0)) ;;; Generated autoloads from emulation/viper-keym.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper-keym" '("viper-" "ex-read-filename-map"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper-keym" '("ex-read-filename-map" "viper-"))) ;;;*** @@ -37650,7 +36990,7 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'. ;;;;;; 0 0)) ;;; Generated autoloads from emulation/viper-macs.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper-macs" '("viper-" "ex-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper-macs" '("ex-" "viper-"))) ;;;*** @@ -37752,8 +37092,9 @@ has to create the buffer, it disables undo in the buffer. See the `warnings' custom group for user customization features. -See also `warning-series', `warning-prefix-function' and -`warning-fill-prefix' for additional programming features. +See also `warning-series', `warning-prefix-function', +`warning-fill-prefix', and `warning-fill-column' for additional +programming features. \(fn TYPE MESSAGE &optional LEVEL BUFFER-NAME)" nil nil) @@ -37787,7 +37128,7 @@ this is equivalent to `display-warning', using \(fn MESSAGE &rest ARGS)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "warnings" '("warning-" "log-warning-minimum-level" "display-warning-minimum-level"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "warnings" '("display-warning-minimum-level" "log-warning-minimum-level" "warning-"))) ;;;*** @@ -37803,9 +37144,7 @@ buffer, the target of the links, and the permission bits of the files. After typing \\[wdired-finish-edit], Emacs modifies the files and directories to reflect your edits. -See `wdired-mode'. - -\(fn)" t nil) +See `wdired-mode'." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "wdired" '("wdired-"))) @@ -37821,9 +37160,7 @@ See the documentation for the `webjump-sites' variable for how to customize the hotlist. Please submit bug reports and other feedback to the author, Neil W. Van Dyke -<nwv@acm.org>. - -\(fn)" t nil) +<nwv@acm.org>." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "webjump" '("webjump-"))) @@ -37849,9 +37186,11 @@ or call the function `which-function-mode'.") (autoload 'which-function-mode "which-func" "\ Toggle mode line display of current function (Which Function mode). -With a prefix argument ARG, enable Which Function mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Which-Function mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Which Function mode is a global minor mode. When enabled, the current function name is continuously displayed in the mode line, @@ -37869,11 +37208,11 @@ in certain major modes. (autoload 'whitespace-mode "whitespace" "\ Toggle whitespace visualization (Whitespace mode). -With a prefix argument ARG, enable Whitespace mode if ARG is -positive, and disable it otherwise. -If called from Lisp, also enables the mode if ARG is omitted or nil, -and toggles it if ARG is `toggle'. +If called interactively, enable Whitespace mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. See also `whitespace-style', `whitespace-newline' and `whitespace-display-mappings'. @@ -37882,11 +37221,11 @@ See also `whitespace-style', `whitespace-newline' and (autoload 'whitespace-newline-mode "whitespace" "\ Toggle newline visualization (Whitespace Newline mode). -With a prefix argument ARG, enable Whitespace Newline mode if ARG -is positive, and disable it otherwise. -If called from Lisp, also enables the mode if ARG is omitted or nil, -and toggles it if ARG is `toggle'. +If called interactively, enable Whitespace-Newline mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Use `whitespace-newline-mode' only for NEWLINE visualization exclusively. For other visualizations, including NEWLINE @@ -37909,11 +37248,11 @@ or call the function `global-whitespace-mode'.") (autoload 'global-whitespace-mode "whitespace" "\ Toggle whitespace visualization globally (Global Whitespace mode). -With a prefix argument ARG, enable Global Whitespace mode if ARG -is positive, and disable it otherwise. -If called from Lisp, also enables the mode if ARG is omitted or nil, -and toggles it if ARG is `toggle'. +If called interactively, enable Global Whitespace mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. See also `whitespace-style', `whitespace-newline' and `whitespace-display-mappings'. @@ -37932,11 +37271,11 @@ or call the function `global-whitespace-newline-mode'.") (autoload 'global-whitespace-newline-mode "whitespace" "\ Toggle global newline visualization (Global Whitespace Newline mode). -With a prefix argument ARG, enable Global Whitespace Newline mode -if ARG is positive, and disable it otherwise. -If called from Lisp, also enables the mode if ARG is omitted or nil, -and toggles it if ARG is `toggle'. +If called interactively, enable Global Whitespace-Newline mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Use `global-whitespace-newline-mode' only for NEWLINE visualization exclusively. For other visualizations, including @@ -38142,9 +37481,7 @@ The problems cleaned up are: `space-after-tab::space', replace TABs by SPACEs. See `whitespace-style', `indent-tabs-mode' and `tab-width' for -documentation. - -\(fn)" t nil) +documentation." t nil) (autoload 'whitespace-cleanup-region "whitespace" "\ Cleanup some blank problems at region. @@ -38258,9 +37595,11 @@ Show widget browser for WIDGET in other window. (autoload 'widget-minor-mode "wid-browse" "\ Minor mode for traversing widgets. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. + +If called interactively, enable Widget minor mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. \(fn &optional ARG)" t nil) @@ -38298,15 +37637,13 @@ Call `insert' with ARGS even if surrounding text is read only. \(fn &rest ARGS)" nil nil) -(defvar widget-keymap (let ((map (make-sparse-keymap))) (define-key map " " 'widget-forward) (define-key map " " 'widget-backward) (define-key map [(shift tab)] 'widget-backward) (put 'widget-backward :advertised-binding [(shift tab)]) (define-key map [backtab] 'widget-backward) (define-key map [down-mouse-2] 'widget-button-click) (define-key map [down-mouse-1] 'widget-button-click) (define-key map [(control 109)] 'widget-button-press) map) "\ +(defvar widget-keymap (let ((map (make-sparse-keymap))) (define-key map "\11" 'widget-forward) (define-key map "\33\11" 'widget-backward) (define-key map [(shift tab)] 'widget-backward) (put 'widget-backward :advertised-binding [(shift tab)]) (define-key map [backtab] 'widget-backward) (define-key map [down-mouse-2] 'widget-button-click) (define-key map [down-mouse-1] 'widget-button-click) (define-key map [(control 109)] 'widget-button-press) map) "\ Keymap containing useful binding for buffers containing widgets. Recommended as a parent keymap for modes using widgets. Note that such modes will need to require wid-edit.") (autoload 'widget-setup "wid-edit" "\ -Setup current buffer so editing string widgets works. - -\(fn)" nil nil) +Setup current buffer so editing string widgets works." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "wid-edit" '("widget-"))) @@ -38321,7 +37658,8 @@ With no prefix argument, or with prefix argument equal to zero, \"left\" is relative to the position of point in the window; otherwise it is relative to the top edge (for positive ARG) or the bottom edge \(for negative ARG) of the current window. -If no window is at the desired location, an error is signaled. +If no window is at the desired location, an error is signaled +unless `windmove-create-window' is non-nil and a new window is created. \(fn &optional ARG)" t nil) @@ -38331,7 +37669,8 @@ With no prefix argument, or with prefix argument equal to zero, \"up\" is relative to the position of point in the window; otherwise it is relative to the left edge (for positive ARG) or the right edge (for negative ARG) of the current window. -If no window is at the desired location, an error is signaled. +If no window is at the desired location, an error is signaled +unless `windmove-create-window' is non-nil and a new window is created. \(fn &optional ARG)" t nil) @@ -38341,7 +37680,8 @@ With no prefix argument, or with prefix argument equal to zero, \"right\" is relative to the position of point in the window; otherwise it is relative to the top edge (for positive ARG) or the bottom edge (for negative ARG) of the current window. -If no window is at the desired location, an error is signaled. +If no window is at the desired location, an error is signaled +unless `windmove-create-window' is non-nil and a new window is created. \(fn &optional ARG)" t nil) @@ -38351,16 +37691,114 @@ With no prefix argument, or with prefix argument equal to zero, \"down\" is relative to the position of point in the window; otherwise it is relative to the left edge (for positive ARG) or the right edge \(for negative ARG) of the current window. -If no window is at the desired location, an error is signaled. +If no window is at the desired location, an error is signaled +unless `windmove-create-window' is non-nil and a new window is created. \(fn &optional ARG)" t nil) (autoload 'windmove-default-keybindings "windmove" "\ Set up keybindings for `windmove'. -Keybindings are of the form MODIFIER-{left,right,up,down}. -Default MODIFIER is `shift'. +Keybindings are of the form MODIFIERS-{left,right,up,down}, +where MODIFIERS is either a list of modifiers or a single modifier. +Default value of MODIFIERS is `shift'. + +\(fn &optional MODIFIERS)" t nil) + +(autoload 'windmove-display-left "windmove" "\ +Display the next buffer in window to the left of the current one. +See the logic of the prefix ARG in `windmove-display-in-direction'. + +\(fn &optional ARG)" t nil) + +(autoload 'windmove-display-up "windmove" "\ +Display the next buffer in window above the current one. +See the logic of the prefix ARG in `windmove-display-in-direction'. + +\(fn &optional ARG)" t nil) -\(fn &optional MODIFIER)" t nil) +(autoload 'windmove-display-right "windmove" "\ +Display the next buffer in window to the right of the current one. +See the logic of the prefix ARG in `windmove-display-in-direction'. + +\(fn &optional ARG)" t nil) + +(autoload 'windmove-display-down "windmove" "\ +Display the next buffer in window below the current one. +See the logic of the prefix ARG in `windmove-display-in-direction'. + +\(fn &optional ARG)" t nil) + +(autoload 'windmove-display-same-window "windmove" "\ +Display the next buffer in the same window. + +\(fn &optional ARG)" t nil) + +(autoload 'windmove-display-default-keybindings "windmove" "\ +Set up keybindings for directional buffer display. +Keys are bound to commands that display the next buffer in the specified +direction. Keybindings are of the form MODIFIERS-{left,right,up,down}, +where MODIFIERS is either a list of modifiers or a single modifier. +Default value of MODIFIERS is `shift-meta'. + +\(fn &optional MODIFIERS)" t nil) + +(autoload 'windmove-delete-left "windmove" "\ +Delete the window to the left of the current one. +If prefix ARG is `C-u', delete the selected window and +select the window that was to the left of the current one. + +\(fn &optional ARG)" t nil) + +(autoload 'windmove-delete-up "windmove" "\ +Delete the window above the current one. +If prefix ARG is `C-u', delete the selected window and +select the window that was above the current one. + +\(fn &optional ARG)" t nil) + +(autoload 'windmove-delete-right "windmove" "\ +Delete the window to the right of the current one. +If prefix ARG is `C-u', delete the selected window and +select the window that was to the right of the current one. + +\(fn &optional ARG)" t nil) + +(autoload 'windmove-delete-down "windmove" "\ +Delete the window below the current one. +If prefix ARG is `C-u', delete the selected window and +select the window that was below the current one. + +\(fn &optional ARG)" t nil) + +(autoload 'windmove-delete-default-keybindings "windmove" "\ +Set up keybindings for directional window deletion. +Keys are bound to commands that delete windows in the specified +direction. Keybindings are of the form PREFIX MODIFIERS-{left,right,up,down}, +where PREFIX is a prefix key and MODIFIERS is either a list of modifiers or +a single modifier. Default value of PREFIX is `C-x' and MODIFIERS is `shift'. + +\(fn &optional PREFIX MODIFIERS)" t nil) + +(autoload 'windmove-swap-states-left "windmove" "\ +Swap the states with the window on the left from the current one." t nil) + +(autoload 'windmove-swap-states-up "windmove" "\ +Swap the states with the window above from the current one." t nil) + +(autoload 'windmove-swap-states-down "windmove" "\ +Swap the states with the window below from the current one." t nil) + +(autoload 'windmove-swap-states-right "windmove" "\ +Swap the states with the window on the right from the current one." t nil) + +(autoload 'windmove-swap-states-default-keybindings "windmove" "\ +Set up keybindings for directional window swap states. +Keys are bound to commands that swap the states of the selected window +with the window in the specified direction. Keybindings are of the form +MODIFIERS-{left,right,up,down}, where MODIFIERS is either a list of modifiers +or a single modifier. Default value of MODIFIERS is `shift-super'. + +\(fn &optional MODIFIERS)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "windmove" '("windmove-"))) @@ -38381,9 +37819,11 @@ or call the function `winner-mode'.") (autoload 'winner-mode "winner" "\ Toggle Winner mode on or off. -With a prefix argument ARG, enable Winner mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'. + +If called interactively, enable Winner mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. Winner mode is a global minor mode that records the changes in the window configuration (i.e. how the frames are partitioned @@ -38425,9 +37865,7 @@ should be a topic string and non-nil RE-CACHE forces re-caching. \(fn &optional TOPIC RE-CACHE)" t nil) (autoload 'woman-dired-find-file "woman" "\ -In dired, run the WoMan man-page browser on this file. - -\(fn)" t nil) +In dired, run the WoMan man-page browser on this file." t nil) (autoload 'woman-find-file "woman" "\ Find, decode and browse a specific UN*X man-page source file FILE-NAME. @@ -38445,7 +37883,7 @@ Default bookmark handler for Woman buffers. \(fn BOOKMARK)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "woman" '("woman" "WoMan-" "menu-bar-manuals-menu" "set-woman-file-regexp"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "woman" '("WoMan-" "menu-bar-manuals-menu" "set-woman-file-regexp" "woman"))) ;;;*** @@ -38517,6 +37955,12 @@ Both features can be combined by providing a cons cell \(fn &optional BEG END BUFFER PARSE-DTD PARSE-NS)" nil nil) +(autoload 'xml-remove-comments "xml" "\ +Remove XML/HTML comments in the region between BEG and END. +All text between the <!-- ... --> markers will be removed. + +\(fn BEG END)" nil nil) + (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "xml" '("xml-"))) ;;;*** @@ -38544,20 +37988,13 @@ 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 -(autoload 'xref-find-backend "xref" "\ - - -\(fn)" nil nil) +(autoload 'xref-find-backend "xref" nil nil nil) (autoload 'xref-pop-marker-stack "xref" "\ -Pop back to where \\[xref-find-definitions] was last invoked. - -\(fn)" t nil) +Pop back to where \\[xref-find-definitions] was last invoked." t nil) (autoload 'xref-marker-stack-empty-p "xref" "\ -Return t if the marker stack is empty; nil otherwise. - -\(fn)" nil nil) +Return t if the marker stack is empty; nil otherwise." nil nil) (autoload 'xref-find-definitions "xref" "\ Find the definition of the identifier at point. @@ -38591,6 +38028,12 @@ is nil, prompt only if there's no usable symbol at point. \(fn IDENTIFIER)" t nil) +(autoload 'xref-find-definitions-at-mouse "xref" "\ +Find the definition of identifier at or around mouse click. +This command is intended to be bound to a mouse event. + +\(fn EVENT)" t nil) + (autoload 'xref-find-apropos "xref" "\ Find all meaningful symbols that match PATTERN. The argument has the same meaning as in `apropos'. @@ -38617,7 +38060,7 @@ IGNORES is a list of glob patterns. ;;;### (autoloads nil "xscheme" "progmodes/xscheme.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/xscheme.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "xscheme" '("xscheme-" "start-scheme" "scheme-" "exit-scheme-interaction-mode" "verify-xscheme-buffer" "local-" "global-set-scheme-interaction-buffer" "run-scheme" "reset-scheme" "default-xscheme-runlight"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "xscheme" '("default-xscheme-runlight" "exit-scheme-interaction-mode" "global-set-scheme-interaction-buffer" "local-" "reset-scheme" "run-scheme" "scheme-" "start-scheme" "verify-xscheme-buffer" "xscheme-"))) ;;;*** @@ -38643,9 +38086,11 @@ or call the function `xterm-mouse-mode'.") (autoload 'xterm-mouse-mode "xt-mouse" "\ Toggle XTerm mouse mode. -With a prefix argument ARG, enable XTerm mouse mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. + +If called interactively, enable Xterm-Mouse mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. 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 @@ -38683,9 +38128,7 @@ Yenc decode region between START and END using an internal decoder. \(fn START END)" t nil) (autoload 'yenc-extract-filename "yenc" "\ -Extract file name from an yenc header. - -\(fn)" nil nil) +Extract file name from an yenc header." nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "yenc" '("yenc-"))) @@ -38702,9 +38145,7 @@ Extract file name from an yenc header. ;;; Generated autoloads from play/zone.el (autoload 'zone "zone" "\ -Zone out, completely. - -\(fn)" t nil) +Zone out, completely." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "zone" '("zone-"))) @@ -38755,18 +38196,37 @@ Zone out, completely. ;;;;;; "emacs-lisp/eieio-opt.el" "emacs-lisp/eldoc.el" "emacs-lisp/float-sup.el" ;;;;;; "emacs-lisp/lisp-mode.el" "emacs-lisp/lisp.el" "emacs-lisp/macroexp.el" ;;;;;; "emacs-lisp/map-ynp.el" "emacs-lisp/nadvice.el" "emacs-lisp/syntax.el" -;;;;;; "emacs-lisp/timer.el" "env.el" "epa-hook.el" "eshell/em-alias.el" -;;;;;; "eshell/em-banner.el" "eshell/em-basic.el" "eshell/em-cmpl.el" -;;;;;; "eshell/em-dirs.el" "eshell/em-glob.el" "eshell/em-hist.el" -;;;;;; "eshell/em-ls.el" "eshell/em-pred.el" "eshell/em-prompt.el" -;;;;;; "eshell/em-rebind.el" "eshell/em-script.el" "eshell/em-smart.el" -;;;;;; "eshell/em-term.el" "eshell/em-tramp.el" "eshell/em-unix.el" -;;;;;; "eshell/em-xtra.el" "facemenu.el" "faces.el" "files.el" "font-core.el" -;;;;;; "font-lock.el" "format.el" "frame.el" "help.el" "hfy-cmap.el" -;;;;;; "ibuf-ext.el" "indent.el" "international/characters.el" "international/charscript.el" +;;;;;; "emacs-lisp/timer.el" "env.el" "epa-hook.el" "erc/erc-autoaway.el" +;;;;;; "erc/erc-button.el" "erc/erc-capab.el" "erc/erc-compat.el" +;;;;;; "erc/erc-dcc.el" "erc/erc-desktop-notifications.el" "erc/erc-ezbounce.el" +;;;;;; "erc/erc-fill.el" "erc/erc-identd.el" "erc/erc-imenu.el" +;;;;;; "erc/erc-join.el" "erc/erc-list.el" "erc/erc-log.el" "erc/erc-match.el" +;;;;;; "erc/erc-menu.el" "erc/erc-netsplit.el" "erc/erc-notify.el" +;;;;;; "erc/erc-page.el" "erc/erc-pcomplete.el" "erc/erc-replace.el" +;;;;;; "erc/erc-ring.el" "erc/erc-services.el" "erc/erc-sound.el" +;;;;;; "erc/erc-speedbar.el" "erc/erc-spelling.el" "erc/erc-stamp.el" +;;;;;; "erc/erc-track.el" "erc/erc-truncate.el" "erc/erc-xdcc.el" +;;;;;; "eshell/em-alias.el" "eshell/em-banner.el" "eshell/em-basic.el" +;;;;;; "eshell/em-cmpl.el" "eshell/em-dirs.el" "eshell/em-glob.el" +;;;;;; "eshell/em-hist.el" "eshell/em-ls.el" "eshell/em-pred.el" +;;;;;; "eshell/em-prompt.el" "eshell/em-rebind.el" "eshell/em-script.el" +;;;;;; "eshell/em-smart.el" "eshell/em-term.el" "eshell/em-tramp.el" +;;;;;; "eshell/em-unix.el" "eshell/em-xtra.el" "facemenu.el" "faces.el" +;;;;;; "files.el" "font-core.el" "font-lock.el" "format.el" "frame.el" +;;;;;; "help.el" "hfy-cmap.el" "ibuf-ext.el" "indent.el" "international/characters.el" +;;;;;; "international/charprop.el" "international/charscript.el" ;;;;;; "international/cp51932.el" "international/eucjp-ms.el" "international/mule-cmds.el" -;;;;;; "international/mule-conf.el" "international/mule.el" "isearch.el" -;;;;;; "jit-lock.el" "jka-cmpr-hook.el" "language/burmese.el" "language/cham.el" +;;;;;; "international/mule-conf.el" "international/mule.el" "international/uni-bidi.el" +;;;;;; "international/uni-brackets.el" "international/uni-category.el" +;;;;;; "international/uni-combining.el" "international/uni-comment.el" +;;;;;; "international/uni-decimal.el" "international/uni-decomposition.el" +;;;;;; "international/uni-digit.el" "international/uni-lowercase.el" +;;;;;; "international/uni-mirrored.el" "international/uni-name.el" +;;;;;; "international/uni-numeric.el" "international/uni-old-name.el" +;;;;;; "international/uni-special-lowercase.el" "international/uni-special-titlecase.el" +;;;;;; "international/uni-special-uppercase.el" "international/uni-titlecase.el" +;;;;;; "international/uni-uppercase.el" "isearch.el" "jit-lock.el" +;;;;;; "jka-cmpr-hook.el" "language/burmese.el" "language/cham.el" ;;;;;; "language/chinese.el" "language/cyrillic.el" "language/czech.el" ;;;;;; "language/english.el" "language/ethiopic.el" "language/european.el" ;;;;;; "language/georgian.el" "language/greek.el" "language/hebrew.el" @@ -38789,29 +38249,29 @@ Zone out, completely. ;;;;;; "leim/quail/latin-post.el" "leim/quail/latin-pre.el" "leim/quail/persian.el" ;;;;;; "leim/quail/programmer-dvorak.el" "leim/quail/py-punct.el" ;;;;;; "leim/quail/pypunct-b5.el" "leim/quail/quick-b5.el" "leim/quail/quick-cns.el" -;;;;;; "leim/quail/rfc1345.el" "leim/quail/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-keys.el" -;;;;;; "org/ob-lob.el" "org/ob-matlab.el" "org/ob-tangle.el" "org/ob.el" -;;;;;; "org/org-archive.el" "org/org-attach.el" "org/org-bbdb.el" -;;;;;; "org/org-clock.el" "org/org-datetree.el" "org/org-element.el" -;;;;;; "org/org-feed.el" "org/org-footnote.el" "org/org-id.el" "org/org-indent.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-keys.el" "org/ob-lob.el" +;;;;;; "org/ob-matlab.el" "org/ob-tangle.el" "org/ob.el" "org/org-archive.el" +;;;;;; "org/org-attach.el" "org/org-bbdb.el" "org/org-clock.el" +;;;;;; "org/org-datetree.el" "org/org-element.el" "org/org-feed.el" +;;;;;; "org/org-footnote.el" "org/org-id.el" "org/org-indent.el" ;;;;;; "org/org-install.el" "org/org-irc.el" "org/org-mobile.el" ;;;;;; "org/org-plot.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-man.el" "org/ox-md.el" "org/ox-odt.el" ;;;;;; "org/ox-org.el" "org/ox-publish.el" "org/ox-texinfo.el" "org/ox.el" -;;;;;; "progmodes/elisp-mode.el" "progmodes/prog-mode.el" "ps-def.el" -;;;;;; "ps-mule.el" "register.el" "replace.el" "rfn-eshadow.el" -;;;;;; "select.el" "simple.el" "startup.el" "subdirs.el" "subr.el" -;;;;;; "textmodes/fill.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" +;;;;;; "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" "textmodes/fill.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" "textmodes/reftex-sel.el" ;;;;;; "textmodes/reftex-toc.el" "textmodes/text-mode.el" "uniquify.el" ;;;;;; "vc/ediff-hook.el" "vc/vc-hooks.el" "version.el" "widget.el" diff --git a/lisp/leim/quail/croatian.el b/lisp/leim/quail/croatian.el index 9d3def9827c..8fefe1cf821 100644 --- a/lisp/leim/quail/croatian.el +++ b/lisp/leim/quail/croatian.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2003-2019 Free Software Foundation, Inc. -;; Author: Hrvoje Nikšić <hniksic@xemacs.org> +;; Author: Hrvoje Nikšić <hrvoje.niksic@avl.com> ;; Keywords: i18n ;; This file is part of GNU Emacs. diff --git a/lisp/leim/quail/cyril-jis.el b/lisp/leim/quail/cyril-jis.el index 0214a51d74e..67271ab3c47 100644 --- a/lisp/leim/quail/cyril-jis.el +++ b/lisp/leim/quail/cyril-jis.el @@ -32,114 +32,110 @@ ;;; Code: (quail-define-package - "cyrillic-jis-russian" "Cyrillic" "$B'('+(B" nil - "$B'+'8'5','&'/(B keyboard layout same as JCUKEN (JIS X0208.1983 encoding)" + "cyrillic-jis-russian" "Cyrillic" "ЖЙ" nil + "ЙЦУКЕН keyboard layout same as JCUKEN (JIS X0208.1983 encoding)" nil t t t t nil nil nil nil nil t) -;; 1! 2@ 3# 4" 5: 6, 7. 8* 9( 0) -_ =+ ,L!(B -;; ,L9(B ,LF(B ,LC(B ,L:(B ,L5(B ,L=(B ,L3(B ,LH(B ,LI(B ,L7(B ,LE(B ,Lj(B -;; ,LD(B ,LK(B ,L2(B ,L0(B ,L?(B ,L@(B ,L>(B ,L;(B ,L4(B ,L6(B ,LM(B -;; ,LO(B ,LG(B ,LA(B ,L<(B ,L8(B ,LB(B ,LL(B ,L1(B ,LN(B /? +;; 1! 2@ 3# 4" 5: 6, 7. 8* 9( 0) -_ =+ Ё +;; Й Ц У К Е Н Г Ш Щ З Х ъ +;; Ф Ы В А П Р О Л Д Ж Э +;; Я Ч С М И Т Ь Б Ю /? (quail-define-rules - ("1" ?$B#1(B) - ("2" ?$B#2(B) - ("3" ?$B#3(B) - ("4" ?$B#4(B) - ("5" ?$B#5(B) - ("6" ?$B#6(B) - ("7" ?$B#7(B) - ("8" ?$B#8(B) - ("9" ?$B#9(B) - ("0" ?$B#0(B) - ("-" ?$B!](B) - ("=" ?$B!a(B) - ("`" ?$B'W(B) - ("q" ?$B'[(B) - ("w" ?$B'h(B) - ("e" ?$B'e(B) - ("r" ?$B'\(B) - ("t" ?$B'V(B) - ("y" ?$B'_(B) - ("u" ?$B'T(B) - ("i" ?$B'j(B) - ("o" ?$B'k(B) - ("p" ?$B'Y(B) - ("[" ?$B'g(B) - ("]" ?$B'l(B) - ("a" ?$B'f(B) - ("s" ?$B'm(B) - ("d" ?$B'S(B) - ("f" ?$B'Q(B) - ("g" ?$B'a(B) - ("h" ?$B'b(B) - ("j" ?$B'`(B) - ("k" ?$B'](B) - ("l" ?$B'U(B) - (";" ?$B'X(B) - ("'" ?$B'o(B) - ("\\" ?$B!@(B) - ("z" ?$B'q(B) - ("x" ?$B'i(B) - ("c" ?$B'c(B) - ("v" ?$B'^(B) - ("b" ?$B'Z(B) - ("n" ?$B'd(B) - ("m" ?$B'n(B) - ("," ?$B'R(B) - ("." ?$B'p(B) - ("/" ?$B!?(B) + ("1" ?1) + ("2" ?2) + ("3" ?3) + ("4" ?4) + ("5" ?5) + ("6" ?6) + ("7" ?7) + ("8" ?8) + ("9" ?9) + ("0" ?0) + ("-" ?−) + ("=" ?=) + ("`" ?ё) + ("q" ?й) + ("w" ?ц) + ("e" ?у) + ("r" ?к) + ("t" ?е) + ("y" ?н) + ("u" ?г) + ("i" ?ш) + ("o" ?щ) + ("p" ?з) + ("[" ?х) + ("]" ?ъ) + ("a" ?ф) + ("s" ?ы) + ("d" ?в) + ("f" ?а) + ("g" ?п) + ("h" ?р) + ("j" ?о) + ("k" ?л) + ("l" ?д) + (";" ?ж) + ("'" ?э) + ("\\" ?\) + ("z" ?я) + ("x" ?ч) + ("c" ?с) + ("v" ?м) + ("b" ?и) + ("n" ?т) + ("m" ?ь) + ("," ?б) + ("." ?ю) + ("/" ?/) - ("!" ?$B!*(B) - ("@" ?$B!w(B) - ("#" ?$B!t(B) - ("$" ?$B!I(B) - ("%" ?$B!'(B) - ("^" ?$B!$(B) - ("&" ?$B!%(B) - ("*" ?$B!v(B) - ("(" ?$B!J(B) - (")" ?$B!K(B) - ("_" ?$B!2(B) - ("+" ?$B!\(B) - ("~" ?$B''(B) - ("Q" ?$B'+(B) - ("W" ?$B'8(B) - ("E" ?$B'5(B) - ("R" ?$B',(B) - ("T" ?$B'&(B) - ("Y" ?$B'/(B) - ("U" ?$B'$(B) - ("I" ?$B':(B) - ("O" ?$B';(B) - ("P" ?$B')(B) - ("{" ?$B'7(B) - ("}" ?$B'<(B) - ("A" ?$B'6(B) - ("S" ?$B'=(B) - ("D" ?$B'#(B) - ("F" ?$B'!(B) - ("G" ?$B'1(B) - ("H" ?$B'2(B) - ("J" ?$B'0(B) - ("K" ?$B'-(B) - ("L" ?$B'%(B) - (":" ?$B'((B) - ("\"" ?$B'?(B) - ("|" ?$B!C(B) - ("Z" ?$B'A(B) - ("X" ?$B'9(B) - ("C" ?$B'3(B) - ("V" ?$B'.(B) - ("B" ?$B'*(B) - ("N" ?$B'4(B) - ("M" ?$B'>(B) - ("<" ?$B'"(B) - (">" ?$B'@(B) - ("?" ?$B!)(B)) - -;; Local Variables: -;; coding: iso-2022-7bit -;; End: + ("!" ?!) + ("@" ?@) + ("#" ?#) + ("$" ?”) + ("%" ?:) + ("^" ?,) + ("&" ?.) + ("*" ?*) + ("(" ?() + (")" ?)) + ("_" ?_) + ("+" ?+) + ("~" ?Ё) + ("Q" ?Й) + ("W" ?Ц) + ("E" ?У) + ("R" ?К) + ("T" ?Е) + ("Y" ?Н) + ("U" ?Г) + ("I" ?Ш) + ("O" ?Щ) + ("P" ?З) + ("{" ?Х) + ("}" ?Ъ) + ("A" ?Ф) + ("S" ?Ы) + ("D" ?В) + ("F" ?А) + ("G" ?П) + ("H" ?Р) + ("J" ?О) + ("K" ?Л) + ("L" ?Д) + (":" ?Ж) + ("\"" ?Э) + ("|" ?|) + ("Z" ?Я) + ("X" ?Ч) + ("C" ?С) + ("V" ?М) + ("B" ?И) + ("N" ?Т) + ("M" ?Ь) + ("<" ?Б) + (">" ?Ю) + ("?" ??)) ;;; cyril-jis.el ends here diff --git a/lisp/leim/quail/georgian.el b/lisp/leim/quail/georgian.el index 61003b8f99c..a1cdb584653 100644 --- a/lisp/leim/quail/georgian.el +++ b/lisp/leim/quail/georgian.el @@ -22,8 +22,14 @@ ;;; Commentary: -;; Georgian input following the Yudit map from Mark Leisher -;; <mleisher@crl.nmsu.edu>. +;; This file defines the following Georgian keyboards: +;; +;; - Georgian input following the Yudit map from Mark Leisher +;; <mleisher@crl.nmsu.edu>. +;; +;; - QWERTY-based Georgian. +;; +;; - QWERTY-based Nuskhuri script. ;;; Code: @@ -74,10 +80,103 @@ ("i1" ?ჲ) ("w" ?ჳ) ("f" ?ჶ) - ;; Presumably, these are GEORGIAN LETTER YN, GEORGIAN LETTER ELIFI, - ;; accepted for U+10F7, U+10F8 -- fx - ("y" ?) ;; Letter not in Unicode (private use code). - ("e1" ?) ;; Letter not in Unicode (private use code). + ("y" ?ჷ) + ("e1" ?ჸ) + ) + +(quail-define-package + "georgian-qwerty" "Georgian" "ქ" t + "Georgian input based on QWERTY keyboard." + nil t nil nil t nil nil nil nil nil t) + +(quail-define-rules + ("a" ?ა) + ("b" ?ბ) + ("g" ?გ) + ("d" ?დ) + ("e" ?ე) + ("v" ?ვ) + ("z" ?ზ) + ("T" ?თ) + ("i" ?ი) + ("k" ?კ) + ("l" ?ლ) + ("m" ?მ) + ("n" ?ნ) + ("o" ?ო) + ("p" ?პ) + ("J" ?ჟ) + ("r" ?რ) + ("s" ?ს) + ("t" ?ტ) + ("u" ?უ) + ("f" ?ფ) + ("q" ?ქ) + ("R" ?ღ) + ("y" ?ყ) + ("S" ?შ) + ("C" ?ჩ) + ("c" ?ც) + ("Z" ?ძ) + ("w" ?წ) + ("W" ?ჭ) + ("x" ?ხ) + ("j" ?ჯ) + ("h" ?ჰ) + ("X" ?ჴ) + ("H" ?ჱ) + ("K" ?ჵ) + ("I" ?ჲ) + ("V" ?ჳ) + ("F" ?ჶ) + ("Y" ?ჸ) + ("G" ?ჷ) + ) + +(quail-define-package + "georgian-nuskhuri" "Georgian" "ⴌ" t + "Nuskhuri Georgian (QWERTY-based)." + nil t nil nil t nil nil nil nil nil t) + +(quail-define-rules + ("a" ?ⴀ) + ("b" ?ⴁ) + ("g" ?ⴂ) + ("d" ?ⴃ) + ("e" ?ⴄ) + ("v" ?ⴅ) + ("z" ?ⴆ) + ("T" ?ⴇ) + ("i" ?ⴈ) + ("k" ?ⴉ) + ("l" ?ⴊ) + ("m" ?ⴋ) + ("n" ?ⴌ) + ("o" ?ⴍ) + ("p" ?ⴎ) + ("J" ?ⴏ) + ("r" ?ⴐ) + ("s" ?ⴑ) + ("t" ?ⴒ) + ("u" ?ⴓ) + ("f" ?ⴔ) + ("q" ?ⴕ) + ("R" ?ⴖ) + ("y" ?ⴗ) + ("S" ?ⴘ) + ("C" ?ⴙ) + ("c" ?ⴚ) + ("Z" ?ⴛ) + ("w" ?ⴜ) + ("W" ?ⴝ) + ("x" ?ⴞ) + ("j" ?ⴟ) + ("h" ?ⴠ) + ("X" ?ⴤ) + ("H" ?ⴡ) + ("K" ?ⴥ) + ("I" ?ⴢ) + ("V" ?ⴣ) ) ;;; georgian.el ends here diff --git a/lisp/leim/quail/hanja-jis.el b/lisp/leim/quail/hanja-jis.el index 79730b816ef..6f753259456 100644 --- a/lisp/leim/quail/hanja-jis.el +++ b/lisp/leim/quail/hanja-jis.el @@ -1,4 +1,4 @@ -;;; hanja-jis.el --- Quail package for inputting Korean Hanja (JISX0208) -*-coding: iso-2022-7bit;-*- +;;; hanja-jis.el --- Quail package for inputting Korean Hanja (JISX0208) ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, ;; 2006, 2007, 2008, 2009, 2010, 2011 @@ -29,499 +29,499 @@ (require 'quail) (quail-define-package - "korean-hanja-jis" "Korean" "$B4A(B2" t - "2$(C9z=D(BJIS$B4A;z(B: $B3:aD$(CGO4B(B $B4A;z$(C@G(B $B1$$(C@;(B $(CGQ1[(B2$(C9z$B<0$(C@87N(B $B8F=P$(CGO?)(B $BA*Z$(B" + "korean-hanja-jis" "Korean" "漢2" t + "2벌식JIS漢字: 該當하는 漢字의 韻을 한글2벌式으로 呼出하여 選擇" nil nil nil nil nil nil t) (quail-define-rules - ("rk" "$B1]2>2@2A2B2C2D2E2G2H2K2M2N2Q2T2W2X2`2o3976P$PqQ+RjS'[H[I`]aPcwgWhSkEkhlKlhmF(B") - ("rkr" "$B3F3J3L3P3Q3S3U5Q5S9oH9RJS>T=WmXBZ([d]W`Bk4l;r((B") - ("rks" "$B064%4&4)4/43444B4G4H4J4N4V:&:):1?{U!XLYc[8[K[Y[e`CarcCecgek]s*su(B") - ("rkf" "$B2p3e3i3k3l7GP"[+brcqf;iypbpv(B") - ("rka" "$B4*4.46484:4;4E4F4U7g848::0QaT,T0VHY"Y~\m]>^@aQbWeHiTm^nGoHs|(B") - ("rkq" "$B2!389C9gL(R:b5fpo^(B") - ("rkd" "$B2,3`6/607D9/959>9G9K9P9V9]9_9dFzP6Q,S3U*V>XMY,[:[|aEbee,eZf5i(jvlora(B") - ("ro" "$B2B2U2p2r2~3'3)3+3,3.313435383;8DP"P$PCQsXAXhYb\4^taNb5k;(B") - ("ror" "$B5RS=(B") - ("rod" "$B9#99dkf=f>o3(B") - ("ri" "$B2X(B") - ("rir" "$BnS(B") - ("rj" "$B5n5o5p5q5r5t5w5x<V?x?~P`PbTRZ!Z)Z*]0_Yc@d(gplwn1nSnj(B") - ("rjs" "$B4%6R7o7r7z80X4Ykg'iJkim!qZ(B") - ("rjf" "$B3i7G7f8pC4KqPu[?[\]ccq(B") - ("rja" "$B4;7p7u8!84Q-QxQyQzQ{\}b[g@sX(B") - ("rjq" "$B5h619e=&Qg(B") - ("rp" "$B7F7GPuX\br(B") - ("rur" "$B2>3J3V3W7b7cPqYH\|g-h#k.ojqnr/rps&(B") - ("rus" "$B3_3o7x8#8$8(8*8+8/G{KzLzPWVtWz[G`Fa+d*f0l$s$(B") - ("ruf" "$B5K7@7h7i7k7mLRQSY1YIYMe~r!(B") - ("rua" "$B3y7s8,XDY:]>d/heni(B") - ("ruq" "$B3fKKXDnw(B") - ("rud" "$B5~6%6*6-6@6C797B7D7I7J7P7T7U7Y7Z7[7_9.999<9E9L:"P7Q?QDQHQmR&R'S+WMX]\{_i`{a9a[b~e%e4e;fVfzh3krmKmtpopts](B") - ("rP" "$B2|3#3&3,5(787<7@7K7L7N7O7Q7R7W7\:fFOU|W@X)[G^da8b#c4d"e;eki)kSl0r!s1(B") - ("rh" "$B6l8E8G8H8I8K8N8O8S8T8V8Z8[8\8]9F9M9Q9b9i9p;)<J?,C!ONPFQYQjRmZ?ZJZ^[W[][^\I\_]xa`b(bPb\cLd2f*f6fxiVjCk8kFkUlKmcn~pQrurzsi(B") - ("rhr" "$B6J9p9r9s9tC+H#S-ZO[g\`mXq~(B") - ("rhs" "$B:$:%:+:-:.TgVBW}[~^xhBjnrArJs.(B") - ("rhf" "$B3j9|\K]qs3(B") - ("rhd" "$B6!6&62636u8x8y9&9)95969WPeW0YJ[}\Jd3iOi^i_lop_(B") - ("rhk" "$B1;2I2J2L2[2]2a8S8X8YFiTFTnTrXyfxhTixjglvpy(B") - ("rhkr" "$B3G3TZ2Z<[v\Zayb_oWp9(B") - ("rhks" "$B4'4142474=4>4C4I4P4Q4S4X4[4\6z?{P%QN]Y^ub9eEeGf%k7oQopsA(B") - ("rhkf" "$B3g3hH&I0Qi[XfZ(B") - ("rhkd" "$B3H6)688w9-9[9\T]W"Z2[%[&[Z^+bhc~d!e&e-fykToJ(B") - ("rho" "$B3]757SS%XyYL[Jjh(B") - ("rhl" "$B2q2t2u2x2z2}3!P*PzTUW_XC\G`skK(B") - ("rhlr" "$Bg2qE(B") - ("rhld" "$B9(9I9O9l^3mDo)(B") - ("ry" "$B3I3P3S3z5j6#6+6,65666:6>8r8s9'9*9;9J9Y9Z;->7R{UHYxZJ\r_$`Db)c#c\fKg1i`m]n[q-qaqb(B") - ("rn" "$B11192$2%2*3C555V5W5X5_5a5d5e5f5l5q6e6f6g6h6i6j6k6m6n6o6p6q7)8{8}9$949=9B9XC!G#H7KUP}QJR"R?RkSRU=UBUdVOV}V~WaW|XvY+Yl[M[N]?]X]\a.aLbZc`d@gOgQgqhgiUjMjdk2kMkpmsn)n9nlplq'qDq\r-szs}(B") - ("rnr" "$B5E5F5G6I9m9qSxT"[xdxkqlr(B") - ("rns" "$B7/727374[ub0b1c[f:je(B") - ("rnf" "$B6~7!7"KYPcRPVA(B") - ("rnd" "$B5\5]5gcVm;(B") - ("rnjs" "$B4+4,5s7q7t7w7}7~8"R%R0RKT!X+[{\^bGe<ipq"(B") - ("rnjf" "$B7!OOP-RP`Um,om(B") - ("rnp" "$B4y5"50B|DYQ\R<[z]$]Eb'dOgLkLlnm,q9q?(B") - ("rnl" "$B5"5.5455S@[z]Eb's}(B") - ("rnlr" "$BDOVn(B") - ("rb" "$B0*1.5,5j6+6e7=7>:"DPTwYdYw\\b#bkcad}eYj_lbm|oaqDr-(B") - ("rbs" "$B556Q6]d0nbsKs}(B") - ("rbf" "$B5L(B") - ("rmr" "$B2D3W6K7`7a7d9nP4QnUqV![yh{n<(B") - ("rms" "$B6O6P6R6T6Z6\6`6a:,Xi\]`wbbhAk3ncq<(B") - ("rmf" "$B7@k?(B") - ("rma" "$B6S6W6X6Y6^6_6b8i:#SaZ"jPsX(B") - ("rmq" "$B075Z5^5b5h5i5kV)(B") - ("rmd" "$B919NOJOKQ>Wqbb(B") - ("rl" "$B0k4k4l4o4p4q4s4t4v4w4z4{4|4}4~5!5$5%5&5'5*5-5/5253585;5=5@5o778J8k8p:j:k:l<(B6H)IIL'P4PXQCQpSOSZT-TtV?W1YVZ\Zz[.[9[L[w\H]c]f]k^?aCc2cEe:f3f4fMk+k1kxl1leq@qVqgr?sJ(B") - ("rlr" "$B5J(B") - ("rls" "$B6[(B") - ("rlf" "$B5H5K5MPKYI(B") - ("rla" "$B6b(B") - ("Rlr" "$B5J(B") - ("sk" "$BF`FaFqQ5U1XoY.Y<Y=[kdy(B") - ("skr" "$BBz(B") - ("sks" "$BCHFqZ:_kl_(B") - ("skf" "$BFhYT^:(B") - ("ska" "$BCKFnFoSGU3n((B") - ("skq" "$BG<jU(B") - ("skd" "$BG9L<[((B") - ("so" "$BBQF`FbFwG5G6G=mr(B") - ("sid" "$B>nUP(B") - ("su" "$B=wY<Y=h'(B") - ("sus" "$BG/G2bzmY(B") - ("suf" "$BYT^:(B") - ("sua" "$BG0WwY@\,(B") - ("suq" "$B@]G1Ypm:oR(B") - ("sud" "$BG+Sf_?`Xfd(B") - ("sP" "$BG)Zc(B") - ("sh" "$BEXE[E\G>RsUWVfW8`obug*gBqN(B") - ("shd" "$BG;G?G@Q/(B") - ("shk" "$B<6(B") - ("shl" "$BG:G>X=g*q/(B") - ("sy" "$BE.G"U>Yz\vo?o_r)(B") - ("sn" "$BfU(B") - ("sns" "$BUD(B") - ("snf" "$BRefmkD(B") - ("sb" "$BI3WY`=nf(B") - ("sbr" "$BWYjHjI(B") - ("smd" "$BG=(B") - ("sl" "$BE%FtG)G*Wb_>_Pg7(B") - ("slr" "$BE.F?(B") - ("slf" "$BFtWbZc(B") - ("sla" "$BDBWl(B") - ("ek" "$BB?BgCcTl(B") - ("eks" "$B1_C"C0C1C4C6C;C<C=C@CACCCDCECGCICJFNFXP9SET%WAXIXUZR\g^Z`NaUeKh[iijXj{j|nBs((B") - ("ekf" "$BC#RtU'WeZ%_}`\m}orpZpg(B") - ("eka" "$BC4C8C9C?CLF^S7S8T`XkY?]__,_8abb>g<i!k)k}q5(B") - ("ekq" "$B7#EkEzF'Quh)(B") - ("ekd" "$BE^EbEdEvE|F2F5Q8Vq[c\+^oaDbUc'j0j;j}oFs^(B") - ("eo" "$B10BPBRBSBTBWB^B_BbBcBeBgFXT2UtVhZ,Z-`^gJi7o>p0(B") - ("ejr" "$BFAW\(B") - ("eh" "$B0p?^D)D7EHEIEKELEOEQERESETEUEYE]EaEgEhEiEmEnEpEqEsExE~F(F+F3F:F;R[T&V:Y[Y\YqZ.[7[m\*]%]9^9^mbQcKe6eBeCe{h8h9k/lum%mmokpkqC(B") - ("ehr" "$B<3FBFDFEFFFGFHFI`1`9`We{l&qqsb(B") - ("ehs" "$B=cFUFWFXFYFZF[F\Z}_wa&n,q+(B") - ("ehf" "$BFMF\Rt[S(B") - ("ehd" "$B4R6ME_E`ElEoF!F/F0F1F4F6F7F8F9F<Q*\u_.aVdig^gtr<s)sj(B") - ("en" "$B1%3u?`EMENEZEwF&F,FIP5Y5ceflh:iQjEjFl&nFr((B") - ("ens" "$BFVF[F\F_g=n,(B") - ("emr" "$BF@(B") - ("emd" "$BEPEtEuEyF#F%F*F-VS\t^naVc$d[d\eX(B") - ("fk" "$B;IMeMfMgSIXqapaziGn6oUozq`(B") - ("fkr" "$B3J3ZMlMmMnMoS>\[_``8`dqQ(B") - ("fks" "$BMpMqMsMvP,UO]3_Q_s`%k&oVolsB(B") - ("fkf" "$BQoSIT?T@dzme(B") - ("fka" "$BMrMtMuMwQ0U:Z0]4dWeqe|k"k5nN(B") - ("fkq" "$B@"O9YG[VgDgEoM(B") - ("fkd" "$BBlBmO-O/O1O2O5O:[-`f`gh>j'lplt(B") - ("fo" "$BPTWR(B") - ("fod" "$BNd(B") - ("fir" "$BN+N,Z6a@(B") - ("fid" "$BL:N+N<N>NBNCNHNINJNLPoQ@QZSJdmdnjllpltmQmRr4(B") - ("fu" "$B023BEWK{N7N8N9NeNoO$O?Q6R/S:W*[q]-`4`5avbjdze8eFg0gFh-i<iCiZjBoLocqfqk(B") - ("fur" "$BNONqNrV'[6]+],]._Ma|c*m`mapNr/(B") - ("fus" "$BNgNmNxNyNzN{N}N~O!O"O#SXXxYcZ;\Bf_gHmSo:rY(B") - ("fuf" "$BNsNtNuNvQXY`^0(B") - ("fua" "$B3yNwN|R=T~ZL_2_R(B") - ("fuq" "$BND`Zr'(B") - ("fud" "$BNNNaNbNfNgNhNjNkNmNnNpSz]2_:f9fYiYpMryst(B") - ("fP" "$BK-NcNiNlc9h-nTp1rg(B") - ("fh" "$B02:mH'IyN:O%O&O'O(O)O*O+O4O7R)S$Y}[E_#_3_I_N`$atb:gbgcgdiCmJmboNoOq!qfrisC(B") - ("fhr" "$B3Q9w</C+NPO<O=O?[rbqc3m\(B") - ("fhs" "$BO@^M(B") - ("fhd" "$BBlBmN5N6O.O6O8S/T;Tb[0\Y`|dFiDp/(B") - ("fhl" "$B@%MjMkN]O(Q4T^Z']*azb}d]f#fPi2iAkQlO(B") - ("fy" "$BN;N=N@NANENFNKUlW!Y|["_yegfXhznRoAs>(B") - ("fyd" "$BN5N6iD(B") - ("fn" "$B<HN^N_O,O0O3Q$\l`4`5aqdMe_e`j3jzo;o{qp(B") - ("fnl" "$BN^^%(B") - ("fb" "$BI5LxN-N.N/N0N1N2N\N]N_N`R-ShT^W!ZX\X^%_H`eaneYe`g{nvo9pEq:(B") - ("fbr" "$BN&O;R-Y$hz(B") - ("fbs" "$BNQNXO@PUVFVG\2^MeE(B") - ("fbf" "$B7*N'N(N*XKdE(B") - ("fbd" "$BN4VWcc(B") - ("fmr" "$BO>P>pU(B") - ("fma" "$BQ[W)XnhR(B") - ("fmd" "$B0=I)KSN?NGNMVE\AhQi3(B") - ("fl" "$B3=8qA8C,DsKiMxMyMzM{M|M}M~N!N"N#N$N%NRNoP]P^X&Xm_"`4`5crdaf@h.h=imjBkJl>nZqkr5rEsW(B") - ("fls" "$BNUNYNZN[RgX'iBm8m9nC(B") - ("fla" "$BNSNTNVNWaepC(B") - ("flq" "$B3^N)N3g~(B") - ("ak" "$BGMGOK`KaKbKcSWU@Vw`uadb{j1j2(B") - ("akr" "$BGyG|KFKkKlLNUki8(B") - ("aks" "$B17HTHUHZJZK|K}K~L!L"OQRDRXV]VoW>W?Xp^`_TbVe\h_jGktm*mNo8q=r#(B") - ("akf" "$BKuKvKwbFcBg}k$p\pi(B") - ("akd" "$BK4K:K;K>LQLVX1f&f(gjh+hOj<j=nzr3(B") - ("ao" "$BGMG^G_G`GaGcGdJrK?KdKeKfKgKhL%Ug`pgugvlNn2pJ(B") - ("aor" "$BG|G~I4L.`Sfwl=lBoyq^sN(B") - ("aod" "$B0:K(LALTLUQ3]ba0hNsf(B") - ("aur" "$BQLQQVm]qf2k,(B") - ("aus" "$BJYL2LHLILJLKLLLMP[QKU_^^b@bTeDsQ(B") - ("auf" "$BJNLG(B") - ("aud" "$B;.L=L>L?L@LCLDZy\U^rbTh,j&nIsf(B") - ("aP" "$BjV(B") - ("ah" "$B18243}G|InJgJhJiJkJlK9K?KAKEKFKHKlL0L6L7LNLOLSLWU(ZV`S`pa(b&bHcjdwfNfnhOkuqxr|(B") - ("ahr" "$BI$KRKTLZL\Q^[7]teYg|s/(B") - ("ahf" "$BKWL^]G]s(B") - ("ahd" "$BL4LXQOTm[$[/](_Bb^ga(B") - ("ay" "$B1,@&G-I@IAICIDIEJhL/ZbZe^]b?eMg{i8(B") - ("an" "$B@&I5IoIpIqIsJjJlK4K?KEKGL3L5L6L7L8L9LPU(V`W'XcXlYEZ[\>bHeYhOj]kX(B") - ("anr" "$BKAKOK|L[`Tfn(B") - ("ans" "$B2cJ-J8J9JZLHLdLfLgLhPnQfX$XpY_e$(B") - ("anf" "$BJ*L^(B") - ("al" "$B3aFfHxHyH}H~JFL#L$LBLoU;VKW9W=_>_Pdve[i/m?sHsSs`(B") - ("als" "$BIRL1LeV1X>XbZa^#eNf+o\sf(B") - ("alf" "$BL)L*\ikm(B") - ("qkr" "$B9}GmGnGoGqGsGtGuGvGwGzG}JmKPKQP8YsYv\w^p`a`yg.p;qPr0rX(B") - ("qks" "$BH<H>H?H@HBHCHIHJHKHLHRHSHWHXJ1JVJ[YBZ5\Q_/amcme+fvj6k'm*(B") - ("qkf" "$BH-H.H/H0H1H4KVUVX#Y6Y{^_b"b$cAlmq{r1(B") - ("qkd" "$BJoJ|J}K'K,K.K5K7K8K<K@KBKCKIR9RMUxVsWEWGZU[D\V^qb|cmg/gVhpiSkno%qwr7(B") - ("qo" "$BGPGRGSGUGVGXGZG[G\G]GeGfGrKLT/WQX`YA^\_d`jfujj(B") - ("qor" "$B3|GFGlGoGpGrGuI4PQVg[1`aa)cndjr0(B") - ("qjs" "$BH(H?HKHMHQHVHYK]ZYZZ\h_/_xc)effLg8j[o@s=(B") - ("qjf" "$BH2H3H5H6f/(B") - ("qja" "$BHAHEHFHHHOK^[p^"c{gw(B") - ("qjq" "$BK!`k(B") - ("qur" "$BI{I}JHJIJJJKQ|Z&]!`za2i0j~m2mdospH(B") - ("qus" "$BHPJQJTJUJXJ[MhQ~RFY(Y7ZN]repg&jokfmgn4n5qX(B") - ("quf" "$BHcJDJLJMP(Z~sh(B") - ("qud" "$BIBIMISJ:J;J<JAJBL_V"Vu[D\V_[c=cme3m~q6qX(B") - ("qh" "$BD=F>IVIaIcIhJ]JbJcJdJeJnJsJuTHUoUph^jppfse(B") - ("qhr" "$BIzI{I|I}I~J!J"J#J$KMKNKPR6Z=Z>\w]M_Ad9h*hyiui}j`m.mUmVqFrX(B") - ("qhs" "$BK\TqlL(B") - ("qhd" "$B0)HFIuJpJtJvJwJ{K%K)K*K/K1K@^"_bcsdK(B") - ("qn" "$B3x4L<C@lG]H]ITIUIVIWIXIYIZI\I^I_I`IbIcIdIeIfIgIiIjIkIlImIoItIzI{I|J#J$JmJsK6P=PZPmP|RuS_T4UUU[Y8YC[T[U[o\T]M^pf)g%gYgxijk>lRlgmUn>n]rjrksOsPse(B") - ("qnr" "$BKL(B") - ("qns" "$BBNHRH[J,J.J/J0J1J2J3J4J5J6J7K[K_RfW][C]d]p_9`6a'a=cic|gnlL(B") - ("qnf" "$BITJ&J'J(J)PGWJWgYD[,`Ac1q|sd(B") - ("qnd" "$BC*J+JxJ~K2TDW:boe^(B") - ("qmr" "$BR6(B") - ("ql" "$B7%H[H\H]H^H_HaHbHcHeHfHgHjHkHlHnHpHqHsHtHwHzH{H|I!J(JOP#PlR8SgU&U9U{X`[,\R`Aa]acbNbgc0c>dDdcdue#f1fGg#g$g>hKhoitjkl"l@lAlLl]nAp)pBp[pfqorL(B") - ("qls" "$BIFIKILINIOIPIQLFUMZ/]']R_@eoi@p~r&(B") - ("qld" "$BI9QRQVQ_U2Xaf[qHqU(B") - ("tk" "$B278%:3:6:;:=:>:?:@:p;E;G;H;J;K;L;M;N;U;W;[;`;b;d;e;l;r;t;v;w;{<%<-<K<L<M<N<O<P<R<S<U<X<Y?)?ZFcGAL&L,LcP/PXQPRSSNTzU0UmWP[O[h\L]y^/^V_C_S`:`[aBc+c,codAdBdCe/fSfhgRh5iImfnanmqJqKrBr^sM(B") - ("tkr" "$B:o:s:w?tSVZK\N`#oK(B") - ("tks" "$B;1;3;5;6;9;:;;;@IGQh[<]haMedlioYo[(B") - ("tkf" "$B;&;';5hq(B") - ("tka" "$B;0;2?9?yRTWD^zdsexf.glhujN(B") - ("tkq" "$B07=BA^Yg]=_'_(p@q%(B") - ("tkd" "$B7,8~=}=~>&>(>0>2>E>M>X>\>]>^>e>o>uAPASAVA[AjAzA|BlBmErF=FKH"MMRVUCURVyV{XS\k]O`.a3fFjak<ksrh(B") - ("to" "$B:I<%^/_Sg(lPp{rT(B") - ("tor" "$B:I:p:w?'T'XG\ecQi,(B") - ("tod" "$B1y>J@7@8`Ocy(B") - ("tid" "$Bq.(B") - ("tj" "$B5P:T=k=l=n=o=p=q=r=s=v=x=y=z={?p@3@4@>@@@BAMD)L;P0ScTPTfVYY3ZFZGd.e1fTf]fqsUsk(B") - ("tjr" "$B3c<.<M<a<b@J@K@N@O@P@YM<^Hb,hnirj.jinYnq(B") - ("tjs" "$B4T@f@g@h@k@p@q@v@z@{@~A"A#A%A*A-A/A1A5A6A7C1OKQ"SEUIUvX:^/`!a}c8e@fAgUiElqpG(B") - ("tjf" "$B1L6}7@@^@_@b@c@eC-FQSwYM\8]u^Xe(e2eJi-jxsv(B") - ("tja" "$BA!A.UQZ{]@]S]Tcxeyezj9k~lXnu(B") - ("tjq" "$B=&>D@"@]RYSqXRXwYpfcm:oRq#(B") - ("tjd" "$B>J>k@+@-@.@1@9@;@<@?@CX9Zp`Od-fag)(B") - ("tp" "$B:P:Y:{@$@*@G@b@vLcWB^/ih(B") - ("th" "$B037+:i<D=j>$>%>,>.>/><>?>B>C>F>K>P>R>S>dA:AAABAGAIAJALA]A_AcAgA{B}I%R#SbU?XG[`\f][]{^j_O_va4d,dTg[hvi+i?l!lsmvn:n[nyp<ppq[rCrM(B") - ("thr" "$B0@B+B.B/B0B3V$etkll^(B") - ("ths" "$B;AB9B;B=C'(B") - ("thf" "$BN(j+(B") - ("thd" "$B>>>YAWAwW~[@^DcpgNiOkVo1psr"(B") - ("thkf" "$B:~(B") - ("tho" "$B:?:U:~;&;/^/_S`tbl(B") - ("thl" "$B?h?jTj(B") - ("tn" "$B<i<j<l<m<s<u<w<x<y<z<{<|<}=$=%=(=+=/=2=7=C=I?\?b?c?e?g?k?o?p?q?tA\AiB5C(C/D\JfLyM"N(RWS4SUSVT1ThU?V-X{YSZ@ZK]U]z^,^l^{_|`Yc.cOdXdoe5e7elf7f{g!g;h%h5hki.j-l(l3n.nHnsnxo5p$p+qrr$(B") - ("tnr" "$B=G=H=I=J=L=M=N=OPhUY`GfihChr(B") - ("tns" "$B=V=X=Y=[=\=]=^=_=b=c=d=f=gFkWNWv^-d#d$f|h&hsh|kNkYo>s((B") - ("tnf" "$B=Q=RN(WuX|[2(B") - ("tnd" "$B?r?shE(B") - ("tnl" "$BPfPg^C(B") - ("tmf" "$BI(`niMi|(B") - ("tmq" "$B<>=&=,=1_<jyp.(B") - ("tmd" "$B>!>#>5>:>g>h>jANFlGhP+QtR4[Fejj$o~(B") - ("tl" "$B0;3A:|;&;H;O;S;T;\;k;m;n;x;{;~<(<,<E<F@'DsLpRQSASOS]UyU}W#W6WtYy`JfBg(gShahikkl5l9p{(B") - ("tlr" "$B6t<0<1>}>~?!?"?#?)?*B)Uf_omHq3(B") - ("tls" "$B:g?-?.?1?5?7?=?@?B?C?E?H?I?U?V?WC$GjH8RqS"UbXFY;Zo_~iglYpur`(B") - ("tlf" "$B<:<<<=<BUi\Cj)(B") - ("tla" "$B;2?3?4?<?D?R?SRTWZ\;]n_)_Dh~o=(B") - ("tlq" "$B=&=:===BDTRARB_'_(a#cgdb(B") - ("Tkd" "$BAPRV(B") - ("Tl" "$B;a(B") - ("dk" "$B0!0"0$2d2e2f2g2j2k2m2n368f;yP3Q;S(U.U4V6[s`Ha^h0jKk(kCn{o<rms!s"(B") - ("dkr" "$B0!0-0.0/3Y3Z3\DWOLP3RxTAVVVjX(X3\[hUhVh`k`n?s-sys{(B") - ("dks" "$B0B0D0F0H4_4c4f4g4i8APtZg]Vpzr=rnro(B") - ("dkf" "$B060D1ZX~Y!]"]1]Fk@mBn!odpK(B") - ("dka" "$B0C0E0G1^264`4b4dVIV^h?k^pws_sa(B") - ("dkq" "$B0(052!3{R}TZ`@(B") - ("dkd" "$B1{6D97Wi]J]vc?pYrs(B") - ("do" "$B0%0&0'3336373eS1SNS`T<V=[#]7b-bJbYbvc(ghi=oup'pKpOq>(B") - ("dor" "$B1U3[LkLqY/YUf~mCoup'(B") - ("dod" "$BSm]/f"rts@(B") - ("di" "$B<M<P<Y<c<fG8LiLjLkLlLmLnYh\?s,(B") - ("dir" "$B0s<c<eLsLtLvU>Ynd`h`hji;oPs4s~(B") - ("did" "$B>\>m>n>w>y>zMHMLMMMNMSM[M\PSTaUPWyZ7ZfZx\k_!_G_laZagaxc:cUjwl*nVqh(B") - ("dj" "$B1w5y5z5{8f8lS0S}S~^Kq,qGrNsw(B") - ("djr" "$B2/21225?M^\z(B") - ("djs" "$B1a8@8AGgI'PpUA_adN(B") - ("djf" "$B]"]1(B") - ("dja" "$B1b1f264`4d8387Q7RLSnV^Vx^;f,ofqd(B") - ("djq" "$B6H(B") - ("dp" "$BWk]P(B") - ("du" "$BFrG!M=M>M?M@MAMBP.]C^.aBe1gMgPh'i1ikl%q1(B") - ("dur" "$B0W0h1V1X5U<MKrLrLuXdehinl#o`ogp?qcrH(B") - ("dus" "$B0v1c1d1h1i1l1m1o1t8&8'<!A3FPFpG3J%RdSkU+U/WzYPYa\=])^'^2^7^=_]d'gCh/icj@l'(B") - ("duf" "$B0v1Y1\@bG.ReSYsv(B") - ("dua" "$B1^1j1k1p1v@wL-QG\ygfgroeqyr6rPsEsa(B") - ("duq" "$B1^MUSq[!pT(B") - ("dud" "$B1D1E1F1G1I1J1K1M1N1O1P1Q1S7J7^RiS[TJU$U%Zu\3\F^s_J`r`}`~ewj>lWn;pD(B") - ("dP" "$B0e1C1H1L1T4"7X7];y<IM@MBP)P.PdQ;Q<St[*]u`IbKbOcRfJghi"i#i:iRjcl%l?p?rIsL(B") - ("dh" "$B0-1(1*1w1x1|2(8^8`8a8b8c8d8g8h8mP~S*SKSSTITTT|U<UhWXX(XeZDZm_4_r_z`3`iiej(n+o2rbsg(B") - ("dhr" "$B0$206L9vM`(B") - ("dhs" "$B292:X2aicSi%i>jrr[r\(B") - ("dhf" "$BQ:\Eg,(B") - ("dhd" "$B2'MJTYW+a%a1a~c<hcp6s0(B") - ("dhk" "$B0#122i3?4$7&RwSyc]hbiwkBkw(B") - ("dhks" "$B08404K4P4X4a4e4hOPOROSU6^1_5iol2op(B") - ("dhkf" "$B[)(B") - ("dhkd" "$B1}2"2&9DUwWH[>]j(B") - ("dho" "$B0#3?OARwbdiw(B") - ("dhl" "$B0Z307(VLV[`Pbvi'r>(B") - ("dy" "$B1z3Z6F9x>qD8F+LsMEMIMKMRMTMWMXMZQ'TpU-UKULVRVvWTWUY9YjYz\[\v]H_$`"`vcXc_eeh}j4kon-n3qAs8t!t#t$(B") - ("dyr" "$B?+C+M]M_MaV;^ieUhljs(B") - ("dyd" "$B23B{M&M/M0MCMFMGMOMPMQMVMYP\XJXY\Wa5f`gNill}o0ps(B") - ("dn" "$B0r1&1'1)1*1+2$2%5m6h6r6s6v6w6x6y?uKtL`M$M%M'M+M4M9P2P}R^R_VJ\d]?]XaOb3c;c<d~foi9kpsIsz(B") - ("dnr" "$B000jR(TT_4_z(B") - ("dns" "$B0w1$1>1?1@Zt]N_pe"fQp(pq(B") - ("dnf" "$B080S1516]5_q(B") - ("dnd" "$B7'M:(B") - ("dnjs" "$B080w1!1`1e1g1n1q1r1s1u3@4j85868;I2QMT$T(U6UcXE^S`)gkiojOkdmWn|ovp((B") - ("dnjf" "$B1[7nXz[)denh(B") - ("dnl" "$B010L0N0O0Q0R0S0V0Y0^0_0`0b0c161R4m56OAQ&S@SxT#Vk^O`*a_eOh<ivjLm{pjr2(B") - ("db" "$B0T0]0d:y<t=@D\FSFjFyF}G(KnL{L|L}L~M!M"M#M(M)M*M-M.M1M2M3M5M6M7MDPRQASHS|U^ViXoYfYiZA\@^a^b`qahdre7g+gLhPi$iXj!j"j@k!k0kglzl|n'nXo+pds[sl(B") - ("dbr" "$B0i4!FyS|]Zdx(B") - ("dbs" "$B0t0}1<=aUzlVnJ(B") - ("dbf" "$Bffrr(B") - ("dbd" "$B=?M;e0(B") - ("dms" "$B1#286dRaT-T7X@X[]V`;p,su(B") - ("dmf" "$B255?(B") - ("dma" "$B0{0|0~1"2;5?6cR_U5V@];pF(B") - ("dmq" "$B5cM,M8X%(B") - ("dmd" "$B1~5?6EBkGhXfg?j$m@mA(B") - ("dml" "$B0M0U0X0a365#57595<5?5A5B5C5DODPaV=VTVXXt]:_q`Hbcc&ePg_nPq>(B") - ("dl" "$B0;0J0K0P0W0[0\1B;\<$<)<*<X?)BBBfCPFRFsFvP1U)UuVaW3W4W^^&`ba-aXfggokHlFlHlIm_mnp0(B") - ("dlr" "$B1WMbMcVXW5[;fDkjs2(B") - ("dls" "$B0u0v0x0y0z1l?M?N?O?YFRG&G'LbP@PAQ9QcTEUTW.]e^P_]h!h;iNpW(B") - ("dlf" "$B0l0m0n0oF|P!PETejRn_o-(B") - ("dla" "$B1A?QDBG$G%L-U,WljSjT(B") - ("dlq" "$B9~F{F~R]T)rl(B") - ("dld" "$B>jP;QtUT(B") - ("wk" "$B040q:4:8:::^:n;F;I;P;Q;R;Z;g;p;q;s;z;|<"<'<+<Q<T@F@QDSI&PwQ}RoR~UZWs^h_Ua*aSbDbEdggsh$hti4i5k9lGlZl`r8s:sn(B") - ("wkr" "$B:n:r<[<]<^<_<`?]?}SpU"UeZQ[P_Zd+e?ginLs'(B") - ("wks" "$B;7;DV#X}\"]L_%b7(B") - ("wka" "$B;=;C@xC9V*_*_+d>dQjDlQo4(B") - ("wkq" "$B;(AYA^C}SrYgd4p7p8(B") - ("wkd" "$B>">)>->1>8>@>O>Q>U>_>c>f>l>s>uATAqArAuB!B"D"D%D2D9F5P?TGTVTcTyT}U#UrVQW2\u\~^J^y`-`/`R`xaog6gGgIg`h7hIi,i6jfl[l\o6rc(B") - ("wo" "$B:F:H:K:M:R:X:[:\:_:`:b<F@FB8^hc7eRexl9lZsn(B") - ("wod" "$BA9AdAhAyVDVl`'bUd7d8kZo#(B") - ("wj" "$B093n5O<Q=m=s=t={=|A;A@CtCuCvCwCxCyDcDlDqE!EKGgH$LYPJRrW7Y3[A[R\:]|_L`2aTbicle*f8fTgsiWk:kIl7m0p3sr(B") - ("wjr" "$B2.<Z<d@Q@R@S@V@W@XB1C`CdD$D_E&E(E)E*E+E,E-LvR*W/_U`?a{c!d{gii4k6mlmqmx(B") - ("wjs" "$B<2=W@o@r@s@y@}A'A,A0A4B7C.DQE5E6E8E;E>E?EAEBECEDEEG{H*KjMdQ#QrR4RdSsT{UsV\W%X"X}Y%ZBZS]a^!_E`0a/aYaub!c"d%d5d?euf?fHg"lcm7mYm[nonto"oCp4pSp|q4qBs6s7t"(B") - ("wjf" "$B=`@Z@[@^@`@a@dCbLERERGRzY#ZqZr^6cffOlkmE(B") - ("wja" "$B0>@jA2E9E@FQG4V3dRpAsVsZ(B") - ("wjq" "$B@\D3XR\&\7\D]~^XfcrW(B") - ("wjd" "$B0f;*>=>Z>`>p>t>{@,@/@0@5@:@EBGCzD.D:DbDdDeDgDhDjDmDnDrDuDvDwDxDzD{E"E#E$FTKoLwMdP'RZVlY]ZW[l^F^[a6aKbMcWf^hGj:mwn&nDnKoFp=pP(B") - ("wp" "$B1-:O:Q:W:]:^=t=|@)@=@F@^BhBiBjDiDkDoDpDsDtD}P_Q1Q}Z+Zq_;bDbEbIgAi5lZm3pIpmpnsn(B") - ("wh" "$B3v7+:x;4<D=u><>H>[>rA;A<ADAEAFAHAKA`AaAbAeAfAgAlAtAxB$BdC{C|D$D&D+D,D/D4D7D8D;DUD^D_D`FXGBH%POPYS^SdWIXNXTXjY2Y4Zj[j[t\'\*_6`,bic/cGcZc^cud|e6f-fTfrg]iskGkPl!ldm/oXp:qt(B") - ("whr" "$BB-B2dHhwo7(B") - ("whs" "$BB:YO(B") - ("whf" "$B@[B4OHR@`L(B") - ("whd" "$B<o<p=!=*=>=D>a>bAnI"P:WOXQ\#\$\b^JdpeTj*l{m'm)oG(B") - ("whk" "$B:4:8:A:B:C(B") - ("whl" "$B:a(B") - ("wy" "$Bn[(B") - ("wn" "$B3t:n<g<k<n<r<v<~=#='=.=5=;=K?_AUAvB-B2ChCkClCmCpCqCrCsD4D]I*L+P&PMPvQ2QISUW$ZlaFaGcGdVdZe!eBfthwiakOlam4mTn$oIsG(B") - ("wnr" "$B4!C]dx(B") - ("wns" "$B1==S=T=W=Y=`=c=eFVH;KpQ.RETSWvX"X6^4_=b/jAm-mu(B") - ("wnd" "$B=0=ECfCg(B") - ("wmr" "$BB(B1(B") - ("wmf" "$B6{(B") - ("wma" "$BWc(B") - ("wmq" "$B=4=AIxM,\7eI(B") - ("wmd" "$B3(9y>I>Z>xA9A=A>A}A~B#D'YN\t__kz(B") - ("wl" "$B4t5@;V;X;Y;];^;_;c;f;h;i;j;o;}<1<A<G?%B~CNCOCRCSCXCYDRDlDqEVG7S!T.TMVcW7Yu[L]ma\c-fMfsgSk:lDlSlflym5mIn/owr?s9(B") - ("wlr" "$B?%?&D>SDcFcM(B") - ("wls" "$B?0?6?8?:?>???A?G?J?L?P?T?XC$DADCDDDEE6FxKyPVSQZi]I_~`_a+a;b8bCbSeVgKhmjWlcmGo/(B") - ("wlf" "$B<8<;<@<ACaCbE3IHLEPERzSDT9Ve[_fOg4g5lDlkmE(B") - ("wla" "$BD?ZPnErq(B") - ("wlq" "$B<9=4=8=AeI(B") - ("wld" "$B@!D'D(_-(B") - ("ck" "$B3n:!:5:7:9:<<V<W<ZOMPNSMV+VMY-Ym[3\Lbxd4gsm"n`(B") - ("ckr" "$B:q:u:x@NB*ByCeCxY'eSm0oXsqsx(B") - ("cks" "$B;8;<;>;?;A@qRUZ9`&cbdlesl-lUo4oSoTqB(B") - ("ckf" "$B;!;";$;%QkY)`\e'(B") - ("cka" "$B;2;4;BA2Q(Q)RTTOVPVZXNXOXPXrXs\ackk{k|l)l+q](B") - ("ckd" "$B>'>+>3>4>;>T?zAOARAdAkAsD*D1H+PiQlRRX0XHYoZHZd^E^k^}`KalcYgZm#r.(B") - ("co" "$B:9:D:L:N:S:V:W:Z<F@UMi\Me=hql8n`pV(B") - ("cor" "$B:p:t:u:v:}@UA<QFSTY>[Pbyd)dG(B") - ("cj" "$B:J=h@(A@Q]X.^Ge1hF(B") - ("cjr" "$B;I<\@I@L@M@TD=QqRhWFZ3^~akinljm$m(m6p"s5(B") - ("cjs" "$B0+6N6z6|;=@i@n@q@t@u@|A$A&A(A)A+C)E7PBPjQdSCV_Z#[a\9^I^Y_Ea$chh(lMlxoqotph(B") - ("cjf" "$BDVE/E0E1E2E4FLFmS5V%YZmPnno$oDoEq8(B") - ("cja" "$B84@mE:E<Q!W[Ww\a\y]~b]dSdUd^d_j9k-k[k~(B") - ("cjq" "$B>*>9>vC}D!D-D5E=aHaIaJbLjymLmM(B") - ("cjd" "$B;*;,@2@6@A@DD#D0W,W-fehGiq(B") - ("cp" "$B@ZBNBXBZBaDVDfDyD|D~FeFmSFSiSjYZ\<^8^|bIbfh\hxjim<m=n*pLqsqv(B") - ("ch" "$B7-=i>%>6>7>A>G>K>L>S>V>d?]A?ACApD6D8ICQvR#R+V%V9X!X7X^[B\%^W_VcDggkWl:mknLndqzs<ss(B") - ("chr" "$B<q>|?$?(?tB%B0SvV$ZKb`badHifk=m1o7qq(B") - ("chs" "$B1%@#B<WVn7(B") - ("chd" "$B=>=FAQAZAmAoC~DMF4G,N5N6P:PxR2WOWdX;eAeTfb(B") - ("chl" "$B:E:GVCYt\c^/(B") - ("cn" "$B0,1/3b<h<q="=%=)=-=6=9=P?[?d?m?n?u?v?wAFC\CjDFDGDHDIDJGkOISBU7U9VdX/YXYY\6\d^Wa,b2cTd6dHeWf\gmhZn@p%p2pcqWqerUsF(B") - ("cnr" "$B1/<3<4=3=K=LC[C\C^C_C`M.\egXm&(B") - ("cns" "$B=UDXrV(B") - ("cnf" "$B=P[2sY(B") - ("cnd" "$B2-=<=F>WCiCnCoMCQU`>g^j5(B") - ("cnp" "$BX,X-X8aahDlT(B") - ("cnl" "$B<h<q="=-?a?f?i?l@HOIS\U8X8Ye\r]^aafCf\g9hDk9nMqe(B") - ("cmr" "$BB&B'B,D=P<X<Z`(B") - ("cms" "$Bsp(B") - ("cma" "$Boo(B") - ("cmd" "$BA=A>AX(B") - ("cl" "$B:7:9;u<#<&>}?"?%CMCQCTCUCVCWCZD'D>FePLRHRNSPTiV5VbVpVz[i_ua7a?awbtcPcze#e>eLfWiPjul8lemOo!p5r5rKrvrwscso(B") - ("clr" "$BB'B,D<R,RNVzX<ZE(B") - ("cls" "$B?Fk%sp(B") - ("clf" "$B<7<?(B") - ("cla" "$B5N?/?2?;?KC9D@KmUjWZZP\;o*o,ooqT(B") - ("clq" "$Bj/(B") - ("cld" "$B>NGicJjYqU(B") - ("cho" "$B2wTo`V(B") - ("xk" "$B<XB>BBBCBDBEBFBGBHBIBJBKBLBMCSOMPIS#TXU`YYYe[4\s]}g!m>qLrx(B") - ("xkr" "$BBnBoBqBsBtBuBvBwBxByE'EYPkS6Y>[Q_7ner0(B") - ("xks" "$BBMC2C3C7C:C>CBCFF]FgW<X_Z:]QjX(B") - ("xkf" "$BC%C&(B") - ("xka" "$BC5C?b>lE(B") - ("xkq" "$BEcEkYr\PpaperW(B") - ("xkd" "$BEfErE|F"Vfb;j#(B") - ("xo" "$B@GB@BABUBVBYB[B]BaBfBgG=KXLaQ<\(cze)ihkHq&qM(B") - ("xor" "$BBpBrBtZ$_7(B") - ("xh" "$BEFEGEQEZEeF$Q=h9(B") - ("xhs" "$Bjt(B") - ("xhd" "$B23DKDLE{E}HuWxXV(B") - ("xhl" "$B?dBOB\B`DHDIDJFXjtpx(B") - ("xn" "$BEJEjF)F.L{Pye5o+qmr,(B") - ("xmr" "$BB_FCXW(B") - ("vk" "$B?|GCGDGEGGGHGIGJGKGLGNHmHvT3WfZ4[1`(``bncvfRg8hJh]jZllox(B") - ("vks" "$B:d:eH=HDHGHNR!]ra"ng(B") - ("vkf" "$B;+H,R\[5n\(B") - ("vo" "$B143-GIGTGWGXG\GbH4HmI#PPUVX#Y6ZT[1]o`cp>(B") - ("vod" "$BC*K#K5KDW:WEZU_0b|e^(B") - ("vir" "$BX?(B") - ("vus" "$BJ?JPJRJSJTJWJXJ\Y(fIgyi~jokfqY(B") - ("vua" "$BlJ(B") - ("vud" "$BDZI>IMJ?Wh^$bogyhLr9(B") - ("vP" "$B3AGQGYJ>J@JCJDJEKJUJVrW&ZIZMasi0qo(B") - ("vh" "$B1:3s3wGxGzI[I]IrJ^J_J`JaJqJyJzK"K$K&K+K0K=R1R5R7RvS.T5YF[T_F_\aWb.f}gTgzj\jqmynppRq0q}r:rDsR(B") - ("vhr" "$BGxGzI}K=_F(B") - ("vy" "$B<]I6I7I8I:I;I<I=I?QwUEXX]Ke]q(q)q*q_qjqurd(B") - ("vns" "$BJ,(B") - ("vna" "$BIJcHcI(B") - ("vnd" "$BIvIwK-afkel4q$qH(B") - ("vb" "$BI7(B") - ("vl" "$BH`HdHhHiHmHoHrllmdox(B") - ("vlf" "$B2^HfHgI$I%I+I,I-I.J'J)PGYDdJkvm+s+(B") - ("vlq" "$BI/I}K3^"(B") - ("gk" "$B2<2?2F2O2Y2\2b2l3E<6ROR`V|^Q`leKf!kEl.n"o(rQ(B") - ("gkr" "$B2)3X5TDaT[U\U]^A`Bajkbl;s?(B") - ("gks" "$B4(4@4A4M4W4Z8B:(UFUGW{Y*YRZ][e_K`Cb*f'n8qSqlsm(B") - ("gkf" "$B323d3e3mR$bRiys\(B") - ("gka" "$B4O4Y4^H!MtQbRyS2S?VH]#^>eHh1n8nro|pwq2rRsD(B") - ("gkq" "$B389^9gH:RnR}^eb4b5b6hdonr{(B") - ("gkd" "$B7e9+91939:9A9R9T9_9`FzP6PDRbWqe}fjobprr*(B") - ("go" "$B0g2r3#3$3*3/31323:3<:zPsT6TnTxUXW(Xh\4i&j7k;k_n0nOqO(B") - ("gor" "$B3/3Kbkk*mJ(B") - ("god" "$B0I8v9,9Te.jbr}(B") - ("gid" "$B5}6?6A6B8~9aSlq.(B") - ("gj" "$B135u5vTR[[]A^w(B") - ("gjs" "$B7{8%8.YW`[(B") - ("gjf" "$B]<iyj8(B") - ("gja" "$B8183VUp*qd(B") - ("gur" "$B3E3R3W7CTu^)r+(B") - ("gus" "$B0<7|8)8+8-82898<8=8>8?9`JGPWRl^-aRbAeQidjJnkp}(B") - ("guf" "$B7j7l>iJGLRUSk#pv(B") - ("gua" "$B7y(B") - ("guq" "$B0A3p6"6(6.64696<KKOFTsV7XDYQ^5`Ed)d:h2nwo}p!(B") - ("gud" "$B3>5|7:7;7?7A7U7V7e9UTk_W_X`rfzj%mj(B") - ("gP" "$B7E7RQBR>TxWBX*b=c4l~nQp^(B") - ("gh" "$B3O8C8F8L8M8P8Q8R8U8W8[8_8c8j8n8o9%9@9f9h9j9k:c;)<JD[QTTdW`Y&Z_Zn\5]]]l^v^w`7`ha!b(b+hYhfiHiKizn=o.q7(B") - ("ghr" "$B0?9s9tOGUeZO(B") - ("ghs" "$B:':*:+:.:2[~\!^U^g_c`m(B") - ("ghf" "$B3K9z9{]Gcts3(B") - ("ghq" "$B3f(B") - ("ghd" "$B909?9H9cR|]g]wkAobr*(B") - ("ghk" "$B2=2P2R2S2V2Z2_2h3q3r7$CtOBOCS;V<aAdqo&(B") - ("ghkr" "$B3H3M3N3OZ2Z<ayb_j?p9(B") - ("ghks" "$B4-45494<4?4D4T4]88OKT(TvUaUnXu]D^R^S_eb*bAbbl,l6oBqir%r](B") - ("ghkf" "$B1[3h3j;#`Qbwi]l/ohoi(B") - ("ghkd" "$B2+677;92989D9SKZQWQ`WSWrX5Zh^T^f_jd;dPfki{n#p&rS(B") - ("gho" "$B2h7S`VaA(B") - ("ghl" "$B2q2s2u2v2y2z2{3"3%=ZI0OEPrQER;TUWKXg[X\G^Neig:h"i'i\kKkRmorf(B") - ("ghlr" "$B2h3D3MaA(B") - ("ghld" "$B2#909U9li*mDo)sT(B") - ("gy" "$B6G8s8z9;9Z:hP{S,SeSoZCZ|[f^B_^`+qaqb(B") - ("gn" "$B0r5`8e8t8u8|9!9"PHRcSLSR^A_h`Md<kMmp(B") - ("gns" "$B7.7071FkR._m_nhXnU(B") - ("gnd" "$Bi*(B") - ("gnjs" "$B3~7vCHX:Zwh@kcl,(B") - ("gnp" "$BCnRCS<TL_{(B") - ("gnl" "$B4x5+51WCY&Zv]`ka(B") - ("gb" "$B5Y7H7MC\Z8_^iLl<(B") - ("gbr" "$BC\(B") - ("gbf" "$BWukys;(B") - ("gbd" "$B6$6'6;R3Wo^((B") - ("gmr" "$B9un^(B") - ("gms" "$B6U:/WLWWYWnW(B") - ("gmf" "$B5%5IKxV(k?(B") - ("gma" "$B6V7g(B") - ("gmq" "$B5[]@^*b%fE(B") - ("gmd" "$B6=Fz(B") - ("gml" "$B4n4r4u5)5:5>I1Q%RzS)S`XAXZY&Zk[']8_f_g_t`!`:c6f<nZrF(B") - ("glf" "$B5Merk#pvs\(B") - ("unknown" "$B4#<5DNFJFdFuJ=KsL]QeRIRpS&S9SuS{T*T+T8T:T>TBTCTKTNTQTWT\T_UNU~V&V,V-V.V/V0V2V4V8VNW;WjWnWpY0YKY^Z1Zs[=[b[n\)\-\.\/\0\1\O\S\j\n\o\p\q\x]&]6]B]i^<^L^c_&_1`<a:a<a>b<bBbXbmbpbsc%c5cNcdc}d&d1d=dIdLdYdddfdhdte9eaebemenevf$g3g\h4h6hHhMhWhhiFi[ibj,jQj^jmk\lCmZmhmimzn%n}o'oZo]p#p-pXp]p`q;qIqRr;r@rGrOrZr_rer~s#s%(B")) + ("rk" "榎仮伽価佳加可嘉嫁家暇架歌珂稼苛茄迦駕街袈个假價呵哥枷柯珈痂笳舸葭訶謌賈跏軻") + ("rkr" "各格殻覚角較閣却脚刻塙卻咯埆恪愨擱桷殼狢覺貉鬥") + ("rks" "斡乾侃刊姦干幹澗看竿簡肝間墾懇艮菅奸慳揀杆柬栞桿狠癇稈繝艱諫鶫齦") + ("rkf" "介喝渇葛褐掲丐曷碣竭羯蝎鞨頡") + ("rka" "勘堪感憾敢柑甘監鑑欠鹸減紺凵坎坩嵌戡撼橄歉淦疳瞰緘蚶轗酣鑒龕") + ("rkq" "押蓋甲合岬匣盖胛閘") + ("rkd" "岡橿強彊慶康控江糠綱腔講鋼降剛虹亢僵啌姜崗慷扛杠棡疆矼絳繦羌薑襁跫鱇") + ("ro" "佳箇介解改皆芥開階凱咳慨概蓋鎧個丐个价剴愾懈揩楷漑疥盖觧") + ("ror" "客喀") + ("rod" "坑更粳羹羮鏗") + ("ri" "茄") + ("rir" "醵") + ("rj" "去居巨拒拠渠距鋸車据裾俥倨墟據擧舉欅炬秬筥苣踞遽醵鉅") + ("rjs" "乾巾件健建鍵愆搴腱虔謇蹇騫") + ("rjf" "渇掲傑乞担桝偈杰桀气竭") + ("rja" "柑倹剣検鹸儉劍劔劒剱檢瞼臉黔") + ("rjq" "笈怯劫拾刧") + ("rp" "憩掲偈憇碣") + ("rur" "仮格隔革撃激假挌檄膈茖覡闃骼鬲鴃鵙") + ("rus" "樫鰹堅牽犬絹肩見遣縛繭鑓俔幵悁枅狷甄筧羂譴鵑") + ("ruf" "桔契決潔結訣孟决抉拮挈缺髻") + ("rua" "鎌兼謙慊拑歉箝蒹鉗") + ("ruq" "恰頬慊鋏") + ("rud" "京競卿境鏡驚傾径慶敬景経茎荊警軽頚鯨庚更梗硬耕頃亰竸冂冏剄勁勍哽徑憬檠煢瓊畊痙磬絅經綮耿脛莖謦輕逕竟頸黥") + ("rP" "戒械界階季係啓契桂渓稽系継繋計鶏堺届屆彑悸枅溪畍癸禊笄綮繼薊誡谿髻鷄") + ("rh" "苦古固姑孤庫故枯袴股菰鈷雇顧鼓稿考膏高拷告皐縞尻叩藁估凅刳呱攷敲杲柧桍栲槁槹沽痼皋睾瞽稾箍罟羔胯蛄蠱觚詁誥賈辜錮靠鴣鵁皷") + ("rhr" "曲告穀酷鵠谷硲哭斛梏槲轂髷") + ("rhs" "困坤昆梱混壼崑悃棍滾菎褌鯀鯤鶤") + ("rhf" "滑骨榾汨鶻") + ("rhd" "供共恐恭空公功孔工控攻貢倥廾拱椌槓箜蚣蛩蛬跫鞏") + ("rhk" "瓜寡科果菓課過袴誇跨鍋堝夥夸戈胯萪蝌裹踝顆") + ("rhkr" "廓郭擴攫椁槨癨矍钁霍") + ("rhks" "冠官寛慣棺款潅管莞観貫関館舘串菅丱冦毋灌盥綸綰罐觀鑵關鸛") + ("rhkf" "括活筈桧刮檜聒") + ("rhkd" "拡匡狂光広鉱砿壙廣擴曠昿框洸礦筐筺絋絖胱誑鑛") + ("rho" "掛卦罫咼戈挂枴褂") + ("rhl" "会塊壊怪恢拐魁乖傀壞恠愧槐瑰詼") + ("rhlr" "膕馘") + ("rhld" "宏紘肱轟浤軣鍠") + ("ry" "撹覚較噛糾僑叫喬教橋矯蕎交佼孝巧校絞郊酵鮫招咬嬌攪敲橇澆狡皎磽窖翹膠蛟轎釖餃驕驍") + ("rn" "臼厩欧殴鴎鈎亀丘久仇救求灸球究旧拒九倶句区狗玖矩躯駆駈駒具粂勾口垢拘構溝購叩韮鳩釦傴冓劬區咎嘔媾嫗寇嶇廐廏怐惧懼扣搆柩枸歐毆毬甌疚瞿窶篝舅舊苟蒟蚯衢裘覯詬謳逑遘邱鉤韭颶馗驅鬮齲龜") + ("rnr" "掬菊鞠局麹国囗國椈鬻鞫跼") + ("rns" "君群軍郡桾皸皹窘羣裙") + ("rnf" "屈掘窟堀倔厥崛") + ("rnd" "宮弓窮穹躬") + ("rnjs" "勧巻挙倦券圏拳捲権劵勸卷圈惓椦權眷綣蜷顴") + ("rnjf" "掘蕨亅厥獗蹶闕") + ("rnp" "机帰軌凧潰几匱椢櫃歸皈簣臾詭跪蹶餽饋") + ("rnl" "帰貴鬼亀喟椢歸皈龜") + ("rnlr" "掴幗") + ("rb" "葵窺規糾叫九圭珪頃槻奎揆摎樛癸硅竅糺繆袿赳逵閨馗鬮") + ("rbs" "亀均菌箘鈞麕龜") + ("rbf" "橘") + ("rmr" "可革極劇戟隙克亟剋尅屐棘蕀郤") + ("rms" "僅勤巾斤筋芹謹近根懃槿瑾矜菫覲釿饉") + ("rmf" "契訖") + ("rma" "錦琴禁禽衿襟金檎今噤擒衾黔") + ("rmq" "扱及急汲笈級給岌") + ("rmd" "恒肯亙亘兢恆矜") + ("rl" "磯企伎器基奇寄岐幾忌旗既期棋棄機気汽畿祈紀記起飢騎妓技欺祇居祁己碁乞崎埼碕示其肌鰭箕亟俟冀剞嗜噐圻竒嵜弃掎旡曁朞杞枳棊榿气氣沂淇畸祺稘綺羈羇耆覊覬譏豈跂饑騏驥鮨麒") + ("rlr" "喫") + ("rls" "緊") + ("rlf" "吉桔詰佶拮") + ("rla" "金") + ("Rlr" "喫") + ("sk" "奈那難儺娜懦扨拏拿梛糯") + ("skr" "諾") + ("sks" "暖難攤煖赧") + ("skf" "捺捏涅") + ("ska" "男南楠喃娚遖") + ("skq" "納衲") + ("skd" "嚢娘曩") + ("so" "耐奈内匂乃廼能迺") + ("sid" "嬢孃") + ("su" "女拏拿茹") + ("sus" "年撚碾輾") + ("suf" "捏涅") + ("sua" "念恬拈棯") + ("suq" "摂捻攝躡鑷") + ("sud" "寧嚀濘獰聹") + ("sP" "禰昵") + ("sh" "努奴怒脳呶孥帑弩瑙碯腦臑駑") + ("shd" "濃膿農儂") + ("shk" "雫") + ("shl" "悩脳惱腦餒") + ("sy" "溺尿嫋撓橈鐃閙鬧") + ("sn" "耨") + ("sns" "嫩") + ("snf" "吶肭訥") + ("sb" "紐忸狃鈕") + ("sbr" "忸衄衂") + ("smd" "能") + ("sl" "泥尼禰祢怩濔瀰膩") + ("slr" "溺匿") + ("slf" "尼怩昵") + ("sla" "賃恁") + ("ek" "多大茶夛") + ("eks" "円但丹単担旦短端箪胆蛋鍛団壇断檀段椴敦亶單團彖愽慱斷槫湍猯疸緞葮蜑袒襌褝鄲鶉") + ("ekf" "達咄妲怛撻燵獺逹闥靼韃") + ("eka" "担淡湛耽談曇啖啗壜憺擔毯潭澹痰眈膽蕁覃譚餤") + ("ekq" "沓搭答踏剳荅") + ("ekd" "党唐塘当糖堂撞儻幢档棠溏當瞠礑螳蟷襠鐺黨") + ("eo" "碓対岱帯待戴袋貸隊黛代大敦垈對帶擡抬玳臺薹鐓隶") + ("ejr" "徳悳") + ("eh" "稲図挑跳堵塗屠徒渡菟賭途都鍍度倒刀島嶋悼桃梼盗淘涛祷到逃陶導萄道叨圖嶌掏掉搗擣朷檮棹櫂盜濤滔睹稻絛綢綯纛荼莵覩跿蹈迯闍韜饕") + ("ehr" "竺涜督禿篤毒独読牘犢獨纛讀髑黷") + ("ehs" "純噸惇敦沌豚遁頓暾燉瓲遯飩") + ("ehf" "突頓咄柮") + ("ehd" "諌桐冬凍東棟董働動同憧洞瞳童胴銅僮橦潼疼粡艟苳鮗鶇鼕") + ("en" "吋兜逗斗杜土痘豆頭読亠抖竇肚荳蚪蠹蠧讀酘鬥") + ("ens" "屯遁頓鈍臀遯") + ("emr" "得") + ("emd" "登灯燈等藤謄鐙騰嶝橙滕疼磴籐籘縢") + ("fk" "刺羅螺裸喇懶瘰癩蘿邏鑼陏騾") + ("fkr" "格楽洛絡落酪咯樂烙犖珞駱") + ("fks" "乱卵欄蘭亂嬾欒瀾燗爛襴鑾闌鸞") + ("fkf" "剌喇埒埓糲辣") + ("fka" "嵐濫藍覧儖婪攬欖籃繿纜襤覽醂") + ("fkq" "摺蝋拉柆臘臈鑞") + ("fkd" "滝瀧廊朗榔浪狼郎朖琅瑯莨螂跟踉") + ("fo" "來徠") + ("fod" "冷") + ("fir" "掠略擽畧") + ("fid" "椋掠亮両梁涼糧良諒量倆兩凉喨粱粮裲跟踉輛輌魎") + ("fu" "芦蛎砺麿侶慮旅励麗呂録儷勵唳廬梠櫚犂犁癘礪糲絽綟膂臚茘藜蘆蠣蠡鑢閭驢驪") + ("fur" "力暦歴屶朸櫟檪櫪瀝癧礫轢轣靂鬲") + ("fus" "怜零恋憐漣煉練聯蓮連錬嗹戀揀攣楝聨臠輦鏈鰊") + ("fuf" "列劣烈裂冽捩洌") + ("fua" "鎌廉簾匳奩斂濂瀲") + ("fuq" "猟獵鬣") + ("fud" "領令伶嶺怜玲苓鈴零霊齢囹櫺澪羚聆蛉靈鴒齡") + ("fP" "豊例礼隷禮茘醴隸鱧") + ("fh" "芦鷺櫨蕗虜魯櫓炉賂路露労牢老勞咾撈枦滷潦濾瀘爐癆盧艪艫舮蘆輅轤鑪鈩顱驢鱸鹵") + ("fhr" "角漉鹿谷緑麓禄録梺碌祿轆") + ("fhs" "論淪") + ("fhd" "滝瀧竜龍弄篭聾哢垰壟朧槞瓏籠蘢隴") + ("fhl" "瀬頼雷塁賂儡壘擂櫑癩磊籟罍耒蕾藾誄賚") + ("fy" "了僚寮料療瞭遼寥廖撩暸燎繚聊蓼醪鐐鷯") + ("fyd" "竜龍蘢") + ("fn" "屡涙累婁楼漏僂樓犂犁瘻簍縷縲螻褸鏤陋髏") + ("fnl" "涙泪") + ("fb" "謬柳劉流溜琉留硫瑠塁累類勠嚠壘廖旒榴泪瀏璢瘤繆縲茆鉚鏐霤餾") + ("fbr" "陸六勠戮蓼") + ("fbs" "倫輪論侖崙崘棆淪綸") + ("fbf" "栗律率葎慄篥") + ("fbd" "隆嶐窿") + ("fmr" "肋仂勒") + ("fma" "凛廩懍菻") + ("fmd" "綾菱睦凌稜陵崚楞蔆薐") + ("fl" "浬鯉糎狸提哩利吏履李梨理璃痢裏裡里離厘麗俚俐悧罹漓犂犁竰籬羸莅莉蜊蠡詈貍釐驪魑鯏黐") + ("fls" "燐隣鱗麟吝悋藺躙躪鄰") + ("fla" "林淋琳臨痳霖") + ("flq" "笠立粒苙") + ("ak" "罵馬摩磨魔麻嘛媽麼瑪痲碼蟇蟆") + ("akr" "漠莫貌幕膜摸寞藐") + ("aks" "鰻挽晩蛮娩万慢満漫蔓湾卍曼巒幔彎弯懣滿灣瞞縵萬蠻謾蹣輓鏝饅鬘") + ("akf" "抹末沫眛秣茉襪靺韈") + ("akd" "亡忘忙望妄網惘网罔芒茫莽蠎蟒鋩魍") + ("ao" "罵媒梅楳煤買売呆某埋妹昧枚毎魅寐瑁苺莓賣邁霾") + ("aor" "莫麦百脈獏脉貊貘陌驀麥") + ("aod" "虻萌盟猛盲儚氓甍萠黽") + ("aur" "冖冪幎汨羃覓") + ("aus" "勉眠免棉綿緬面麺俛冕宀湎眄瞑緜麪") + ("auf" "蔑滅") + ("aud" "皿冥名命明銘鳴暝榠溟瞑茗螟酩黽") + ("aP" "袂") + ("ah" "姥牡茅莫侮募墓慕暮母帽某冒謀貌鉾膜粍牟矛摸模毛耗姆旄獏瑁瓱皃眸竓糢耄冐莽謨髦鴾") + ("ahr" "匹牧穆木目凩朷沐繆苜鶩") + ("ahf" "没勿歿沒") + ("ahd" "夢蒙冢梦曚朦檬濛矇艨") + ("ay" "卯畝猫廟描秒苗錨墓妙杳昴渺眇緲茆藐") + ("an" "畝謬撫武舞蕪戊母亡某謀貿務無牟矛霧鵡茂姆巫廡憮懋拇无楙眸繆莽袤誣") + ("anr" "冒墨万黙默冐") + ("ans" "蚊吻文聞娩免問紋門匁們刎悗懣捫紊") + ("anf" "物勿") + ("al" "梶謎尾微眉美米味未迷弥媚嵋弭彌濔瀰糜縻薇躾麋靡黴") + ("als" "敏民悶岷愍憫旻泯緡罠閔黽") + ("alf" "密蜜樒謐") + ("qkr" "狛剥博拍泊箔粕舶薄迫爆駁簿撲朴亳搏摶樸溥珀璞膊雹駮魄鰒") + ("qks" "伴半反叛搬斑班畔繁般頒飯盤磐扮返弁拌攀槃潘瘢竝絆胖蟠襷蹣") + ("qkf" "鉢溌発醗髪抜勃孛悖拔撥渤癶發秡跋髮魃") + ("qkd" "倣放方芳訪邦傍坊妨房棒紡肪防匚厖尨幇彭彷旁枋榜滂磅竝膀舫蒡蚌謗錺髣魴") + ("qo" "俳拝排杯盃背輩配倍培賠陪白北坏徘憊拜湃焙琲胚裴") + ("qor" "栢覇伯拍柏白舶百佰帛霸珀瓸竡粨魄") + ("qjs" "幡反繁藩煩番蕃翻旛旙樊潘燔礬繙飜膰袢鐇鷭") + ("qjf" "伐罰筏閥罸") + ("qja" "帆氾汎犯範凡梵泛笵范") + ("qjq" "法琺") + ("qur" "副幅僻壁癖碧劈擘檗璧甓薜襞躄辟闢霹") + ("qus" "釆変編辺便弁来辨卞扁抃變汳辮胼褊諞辯邊邉駢") + ("quf" "批閉別瞥丿暼鼈") + ("qud" "病浜瓶丙併兵柄並餅屏并枋榜炳秉竝絣迸餠駢") + ("qh" "捗鴇埠普父譜保歩甫補輔菩報宝堡寶寳葆褓鞴黼") + ("qhr" "伏副復幅服福腹複覆僕卜撲匐攴攵樸殕濮箙茯蔔蝠蝮袱蹼輻輹馥鰒") + ("qhs" "本夲賁") + ("qhd" "逢汎封俸奉峰峯捧縫蓬蜂鋒鳳棒泛烽笂篷") + ("qn" "釜缶蔀専培否不付埠夫婦富冨府扶敷斧浮父符腐膚芙負賦赴阜附撫部伏副復複覆簿報剖仆俘俯傅咐嘸坿孚孵抔拊枹柎桴榑殕溥罘腑艀苻蜉訃賻趺輻郛釡鳧鳬麩麸黼") + ("qnr" "北") + ("qns" "体頒匪分噴墳憤扮焚奮粉糞紛雰奔盆吩忿枌氛汾濆犇瓰畚竕笨芬賁") + ("qnf" "不弗払沸仏佛彿怫拂朏狒祓髴黻") + ("qnd" "棚鮒崩朋鵬堋弸硼繃") + ("qmr" "匐") + ("ql" "轡匪卑否妃庇悲扉批斐比泌碑秘緋肥誹費非飛備枇毘琵鼻沸箆丕俾匕嚊妣婢屁憊朏榧狒痞痺睥砒祕秕篦粃糒紕羆翡脾腓臂菲蓖蜚裨譬貔豼賁贔鄙隗霏鞁鞴髀鯡") + ("qls" "鋲彬斌瀕貧賓頻牝嬪擯檳殯濱繽蘋顰鬢") + ("qld" "氷冫冰凭娉憑聘馮騁") + ("tk" "卸献些唆沙砂詐鎖裟咋仕伺使司史嗣四士師思斯死獅私糸詞賜飼事似寺璽辞舎写射捨赦斜社紗謝蛇邪食笥乍覗巳蓑貰亊俟冩厶嗄奢娑寫徙柤梭槎泗洒渣瀉灑犧獻畭祀祠竢篩簑簔絲耜肆舍莎乕辭釶鉈駟駛鯊鰤麝") + ("tkr" "削朔索数嗽數槊爍鑠") + ("tks" "傘山撒散珊産算酸蒜刪杣汕疝繖跚閂閊") + ("tkf" "殺薩撒蔡") + ("tka" "三参森杉參彡滲糂纔罧芟蔘衫") + ("tkq" "扱渋挿插歃澁澀霎颯") + ("tkd" "桑向傷償商嘗尚床湘祥裳詳象賞上常状双喪爽想相霜像滝瀧湯峠橡箱様雙嫦孀庠廂慯樣殤牀甞翔裃觴謫鱶") + ("to" "塞璽洒灑腮賽顋鰓") + ("tor" "塞咋索色嗇愬槭穡薔") + ("tod" "甥省牲生猩笙") + ("tid" "餉") + ("tj" "黍犀暑曙庶緒署書薯藷叙序徐恕鋤瑞棲栖西誓逝鼠挑婿舒噬墅壻嶼抒敍敘筮絮耡聟胥黎鼡") + ("tjr" "潟汐射釈錫席惜昔析石碩夕淅皙蓆蜥螫裼釋鉐") + ("tjs" "還蝉仙先宣扇撰洗煽旋線羨腺船選銑鮮善禅繕膳単亘僊單嬋尠愃洒燹癬禪綫譱舩蘚跣霰") + ("tjf" "洩屑契折設説雪舌鱈苫囓挈楔泄渫紲絏緤薛褻齧") + ("tja" "繊閃孅暹歙殲殱笘纖纎蟾譫贍銛") + ("tjq" "拾渉摺摂燮囁慴懾攝聶躡鑷顳") + ("tjd" "省城姓性成星盛聖声誠醒惺晟猩筬聲腥") + ("tp" "歳細笹世勢税説洗貰彗洒蛻") + ("th" "鯵繰咲篠所召哨宵小少昭梢沼消焼硝笑紹肖鞘塑疏疎素蘇訴遡掃掻巣燥騒蛸疋劭嘯嫂愬梳樔毟泝溯瀟燒甦筱簫艘蔬蕭蘓譟踈逍邵釖銷霄韶騷鮹鰺") + ("thr" "粟束速俗属続屬續謖贖") + ("ths" "餐孫損遜巽") + ("thf" "率蟀") + ("thd" "松訟宋送悚枩淞竦舂蚣誦鎹頌鬆") + ("thkf" "刷") + ("tho" "鎖砕刷殺晒洒灑瑣碎") + ("thl" "粋衰夊") + ("tn" "守手殊狩首受寿授樹綬需囚収修愁秀繍蒐讐酬獣宿須垂帥水睡遂随瑞髄数捜痩袖竪誰嬬穂薮輸率叟售嗾嗽埀壽嫂岫戍搜收數殳泅洙溲漱燧獸祟穗籔粹綉綏繻羞脩隋膸茱莎蓚藪雖讎豎隨酥銖銹鏥陲隧髓鬚") + ("tnr" "叔夙宿淑縮粛塾熟俶孰倏肅菽蓿") + ("tns" "瞬舜駿循旬楯殉淳盾純巡醇順馴徇恂洵筍笋脣荀蓴蕣詢諄鐓鶉") + ("tnf" "術述率恤戌朮") + ("tnd" "崇嵩菘") + ("tnl" "倅伜淬") + ("tmf" "膝瑟虱蝨") + ("tmq" "湿拾習襲濕褶隰") + ("tmd" "勝升承昇丞乗剰僧縄蝿乘剩甸枡繩蠅陞") + ("tl" "飴柿匙殺使始屍市施視詩試侍寺時示蒔偲柴是提矢厮啻嗜嘶尸屎廝弑恃撕猜翅腮舐葹蓍諡豕豺顋") + ("tlr" "喰式識埴飾拭植殖食蝕息寔熄軾餝") + ("tls" "榊伸信娠慎新申神紳臣薪身辛腎訊迅辰矧噺呻哂宸愼抻晨燼蜃贐頤鰰") + ("tlf" "失室悉実實榁蟋") + ("tla" "参審心深芯尋甚參忱椹沁潯瀋蕈鐔") + ("tlq" "拾什十渋辻卅丗澁澀瓧竍籵") + ("Tkd" "双雙") + ("Tl" "氏") + ("dk" "亜唖阿俄峨我牙芽蛾雅餓涯御児亞兒哦娥婀峩椏猗痾莪衙襾訝錏鐚鴉鵝鵞") + ("dkr" "亜悪握渥岳楽顎鍔鰐亞咢堊嶽幄惡愕樂萼蕚葯諤鄂鶚齷齶") + ("dks" "安按案鞍岸眼贋雁顔諺偐晏殷顏鮟鴈鳫") + ("dkf" "斡按謁戛戞蘗蘖歹訐軋遏閼靄") + ("dka" "庵暗闇厭俺巌癌岩嵒巖菴諳頷黯黶") + ("dkq" "姶圧押鴨哈壓狎") + ("dkd" "央仰昂怏殃泱秧鞅鴦") + ("do" "哀愛挨崖涯碍喝啀嗄噫埃崕曖欸皚睚瞹磑礙艾藹阨隘靄靉饐") + ("dor" "液額夜厄扼掖腋軛阨隘") + ("dod" "嚶櫻罌鶯鸚") + ("di" "射斜邪若惹埜也冶夜爺耶野揶椰鵺") + ("dir" "鰯若弱約薬躍嫋搦籥葯蒻藥鑰鶸龠") + ("did" "詳壌嬢穣譲醸揚楊様洋羊陽養佯壤孃恙攘昜暘樣漾瀁煬痒瘍癢禳穰襄讓釀驤") + ("dj" "於漁禦魚御語唹圄圉淤飫馭鯲齬") + ("djr" "億憶臆疑抑檍") + ("djs" "堰言諺這彦偃嫣焉篶") + ("djf" "蘗蘖") + ("dja" "奄掩俺巌岩験厳儼厂嚴巖广淹罨閹驗") + ("djq" "業") + ("dp" "恚殪") + ("du" "汝如予余与誉輿預豫歟洳畭絮舁與茹蕷蜍譽餘") + ("dur" "易域疫駅逆射亦役訳懌繹蜴譯閠閾霓驛鯣") + ("dus" "咽宴延沿演煙燕縁鉛研硯次然鳶軟燃淵吮嚥妍娟悁捐掾椽櫞衍涓涎渊烟筵臙莚蜒蠕讌") + ("duf" "咽悦閲説熱吶噎齧") + ("dua" "厭炎焔艶塩染稔冉檐艷苒閻髯魘鯰鹽黶") + ("duq" "厭葉囁曄靨") + ("dud" "営嬰影映栄永泳瑛盈穎頴英詠景迎咏營塋佞侫暎楹榮潁瀛瑩瓔珱纓蠑贏郢霙") + ("dP" "医叡曳洩鋭刈詣芸児蕊誉預乂豫倪兒兌囈曵泄猊睨睿穢翳艾蘂蕋藝蚋裔譽貎霓鯢麑") + ("dh" "悪烏迂於汚奥襖五伍午呉吾娯悟梧誤傲唔嗚嗷塢墺奧媼寤忤惡懊敖晤澳熬燠牾珸蜈螯遨鏖鰲鼇") + ("dhr" "阿屋玉獄沃") + ("dhs" "温穏慍瘟穩薀蘊褞鰮鰛") + ("dhf" "兀榲膃") + ("dhd" "翁擁壅廱瓮甕癰禺蓊雍鶲") + ("dhk" "娃渦臥蛙瓦窪哇囮窩萵蝸訛譌") + ("dhks" "宛完緩莞関玩翫頑椀碗腕婉浣澣蜿豌關") + ("dhkf" "曰") + ("dhkd" "往旺王皇尢徃枉汪") + ("dho" "娃蛙倭哇矮蝸") + ("dhl" "畏外隈嵬巍猥磑薈鮠") + ("dy" "凹楽尭腰擾銚陶約妖揺曜窯耀要謡遥僥夭姚嬲嫐嶢幺徭徼拗搖撓樂橈殀澆燿瑶窈窰繞蕘蟯謠遶邀饒鷂堯遙瑤") + ("dyr" "辱谷慾欲浴峪溽縟蓐褥") + ("dyd" "桶茸勇湧涌傭容庸溶熔用蓉踊俑慂慵榕甬聳舂蛹踴鎔頌") + ("dn" "芋右宇羽迂雨欧殴牛区愚虞偶寓遇隅枢又尤佑優友憂祐郵于傴吁吽嵎樞歐毆疣盂禹禺紆肬藕謳麌齲") + ("dnr" "旭郁勗墺澳燠") + ("dns" "員韻云運雲暈殞熕紜耘隕韵") + ("dnf" "宛尉欝蔚鬱熨") + ("dnd" "熊雄") + ("dnjs" "宛員院園怨援猿苑薗遠鴛垣願元原源媛冤圓圜婉寃愿湲爰芫蜿袁諢轅鋺阮隕") + ("dnjf" "越月戉曰粤鉞") + ("dnl" "葦位偉囲委威尉慰為緯胃萎謂違蔚衛危偽倭僞喟囗圍幃渭爲痿縅莠蝟衞逶韋魏") + ("db" "惟維遺桜儒柔嬬酉楢肉乳濡鮪愉愈油癒諭輸唯宥幽悠有柚猶猷由裕誘遊幼侑兪喩囿孺帷懦揉揄攸楡渝游瑜瘉糅綏腴臾萸蕕蚰蝓蝣蠕襦覦諛蹂踰逾釉鍮鞣黝鼬") + ("dbr" "育粥肉囿毓鬻") + ("dbs" "允胤閏潤尹贇酳") + ("dbf" "聿鴪") + ("dbd" "戎融絨") + ("dms" "隠恩銀听圻垠慇憖殷犹隱齦") + ("dmf" "乙疑") + ("dma" "飲淫蔭陰音疑吟吽婬崟飮霪") + ("dmq" "泣揖邑悒") + ("dmd" "応疑凝鷹蝿應膺蠅軅軈") + ("dml" "依意椅衣涯毅儀宜擬疑義蟻誼議歪倚崕嶬嶷懿欹熨猗矣礒縊艤醫饐") + ("dl" "飴以伊夷易異移餌施爾而耳蛇食詑台弛寅二迩弍姨尓已彝彜怡洟珥甅痍肄苡詒貽貳貮轜邇隶") + ("dlr" "益翌翼嶷弋杙翊謚鷁") + ("dls" "印咽因姻引煙人仁刃靭寅忍認籾仞仭儿刄堙孕廴氤湮烟茵荵蚓靱") + ("dlf" "一壱溢逸日弌佚壹衵釼鎰") + ("dla" "荏壬賃任妊稔姙恁衽袵") + ("dlq" "込廿入叺圦鳰") + ("dld" "剰仍剩孕") + ("wk" "梓茨佐左査剤作仔刺姉姿子孜紫諮資雌字慈滋磁自煮者斉積柘髭偖劑呰咨孳恣滓炙瓷疵眥眦粢苴茲蔗藉薺觜貲齎赭鮓鷓齊") + ("wkr" "作昨勺杓灼爵酌酢雀嚼妁寉斫柞炸筰綽芍醋鵲") + ("wks" "桟残孱戔棧殘潺盞") + ("wka" "蚕暫潜湛岑潛濳箴簪蠶賺鏨") + ("wkq" "雑匝挿喋囃插箚襍雜") + ("wkd" "匠奨将庄掌樟章粧蒋醤障丈場杖状壮荘葬装臓蔵帳張腸長撞仗塲墻壯奘奬妝將嶂弉橦檣淙漿爿牆獎璋瘴膓臟臧艢莊萇薔藏裝贓賍鏘鱆") + ("wo" "再哉宰才災斎裁載在材財柴斉存滓齋縡纔豺齎齊") + ("wod" "噌槍争鎗崢幀爭瞠箏筝諍錚") + ("wj" "姐且杵煮渚藷諸鋤除岨狙樗瀦猪苧著貯低底抵邸屠這箸儲佇咀弖抒杼柢楮沮潴牴疽砠竚紵羝耡苴蛆觝詆豬躇雎齟") + ("wjr" "荻借寂積籍績赤跡蹟賊逐嫡弔吊摘敵滴的笛適鏑躍勣廸炙狄癪磧糴芍藉覿迪迹逖") + ("wjs" "鴫竣戦栓栴煎箭詮銭前全揃樽佃典填展纏転顛伝殿澱田電縛畑槙淀傳剪甸吮囀奠專巓廛悛戔戰畋旃氈沺濺牋甎痊癜癲磚筌箋篆纒羶翦腆趁躔輾轉鈿銓錢鐫雋靦顫餞饌鷆鷏槇") + ("wjf" "準切拙折窃節絶窒姪凖卩咥截晢晰浙竊耋跌軼") + ("wja" "鮎占漸店点苫粘岾簟霑黏點") + ("wjq" "接蝶慴椄楫楪沾渫聶鰈") + ("wjd" "井鯖晶証鉦情浄錠征政整正精静打丁町頂亭停偵貞呈定庭廷挺汀碇禎程艇訂鄭釘鼎瀞柾靖淀丼叮幀掟旌梃淨渟甼疔睛穽聢菁蟶逞遉酊酲鐺霆靜") + ("wp" "鵜栽済祭際剤諸除制製斉折第醍題堤帝弟悌提梯蹄俤儕劑擠晢濟眥眦睇臍薺齎躋霽齏韲齊") + ("wh" "竃繰錯惨篠助昭照詔条岨措祖租粗組阻操早曹槽漕燥糟藻遭造鯛兆凋弔彫朝潮眺調跳銚鳥蔦爪吊釣敦蚤肇佻俎嘲噪徂慘慥懆找抓晁條梍棗棹澡爼砠祚稠窕竈笊糶絛罩耡胙艚蜩詛誂譟趙躁鑿雕髞") + ("whr" "足族簇蔟鏃") + ("whs" "尊拵") + ("whf" "拙卒枠卆猝") + ("whd" "種腫宗終従縦鍾鐘綜柊从從慫棕椶樅淙粽縱螽踵蹤踪鑁") + ("whk" "佐左坐座挫") + ("whl" "罪") + ("wy" "釖") + ("wn" "株作主朱珠酒呪周州洲舟週住祝厨奏走足族宙昼柱注註酎鋳駐調紬肘湊丶侏做儔冑嗾廚晝疇畴稠籌籀紂綢胄蔟蛛誅赱躊輳遒鑄麈") + ("wnr" "粥竹鬻") + ("wns" "噂俊峻竣駿準純遵屯隼鱒儁凖墫恂悛惷浚濬皴蠢蹲逡") + ("wnd" "衆重中仲") + ("wmr" "即賊") + ("wmf" "櫛") + ("wma" "怎") + ("wmq" "輯汁葺揖楫緝") + ("wmd" "絵甑症証蒸噌曾曽増憎贈徴拯橙烝證") + ("wl" "岐祇志指支旨枝止祉紙肢脂至誌持識質芝織只知地智池蜘遅漬底抵砥之咫址塒帋弖摯枳沚痣祗耆胝舐觝貭贄趾踟躓輊遲阯鮨鷙") + ("wlr" "織職直喞稙稷") + ("wls" "唇振晋榛疹真秦診進震塵尽陣辰珍鎮陳津填賑侭儘嗔晉殄燼珎甄畛盡眞瞋縉臻蓁袗趁軫鎭") + ("wlf" "叱嫉疾質秩窒迭蛭姪佚咥喞垤帙桎耋膣腟貭跌軼") + ("wla" "朕斟酖鴆") + ("wlq" "執輯集汁緝") + ("wld" "澄徴懲澂") + ("ck" "且此叉嵯差瑳車遮借詫侘嗟岔嵳扠搓朿槎磋箚苴蹉釵") + ("ckr" "搾窄錯昔捉濁着著戳縒躇鑿齣齪") + ("cks" "燦纂讃賛餐撰簒攅爨竄粲纉讚贊鏨鑽鑚饌") + ("ckf" "察拶擦札刹扎獺紮") + ("cka" "参惨斬漸僭僣參塹嶄巉慘慙慚懺懴槧站譖譛讒讖驂") + ("ckd" "唱娼廠彰昌菖椙創倉槍窓蒼暢脹畠倡剏厰悵愴搶敞昶淌滄漲猖瘡窗艙蹌鬯") + ("co" "差債彩採采砦祭菜柴責莱寨綵蔡豸釵靫") + ("cor" "咋柵窄策冊責措册嘖拆柞磔筴簀") + ("cj" "妻処凄狙處悽淒絮萋") + ("cjr" "刺尺隻戚斥脊捗剔呎彳擲滌瘠蜴跖蹐蹠躑陟鶺") + ("cjs" "茜粁串釧蚕千川撰泉浅穿舛薦賎践遷辿天仟倩刋喘巛擅栫楾淺湶濺瓩竏荐賤踐闡阡韆") + ("cjf" "綴哲徹撤轍鉄凸畷啜屮掣輟銕錣鐵鐡餮") + ("cja" "鹸尖添甜僉忝恬槧檐沾瞻簷簽籤籖蟾覘諂譫") + ("cjq" "妾捷畳喋帖牒諜貼疊疉疂睫褶輒輙") + ("cjd" "鯖錆晴清請青庁聴廳廰聽菁蜻") + ("cp" "切体替滞逮綴剃締諦逓薙畷啼嚔嚏掣楴涕滯睇砌蒂蔕裼躰軆遞靆體髢") + ("ch" "鍬初哨抄招樵焦硝礁肖蕉鞘酢楚礎草超銚秒剿劭勦屮峭悄愀憔杪椒湫炒稍艸誚貂迢醋鈔髫鷦齠") + ("chr" "趣嘱燭触数促属囑屬數矗矚簇蜀觸躅鏃髑") + ("chs" "吋寸村忖邨") + ("chd" "従銃叢惣総聡寵塚憧葱竜龍从偬匆從怱愡總縱聰") + ("chl" "催最崔摧榱洒") + ("cn" "穐丑鰍取趣就愁秋臭酋醜出諏推錐錘枢趨雛粗畜抽墜椎槌追鎚萩鷲啾娵婢帚惆掫捶楸樞湫甃皺龝箒簇縋聚芻蒭鄒陬隹鞦騅驟鰌麁") + ("cnr" "丑竺軸蹴祝縮築畜筑蓄逐柚槭舳蹙") + ("cns" "春椿鰆") + ("cnf" "出朮黜") + ("cnd" "沖充銃衝忠虫衷傭冲狆艟蟲") + ("cnp" "悴忰惴瘁萃贅") + ("cnl" "取趣就臭吹炊翠酔脆鷲嘴娶惴揣橇毳瘁翆聚膵萃觜醉驟") + ("cmr" "側則測捗仄惻昃") + ("cms" "齔") + ("cma" "闖") + ("cmd" "曾曽層") + ("cl" "嵯差歯治痔埴植織値恥痴稚置致馳徴直薙侈卮厠嗤夂峙巵幟廁梔熾畄畤癡碪穉笞紕緇緻耻蚩褫豸跂輜錙雉魑鯔鴟鵄黹齒") + ("clr" "則測勅飭厠廁惻敕") + ("cls" "親襯齔") + ("clf" "七漆") + ("cla" "砧侵寝浸針湛沈枕寢忱斟椹鍼鍖闖駸") + ("clq" "蟄") + ("cld" "称秤稱袮騁") + ("cho" "快夬獪") + ("xk" "蛇他詑唾堕妥惰打柁舵楕陀駄騨池詫佗咤墮它捶揣朶橢沱隋躱駝鴕") + ("xkr" "卓啄托拓沢濯琢託鐸濁擢度倬啅拆柝澤鈬魄") + ("xks" "騨嘆坦歎炭綻誕弾呑灘彈憚攤殫袒") + ("xkf" "奪脱") + ("xka" "探耽眈貪") + ("xkq" "塔搭搨榻鞜鞳鰈") + ("xkd" "宕湯糖蕩帑盪蝪") + ("xo" "税太汰怠態泰胎苔逮台大能殆戻兌棣笞紿蛻詒颱駘") + ("xor" "宅択沢擇澤") + ("xh" "兎吐菟土套討兔莵") + ("xhs" "褪") + ("xhd" "桶痛通筒統樋恫慟") + ("xhl" "推堆腿退槌追鎚敦褪頽") + ("xn" "妬投透闘愉偸綉鍮骰鬪") + ("xmr" "貸特慝") + ("vk" "頗巴把播杷波派琶破婆芭罷簸坡怕擺霸爬玻碆笆耙膰菠葩袙跛陂") + ("vks" "坂阪判板版販辧汳瓣鈑") + ("vkf" "捌八叭杁釟") + ("vo" "唄貝派敗牌背倍狽抜罷稗佩孛悖拔旆霸沛珮霈") + ("vod" "棚烹傍膨弸彭旁澎磅繃") + ("vir" "愎") + ("vus" "平偏片篇編遍便鞭扁翩苹蝙褊諞騙") + ("vua" "貶") + ("vud" "坪評浜平怦泙硼苹萍鮃") + ("vP" "柿廃肺幣弊蔽閉陛吠嬖幤廢敝斃癈薜髀") + ("vh" "浦鞄蒲曝爆布怖葡舗鋪圃捕包庖抱泡砲胞褒飽暴勹匍匏咆哺垉抛枹瀑炮疱皰脯舖苞袍襃逋鉋靤餔髱鮑鯆麭") + ("vhr" "曝爆幅暴瀑") + ("vy" "杓俵彪標漂瓢票表豹剽嫖慓殍縹飄飃飆驃驫髟鰾") + ("vns" "分") + ("vna" "品稟禀") + ("vnd" "楓風豊瘋諷豐颪馮") + ("vb" "彪") + ("vl" "彼披疲皮罷被避跛辟陂") + ("vlf" "嘩比泌匹疋弼必畢筆払仏佛拂篳譁蹕鵯") + ("vlq" "逼幅乏泛") + ("gk" "下何夏河荷蝦霞賀嚇雫厦呀廈渮瑕緞罅訶谺遐鍜鰕") + ("gkr" "鴬学虐鶴壑學斈涸狢瘧謔貉鷽") + ("gks" "寒汗漢翰閑韓限恨嫺嫻悍扞捍旱桿瀚狠皖罕邯駻骭鼾") + ("gkf" "害割喝轄劼瞎蝎黠") + ("gka" "艦陥含函濫凾咸啣喊嵌檻涵緘莟邯銜陷頷餡鰔鹹") + ("gkq" "蓋閤合蛤呷哈溘盍盖盒葢闔鴿") + ("gkd" "桁巷恒抗杭港航行降項虹亢伉吭恆缸肛閧頏鬨") + ("go" "亥解械海蟹劾咳害該骸鮭偕垓夥奚孩廨懈楷薤蠏觧諧邂醢駭") + ("gor" "劾核硅覈輅") + ("god" "杏倖幸行絎裄鵆") + ("gid" "享郷響饗向香嚮餉") + ("gj" "嘘虚許墟栩歔滸") + ("gjs" "憲献軒掀獻") + ("gjf" "歇蝎蠍") + ("gja" "険験嶮險驗") + ("gur" "嚇赫革恵奕洫鬩") + ("gus" "絢懸県見賢顕弦玄現絃舷項頁俔呟洵痃眩縣蜆衒鉉顯") + ("guf" "穴血冗頁孟孑襭頡") + ("gua" "嫌") + ("guq" "袷叶侠協峡挟狭脅頬脇夾峽慊挾浹狹筴篋莢鋏陜陝") + ("gud" "馨亨刑兄型形荊蛍桁衡夐炯烱瑩脛螢迥") + ("gP" "慧繋兮匸奚彗惠盻禊蹊醯鞋") + ("gh" "穫乎呼弧戸湖狐糊胡虎雇互吾瑚護醐好浩号壕濠豪冴皐縞壷冱壺怙戲昊晧楜毫沍滬滸犒琥瓠皋皓葫蒿虍號蝴扈鎬餬") + ("ghr" "或酷鵠惑寉斛") + ("ghs" "婚昏昆混魂棍棔渾溷焜琿") + ("ghf" "核忽惚歿笏鶻") + ("ghq" "恰") + ("ghd" "弘洪紅鴻哄汞泓訌閧鬨") + ("ghk" "化火禍禾花華貨画椛樺靴樗和話啝崋畫糀錵") + ("ghkr" "拡獲確穫擴攫癨矍蠖霍") + ("ghks" "喚患換桓歓環還丸幻亘圜奐宦寰懽歡渙湲煥皖眩矜讙豢鐶驩鬟鰥") + ("ghkf" "越活滑撮猾磆蛞豁闊濶") + ("ghkd" "黄況兄慌晃皇荒幌况凰徨恍惶晄湟滉煌篁簧肓蝗遑隍鰉") + ("gho" "画罫獪畫") + ("ghl" "会回壊廻悔恢懐晦灰准桧賄會囘匯壞徊懷檜槐淮繪膾茴薈蛔詼誨迴鱠") + ("ghlr" "画劃獲畫") + ("ghld" "横弘衡轟薨軣鍠黌") + ("gy" "暁佼効校酵肴傚哮嚆囂效曉梟淆烋爻驕驍") + ("gn" "芋朽後侯候厚后喉佝吼嗅嘔涸煦猴篌詬逅") + ("gns" "勲薫訓馴勳熏燻葷醺") + ("gnd" "薨") + ("gnjs" "萱喧暖愃暄萓諠讙") + ("gnp" "虫卉喙毀燬") + ("gnl" "揮徽輝彙戲暉麾諱") + ("gb" "休携畦畜攜烋虧貅") + ("gbr" "畜") + ("gbf" "恤譎鷸") + ("gbd" "兇凶胸匈恟洶") + ("gmr" "黒釛") + ("gms" "欣痕很忻掀釁") + ("gmf" "汽吃迄屹訖") + ("gma" "欽欠") + ("gmq" "吸歙洽皀翕") + ("gmd" "興虹") + ("gml" "喜嬉希稀戯犠姫僖咥唏噫愾憙戲晞曦欷煕熈熹燹犧禧羲釐鯑") + ("glf" "詰纈襭頡黠") + ("unknown" "苅宍栂栃凪弐塀俣杢刔夘咒哘唸囎圀圷圸垳垪埔埖埣塰堽墹墸壗壥嬶屓乢妛岫岻岶岼峅峇峺嵶彁怺恷恊抂挧掵擶暃杤桙梹椥椨椪椚椣椡槝樮櫁樌橲樶橸樢檸欟歛汢渕淕溂潸澑犲畉畆畩蘯眤瞶硴碚碵礇禝穃邃笶筅箟篏簓簗籏粐粭粫糘綛縺繧纃緕纐罎膤艝茣莇菷萢蒄蓙蘰蚫蛯蟐袞袰褄諚戝轌辷迚逧逎鍄錻閇閖陦隲靹鞆鞐饂馼駲鮖鮴鯒鯱鰄鰡鱚鵈鵤鵐")) ;;; hanja-jis.el ends here diff --git a/lisp/leim/quail/japanese.el b/lisp/leim/quail/japanese.el index 74f02b141da..d536b5e5c96 100644 --- a/lisp/leim/quail/japanese.el +++ b/lisp/leim/quail/japanese.el @@ -1,4 +1,4 @@ -;;; japanese.el --- Quail package for inputting Japanese -*-coding: iso-2022-7bit;-*- +;;; japanese.el --- Quail package for inputting Japanese ;; Copyright (C) 2001-2019 Free Software Foundation, Inc. ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -31,7 +31,7 @@ (require 'kkc) (defvar quail-japanese-use-double-n nil - "If non-nil, use type \"nn\" to insert $B$s(B.") + "If non-nil, use type \"nn\" to insert ん.") ;; Update Quail translation region while considering Japanese bizarre ;; translation rules. @@ -47,14 +47,14 @@ (setq quail-current-str (aref quail-current-key 0) control-flag t)) ((= (aref quail-current-key 0) ?n) - (setq quail-current-str ?$B$s(B) + (setq quail-current-str ?ん) (if (and quail-japanese-use-double-n (> keylen 0) (= (aref quail-current-key 1) ?n)) (setq control-flag t))) ((and (> keylen 1) (= (aref quail-current-key 0) (aref quail-current-key 1))) - (setq quail-current-str ?$B$C(B)) + (setq quail-current-str ?っ)) (t (setq quail-current-str (aref quail-current-key 0)))) (if (integerp control-flag) @@ -84,10 +84,10 @@ (defun quail-japanese-kanji-kkc () (interactive) (when (= (char-before (overlay-end quail-conv-overlay)) ?n) - ;; The last char is `n'. We had better convert it to `$B$s(B' + ;; The last char is `n'. We had better convert it to `ん' ;; before kana-kanji conversion. (goto-char (1- (overlay-end quail-conv-overlay))) - (insert ?$B$s(B) + (insert ?ん) (delete-char 1)) (let* ((from (copy-marker (overlay-start quail-conv-overlay))) (len (- (overlay-end quail-conv-overlay) from))) @@ -135,113 +135,113 @@ (throw 'quail-tag nil)) (defvar quail-japanese-transliteration-rules - '(( "a" "$B$"(B") ( "i" "$B$$(B") ( "u" "$B$&(B") ( "e" "$B$((B") ( "o" "$B$*(B") - ("ka" "$B$+(B") ("ki" "$B$-(B") ("ku" "$B$/(B") ("ke" "$B$1(B") ("ko" "$B$3(B") - ("sa" "$B$5(B") ("si" "$B$7(B") ("su" "$B$9(B") ("se" "$B$;(B") ("so" "$B$=(B") - ("ta" "$B$?(B") ("ti" "$B$A(B") ("tu" "$B$D(B") ("te" "$B$F(B") ("to" "$B$H(B") - ("na" "$B$J(B") ("ni" "$B$K(B") ("nu" "$B$L(B") ("ne" "$B$M(B") ("no" "$B$N(B") - ("ha" "$B$O(B") ("hi" "$B$R(B") ("hu" "$B$U(B") ("he" "$B$X(B") ("ho" "$B$[(B") - ("ma" "$B$^(B") ("mi" "$B$_(B") ("mu" "$B$`(B") ("me" "$B$a(B") ("mo" "$B$b(B") - ("ya" "$B$d(B") ("yu" "$B$f(B") ("yo" "$B$h(B") - ("ra" "$B$i(B") ("ri" "$B$j(B") ("ru" "$B$k(B") ("re" "$B$l(B") ("ro" "$B$m(B") - ("la" "$B$i(B") ("li" "$B$j(B") ("lu" "$B$k(B") ("le" "$B$l(B") ("lo" "$B$m(B") - ("wa" "$B$o(B") ("wi" "$B$p(B") ("wu" "$B$&(B") ("we" "$B$q(B") ("wo" "$B$r(B") - ("n'" "$B$s(B") - ("ga" "$B$,(B") ("gi" "$B$.(B") ("gu" "$B$0(B") ("ge" "$B$2(B") ("go" "$B$4(B") - ("za" "$B$6(B") ("zi" "$B$8(B") ("zu" "$B$:(B") ("ze" "$B$<(B") ("zo" "$B$>(B") - ("da" "$B$@(B") ("di" "$B$B(B") ("du" "$B$E(B") ("de" "$B$G(B") ("do" "$B$I(B") - ("ba" "$B$P(B") ("bi" "$B$S(B") ("bu" "$B$V(B") ("be" "$B$Y(B") ("bo" "$B$\(B") - ("pa" "$B$Q(B") ("pi" "$B$T(B") ("pu" "$B$W(B") ("pe" "$B$Z(B") ("po" "$B$](B") - - ("kya" ["$B$-$c(B"]) ("kyu" ["$B$-$e(B"]) ("kye" ["$B$-$'(B"]) ("kyo" ["$B$-$g(B"]) - ("sya" ["$B$7$c(B"]) ("syu" ["$B$7$e(B"]) ("sye" ["$B$7$'(B"]) ("syo" ["$B$7$g(B"]) - ("sha" ["$B$7$c(B"]) ("shu" ["$B$7$e(B"]) ("she" ["$B$7$'(B"]) ("sho" ["$B$7$g(B"]) - ("cha" ["$B$A$c(B"]) ("chu" ["$B$A$e(B"]) ("che" ["$B$A$'(B"]) ("cho" ["$B$A$g(B"]) - ("tya" ["$B$A$c(B"]) ("tyu" ["$B$A$e(B"]) ("tye" ["$B$A$'(B"]) ("tyo" ["$B$A$g(B"]) - ("nya" ["$B$K$c(B"]) ("nyu" ["$B$K$e(B"]) ("nye" ["$B$K$'(B"]) ("nyo" ["$B$K$g(B"]) - ("hya" ["$B$R$c(B"]) ("hyu" ["$B$R$e(B"]) ("hye" ["$B$R$'(B"]) ("hyo" ["$B$R$g(B"]) - ("mya" ["$B$_$c(B"]) ("myu" ["$B$_$e(B"]) ("mye" ["$B$_$'(B"]) ("myo" ["$B$_$g(B"]) - ("rya" ["$B$j$c(B"]) ("ryu" ["$B$j$e(B"]) ("rye" ["$B$j$'(B"]) ("ryo" ["$B$j$g(B"]) - ("lya" ["$B$j$c(B"]) ("lyu" ["$B$j$e(B"]) ("lye" ["$B$j$'(B"]) ("lyo" ["$B$j$g(B"]) - ("gya" ["$B$.$c(B"]) ("gyu" ["$B$.$e(B"]) ("gye" ["$B$.$'(B"]) ("gyo" ["$B$.$g(B"]) - ("zya" ["$B$8$c(B"]) ("zyu" ["$B$8$e(B"]) ("zye" ["$B$8$'(B"]) ("zyo" ["$B$8$g(B"]) - ("jya" ["$B$8$c(B"]) ("jyu" ["$B$8$e(B"]) ("jye" ["$B$8$'(B"]) ("jyo" ["$B$8$g(B"]) - ( "ja" ["$B$8$c(B"]) ( "ju" ["$B$8$e(B"]) ( "je" ["$B$8$'(B"]) ( "jo" ["$B$8$g(B"]) - ("bya" ["$B$S$c(B"]) ("byu" ["$B$S$e(B"]) ("bye" ["$B$S$'(B"]) ("byo" ["$B$S$g(B"]) - ("pya" ["$B$T$c(B"]) ("pyu" ["$B$T$e(B"]) ("pye" ["$B$T$'(B"]) ("pyo" ["$B$T$g(B"]) - - ("kwa" ["$B$/$n(B"]) ("kwi" ["$B$/$#(B"]) ("kwe" ["$B$/$'(B"]) ("kwo" ["$B$/$)(B"]) - ("tsa" ["$B$D$!(B"]) ("tsi" ["$B$D$#(B"]) ("tse" ["$B$D$'(B"]) ("tso" ["$B$D$)(B"]) - ( "fa" ["$B$U$!(B"]) ( "fi" ["$B$U$#(B"]) ( "fe" ["$B$U$'(B"]) ( "fo" ["$B$U$)(B"]) - ("gwa" ["$B$0$n(B"]) ("gwi" ["$B$0$#(B"]) ("gwe" ["$B$0$'(B"]) ("gwo" ["$B$0$)(B"]) - - ("dyi" ["$B$G$#(B"]) ("dyu" ["$B$I$%(B"]) ("dye" ["$B$G$'(B"]) ("dyo" ["$B$I$)(B"]) - ("xwi" ["$B$&$#(B"]) ("xwe" ["$B$&$'(B"]) ("xwo" ["$B$&$)(B"]) - - ("shi" "$B$7(B") ("tyi" ["$B$F$#(B"]) ("chi" "$B$A(B") ("tsu" "$B$D(B") ("ji" "$B$8(B") - ("fu" "$B$U(B") - ("ye" ["$B$$$'(B"]) - - ("va" ["$B%t$!(B"]) ("vi" ["$B%t$#(B"]) ("vu" "$B%t(B") ("ve" ["$B%t$'(B"]) ("vo" ["$B%t$)(B"]) - - ("xa" "$B$!(B") ("xi" "$B$#(B") ("xu" "$B$%(B") ("xe" "$B$'(B") ("xo" "$B$)(B") - ("xtu" "$B$C(B") ("xya" "$B$c(B") ("xyu" "$B$e(B") ("xyo" "$B$g(B") ("xwa" "$B$n(B") - ("xka" "$B%u(B") ("xke" "$B%v(B") - - ("1" "$B#1(B") ("2" "$B#2(B") ("3" "$B#3(B") ("4" "$B#4(B") ("5" "$B#5(B") - ("6" "$B#6(B") ("7" "$B#7(B") ("8" "$B#8(B") ("9" "$B#9(B") ("0" "$B#0(B") - - ("!" "$B!*(B") ("@" "$B!w(B") ("#" "$B!t(B") ("$" "$B!p(B") ("%" "$B!s(B") - ("^" "$B!0(B") ("&" "$B!u(B") ("*" "$B!v(B") ("(" "$B!J(B") (")" "$B!K(B") - ("-" "$B!<(B") ("=" "$B!a(B") ("`" "$B!.(B") ("\\" "$B!o(B") ("|" "$B!C(B") - ("_" "$B!2(B") ("+" "$B!\(B") ("~" "$B!1(B") ("[" "$B!V(B") ("]" "$B!W(B") - ("{" "$B!P(B") ("}" "$B!Q(B") (":" "$B!'(B") (";" "$B!((B") ("\"" "$B!I(B") - ("'" "$B!G(B") ("." "$B!#(B") ("," "$B!"(B") ("<" "$B!c(B") (">" "$B!d(B") - ("?" "$B!)(B") ("/" "$B!?(B") - - ("z1" "$B!{(B") ("z!" "$B!|(B") - ("z2" "$B"&(B") ("z@" "$B"'(B") - ("z3" "$B"$(B") ("z#" "$B"%(B") - ("z4" "$B""(B") ("z$" "$B"#(B") - ("z5" "$B!~(B") ("z%" "$B"!(B") - ("z6" "$B!y(B") ("z^" "$B!z(B") - ("z7" "$B!}(B") ("z&" "$B!r(B") - ("z8" "$B!q(B") ("z*" "$B!_(B") - ("z9" "$B!i(B") ("z(" "$B!Z(B") - ("z0" "$B!j(B") ("z)" "$B![(B") - ("z-" "$B!A(B") ("z_" "$B!h(B") - ("z=" "$B!b(B") ("z+" "$B!^(B") - ("z\\" "$B!@(B") ("z|" "$B!B(B") - ("z`" "$B!-(B") ("z~" "$B!/(B") - - ("zq" "$B!T(B") ("zQ" "$B!R(B") - ("zw" "$B!U(B") ("zW" "$B!S(B") - ("zr" "$B!9(B") ("zR" "$B!8(B") - ("zt" "$B!:(B") ("zT" "$B!x(B") - ("zp" "$B")(B") ("zP" "$B",(B") - ("z[" "$B!X(B") ("z{" "$B!L(B") - ("z]" "$B!Y(B") ("z}" "$B!M(B") - - ("zs" "$B!3(B") ("zS" "$B!4(B") - ("zd" "$B!5(B") ("zD" "$B!6(B") - ("zf" "$B!7(B") ("zF" "$B"*(B") - ("zg" "$B!>(B") ("zG" "$B!=(B") - ("zh" "$B"+(B") - ("zj" "$B"-(B") - ("zk" "$B",(B") - ("zl" "$B"*(B") - ("z;" "$B!+(B") ("z:" "$B!,(B") - ("z'" "$B!F(B") ("z\"" "$B!H(B") + '(( "a" "あ") ( "i" "い") ( "u" "う") ( "e" "え") ( "o" "お") + ("ka" "か") ("ki" "き") ("ku" "く") ("ke" "け") ("ko" "こ") + ("sa" "さ") ("si" "し") ("su" "す") ("se" "せ") ("so" "そ") + ("ta" "た") ("ti" "ち") ("tu" "つ") ("te" "て") ("to" "と") + ("na" "な") ("ni" "に") ("nu" "ぬ") ("ne" "ね") ("no" "の") + ("ha" "は") ("hi" "ひ") ("hu" "ふ") ("he" "へ") ("ho" "ほ") + ("ma" "ま") ("mi" "み") ("mu" "む") ("me" "め") ("mo" "も") + ("ya" "や") ("yu" "ゆ") ("yo" "よ") + ("ra" "ら") ("ri" "り") ("ru" "る") ("re" "れ") ("ro" "ろ") + ("la" "ら") ("li" "り") ("lu" "る") ("le" "れ") ("lo" "ろ") + ("wa" "わ") ("wi" "ゐ") ("wu" "う") ("we" "ゑ") ("wo" "を") + ("n'" "ん") + ("ga" "が") ("gi" "ぎ") ("gu" "ぐ") ("ge" "げ") ("go" "ご") + ("za" "ざ") ("zi" "じ") ("zu" "ず") ("ze" "ぜ") ("zo" "ぞ") + ("da" "だ") ("di" "ぢ") ("du" "づ") ("de" "で") ("do" "ど") + ("ba" "ば") ("bi" "び") ("bu" "ぶ") ("be" "べ") ("bo" "ぼ") + ("pa" "ぱ") ("pi" "ぴ") ("pu" "ぷ") ("pe" "ぺ") ("po" "ぽ") + + ("kya" ["きゃ"]) ("kyu" ["きゅ"]) ("kye" ["きぇ"]) ("kyo" ["きょ"]) + ("sya" ["しゃ"]) ("syu" ["しゅ"]) ("sye" ["しぇ"]) ("syo" ["しょ"]) + ("sha" ["しゃ"]) ("shu" ["しゅ"]) ("she" ["しぇ"]) ("sho" ["しょ"]) + ("cha" ["ちゃ"]) ("chu" ["ちゅ"]) ("che" ["ちぇ"]) ("cho" ["ちょ"]) + ("tya" ["ちゃ"]) ("tyu" ["ちゅ"]) ("tye" ["ちぇ"]) ("tyo" ["ちょ"]) + ("nya" ["にゃ"]) ("nyu" ["にゅ"]) ("nye" ["にぇ"]) ("nyo" ["にょ"]) + ("hya" ["ひゃ"]) ("hyu" ["ひゅ"]) ("hye" ["ひぇ"]) ("hyo" ["ひょ"]) + ("mya" ["みゃ"]) ("myu" ["みゅ"]) ("mye" ["みぇ"]) ("myo" ["みょ"]) + ("rya" ["りゃ"]) ("ryu" ["りゅ"]) ("rye" ["りぇ"]) ("ryo" ["りょ"]) + ("lya" ["りゃ"]) ("lyu" ["りゅ"]) ("lye" ["りぇ"]) ("lyo" ["りょ"]) + ("gya" ["ぎゃ"]) ("gyu" ["ぎゅ"]) ("gye" ["ぎぇ"]) ("gyo" ["ぎょ"]) + ("zya" ["じゃ"]) ("zyu" ["じゅ"]) ("zye" ["じぇ"]) ("zyo" ["じょ"]) + ("jya" ["じゃ"]) ("jyu" ["じゅ"]) ("jye" ["じぇ"]) ("jyo" ["じょ"]) + ( "ja" ["じゃ"]) ( "ju" ["じゅ"]) ( "je" ["じぇ"]) ( "jo" ["じょ"]) + ("bya" ["びゃ"]) ("byu" ["びゅ"]) ("bye" ["びぇ"]) ("byo" ["びょ"]) + ("pya" ["ぴゃ"]) ("pyu" ["ぴゅ"]) ("pye" ["ぴぇ"]) ("pyo" ["ぴょ"]) + + ("kwa" ["くゎ"]) ("kwi" ["くぃ"]) ("kwe" ["くぇ"]) ("kwo" ["くぉ"]) + ("tsa" ["つぁ"]) ("tsi" ["つぃ"]) ("tse" ["つぇ"]) ("tso" ["つぉ"]) + ( "fa" ["ふぁ"]) ( "fi" ["ふぃ"]) ( "fe" ["ふぇ"]) ( "fo" ["ふぉ"]) + ("gwa" ["ぐゎ"]) ("gwi" ["ぐぃ"]) ("gwe" ["ぐぇ"]) ("gwo" ["ぐぉ"]) + + ("dyi" ["でぃ"]) ("dyu" ["どぅ"]) ("dye" ["でぇ"]) ("dyo" ["どぉ"]) + ("xwi" ["うぃ"]) ("xwe" ["うぇ"]) ("xwo" ["うぉ"]) + + ("shi" "し") ("tyi" ["てぃ"]) ("chi" "ち") ("tsu" "つ") ("ji" "じ") + ("fu" "ふ") + ("ye" ["いぇ"]) + + ("va" ["ヴぁ"]) ("vi" ["ヴぃ"]) ("vu" "ヴ") ("ve" ["ヴぇ"]) ("vo" ["ヴぉ"]) + + ("xa" "ぁ") ("xi" "ぃ") ("xu" "ぅ") ("xe" "ぇ") ("xo" "ぉ") + ("xtu" "っ") ("xya" "ゃ") ("xyu" "ゅ") ("xyo" "ょ") ("xwa" "ゎ") + ("xka" "ヵ") ("xke" "ヶ") + + ("1" "1") ("2" "2") ("3" "3") ("4" "4") ("5" "5") + ("6" "6") ("7" "7") ("8" "8") ("9" "9") ("0" "0") + + ("!" "!") ("@" "@") ("#" "#") ("$" "$") ("%" "%") + ("^" "^") ("&" "&") ("*" "*") ("(" "(") (")" ")") + ("-" "ー") ("=" "=") ("`" "`") ("\\" "¥") ("|" "|") + ("_" "_") ("+" "+") ("~" " ̄") ("[" "「") ("]" "」") + ("{" "{") ("}" "}") (":" ":") (";" ";") ("\"" "”") + ("'" "’") ("." "。") ("," "、") ("<" "<") (">" ">") + ("?" "?") ("/" "/") + + ("z1" "○") ("z!" "●") + ("z2" "▽") ("z@" "▼") + ("z3" "△") ("z#" "▲") + ("z4" "□") ("z$" "■") + ("z5" "◇") ("z%" "◆") + ("z6" "☆") ("z^" "★") + ("z7" "◎") ("z&" "£") + ("z8" "¢") ("z*" "×") + ("z9" "♂") ("z(" "【") + ("z0" "♀") ("z)" "】") + ("z-" "〜") ("z_" "∴") + ("z=" "≠") ("z+" "±") + ("z\\" "\") ("z|" "‖") + ("z`" "´") ("z~" "¨") + + ("zq" "《") ("zQ" "〈") + ("zw" "》") ("zW" "〉") + ("zr" "々") ("zR" "仝") + ("zt" "〆") ("zT" "§") + ("zp" "〒") ("zP" "↑") + ("z[" "『") ("z{" "〔") + ("z]" "』") ("z}" "〕") + + ("zs" "ヽ") ("zS" "ヾ") + ("zd" "ゝ") ("zD" "ゞ") + ("zf" "〃") ("zF" "→") + ("zg" "‐") ("zG" "—") + ("zh" "←") + ("zj" "↓") + ("zk" "↑") + ("zl" "→") + ("z;" "゛") ("z:" "゜") + ("z'" "‘") ("z\"" "“") ("zx" [":-"]) ("zX" [":-)"]) - ("zc" "$B!;(B") ("zC" "$B!n(B") - ("zv" "$B"((B") ("zV" "$B!`(B") - ("zb" "$B!k(B") ("zB" "$B"+(B") - ("zn" "$B!l(B") ("zN" "$B"-(B") - ("zm" "$B!m(B") ("zM" "$B".(B") - ("z," "$B!E(B") ("z<" "$B!e(B") - ("z." "$B!D(B") ("z>" "$B!f(B") - ("z/" "$B!&(B") ("z?" "$B!g(B") + ("zc" "〇") ("zC" "℃") + ("zv" "※") ("zV" "÷") + ("zb" "°") ("zB" "←") + ("zn" "′") ("zN" "↓") + ("zm" "″") ("zM" "〓") + ("z," "‥") ("z<" "≦") + ("z." "…") ("z>" "≧") + ("z/" "・") ("z?" "∞") ("\\\\" quail-japanese-self-insert-and-switch-to-alpha) ("{{" quail-japanese-self-insert-and-switch-to-alpha) @@ -252,81 +252,81 @@ )) -;; $B%m!<%^;zF~NO5Z$S2>L>4A;zJQ49$K$h$kF|K\8lF~NO%a%=%C%I(B +;; ローマ字入力及び仮名漢字変換による日本語入力メソッド ;; -;; $B$3$NF~NO%a%=%C%I$G$NF|K\8l$NF~NO$OFs$D$N%9%F!<%8!V%m!<%^;z2>L>JQ49!W(B -;; $B$H!V2>L>4A;zJQ49!W$+$i$J$k!#:G=i$O%m!<%^;z2>L>JQ49$N%9%F!<%8$G!"%9(B -;; $B%Z!<%9%-!<$r2!$9$3$H$K$h$j!"<!$N%9%F!<%8!V2>L>4A;zJQ49!W$X?J$`!#(B +;; この入力メソッドでの日本語の入力は二つのステージ「ローマ字仮名変換」 +;; と「仮名漢字変換」からなる。最初はローマ字仮名変換のステージで、ス +;; ペースキーを押すことにより、次のステージ「仮名漢字変換」へ進む。 ;; -;; $B!V%m!<%^;z2>L>JQ49!W(B +;; 「ローマ字仮名変換」 ;; -;; $BJ?2>L>$O>.J8;z%-!<!JNs!K$rBG$D$3$H$K$h$jF~NO!#6gFIE@!"3g8LN`$OBP1~(B -;; $B$9$k1Q;z%-!<$rBG$D$3$H$K$h$jF~NO!#$=$NB>$N%7%s%\%k$O(B `z' $B$KB3$1$F2?(B -;; $B$l$+$N%-!<$rBG$D$3$H$K$h$jF~NO!#2<$KA4$F$N2DG=$J%-!<%7!<%1%s%9%j%9(B -;; $B%H%"%C%W$5$l$F$$$k!#F~NO$5$l$?J8;z$O2<@~$G<($5$l$k!#(B +;; 平仮名は小文字キー(列)を打つことにより入力。句読点、括弧類は対応 +;; する英字キーを打つことにより入力。その他のシンボルは `z' に続けて何 +;; れかのキーを打つことにより入力。下に全ての可能なキーシーケンスリス +;; トアップされている。入力された文字は下線で示される。 ;; -;; $B$5$i$K0J2<$N%-!<$GFCJL$J=hM}$r9T$&!#(B +;; さらに以下のキーで特別な処理を行う。 ;; -;; K $BJ?2>L>$rJR2>L>$K!"$"$k$$$OJR2>L>$rJ?2>L>$KJQ49(B -;; qq $B$3$NF~NO%a%=%C%I$H(B `japanese-ascii' $BF~NO%a%=%C%I$r%H%0%k@ZBX(B -;; qz `japanese-zenkaku' $BF~NO%a%=%C%I$K%7%U%H(B -;; qh $B$HBG$F$P85$KLa$k(B -;; RET $B8=:_$NF~NOJ8;zNs$r3NDj(B -;; SPC $B2>L>4A;zJQ49$K?J$`(B +;; K 平仮名を片仮名に、あるいは片仮名を平仮名に変換 +;; qq この入力メソッドと `japanese-ascii' 入力メソッドをトグル切替 +;; qz `japanese-zenkaku' 入力メソッドにシフト +;; qh と打てば元に戻る +;; RET 現在の入力文字列を確定 +;; SPC 仮名漢字変換に進む ;; -;; `japanese-ascii' $BF~NO%a%=%C%I$O(B ASCII $BJ8;z$rF~NO$9$k$N$K;H$&!#$3$l(B -;; $B$OF~NO%a%=%C%I$r%*%U$K$9$k$N$H$[$H$s$IF1$8$G$"$k!#0[$J$k$N$O(B qq $B$H(B -;; $BBG$D$3$H$K$h$j!"(B`japanese' $BF~NO%a%=%C%I$KLa$l$kE@$G$"$k!#(B +;; `japanese-ascii' 入力メソッドは ASCII 文字を入力するのに使う。これ +;; は入力メソッドをオフにするのとほとんど同じである。異なるのは qq と +;; 打つことにより、`japanese' 入力メソッドに戻れる点である。 ;; -;; `japanese-zenkaku' $BF~NO%a%=%C%I$OA43Q1Q?t;z$rF~NO$9$k$N$K;H$&!#(B +;; `japanese-zenkaku' 入力メソッドは全角英数字を入力するのに使う。 ;; -;; $B!V%m!<%^;z2>L>JQ49!W%9%F!<%8$G$N%-!<%7!<%1%s%9$N%j%9%H$O:G8e$KIU$1(B -;; $B$F$"$k!#(B +;; 「ローマ字仮名変換」ステージでのキーシーケンスのリストは最後に付け +;; てある。 ;; -;; $B!V2>L>4A;zJQ49!W(B +;; 「仮名漢字変換」 ;; -;; $B$3$N%9%F!<%8$G$O!"A0%9%F!<%8$GF~NO$5$l$?J8;zNs$r2>L>4A;zJQ49$9$k!#(B -;; $BJQ49$5$l$?J8;zNs$O!"CmL\J8@a!JH?E>I=<(!K$H;D$j$NF~NO!J2<@~I=<(!K$K(B -;; $BJ,$1$i$l$k!#CmL\J8@a$KBP$7$F$O0J2<$N%3%^%s%I$,;H$($k!#(B +;; このステージでは、前ステージで入力された文字列を仮名漢字変換する。 +;; 変換された文字列は、注目文節(反転表示)と残りの入力(下線表示)に +;; 分けられる。注目文節に対しては以下のコマンドが使える。 ;; ;; SPC, C-n kkc-next -;; $B<!$NJQ498uJd$rI=<((B -;; kkc-show-conversion-list-count $B0J>eB3$1$FBG$F$P!"JQ498uJd%j%9(B -;; $B%H$r%(%3!<%(%j%"$KI=<((B +;; 次の変換候補を表示 +;; kkc-show-conversion-list-count 以上続けて打てば、変換候補リス +;; トをエコーエリアに表示 ;; C-p kkc-prev -;; $BA0$NJQ498uJd$rI=<((B -;; kkc-show-conversion-list-count $B0J>eB3$1$FBG$F$P!"JQ498uJd%j%9(B -;; $B%H$r%(%3!<%(%j%"$KI=<((B +;; 前の変換候補を表示 +;; kkc-show-conversion-list-count 以上続けて打てば、変換候補リス +;; トをエコーエリアに表示 ;; l kkc-show-conversion-list-or-next-group -;; $B:G9b#1#08D$^$G$NJQ498uJd$r%(%3!<%(%j%"$KI=<(!#(B -;; $BB3$1$FBG$?$l$l$P!"<!$N#1#08uJd$rI=<(!#(B +;; 最高10個までの変換候補をエコーエリアに表示。 +;; 続けて打たれれば、次の10候補を表示。 ;; L kkc-show-conversion-list-or-prev-group -;; $B:G9b#1#08D$^$G$NJQ498uJd$r%(%3!<%(%j%"$KI=<(!#(B -;; $BB3$1$FBG$?$l$l$P!"A0$N#1#08uJd$rI=<(!#(B +;; 最高10個までの変換候補をエコーエリアに表示。 +;; 続けて打たれれば、前の10候補を表示。 ;; 0..9 kkc-select-from-list -;; $BBG$?$l$??t;z$NJQ498uJd$rA*Br(B +;; 打たれた数字の変換候補を選択 ;; H kkc-hiragana -;; $BCmL\J8@a$rJ?2>L>$KJQ49(B +;; 注目文節を平仮名に変換 ;; K kkc-katakana -;; $BCmL\J8@a$rJR2>L>$KJQ49(B +;; 注目文節を片仮名に変換 ;; C-o kkc-longer -;; $BCmL\J8@a$r8e$m$K0lJ8;z?-$P$9(B +;; 注目文節を後ろに一文字伸ばす ;; C-i kkc-shorter -;; $BCmL\J8@a$r8e$m$+$i0lJ8;z=L$a$k(B +;; 注目文節を後ろから一文字縮める ;; C-f kkc-next-phrase -;; $BCmL\J8@a$r3NDj$5$;$k!#$b$7;D$j$NF~NO$,$^$@$"$l$P!":G=i$NJ8@a$r(B -;; $BA*Br$7!"$=$l$rCmL\J8@a$H$7!"$=$N:G=i$NJQ498uJd$rI=<($9$k!#(B +;; 注目文節を確定させる。もし残りの入力がまだあれば、最初の文節を +;; 選択し、それを注目文節とし、その最初の変換候補を表示する。 ;; DEL, C-c kkc-cancel -;; $B2>L>4A;zJQ49$r%-%c%s%;%k$7!"%m!<%^;z2>L>JQ49$N%9%F!<%8$KLa$k!#(B +;; 仮名漢字変換をキャンセルし、ローマ字仮名変換のステージに戻る。 ;; return kkc-terminate -;; $BA4J8@a$r3NDj$5$;$k!#(B +;; 全文節を確定させる。 ;; C-SPC, C-@ kkc-first-char-only -;; $B:G=i$NJ8;z$r3NDj$5$;!";D$j$O:o=|$9$k!#(B +;; 最初の文字を確定させ、残りは削除する。 ;; C-h kkc-help -;; $B$3$l$i$N%-!<%P%$%s%I$N%j%9%H$rI=<($9$k!#$"(B +;; これらのキーバインドのリストを表示する。あ (quail-define-package - "japanese" "Japanese" "A$B$"(B" + "japanese" "Japanese" "Aあ" nil "Japanese input method by Roman transliteration and Kana-Kanji conversion. @@ -433,7 +433,7 @@ Type \"qq\" to go back to previous input method." (quail-define-rules ("qq" quail-japanese-switch-package)) (quail-define-package - "japanese-zenkaku" "Japanese" "$B#A(B" + "japanese-zenkaku" "Japanese" "A" nil "Japanese zenkaku alpha numeric character input method. ---- Special key bindings ---- @@ -445,30 +445,30 @@ qh: shift to the input method `japanese', (quail-define-rules -(" " "$B!!(B") ("!" "$B!*(B") ("\"" "$B!m(B") ("#" "$B!t(B") -("$" "$B!p(B") ("%" "$B!s(B") ("&" "$B!u(B") ("'" "$B!l(B") -("(" "$B!J(B") (")" "$B!K(B") ("*" "$B!v(B") ("+" "$B!\(B") -("," "$B!$(B") ("-" "$B!](B") ("." "$B!%(B") ("/" "$B!?(B") -("0" "$B#0(B") ("1" "$B#1(B") ("2" "$B#2(B") ("3" "$B#3(B") -("4" "$B#4(B") ("5" "$B#5(B") ("6" "$B#6(B") ("7" "$B#7(B") -("8" "$B#8(B") ("9" "$B#9(B") (":" "$B!'(B") (";" "$B!((B") -("<" "$B!c(B") ("=" "$B!a(B") (">" "$B!d(B") ("?" "$B!)(B") -("@" "$B!w(B") ("A" "$B#A(B") ("B" "$B#B(B") ("C" "$B#C(B") -("D" "$B#D(B") ("E" "$B#E(B") ("F" "$B#F(B") ("G" "$B#G(B") -("H" "$B#H(B") ("I" "$B#I(B") ("J" "$B#J(B") ("K" "$B#K(B") -("L" "$B#L(B") ("M" "$B#M(B") ("N" "$B#N(B") ("O" "$B#O(B") -("P" "$B#P(B") ("Q" "$B#Q(B") ("R" "$B#R(B") ("S" "$B#S(B") -("T" "$B#T(B") ("U" "$B#U(B") ("V" "$B#V(B") ("W" "$B#W(B") -("X" "$B#X(B") ("Y" "$B#Y(B") ("Z" "$B#Z(B") ("[" "$B!N(B") -("\\" "$B!o(B") ("]" "$B!O(B") ("^" "$B!0(B") ("_" "$B!2(B") -("`" "$B!F(B") ("a" "$B#a(B") ("b" "$B#b(B") ("c" "$B#c(B") -("d" "$B#d(B") ("e" "$B#e(B") ("f" "$B#f(B") ("g" "$B#g(B") -("h" "$B#h(B") ("i" "$B#i(B") ("j" "$B#j(B") ("k" "$B#k(B") -("l" "$B#l(B") ("m" "$B#m(B") ("n" "$B#n(B") ("o" "$B#o(B") -("p" "$B#p(B") ("q" "$B#q(B") ("r" "$B#r(B") ("s" "$B#s(B") -("t" "$B#t(B") ("u" "$B#u(B") ("v" "$B#v(B") ("w" "$B#w(B") -("x" "$B#x(B") ("y" "$B#y(B") ("z" "$B#z(B") ("{" "$B!P(B") -("|" "$B!C(B") ("}" "$B!Q(B") ("~" "$B!A(B") +(" " " ") ("!" "!") ("\"" "″") ("#" "#") +("$" "$") ("%" "%") ("&" "&") ("'" "′") +("(" "(") (")" ")") ("*" "*") ("+" "+") +("," ",") ("-" "−") ("." ".") ("/" "/") +("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") ("{" "{") +("|" "|") ("}" "}") ("~" "〜") ("qq" quail-japanese-switch-package) ("qh" quail-japanese-switch-package) @@ -485,7 +485,7 @@ qh: shift to the input method `japanese', (quail-define-package "japanese-hankaku-kana" - "Japanese" "(I1(B" + "Japanese" "ア" nil "Japanese hankaku katakana input method by Roman transliteration. ---- Special key bindings ---- @@ -514,7 +514,7 @@ qq: toggle between this input method and the input method `japanese-ascii'. trans))) (quail-define-package - "japanese-hiragana" "Japanese" "$B$"(B" + "japanese-hiragana" "Japanese" "あ" nil "Japanese hiragana input method by Roman transliteration." nil t t nil nil nil nil nil @@ -535,7 +535,7 @@ qq: toggle between this input method and the input method `japanese-ascii'. control-flag) (quail-define-package - "japanese-katakana" "Japanese" "$B%"(B" + "japanese-katakana" "Japanese" "ア" nil "Japanese katakana input method by Roman transliteration." nil t t nil nil nil nil nil diff --git a/lisp/leim/quail/latin-ltx.el b/lisp/leim/quail/latin-ltx.el index 754f662d9b4..e247739661e 100644 --- a/lisp/leim/quail/latin-ltx.el +++ b/lisp/leim/quail/latin-ltx.el @@ -67,7 +67,7 @@ system, including many technical ones. Examples: (and (characterp char) (< char 128))) (defmacro latin-ltx--define-rules (&rest rules) - (load "uni-name") + (load "uni-name" nil t) (let ((newrules ())) (dolist (rule rules) (pcase rule @@ -105,10 +105,11 @@ system, including many technical ones. Examples: (setq rules (delq c rules))) (message "Conflict for %S: %S" (car rule) (apply #'string conflicts))))))) - (let ((inputs (mapcar #'car newrules))) - (setq inputs (delete-dups inputs)) - (message "latin-ltx: %d rules (+ %d conflicts)!" - (length inputs) (- (length newrules) (length inputs)))) + (let* ((inputs (delete-dups (mapcar #'car newrules))) + (conflicts (- (length newrules) (length inputs)))) + (unless (zerop conflicts) + (message "latin-ltx: %d rules (+ %d conflicts)!" + (length inputs) conflicts))) `(quail-define-rules ,@(nreverse newrules))))) (latin-ltx--define-rules @@ -453,10 +454,10 @@ system, including many technical ones. Examples: ("\\lneq" ?≨) ("\\lneqq" ?≨) ("\\lnsim" ?⋦) - ("\\longleftarrow" ?←) - ("\\longleftrightarrow" ?↔) - ("\\longmapsto" ?↦) - ("\\longrightarrow" ?→) + ("\\longleftarrow" ?⟵) + ("\\longleftrightarrow" ?⟷) + ("\\longmapsto" ?⟼) + ("\\longrightarrow" ?⟶) ("\\looparrowleft" ?↫) ("\\looparrowright" ?↬) ("\\lozenge" ?✧) diff --git a/lisp/leim/quail/latin-post.el b/lisp/leim/quail/latin-post.el index 60c0fd13709..589978f31be 100644 --- a/lisp/leim/quail/latin-post.el +++ b/lisp/leim/quail/latin-post.el @@ -739,6 +739,54 @@ Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\=' ("z~~" ["z~"]) ) +;;; Hawaiian postfix input method. It's a small subset of Latin-4 +;;; with the addition of an ʻokina mapping. Hopefully the ʻokina shows +;;; correctly on most displays. + +;;; This reference is an authoritative guide to Hawaiian orthography: +;;; http://www2.hawaii.edu/~strauch/tips/HawaiianOrthography.html + +;;; Initial coding 2018-09-08 Bob Newell, Honolulu, Hawaiʻi +;;; Comments to bobnewell@bobnewell.net + +(quail-define-package + "hawaiian-postfix" "Hawaiian Postfix" "H<" t + "Hawaiian characters input method with postfix modifiers + + | postfix | examples + ------------+---------+---------- + ʻokina | \\=` | \\=` -> ʻ + kahakō | - | a- -> ā + +Doubling the postfix separates the letter and postfix. a-- -> a- +" nil t nil nil nil nil nil nil nil nil t) + +(quail-define-rules + ("A-" ?Ā) + ("E-" ?Ē) + ("I~" ?Ĩ) + ("O-" ?Ō) + ("U-" ?Ū) + ("a-" ?ā) + ("e-" ?ē) + ("i-" ?ī) + ("o-" ?ō) + ("u-" ?ū) + ("`" ?ʻ) + + ("A--" ["A-"]) + ("E--" ["E-"]) + ("I--" ["I-"]) + ("O--" ["O-"]) + ("U--" ["U-"]) + ("a--" ["a-"]) + ("e--" ["e-"]) + ("i--" ["i-"]) + ("o--" ["o-"]) + ("u--" ["u-"]) + ("``" ["`"]) + ) + (quail-define-package "latin-5-postfix" "Latin-5" "5<" t "Latin-5 characters input method with postfix modifiers @@ -1103,6 +1151,7 @@ szz -> sz ("UE" ?Ü) ("ue" ?ü) ("sz" ?ß) + ("SZ" ?ẞ) ("AEE" ["AE"]) ("aee" ["ae"]) @@ -1111,6 +1160,7 @@ szz -> sz ("UEE" ["UE"]) ("uee" ["ue"]) ("szz" ["sz"]) + ("SZZ" ["SZ"]) ("ge" ["ge"]) ("eue" ["eue"]) ("Eue" ["Eue"]) @@ -2184,6 +2234,7 @@ Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\=' ("R~" ?Ř) ("S'" ?Ś) ("S," ?Ş) + ("S/" ?ẞ) ("S^" ?Ŝ) ("S~" ?Š) ("T," ?Ţ) diff --git a/lisp/leim/quail/latin-pre.el b/lisp/leim/quail/latin-pre.el index 150ab10c874..8e0b2748e3f 100644 --- a/lisp/leim/quail/latin-pre.el +++ b/lisp/leim/quail/latin-pre.el @@ -32,7 +32,6 @@ ;; ;; polish-slash: ;; Author: Włodek Bzyl <matwb@univ.gda.pl> -;; Maintainer: Włodek Bzyl <matwb@univ.gda.pl> ;; ;; latin-[89]-prefix: Dave Love <fx@gnu.org> ;; @@ -320,7 +319,7 @@ Key translation rules are: effect | prefix | examples ------------+--------+------------------ - tilde | ~ | ~a -> ă + breve | ~ | ~a -> ă circumflex | ^ | ^a -> â, ^i -> î cedilla | , | ,s -> ş, ,t -> ţ ~ | ~ | ~~ -> ~ @@ -342,11 +341,11 @@ Key translation rules are: effect | prefix | examples ------------+--------+------------------ - tilde | \" | \"a -> â - circumflex | \\=' | \\='a -> â, \\='i -> î - cedilla | \\=' | \\='s -> ş, \\='t -> ţ - \\=' | \\=' | \\='\\=' -> \\=' - \" | \" | \"\" -> \" + breve | \\=' | \\='a -> ă + circumflex | \" \\=' | \"a -> â \\='i -> î + cedilla | \\=' | \\='s -> ş \\='t -> ţ + \\=' | \\=' | \\='\\=' -> \\=' + \" | \" | \"\" -> \" " nil t nil nil nil nil nil nil nil nil t) (quail-define-rules @@ -361,13 +360,14 @@ Key translation rules are: "german-prefix" "German" "DE>" t "German (Deutsch) input method with prefix modifiers Key translation rules are: - \"A -> Ä -> \"O -> Ö \"U -> Ü \"s -> ß + \"A -> Ä -> \"O -> Ö \"S -> ẞ \"U -> Ü \"s -> ß " nil t nil nil nil nil nil nil nil nil t) (quail-define-rules ("\"A" ?Ä) ("\"O" ?Ö) ("\"U" ?Ü) + ("\"S" ?ẞ) ("\"a" ?ä) ("\"o" ?ö) ("\"u" ?ü) @@ -605,7 +605,7 @@ Key translation rules are: circumflex | ^ | ^a -> â diaeresis | \" | \"a -> ä \"\" -> ¨ cedilla | ~ | ~c -> ç ~s -> ş ~~ -> ¸ - dot above | / . | /g -> ġ .o -> ġ + dot above | / . | /g -> ġ .g -> ġ misc | \" ~ / | \"s -> ß ~g -> ğ ~u -> ŭ /h -> ħ /i -> ı symbol | ~ | ~\\=` -> ˘ /# -> £ /$ -> ¤ // -> ° " nil t nil nil nil nil nil nil nil nil t) @@ -1088,15 +1088,15 @@ of characters from a single Latin-N charset. effect | prefix | examples ------------+--------+---------- - acute | \\=' | \\='a -> á, \\='\\=' -> ´ + acute | \\=' | \\='a -> á \\='\\=' -> ´ grave | \\=` | \\=`a -> à circumflex | ^ | ^a -> â diaeresis | \" | \"a -> ä \"\" -> ¨ tilde | ~ | ~a -> ã - cedilla | ~ | ~c -> ç + cedilla | , ~ | ,c -> ç ~c -> ç + caron | ~ | ~c -> č ~g -> ğ breve | ~ | ~a -> ă - caron | ~ | ~c -> č - dot above | ~ / . | ~o -> ġ /o -> ġ .o -> ġ + dot above | / . | /g -> ġ .g -> ġ misc | \" ~ / | \"s -> ß ~d -> ð ~t -> þ /a -> å /e -> æ /o -> ø symbol | ~ | ~> -> » ~< -> « ~! -> ¡ ~? -> ¿ ~~ -> ¸ symbol | _ / | _o -> º _a -> ª // -> ° /\\ -> × _y -> ¥ @@ -1175,6 +1175,7 @@ of characters from a single Latin-N charset. ("\"E" ?Ë) ("\"I" ?Ï) ("\"O" ?Ö) + ("\"S" ?ẞ) ("\"U" ?Ü) ("\"W" ?Ẅ) ("\"Y" ?Ÿ) @@ -1250,7 +1251,10 @@ of characters from a single Latin-N charset. ("~>" ?\») ("~?" ?¿) ("~A" ?Ã) + ("~A" ?Ă) ("~C" ?Ç) + ("~C" ?Č) + (",C" ?Ç) ("~D" ?Ð) ("~G" ?Ğ) ("~N" ?Ñ) @@ -1263,13 +1267,15 @@ of characters from a single Latin-N charset. ("~Z" ?Ž) ("~`" ?˘) ("~a" ?ã) + ("~a" ?ă) ("~c" ?ç) + ("~c" ?č) + (",c" ?ç) ("~d" ?ð) ("~e" ?€) ("~g" ?ğ) ("~n" ?ñ) ("~o" ?õ) - ("~o" ?ġ) ("~p" ?¶) ("~s" ?§) ("~s" ?ş) @@ -1283,4 +1289,52 @@ of characters from a single Latin-N charset. ("~~" ?¸) ) +;;; Hawaiian prefix input method. It's a small subset of Latin-4 +;;; with the addition of an ʻokina mapping. Hopefully the ʻokina shows +;;; correctly on most displays. + +;;; This reference is an authoritative guide to Hawaiian orthography: +;;; http://www2.hawaii.edu/~strauch/tips/HawaiianOrthography.html + +;;; Initial coding 2018-09-08 Bob Newell, Honolulu, Hawaiʻi +;;; Comments to bobnewell@bobnewell.net + +(quail-define-package + "hawaiian-prefix" "Hawaiian Prefix" "H>" t + "Hawaiian characters input method with postfix modifiers + + | prefix | examples + ------------+---------+---------- + ʻokina | \\=` | \\=` -> ʻ + kahakō | - | -a -> ā + +Doubling the prefix separates the letter and prefix. --a -> -a +" nil t nil nil nil nil nil nil nil nil t) + +(quail-define-rules + ("-A" ?Ā) + ("-E" ?Ē) + ("~I" ?Ĩ) + ("-O" ?Ō) + ("-U" ?Ū) + ("-a" ?ā) + ("-e" ?ē) + ("-i" ?ī) + ("-o" ?ō) + ("-u" ?ū) + ("`" ?ʻ) + + ("--A" ["-A"]) + ("--E" ["-E"]) + ("--I" ["-I"]) + ("--O" ["-O"]) + ("--U" ["-U"]) + ("--a" ["-a"]) + ("--e" ["-e"]) + ("--i" ["-i"]) + ("--o" ["-o"]) + ("--u" ["-u"]) + ("``" ["`"]) + ) + ;;; latin-pre.el ends here diff --git a/lisp/leim/quail/py-punct.el b/lisp/leim/quail/py-punct.el index 35bd79e99b4..49ea66effbb 100644 --- a/lisp/leim/quail/py-punct.el +++ b/lisp/leim/quail/py-punct.el @@ -1,4 +1,4 @@ -;;; py-punct.el --- Quail packages for Chinese (pinyin + extra symbols) -*-coding: iso-2022-7bit;-*- +;;; py-punct.el --- Quail packages for Chinese (pinyin + extra symbols) ;; Copyright (C) 2001-2019 Free Software Foundation, Inc. ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -6,7 +6,7 @@ ;; National Institute of Advanced Industrial Science and Technology (AIST) ;; Registration Number H14PRO021 -;; Author: Ken'ichi HANDA <handa@etl.go.jp> +;; Author: Ken'ichi Handa <handa@gnu.org> ;; Keywords: multilingual, input method, Chinese @@ -35,16 +35,16 @@ (load "quail/Punct") (quail-define-package - "chinese-py-punct" "Chinese-GB" "$AF47{(B" + "chinese-py-punct" "Chinese-GB" "拼符" t - "$A::WVJdHk(B $AF4Rt7=08(B and `v' for $A1j5c7{:EJdHk(B + "汉字输入 拼音方案 and `v' for 标点符号输入 This is the combination of the input methods `chinese-py' and `chinese-punct'. You can enter normal Chinese characters by the same way as `chinese-py'. And, you can enter symbols by typing `v' followed by any key sequences defined in `chinese-punct'. -For instance, typing `v' and `%' insert `$A#%(B'. +For instance, typing `v' and `%' insert `%'. ") (setcar (nthcdr 2 quail-current-package) @@ -55,9 +55,9 @@ For instance, typing `v' and `%' insert `$A#%(B'. (load "quail/TONEPY") (quail-define-package - "chinese-tonepy-punct" "Chinese-GB" "$AF47{(B" + "chinese-tonepy-punct" "Chinese-GB" "拼符" t - "$A::WVJdHk(B $A4x5wF4Rt7=08(B and `v' for $A1j5c7{:EJdHk(B + "汉字输入 带调拼音方案 and `v' for 标点符号输入 This is the combination of the input methods `chinese-tonepy' and `chinese-punct'. @@ -66,7 +66,7 @@ You can enter normal Chinese characters by the same way as `chinese-tonepy'. And, you can enter symbols by typing `v' followed by any key sequences defined in `chinese-punct'. -For instance, typing `v' and `%' insert `$A#%(B'. +For instance, typing `v' and `%' insert `%'. ") (setcar (nthcdr 2 quail-current-package) diff --git a/lisp/leim/quail/pypunct-b5.el b/lisp/leim/quail/pypunct-b5.el index ef5863101d2..9f4e73c9f05 100644 --- a/lisp/leim/quail/pypunct-b5.el +++ b/lisp/leim/quail/pypunct-b5.el @@ -1,11 +1,11 @@ -;;; pypunct-b5.el --- Quail packages for Chinese (pinyin + extra symbols) -*-coding: iso-2022-7bit;-*- +;;; pypunct-b5.el --- Quail packages for Chinese (pinyin + extra symbols) ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, ;; 2006, 2007, 2008, 2009, 2010, 2011 ;; National Institute of Advanced Industrial Science and Technology (AIST) ;; Registration Number H14PRO021 -;; Author: Ken'ichi HANDA <handa@etl.go.jp> +;; Author: Ken'ichi Handa <handa@gnu.org> ;; Keywords: multilingual, input method, Chinese @@ -34,9 +34,9 @@ (load "quail/Punct-b5") (quail-define-package - "chinese-py-punct-b5" "Chinese-BIG5" "$(03<>K(B" + "chinese-py-punct-b5" "Chinese-BIG5" "拼符" t - "$(0&d'GTT&,!J3<5x!K(B and `v' for $(0O:X5>KHATT&,(B + "中文輸入【拼音】 and `v' for 標點符號輸入 This is the combination of the input method `chinese-py-b5' and `chinese-punct-b5'. @@ -45,7 +45,7 @@ You can enter normal Chinese characters by the same way as `chinese-py-b5'. And, you can enter symbols by typing `v' followed by any key sequences defined in `chinese-punct-b5'. -For instance, typing `v' and `%' insert `$(0"h(B'. +For instance, typing `v' and `%' insert `%'. ") (setcar (nthcdr 2 quail-current-package) diff --git a/lisp/leim/quail/sami.el b/lisp/leim/quail/sami.el new file mode 100644 index 00000000000..88d34092dd5 --- /dev/null +++ b/lisp/leim/quail/sami.el @@ -0,0 +1,754 @@ +;;; sami.el --- Quail package for inputting Sámi -*-coding: utf-8;-*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; Author: Wojciech S. Gac <wojciech.s.gac@gmail.com> +;; Keywords: i18n, multilingual, input method, Sámi + +;; 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 implements the following input methods for the Sámi +;; language +;; - norwegian-sami-prefix +;; - bergsland-hasselbrink-sami-prefix +;; - southern-sami-prefix +;; - ume-sami-prefix +;; - northern-sami-prefix +;; - inari-sami-prefix +;; - skolt-sami-prefix +;; - kildin-sami-prefix + +;;; Code + +(require 'quail) + +(quail-define-package + "norwegian-sami-prefix" "Sámi" "/NSoS" nil + "Norwegian Southern Sámi input method + +Alphabet (parenthesized letters are used in foreign names): +А а 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) Æ æ Ø ø Å å +" + nil t nil nil nil nil nil nil nil nil t) + +(quail-define-rules + ("А" ?А) + ("а" ?а) + ("B" ?B) + ("b" ?b) + ("C" ?C) + ("c" ?c) + ("D" ?D) + ("d" ?d) + ("E" ?E) + ("e" ?e) + ("F" ?F) + ("f" ?f) + ("G" ?G) + ("g" ?g) + ("H" ?H) + ("h" ?h) + ("I" ?I) + ("i" ?i) + (":I" ?Ï) + (":i" ?ï) + ("J" ?J) + ("j" ?j) + ("K" ?K) + ("k" ?k) + ("L" ?L) + ("l" ?l) + ("M" ?M) + ("m" ?m) + ("N" ?N) + ("n" ?n) + ("O" ?O) + ("o" ?o) + ("P" ?P) + ("p" ?p) + ("Q" ?Q) + ("q" ?q) + ("R" ?R) + ("r" ?r) + ("S" ?S) + ("s" ?s) + ("T" ?T) + ("t" ?t) + ("U" ?U) + ("u" ?u) + ("V" ?V) + ("v" ?v) + ("W" ?W) + ("w" ?w) + ("X" ?X) + ("x" ?x) + ("Y" ?Y) + ("y" ?y) + ("Z" ?Z) + ("z" ?z) + ("AE" ?Æ) + ("ae" ?æ) + ("/O" ?Ø) + ("/o" ?ø) + ("/A" ?Å) + ("/a" ?å)) + +(quail-define-package + "bergsland-hasselbrink-sami-prefix" "Sámi" "/BHS" nil + "Bergsland-Hasselbrink Southern Sámi input method + +Alphabet: +А а  â Á á 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 R r S s +Š š T t U u V v Y y Z z Ž ž Ä ä +Æ æ Ö ö Å å ' +" + nil t nil nil nil nil nil nil nil nil t) + +(quail-define-rules + ("А" ?А) + ("а" ?а) + ("^A" ?Â) + ("^a" ?â) + ("'A" ?Á) + ("'a" ?á) + ("B" ?B) + ("b" ?b) + ("C" ?C) + ("c" ?c) + ("^C" ?Č) + ("^c" ?č) + ("D" ?D) + ("d" ?d) + ("-D" ?Đ) + ("-d" ?đ) + ("E" ?E) + ("e" ?e) + ("F" ?F) + ("f" ?f) + ("G" ?G) + ("g" ?g) + ("H" ?H) + ("h" ?h) + ("I" ?I) + ("i" ?i) + ("^I" ?Î) + ("^i" ?î) + ("J" ?J) + ("j" ?j) + ("K" ?K) + ("k" ?k) + ("L" ?L) + ("l" ?l) + ("M" ?M) + ("m" ?m) + ("N" ?N) + ("n" ?n) + ("/N" ?Ŋ) + ("/n" ?ŋ) + ("O" ?O) + ("o" ?o) + ("P" ?P) + ("p" ?p) + ("R" ?R) + ("r" ?r) + ("S" ?S) + ("s" ?s) + ("^S" ?Š) + ("^s" ?š) + ("T" ?T) + ("t" ?t) + ("U" ?U) + ("u" ?u) + ("V" ?V) + ("v" ?v) + ("Y" ?Y) + ("y" ?y) + ("Z" ?Z) + ("z" ?z) + ("^Z" ?Ž) + ("^z" ?ž) + (":A" ?Ä) + (":a" ?ä) + ("AE" ?Æ) + ("ae" ?æ) + (":O" ?Ö) + (":o" ?ö) + ("/A" ?Å) + ("/a" ?å)) + +(quail-define-package + "southern-sami-prefix" "Sámi" "/SoS" nil + "Contemporary Southern Sámi input method + +Alphabet (parenthesized letters are used in foreign names): +А а 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) Ä ä Ö ö Å å +" + nil t nil nil nil nil nil nil nil nil t) + +(quail-define-rules + ("А" ?А) + ("а" ?а) + ("B" ?B) + ("b" ?b) + ("C" ?C) + ("c" ?c) + ("D" ?D) + ("d" ?d) + ("E" ?E) + ("e" ?e) + ("F" ?F) + ("f" ?f) + ("G" ?G) + ("g" ?g) + ("H" ?H) + ("h" ?h) + ("I" ?I) + ("i" ?i) + (":I" ?Ï) + (":i" ?ï) + ("J" ?J) + ("j" ?j) + ("K" ?K) + ("k" ?k) + ("L" ?L) + ("l" ?l) + ("M" ?M) + ("m" ?m) + ("N" ?N) + ("n" ?n) + ("O" ?O) + ("o" ?o) + ("P" ?P) + ("p" ?p) + ("Q" ?Q) + ("q" ?q) + ("R" ?R) + ("r" ?r) + ("S" ?S) + ("s" ?s) + ("T" ?T) + ("t" ?t) + ("U" ?U) + ("u" ?u) + ("V" ?V) + ("v" ?v) + ("W" ?W) + ("w" ?w) + ("X" ?X) + ("x" ?x) + ("Y" ?Y) + ("y" ?y) + ("Z" ?Z) + ("z" ?z) + (":A" ?Ä) + (":a" ?ä) + (":O" ?Ö) + (":o" ?ö) + ("/A" ?Å) + ("/a" ?å)) + +(quail-define-package + "ume-sami-prefix" "Sámi" "/UmS" nil + "Ume Sámi input method + +Alphabet: +А а Á á B b 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 R r S s T t Ŧ ŧ U u +Ü ü V v Y y Å å Ä ä Ö ö +" + nil t nil nil nil nil nil nil nil nil t) + +(quail-define-rules + ("А" ?А) + ("а" ?а) + ("'A" ?Á) + ("'a" ?á) + ("B" ?B) + ("b" ?b) + ("D" ?D) + ("d" ?d) + ("-D" ?Đ) + ("-d" ?đ) + ("E" ?E) + ("e" ?e) + ("F" ?F) + ("f" ?f) + ("G" ?G) + ("g" ?g) + ("H" ?H) + ("h" ?h) + ("I" ?I) + ("i" ?i) + (":I" ?Ï) + (":i" ?ï) + ("J" ?J) + ("j" ?j) + ("K" ?K) + ("k" ?k) + ("L" ?L) + ("l" ?l) + ("M" ?M) + ("m" ?m) + ("N" ?N) + ("n" ?n) + ("/N" ?Ŋ) + ("/n" ?ŋ) + ("O" ?O) + ("o" ?o) + ("P" ?P) + ("p" ?p) + ("R" ?R) + ("r" ?r) + ("S" ?S) + ("s" ?s) + ("T" ?T) + ("t" ?t) + ("-T" ?Ŧ) + ("-t" ?ŧ) + ("U" ?U) + ("u" ?u) + (":U" ?Ü) + (":u" ?ü) + ("V" ?V) + ("v" ?v) + ("Y" ?Y) + ("y" ?y) + ("/A" ?Å) + ("/a" ?å) + (":A" ?Ä) + (":a" ?ä) + (":O" ?Ö) + (":o" ?ö) + ) + +(quail-define-package + "northern-sami-prefix" "Sámi" "/NoS" nil + "Northern Sámi input method + +Alphabet: +А а Á á 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 R r S s Š š T t +Ŧ ŧ U u V v Z z Ž ž +" + nil t nil nil nil nil nil nil nil nil t) + +(quail-define-rules + ("А" ?А) + ("а" ?а) + ("'A" ?Á) + ("'a" ?á) + ("B" ?B) + ("b" ?b) + ("C" ?C) + ("c" ?c) + ("^C" ?Č) + ("^c" ?č) + ("D" ?D) + ("d" ?d) + ("-D" ?Đ) + ("-d" ?đ) + ("E" ?E) + ("e" ?e) + ("F" ?F) + ("f" ?f) + ("G" ?G) + ("g" ?g) + ("H" ?H) + ("h" ?h) + ("I" ?I) + ("i" ?i) + ("J" ?J) + ("j" ?j) + ("K" ?K) + ("k" ?k) + ("L" ?L) + ("l" ?l) + ("M" ?M) + ("m" ?m) + ("N" ?N) + ("n" ?n) + ("/N" ?Ŋ) + ("/n" ?ŋ) + ("O" ?O) + ("o" ?o) + ("P" ?P) + ("p" ?p) + ("R" ?R) + ("r" ?r) + ("S" ?S) + ("s" ?s) + ("^S" ?Š) + ("^s" ?š) + ("T" ?T) + ("t" ?t) + ("-T" ?Ŧ) + ("-t" ?ŧ) + ("U" ?U) + ("u" ?u) + ("V" ?V) + ("v" ?v) + ("Z" ?Z) + ("z" ?z) + ("^Z" ?Ž) + ("^z" ?ž) + ) + +(quail-define-package + "inari-sami-prefix" "Sámi" "/InS" nil + "Inari Sámi input method + +Alphabet (parenthesized letters are used in foreign names only): +А а  â 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 Ž ž Ä ä +Á á Å å Ö ö +" + nil t nil nil nil nil nil nil nil nil t) + +(quail-define-rules + ("А" ?А) + ("а" ?а) + ("^A" ?Â) + ("^a" ?â) + ("B" ?B) + ("b" ?b) + ("C" ?C) + ("c" ?c) + ("^C" ?Č) + ("^c" ?č) + ("D" ?D) + ("d" ?d) + ("-D" ?Đ) + ("-d" ?đ) + ("E" ?E) + ("e" ?e) + ("F" ?F) + ("f" ?f) + ("G" ?G) + ("g" ?g) + ("H" ?H) + ("h" ?h) + ("I" ?I) + ("i" ?i) + ("J" ?J) + ("j" ?j) + ("K" ?K) + ("k" ?k) + ("L" ?L) + ("l" ?l) + ("M" ?M) + ("m" ?m) + ("N" ?N) + ("n" ?n) + ("O" ?O) + ("o" ?o) + ("P" ?P) + ("p" ?p) + ("Q" ?Q) + ("q" ?q) + ("R" ?R) + ("r" ?r) + ("S" ?S) + ("s" ?s) + ("^S" ?Š) + ("^s" ?š) + ("T" ?T) + ("t" ?t) + ("U" ?U) + ("u" ?u) + ("V" ?V) + ("v" ?v) + ("W" ?W) + ("w" ?w) + ("X" ?X) + ("x" ?x) + ("Y" ?Y) + ("y" ?y) + ("Z" ?Z) + ("z" ?z) + ("^Z" ?Ž) + ("^z" ?ž) + (":A" ?Ä) + (":a" ?ä) + ("'A" ?Á) + ("'a" ?á) + ("/A" ?Å) + ("/a" ?å) + (":O" ?Ö) + (":o" ?ö)) + +(quail-define-package + "skolt-sami-prefix" "Sámi" "/SkS" nil + "Skolt Sámi input method + +Alphabet (parenthesized letters are used in foreign names only): +А а  â 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 Ž ž Å å Ä ä +(Ö ö) ʹ +" + nil t nil nil nil nil nil nil nil nil t) + +(quail-define-rules + ("A" ?А) + ("a" ?а) + ("^A" ?Â) + ("^a" ?â) + ("B" ?B) + ("b" ?b) + ("C" ?C) + ("c" ?c) + ("^C" ?Č) + ("^c" ?č) + ("/X" ?Ʒ) + ("/x" ?ʒ) + ("^X" ?Ǯ) + ("^x" ?ǯ) + ("D" ?D) + ("d" ?d) + ("-D" ?Đ) + ("-d" ?đ) + ("E" ?E) + ("e" ?e) + ("F" ?F) + ("f" ?f) + ("G" ?G) + ("g" ?g) + ("^G" ?Ǧ) + ("^g" ?ǧ) + ("-G" ?Ǥ) + ("-g" ?ǥ) + ("H" ?H) + ("h" ?h) + ("I" ?I) + ("i" ?i) + ("J" ?J) + ("j" ?j) + ("K" ?K) + ("k" ?k) + ("^K" ?Ǩ) + ("^k" ?ǩ) + ("L" ?L) + ("l" ?l) + ("M" ?M) + ("m" ?m) + ("N" ?N) + ("n" ?n) + ("/N" ?Ŋ) + ("/n" ?ŋ) + ("O" ?O) + ("o" ?o) + ("~O" ?Õ) + ("~o" ?õ) + ("P" ?P) + ("p" ?p) + ("Q" ?Q) + ("q" ?q) + ("R" ?R) + ("r" ?r) + ("S" ?S) + ("s" ?s) + ("^S" ?Š) + ("^s" ?š) + ("T" ?T) + ("t" ?t) + ("U" ?U) + ("u" ?u) + ("V" ?V) + ("v" ?v) + ("W" ?W) + ("w" ?w) + ("X" ?X) + ("x" ?x) + ("Y" ?Y) + ("y" ?y) + ("Z" ?Z) + ("z" ?z) + ("^Z" ?Ž) + ("^z" ?ž) + ("/A" ?Å) + ("/a" ?å) + (":A" ?Ä) + (":a" ?ä) + (":O" ?Ö) + (":o" ?ö)) + +(quail-define-package + "kildin-sami-prefix" "Sámi" "/KiS" nil + "Kildin Sámi input method + +Alphabet (parenthesized letters are used in foreign names only): +А а А̄ а̄ Ӓ ӓ Б б В в Г г Д д Е е Е̄ е̄ +Ё ё Ё̄ ё̄ Ж ж З з Һ һ (') И и Ӣ ӣ Й й +Ј ј (Ҋ ҋ) К к Л л Ӆ ӆ М м Ӎ ӎ Н н Ӊ ӊ +Ӈ ӈ О о О̄ о̄ П п Р р Ҏ ҏ С с Т т У у +Ӯ ӯ Ф ф Х х Ц ц Ч ч Ш ш Щ щ Ъ ъ Ы ы +Ь ь Ҍ ҍ Э э Э̄ э̄ Ӭ ӭ Ю ю Ю̄ ю̄ Я я Я̄ я̄ +") + +(quail-define-rules + ("1" ?1) + ("2" ?2) + ("3" ?3) + ("4" ?4) + ("5" ?5) + ("6" ?6) + ("7" ?7) + ("8" ?8) + ("9" ?9) + ("0" ?0) + ("-" ?-) + ("=" ?ч) + ("`" ?ю) + ("-`" ["ю̄"]) + ("q" ?я) + ("-q" ["я̄"]) + ("w" ?в) + ("e" ?е) + ("-e" ["е̄"]) + ("-@" ["ё̄"]) + ("r" ?р) + ("-r" ?ҏ) + ("t" ?т) + ("y" ?ы) + ("u" ?у) + ("-u" ?ӯ) + ("i" ?и) + ("o" ?о) + ("-o" ["о̄"]) + ("p" ?п) + ("[" ?ш) + ("]" ?щ) + ("a" ?а) + ("-a" ["а̄"]) + (":a" ?ӓ) + ("s" ?с) + ("d" ?д) + ("f" ?ф) + ("g" ?г) + ("h" ?х) + ("/h" ?һ) + ("j" ?й) + ("-j" ["ӣ"]) + ("'j" ?ҋ) + ("/j" ?ј) + ("k" ?к) + ("l" ?л) + ("'l" ?ӆ) + (";" ?\;) + ("'" ?') + ("\\" ?э) + ("-\\" ["э̄"]) + (":\\" ?ӭ) + ("z" ?з) + ("x" ?ь) + ("-x" ?ҍ) + ("c" ?ц) + ("v" ?ж) + ("b" ?б) + ("n" ?н) + ("'n" ?ӊ) + (",n" ?ӈ) + ("m" ?м) + ("'m" ?ӎ) + ("," ?,) + ("." ?.) + ("/" ?/) + + ("!" ?!) + ("@" ?ё) + ("#" ?ъ) + ("$" ?Ё) + ("%" ?%) + ("^" ?^) + ("&" ?&) + ("*" ?*) + ("(" ?\() + (")" ?\)) + ("_" ?_) + ("+" ?Ч) + ("~" ?Ю) + ("-~" ["Ю̄"]) + ("Q" ?Я) + ("-Q" ["Я̄"]) + ("W" ?В) + ("E" ?Е) + ("-E" ["Е̄"]) + ("-$" ["Ё̄"]) + ("R" ?Р) + ("-R" ?Ҏ) + ("T" ?Т) + ("Y" ?Ы) + ("U" ?У) + ("-U" ["Ӯ"]) + ("I" ?И) + ("O" ?О) + ("-O" ["О̄"]) + ("P" ?П) + ("{" ?Ш) + ("}" ?Щ) + ("A" ?А) + ("-A" ["А̄"]) + (":A" ?Ӓ) + ("S" ?С) + ("D" ?Д) + ("F" ?Ф) + ("G" ?Г) + ("H" ?Х) + ("/H" ?Һ) + ("J" ?Й) + ("-J" ["Ӣ"]) + ("'J" ?Ҋ) + ("/J" ?Ј) + ("K" ?К) + ("L" ?Л) + ("'L" ?Ӆ) + (":" ?:) + ("\"" ?\") + ("|" ?Э) + ("-|" ["Э̄"]) + (":|" ?Ӭ) + ("Z" ?З) + ("X" ?Ь) + ("-X" ?Ҍ) + ("C" ?Ц) + ("V" ?Ж) + ("B" ?Б) + ("N" ?Н) + ("'N" ?Ӊ) + (",N" ?Ӈ) + ("M" ?М) + ("'M" ?Ӎ) + ("<" ?<) + (">" ?>) + ("?" ??)) + +;;; sami.el ends here diff --git a/lisp/leim/quail/vntelex.el b/lisp/leim/quail/vntelex.el index 78b467de548..9faa5d2278f 100644 --- a/lisp/leim/quail/vntelex.el +++ b/lisp/leim/quail/vntelex.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2001-2019 Free Software Foundation, Inc. -;; Author: Werner Lemberg <wl@gnu.org> +;; Author: Werner Lemberg <wl@gnu.org> ;; Keywords: multilingual, input method, Vietnamese ;; This file is part of GNU Emacs. diff --git a/lisp/linum.el b/lisp/linum.el index cdbc55dc8b8..0a5d8bb2c0b 100644 --- a/lisp/linum.el +++ b/lisp/linum.el @@ -75,12 +75,10 @@ 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). -With a prefix argument ARG, enable Linum mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. Linum mode is a buffer-local minor mode." :lighter "" ; for desktop.el + :append-arg-docstring t (if linum-mode (progn (if linum-eager diff --git a/lisp/loadhist.el b/lisp/loadhist.el index 64720524d21..4e5d8e0f38d 100644 --- a/lisp/loadhist.el +++ b/lisp/loadhist.el @@ -29,6 +29,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defun feature-symbols (feature) "Return the file and list of definitions associated with FEATURE. The value is actually the element of `load-history' @@ -94,7 +96,8 @@ A library name is equivalent to the file name that `load-library' would load." (let ((provides (file-provides file)) (dependents nil)) (dolist (x load-history dependents) - (when (file-set-intersect provides (file-requires (car x))) + (when (and (stringp (car x)) + (file-set-intersect provides (file-requires (car x)))) (push (car x) dependents))))) (defun read-feature (prompt &optional loaded-p) @@ -141,8 +144,6 @@ These are symbols with hooklike values whose names don't end in `-hook' or `-hooks', from which `unload-feature' should try to remove pertinent symbols.") -(define-obsolete-variable-alias 'unload-hook-features-list - 'unload-function-defs-list "22.2") (defvar unload-function-defs-list nil "List of definitions in the Lisp library being unloaded. diff --git a/lisp/loadup.el b/lisp/loadup.el index 9e5502dcaeb..67e8aa7d40a 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -26,6 +26,9 @@ ;; This is loaded into a bare Emacs to make a dumpable one. +;; Emacs injects the variable `dump-mode' to tell us how to dump. +;; We unintern it before allowing user code to run. + ;; If you add a file to be loaded here, keep the following points in mind: ;; i) If the file is no-byte-compile, explicitly load the .el version. @@ -54,33 +57,58 @@ ;; bidi.c needs for its job. (setq redisplay--inhibit-bidi t) +(message "dump mode: %s" dump-mode) + ;; Add subdirectories to the load-path for files that might get -;; autoloaded when bootstrapping. +;; autoloaded when bootstrapping or running Emacs normally. ;; This is because PATH_DUMPLOADSEARCH is just "../lisp". -(if (or (equal (member "bootstrap" command-line-args) '("bootstrap")) +(if (or (member dump-mode '("bootstrap" "pbootstrap")) ;; FIXME this is irritatingly fragile. - (and (stringp (nth 4 command-line-args)) - (string-match "^unidata-gen\\(\\.elc?\\)?$" - (nth 4 command-line-args))) - (member (nth 7 command-line-args) '("unidata-gen-file" - "unidata-gen-charprop")) - (if (fboundp 'dump-emacs) - (string-match "src/bootstrap-emacs" (nth 0 command-line-args)) - t)) - (let ((dir (car load-path))) + (and (stringp (nth 4 command-line-args)) + (string-match "^unidata-gen\\(\\.elc?\\)?$" + (nth 4 command-line-args))) + (member (nth 7 command-line-args) '("unidata-gen-file" + "unidata-gen-charprop")) + (null dump-mode)) + (progn + ;; Find the entry in load-path that contains Emacs elisp and + ;; splice some additional directories in there for the benefit + ;; of autoload and regular Emacs use. + (let ((subdirs '("emacs-lisp" + "progmodes" + "language" + "international" + "textmodes" + "vc")) + (iter load-path)) + (while iter + (let ((dir (car iter)) + (subdirs subdirs) + esubdirs esubdir) + (while subdirs + (setq esubdir (expand-file-name (car subdirs) dir)) + (setq subdirs (cdr subdirs)) + (if (file-directory-p esubdir) + (setq esubdirs (cons esubdir esubdirs)) + (setq subdirs nil esubdirs nil))) + (if esubdirs + (progn + (setcdr iter (nconc (nreverse esubdirs) (cdr iter))) + (setq iter nil)) + (setq iter (cdr iter)) + (if (null iter) + (signal + 'error (list + (format-message + "Could not find elisp load-path: searched %S" + load-path)))))))) ;; We'll probably overflow the pure space. (setq purify-flag nil) ;; Value of max-lisp-eval-depth when compiling initially. - ;; During bootstrapping the byte-compiler is run interpreted when - ;; compiling itself, which uses a lot more stack than usual. - (setq max-lisp-eval-depth 2200) - (setq load-path (list (expand-file-name "." dir) - (expand-file-name "emacs-lisp" dir) - (expand-file-name "progmodes" dir) - (expand-file-name "language" dir) - (expand-file-name "international" dir) - (expand-file-name "textmodes" dir) - (expand-file-name "vc" dir))))) + ;; During bootstrapping the byte-compiler is run interpreted + ;; when compiling itself, which uses a lot more stack + ;; than usual. + (setq max-lisp-eval-depth 2200))) (if (eq t purify-flag) ;; Hash consing saved around 11% of pure space in my tests. @@ -88,10 +116,7 @@ (message "Using load-path %s" load-path) -;; This is a poor man's `last', since we haven't loaded subr.el yet. -(if (and (fboundp 'dump-emacs) - (or (equal (member "bootstrap" command-line-args) '("bootstrap")) - (equal (member "dump" command-line-args) '("dump")))) +(if dump-mode (progn ;; To reduce the size of dumped Emacs, we avoid making huge char-tables. (setq inhibit-load-charset-map t) @@ -350,15 +375,16 @@ lost after dumping"))) ;; file primitive. So the only workable solution to support building ;; in non-ASCII directories is to manipulate unibyte strings in the ;; current locale's encoding. -(if (and (member (car (last command-line-args)) '("dump" "bootstrap")) - (fboundp 'dump-emacs) - (multibyte-string-p default-directory)) +(if (and dump-mode (multibyte-string-p default-directory)) (error "default-directory must be unibyte when dumping Emacs!")) ;; Determine which build number to use ;; based on the executables that now exist. -(if (and (equal (last command-line-args) '("dump")) - (fboundp 'dump-emacs) +(if (and (or + (and (equal dump-mode "dump") + (fboundp 'dump-emacs)) + (and (equal dump-mode "pdump") + (fboundp 'dump-emacs-portable))) (not (eq system-type 'ms-dos))) (let* ((base (concat "emacs-" emacs-version ".")) (exelen (if (eq system-type 'windows-nt) -4)) @@ -368,16 +394,18 @@ lost after dumping"))) (string-to-number (substring name (length base) exelen)))) files))) - (setq emacs-repository-version (condition-case nil (emacs-repository-get-version) - (error nil))) + (setq emacs-repository-version (ignore-errors (emacs-repository-get-version)) + emacs-repository-branch (ignore-errors (emacs-repository-get-branch))) ;; A constant, so we shouldn't change it with `setq'. (defconst emacs-build-number (if versions (1+ (apply 'max versions)) 1)))) (message "Finding pointers to doc strings...") -(if (and (fboundp 'dump-emacs) - (equal (last command-line-args) '("dump"))) +(if (and (or (and (fboundp 'dump-emacs) + (equal dump-mode "dump")) + (and (fboundp 'dump-emacs-portable) + (equal dump-mode "pdump")))) (Snarf-documentation "DOC") (condition-case nil (Snarf-documentation "DOC") @@ -446,53 +474,69 @@ lost after dumping"))) ;; Make sure we will attempt bidi reordering henceforth. (setq redisplay--inhibit-bidi nil) -(if (and (fboundp 'dump-emacs) - (member (car (last command-line-args)) '("dump" "bootstrap"))) - (progn - ;; Prevent build-time PATH getting stored in the binary. - ;; Mainly cosmetic, but helpful for Guix. (Bug#20330) - ;; Do this here, rather than earlier, so that the above code - ;; can invoke Git commands and the like. - (setq exec-path nil) - (message "Dumping under the name emacs") +(if dump-mode + (let ((output (cond ((equal dump-mode "pdump") "emacs.pdmp") + ((equal dump-mode "dump") "emacs") + ((equal dump-mode "bootstrap") "emacs") + ((equal dump-mode "pbootstrap") "bootstrap-emacs.pdmp") + (t (error "unrecognized dump mode %s" dump-mode))))) + (message "Dumping under the name %s" output) (condition-case () - (delete-file "emacs") - (file-error nil)) - ;; We used to dump under the name xemacs, but that occasionally - ;; confused people installing Emacs (they'd install the file - ;; under the name `xemacs'), and it's inconsistent with every - ;; other GNU program's build process. - (dump-emacs "emacs" "temacs") - (message "%d pure bytes used" pure-bytes-used) + (delete-file output) + (file-error nil)) + ;; On MS-Windows, the current directory is not necessarily the + ;; same as invocation-directory. + (let (success) + (unwind-protect + (let ((tmp-dump-mode dump-mode) + (dump-mode nil)) + (if (member tmp-dump-mode '("pdump" "pbootstrap")) + (dump-emacs-portable (expand-file-name output invocation-directory)) + (dump-emacs output "temacs") + (message "%d pure bytes used" pure-bytes-used)) + (setq success t)) + (unless success + (ignore-errors + (delete-file output))))) ;; Recompute NAME now, so that it isn't set when we dump. (if (not (or (eq system-type 'ms-dos) ;; Don't bother adding another name if we're just ;; building bootstrap-emacs. - (equal (last command-line-args) '("bootstrap")))) - (let ((name (format "emacs-%s.%d" emacs-version emacs-build-number)) - (exe (if (eq system-type 'windows-nt) ".exe" ""))) - (while (string-match "[^-+_.a-zA-Z0-9]+" name) - (setq name (concat (downcase (substring name 0 (match-beginning 0))) - "-" - (substring name (match-end 0))))) - (setq name (concat name exe)) - (message "Adding name %s" name) - ;; When this runs on Windows, invocation-directory is not - ;; necessarily the current directory. - (add-name-to-file (expand-file-name (concat "emacs" exe) - invocation-directory) - (expand-file-name name invocation-directory) - t))) + (member dump-mode '("pbootstrap" "bootstrap")))) + (let ((name (format "emacs-%s.%d" emacs-version emacs-build-number)) + (exe (if (eq system-type 'windows-nt) ".exe" ""))) + (while (string-match "[^-+_.a-zA-Z0-9]+" name) + (setq name (concat (downcase (substring name 0 (match-beginning 0))) + "-" + (substring name (match-end 0))))) + (message "Adding name %s" (concat name exe)) + ;; When this runs on Windows, invocation-directory is not + ;; necessarily the current directory. + (add-name-to-file (expand-file-name (concat "emacs" exe) + invocation-directory) + (expand-file-name (concat name exe) + invocation-directory) + t) + (when (equal dump-mode "pdump") + (message "Adding name %s" (concat name ".pdmp")) + (add-name-to-file (expand-file-name "emacs.pdmp" + invocation-directory) + (expand-file-name (concat name ".pdmp") + invocation-directory) + t)))) (kill-emacs))) -;; For machines with CANNOT_DUMP defined in config.h, -;; this file must be loaded each time Emacs is run. +;; This file must be loaded each time Emacs is run from scratch, e.g., temacs. ;; So run the startup code now. First, remove `-l loadup' from args. (if (and (member (nth 1 command-line-args) '("-l" "--load")) (equal (nth 2 command-line-args) "loadup")) (setcdr command-line-args (nthcdr 3 command-line-args))) +;; Don't keep `load-file-name' set during the top-level session! +;; Otherwise, it breaks a lot of code which does things like +;; (or load-file-name byte-compile-current-file). +(setq load-file-name nil) (eval top-level) diff --git a/lisp/locate.el b/lisp/locate.el index a43cecb2a63..452f74610fb 100644 --- a/lisp/locate.el +++ b/lisp/locate.el @@ -1,4 +1,4 @@ -;;; locate.el --- interface to the locate command +;;; locate.el --- interface to the locate command -*- lexical-binding:t -*- ;; Copyright (C) 1996, 1998, 2001-2019 Free Software Foundation, Inc. @@ -261,7 +261,7 @@ that is, with a prefix arg, you get the default behavior." "Run locate (like this): " (cons (concat (car locate-cmd) " " - (mapconcat 'identity (cdr locate-cmd) " ")) + (mapconcat #'identity (cdr locate-cmd) " ")) (+ 2 (length (car locate-cmd)))) nil nil 'locate-history-list)) (let* ((default (locate-word-at-point)) @@ -313,7 +313,7 @@ then `locate-post-command-hook'." (and (not arg) locate-prompt-for-command)))) ;; Find the Locate buffer - (save-window-excursion + (save-window-excursion ;FIXME: What window-excursion? (set-buffer (get-buffer-create locate-buffer-name)) (locate-mode) (let ((inhibit-read-only t) @@ -327,7 +327,7 @@ then `locate-post-command-hook'." (if run-locate-command (shell-command search-string locate-buffer-name) - (apply 'call-process locate-cmd nil t nil locate-cmd-args)) + (apply #'call-process locate-cmd nil t nil locate-cmd-args)) (and filter (locate-filter-output filter)) @@ -466,8 +466,8 @@ do not work in subdirectories. ;; Avoid clobbering this variable (make-local-variable 'dired-subdir-alist) (setq default-directory "/" - buffer-read-only t - selective-display t) + buffer-read-only t) + (add-to-invisibility-spec '(dired . t)) (dired-alist-add-1 default-directory (point-min-marker)) (set (make-local-variable 'dired-directory) "/") (set (make-local-variable 'dired-subdir-switches) locate-ls-subdir-switches) @@ -499,9 +499,9 @@ do not work in subdirectories. (progn (kill-buffer locate-buffer-name) (if locate-current-filter - (error "Locate: no match for %s in database using filter %s" + (user-error "Locate: no match for %s in database using filter %s" search-string locate-current-filter) - (error "Locate: no match for %s in database" search-string)))) + (user-error "Locate: no match for %s in database" search-string)))) (locate-insert-header search-string) @@ -554,7 +554,7 @@ do not work in subdirectories. locate-regexp-match (concat locate-regexp-match ":\n")) - (insert (apply 'format locate-format-string (reverse locate-format-args))) + (insert (apply #'format locate-format-string (reverse locate-format-args))) (save-excursion (goto-char (point-min)) diff --git a/lisp/lpr.el b/lisp/lpr.el index 75ccf445eca..436f9e3e021 100644 --- a/lisp/lpr.el +++ b/lisp/lpr.el @@ -258,7 +258,7 @@ for further customization of the printer command." (defun lpr-print-region (start end switches name) (let ((buf (current-buffer)) - (nswitches (lpr-flatten-list + (nswitches (flatten-tree (mapcar #'lpr-eval-switch ; Dynamic evaluation switches))) (switch-string (if switches @@ -336,23 +336,7 @@ The characters tab, linefeed, space, return and formfeed are not affected." ((consp arg) (apply (car arg) (cdr arg))) (t nil))) -;; `lpr-flatten-list' is defined here (copied from "message.el" and -;; enhanced to handle dotted pairs as well) until we can get some -;; sensible autoloads, or `flatten-list' gets put somewhere decent. - -;; (lpr-flatten-list '((a . b) c (d . e) (f g h) i . j)) -;; => (a b c d e f g h i j) - -(defun lpr-flatten-list (&rest list) - (lpr-flatten-list-1 list)) - -(defun lpr-flatten-list-1 (list) - (cond - ((null list) nil) - ((consp list) - (append (lpr-flatten-list-1 (car list)) - (lpr-flatten-list-1 (cdr list)))) - (t (list list)))) +(define-obsolete-function-alias 'lpr-flatten-list #'flatten-tree "27.1") (provide 'lpr) diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el index bb3a2f03f00..e802c2408f7 100644 --- a/lisp/ls-lisp.el +++ b/lisp/ls-lisp.el @@ -385,13 +385,13 @@ not contain `d', so that a full listing is expected." ;; files we are about to display. (dolist (elt file-alist) (setq attr (cdr elt) - fuid (nth 2 attr) + fuid (file-attribute-user-id attr) uid-len (if (stringp fuid) (string-width fuid) (length (format "%d" fuid))) - fgid (nth 3 attr) + fgid (file-attribute-group-id attr) gid-len (if (stringp fgid) (string-width fgid) (length (format "%d" fgid))) - file-size (nth 7 attr)) + file-size (file-attribute-size attr)) (if (> uid-len max-uid-len) (setq max-uid-len uid-len)) (if (> gid-len max-gid-len) @@ -418,16 +418,9 @@ not contain `d', so that a full listing is expected." files (cdr files) short (car elt) attr (cdr elt) - file-size (nth 7 attr)) + file-size (file-attribute-size attr)) (and attr - (setq sum (+ file-size - ;; Even if neither SUM nor file's size - ;; overflow, their sum could. - (if (or (< sum (- 134217727 file-size)) - (floatp sum) - (floatp file-size)) - sum - (float sum)))) + (setq sum (+ file-size sum)) (insert (ls-lisp-format short attr file-size switches time-index)))) ;; Insert total size of all files: @@ -474,16 +467,22 @@ not contain `d', so that a full listing is expected." (if (memq ?F switches) (ls-lisp-classify-file file fattr) file) - fattr (nth 7 fattr) - switches time-index)) - (message "%s: doesn't exist or is inaccessible" file) - (ding) (sit-for 2))))) ; to show user the message! + fattr (file-attribute-size fattr) + switches time-index)) + ;; Emulate what we do on Posix hosts when we call access-file + ;; in insert-directory. + (signal 'file-error + (list "Reading directory" + "Directory doesn't exist or is inaccessible" + file)))))) (declare-function dired-read-dir-and-switches "dired" (str)) (declare-function dired-goto-next-file "dired" ()) (defun ls-lisp--dired (orig-fun dir-or-list &optional switches) (interactive (dired-read-dir-and-switches "")) + (unless dir-or-list + (setq dir-or-list default-directory)) (if (consp dir-or-list) (funcall orig-fun dir-or-list switches) (let ((dir-wildcard (insert-directory-wildcard-in-dir-p @@ -659,10 +658,9 @@ SWITCHES is a list of characters. Default sorting is alphabetic." (sort (copy-sequence file-alist) ; modifies its argument! (cond ((memq ?S switches) (lambda (x y) ; sorted on size - ;; 7th file attribute is file size ;; Make largest file come first - (< (nth 7 (cdr y)) - (nth 7 (cdr x))))) + (< (file-attribute-size (cdr y)) + (file-attribute-size (cdr x))))) ((setq index (ls-lisp-time-index switches)) (lambda (x y) ; sorted on time (time-less-p (nth index (cdr y)) @@ -719,8 +717,8 @@ FATTR is the file attributes returned by `file-attributes' for the file. The file type indicators are `/' for directories, `@' for symbolic links, `|' for FIFOs, `=' for sockets, `*' for regular files that are executable, and nothing for other types of files." - (let* ((type (car fattr)) - (modestr (nth 8 fattr)) + (let* ((type (file-attribute-type fattr)) + (modestr (file-attribute-modes fattr)) (typestr (substring modestr 0 1)) (file-name (propertize filename 'dired-filename t))) (cond @@ -773,35 +771,13 @@ FOLLOWED by null and full filename, SOLELY for full alpha sort." "Format one line of long ls output for file FILE-NAME. FILE-ATTR and FILE-SIZE give the file's attributes and size. SWITCHES and TIME-INDEX give the full switch list and time data." - (let ((file-type (nth 0 file-attr)) + (let ((file-type (file-attribute-type file-attr)) ;; t for directory, string (name linked to) ;; for symbolic link, or nil. - (drwxrwxrwx (nth 8 file-attr))) ; attribute string ("drwxrwxrwx") + (drwxrwxrwx (file-attribute-modes file-attr))) (concat (if (memq ?i switches) ; inode number - (let ((inode (nth 10 file-attr))) - (if (consp inode) - (if (consp (cdr inode)) - ;; 2^(24+16) = 1099511627776.0, but - ;; multiplying by it and then adding the - ;; other members of the cons cell in one go - ;; loses precision, since a double does not - ;; have enough significant digits to hold a - ;; full 64-bit value. So below we split - ;; 1099511627776 into high 13 and low 5 - ;; digits and compute in two parts. - (let ((p1 (* (car inode) 10995116.0)) - (p2 (+ (* (car inode) 27776.0) - (* (cadr inode) 65536.0) - (cddr inode)))) - (format " %13.0f%05.0f " - ;; Use floor to emulate integer - ;; division. - (+ p1 (floor p2 100000.0)) - (mod p2 100000.0))) - (format " %18.0f " - (+ (* (car inode) 65536.0) - (cdr inode)))) - (format " %18d " inode)))) + (let ((inode (file-attribute-inode-number file-attr))) + (format " %18d " inode))) ;; nil is treated like "" in concat (if (memq ?s switches) ; size in K, rounded up ;; In GNU ls, -h affects the size in blocks, displayed @@ -819,14 +795,14 @@ SWITCHES and TIME-INDEX give the full switch list and time data." (fceiling (/ file-size 1024.0))))) drwxrwxrwx ; attribute string (if (memq 'links ls-lisp-verbosity) - (format "%3d" (nth 1 file-attr))) ; link count + (format "%3d" (file-attribute-link-number file-attr))) ;; Numeric uid/gid are more confusing than helpful; ;; Emacs should be able to make strings of them. ;; They tend to be bogus on non-UNIX platforms anyway so ;; optionally hide them. (if (memq 'uid ls-lisp-verbosity) ;; uid can be a string or an integer - (let ((uid (nth 2 file-attr))) + (let ((uid (file-attribute-user-id file-attr))) (format (if (stringp uid) ls-lisp-uid-s-fmt ls-lisp-uid-d-fmt) @@ -834,7 +810,7 @@ SWITCHES and TIME-INDEX give the full switch list and time data." (if (not (memq ?G switches)) ; GNU ls -- shows group by default (if (or (memq ?g switches) ; UNIX ls -- no group by default (memq 'gid ls-lisp-verbosity)) - (let ((gid (nth 3 file-attr))) + (let ((gid (file-attribute-group-id file-attr))) (format (if (stringp gid) ls-lisp-gid-s-fmt ls-lisp-gid-d-fmt) diff --git a/lisp/macros.el b/lisp/macros.el index 27a14694ee6..4b38506d8a5 100644 --- a/lisp/macros.el +++ b/lisp/macros.el @@ -1,4 +1,4 @@ -;;; macros.el --- non-primitive commands for keyboard macros +;;; macros.el --- non-primitive commands for keyboard macros -*- lexical-binding:t -*- ;; Copyright (C) 1985-1987, 1992, 1994-1995, 2001-2019 Free Software ;; Foundation, Inc. @@ -31,23 +31,20 @@ ;;; Code: +(require 'kmacro) + ;;;###autoload -(defun name-last-kbd-macro (symbol) - "Assign a name to the last keyboard macro defined. -Argument SYMBOL is the name to define. -The symbol's function definition becomes the keyboard macro string. -Such a \"function\" cannot be called from Lisp, but it is a valid editor command." - (interactive "SName for last kbd macro: ") - (or last-kbd-macro - (user-error "No keyboard macro defined")) - (and (fboundp symbol) - (not (stringp (symbol-function symbol))) - (not (vectorp (symbol-function symbol))) - (user-error "Function %s is already defined and not a keyboard macro" - symbol)) - (if (string-equal symbol "") - (user-error "No command name given")) - (fset symbol last-kbd-macro)) +(defalias 'name-last-kbd-macro #'kmacro-name-last-macro) + +(defun macros--insert-vector-macro (definition) + "Print DEFINITION, a vector, into the current buffer." + (dotimes (i (length definition)) + (let ((char (aref definition i))) + (insert (if (zerop i) ?\[ ?\s)) + (if (characterp char) + (princ (prin1-char char) (current-buffer)) + (prin1 char (current-buffer))))) + (insert ?\])) ;;;###autoload (defun insert-kbd-macro (macroname &optional keys) @@ -66,11 +63,7 @@ To save a kbd macro, visit a file of Lisp code such as your `~/.emacs', use this command, and then save the file." (interactive (list (intern (completing-read "Insert kbd macro (name): " obarray - (lambda (elt) - (and (fboundp elt) - (or (stringp (symbol-function elt)) - (vectorp (symbol-function elt)) - (get elt 'kmacro)))) + #'kmacro-keyboard-macro-p t)) current-prefix-arg)) (let (definition) @@ -128,16 +121,17 @@ use this command, and then save the file." (delete-region (point) (1+ (point))) (insert "\\M-\\C-?")))))) (if (vectorp definition) - (let ((len (length definition)) (i 0) char) - (while (< i len) - (insert (if (zerop i) ?\[ ?\s)) - (setq char (aref definition i) - i (1+ i)) - (if (not (numberp char)) - (prin1 char (current-buffer)) - (princ (prin1-char char) (current-buffer)))) - (insert ?\])) - (prin1 definition (current-buffer)))) + (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)))))) (insert ")\n") (if keys (let ((keys (or (where-is-internal (symbol-function macroname) diff --git a/lisp/mail/binhex.el b/lisp/mail/binhex.el index eb00b87f4c1..1cf50aa0678 100644 --- a/lisp/mail/binhex.el +++ b/lisp/mail/binhex.el @@ -1,4 +1,4 @@ -;;; binhex.el --- decode BinHex-encoded text +;;; binhex.el --- decode BinHex-encoded text -*- lexical-binding:t -*- ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. @@ -29,8 +29,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (eval-and-compile (defalias 'binhex-char-int (if (fboundp 'char-int) @@ -90,16 +88,12 @@ input and write the converted data to its standard output." ((boundp 'temporary-file-directory) temporary-file-directory) ("/tmp/"))) -(eval-and-compile - (defalias 'binhex-insert-char - (if (featurep 'xemacs) - 'insert-char - (lambda (char &optional count ignored buffer) - "Insert COUNT copies of CHARACTER into BUFFER." - (if (or (null buffer) (eq buffer (current-buffer))) - (insert-char char count) - (with-current-buffer buffer - (insert-char char count))))))) +(defun binhex-insert-char (char &optional count ignored buffer) + "Insert COUNT copies of CHARACTER into BUFFER." + (if (or (null buffer) (eq buffer (current-buffer))) + (insert-char char count) + (with-current-buffer buffer + (insert-char char count)))) (defvar binhex-crc-table [0 4129 8258 12387 16516 20645 24774 28903 @@ -138,9 +132,9 @@ input and write the converted data to its standard output." (defun binhex-update-crc (crc char &optional count) (if (null count) (setq count 1)) (while (> count 0) - (setq crc (logxor (logand (lsh crc 8) 65280) + (setq crc (logxor (logand (ash crc 8) 65280) (aref binhex-crc-table - (logxor (logand (lsh crc -8) 255) + (logxor (logand (ash crc -8) 255) char))) count (1- count))) crc) @@ -158,14 +152,14 @@ input and write the converted data to its standard output." (defun binhex-string-big-endian (string) (let ((ret 0) (i 0) (len (length string))) (while (< i len) - (setq ret (+ (lsh ret 8) (binhex-char-int (aref string i))) + (setq ret (+ (ash ret 8) (binhex-char-int (aref string i))) i (1+ i))) ret)) (defun binhex-string-little-endian (string) (let ((ret 0) (i 0) (shift 0) (len (length string))) (while (< i len) - (setq ret (+ ret (lsh (binhex-char-int (aref string i)) shift)) + (setq ret (+ ret (ash (binhex-char-int (aref string i)) shift)) i (1+ i) shift (+ shift 8))) ret)) @@ -193,7 +187,7 @@ input and write the converted data to its standard output." (defvar binhex-last-char) (defvar binhex-repeat) -(defun binhex-push-char (char &optional count ignored buffer) +(defun binhex-push-char (char &optional ignored buffer) (cond (binhex-repeat (if (eq char 0) @@ -226,8 +220,8 @@ If HEADER-ONLY is non-nil only decode header and return filename." (goto-char start) (when (re-search-forward binhex-begin-line end t) (setq work-buffer (generate-new-buffer " *binhex-work*")) - (unless (featurep 'xemacs) - (with-current-buffer work-buffer (set-buffer-multibyte nil))) + (with-current-buffer work-buffer + (set-buffer-multibyte nil)) (beginning-of-line) (setq bits 0 counter 0) (while tmp @@ -241,13 +235,13 @@ If HEADER-ONLY is non-nil only decode header and return filename." counter (1+ counter) inputpos (1+ inputpos)) (cond ((= counter 4) - (binhex-push-char (lsh bits -16) 1 nil work-buffer) - (binhex-push-char (logand (lsh bits -8) 255) 1 nil + (binhex-push-char (ash bits -16) nil work-buffer) + (binhex-push-char (logand (ash bits -8) 255) nil work-buffer) - (binhex-push-char (logand bits 255) 1 nil + (binhex-push-char (logand bits 255) nil work-buffer) (setq bits 0 counter 0)) - (t (setq bits (lsh bits 6))))) + (t (setq bits (ash bits 6))))) (if (null file-name-length) (with-current-buffer work-buffer (setq file-name-length (char-after (point-min)) @@ -263,12 +257,12 @@ If HEADER-ONLY is non-nil only decode header and return filename." (setq tmp (and tmp (not (eq inputpos end))))) (cond ((= counter 3) - (binhex-push-char (logand (lsh bits -16) 255) 1 nil + (binhex-push-char (logand (ash bits -16) 255) nil work-buffer) - (binhex-push-char (logand (lsh bits -8) 255) 1 nil + (binhex-push-char (logand (ash bits -8) 255) nil work-buffer)) ((= counter 2) - (binhex-push-char (logand (lsh bits -10) 255) 1 nil + (binhex-push-char (logand (ash bits -10) 255) nil work-buffer)))) (if header-only nil (binhex-verify-crc work-buffer @@ -287,7 +281,7 @@ If HEADER-ONLY is non-nil only decode header and return filename." (defun binhex-decode-region-external (start end) "Binhex decode region between START and END using external decoder." (interactive "r") - (let ((cbuf (current-buffer)) firstline work-buffer status + (let ((cbuf (current-buffer)) firstline work-buffer (file-name (expand-file-name (concat (binhex-decode-region-internal start end t) ".data") diff --git a/lisp/mail/blessmail.el b/lisp/mail/blessmail.el index 42c60c3f6c3..62094bfe2d7 100644 --- a/lisp/mail/blessmail.el +++ b/lisp/mail/blessmail.el @@ -49,15 +49,15 @@ (setq attr (file-attributes dirname)) (if (not (eq t (car attr))) (insert (format "echo %s is not a directory\n" rmail-spool-directory)) - (setq modes (nth 8 attr)) + (setq modes (file-attribute-modes attr)) (cond ((= ?w (aref modes 8)) ;; Nothing needs to be done. ) ((= ?w (aref modes 5)) - (insert "chgrp " (number-to-string (nth 3 attr)) + (insert "chgrp " (number-to-string (file-attribute-group-id attr)) " $* && chmod g+s $*\n")) ((= ?w (aref modes 2)) - (insert "chown " (number-to-string (nth 2 attr)) + (insert "chown " (number-to-string (file-attribute-user-id attr)) " $* && chmod u+s $*\n")) (t (insert "chown root $* && chmod u+s $*\n")))) diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el index 859239405a9..13219a4b444 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -69,6 +69,7 @@ (declare-function x-server-vendor "xfns.c" (&optional terminal)) (declare-function x-server-version "xfns.c" (&optional terminal)) (declare-function message-sort-headers "message" ()) +(declare-function w32--os-description "w32-fns" ()) (defvar message-strip-special-text-properties) (defun report-emacs-bug-can-use-osx-open () @@ -116,6 +117,88 @@ This requires either the macOS \"open\" command, or the freedesktop (concat "mailto:" to))) (error "Subject, To or body not found"))))) +(defvar report-emacs-bug--os-description nil + "Cached value of operating system description.") + +(defun report-emacs-bug--os-description () + "Return a string describing the operating system, or nil." + (cond ((eq system-type 'darwin) + (let (os) + (with-temp-buffer + (when (eq 0 (ignore-errors + (call-process "sw_vers" nil '(t nil) nil))) + (dolist (s '("ProductName" "ProductVersion")) + (goto-char (point-min)) + (if (re-search-forward (format "^%s\\s-*:\\s-+\\(.*\\)$" s) + nil t) + (setq os (concat os " " (match-string 1))))))) + os)) + ((eq system-type 'windows-nt) + (or report-emacs-bug--os-description + (setq report-emacs-bug--os-description (w32--os-description)))) + ((eq system-type 'berkeley-unix) + (with-temp-buffer + (when + (or (eq 0 (ignore-errors (call-process "freebsd-version" nil + '(t nil) nil "-u"))) + (progn (erase-buffer) + (eq 0 (ignore-errors + (call-process "uname" nil + '(t nil) nil "-a"))))) + (unless (zerop (buffer-size)) + (goto-char (point-min)) + (buffer-substring (line-beginning-position) + (line-end-position)))))) + ;; TODO Cygwin, Solaris (usg-unix-v). + (t + (or (let ((file "/etc/os-release")) + (and (file-readable-p file) + (with-temp-buffer + (insert-file-contents file) + (if (re-search-forward + "^\\sw*PRETTY_NAME=\"?\\(.+?\\)\"?$" nil t) + (match-string 1) + (let (os) + (when (re-search-forward + "^\\sw*NAME=\"?\\(.+?\\)\"?$" nil t) + (setq os (match-string 1)) + (if (re-search-forward + "^\\sw*VERSION=\"?\\(.+?\\)\"?$" nil t) + (setq os (concat os " " (match-string 1)))) + os)))))) + (with-temp-buffer + (when (eq 0 (ignore-errors + (call-process "lsb_release" nil '(t nil) + nil "-d"))) + (goto-char (point-min)) + (if (looking-at "^\\sw+:\\s-+") + (goto-char (match-end 0))) + (buffer-substring (point) (line-end-position)))) + (let ((file "/etc/lsb-release")) + (and (file-readable-p file) + (with-temp-buffer + (insert-file-contents file) + (if (re-search-forward + "^\\sw*DISTRIB_DESCRIPTION=\"?\\(.*release.*?\\)\"?$" nil t) + (match-string 1))))) + (catch 'found + (dolist (f (append (file-expand-wildcards "/etc/*-release") + '("/etc/debian_version"))) + (and (not (member (file-name-nondirectory f) + '("lsb-release" "os-release"))) + (file-readable-p f) + (with-temp-buffer + (insert-file-contents f) + (if (not (zerop (buffer-size))) + (throw 'found + (format "%s%s" + (if (equal (file-name-nondirectory f) + "debian_version") + "Debian " "") + (buffer-substring + (line-beginning-position) + (line-end-position))))))))))))) + ;; It's the default mail mode, so it seems OK to use its features. (autoload 'message-bogus-recipient-p "message") (autoload 'message-make-address "message") @@ -225,6 +308,8 @@ usually do not have translators for other languages.\n\n"))) (if (stringp emacs-repository-version) (insert "Repository revision: " emacs-repository-version "\n")) + (if (stringp emacs-repository-branch) + (insert "Repository branch: " emacs-repository-branch "\n")) (if (fboundp 'x-server-vendor) (condition-case nil ;; This is used not only for X11 but also W32 and others. @@ -232,13 +317,9 @@ usually do not have translators for other languages.\n\n"))) "', version " (mapconcat 'number-to-string (x-server-version) ".") "\n") (error t))) - (let ((lsb (with-temp-buffer - (if (eq 0 (ignore-errors - (call-process "lsb_release" nil '(t nil) - nil "-d"))) - (buffer-string))))) - (if (stringp lsb) - (insert "System " lsb "\n"))) + (let ((os (ignore-errors (report-emacs-bug--os-description)))) + (if (stringp os) + (insert "System Description: " os "\n\n"))) (let ((message-buf (get-buffer "*Messages*"))) (if message-buf (let (beg-pos @@ -267,11 +348,6 @@ usually do not have translators for other languages.\n\n"))) "LC_ALL" "LC_COLLATE" "LC_CTYPE" "LC_MESSAGES" "LC_MONETARY" "LC_NUMERIC" "LC_TIME" "LANG" "XMODIFIERS")) (insert (format " locale-coding-system: %s\n" locale-coding-system)) - ;; Only ~ 0.2% of people from a sample of 3200 changed this from - ;; the default, t. - (or (default-value 'enable-multibyte-characters) - (insert (format " default enable-multibyte-characters: %s\n" - (default-value 'enable-multibyte-characters)))) (insert "\n") (insert (format "Major mode: %s\n" (format-mode-line @@ -354,14 +430,10 @@ usually do not have translators for other languages.\n\n"))) report-emacs-bug-orig-text) (error "No text entered in bug report")) ;; Warning for novice users. - (unless (or report-emacs-bug-no-confirmation - (yes-or-no-p - "Send this bug report to the Emacs maintainers? ")) - (goto-char (point-min)) - (if (search-forward "To: ") - (delete-region (point) (line-end-position))) - (if report-emacs-bug-send-hook - (kill-local-variable report-emacs-bug-send-hook)) + (when (and (string-match "bug-gnu-emacs@gnu\\.org" (mail-fetch-field "to")) + (not report-emacs-bug-no-confirmation) + (not (yes-or-no-p + "Send this bug report to the Emacs maintainers? "))) (with-output-to-temp-buffer "*Bug Help*" (princ (substitute-command-keys (format "\ diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el index 27ebe162491..babc3fc212a 100644 --- a/lisp/mail/feedmail.el +++ b/lisp/mail/feedmail.el @@ -1,5 +1,6 @@ -;;; feedmail.el --- assist other email packages to massage outgoing messages -;;; This file is in the public domain. +;;; feedmail.el --- assist other email packages to massage outgoing messages -*- lexical-binding:t -*- + +;; This file is in the public domain. ;; This file is part of GNU Emacs. @@ -1312,25 +1313,21 @@ There's no trivial way to avoid it. It's unwise to just set the value of `buffer-file-name' to nil because that will defeat feedmail's file management features. Instead, arrange for this variable to be set to the value of `buffer-file-name' before setting that to nil. An easy way -to do that would be with defadvice on `mail-send' \(undoing the -assignments in a later advice). +to do that would be with an advice on `mail-send'. feedmail will pretend that `buffer-file-name', if nil, has the value assigned of `feedmail-queue-buffer-file-name' and carry out its normal activities. feedmail does not restore the non-nil value of -`buffer-file-name'. For safe bookkeeping, the user should insure that +`buffer-file-name'. For safe bookkeeping, the user should ensure that feedmail-queue-buffer-file-name is restored to nil. -Example `defadvice' for mail-send: - - (defadvice mail-send (before feedmail-mail-send-before-advice activate) - (setq feedmail-queue-buffer-file-name buffer-file-name) - (setq buffer-file-name nil)) +Example advice for mail-send: - (defadvice mail-send (after feedmail-mail-send-after-advice activate) - (if feedmail-queue-buffer-file-name (setq buffer-file-name feedmail-queue-buffer-file-name)) - (setq feedmail-queue-buffer-file-name nil)) -") + (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)) + (apply orig-fun args)))") ;; defvars to make byte-compiler happy(er) (defvar feedmail-error-buffer nil) @@ -1396,7 +1393,7 @@ It shows the simple addresses and gets a confirmation. Use as: When this hook runs, the current buffer is already the appropriate buffer. It has already had all the header prepping from the standard package. The next step after running the hook will be to save the -message via FCC: processing. The hook might be interested in these: +message via Fcc: processing. The hook might be interested in these: \(1) `feedmail-prepped-text-buffer' contains the header and body of the message, ready to go; (2) `feedmail-address-list' contains a list of simplified recipients of addresses which are to be given to the @@ -1438,7 +1435,7 @@ internal buffers will be reused and things will get confused." ) (defcustom feedmail-queue-runner-mode-setter - (lambda (&optional arg) (mail-mode)) + (lambda (&optional _) (mail-mode)) "A function to set the proper mode of a message file. Called when the message is read back out of the queue directory with a single argument, the optional argument used in the call to @@ -1474,7 +1471,10 @@ set `mail-header-separator' to the value of (defcustom feedmail-queue-runner-message-sender - (lambda (&optional arg) (mail-send)) + (lambda (&optional _) + ;; `mail-send' is not autoloaded, which is why we need the `require'. + (require 'sendmail) (declare-function mail-send "sendmail") + (mail-send)) "Function to initiate sending a message file. Called for each message read back out of the queue directory with a single argument, the optional argument used in the call to @@ -1607,7 +1607,7 @@ Feeds the buffer to it." "Function which actually calls sendmail as a subprocess. Feeds the buffer to it. Probably has some flaws for Resent-* and other complicated cases. Takes addresses from message headers and -might disappoint you with BCC: handling. In case of odd results, consult +might disappoint you with Bcc: handling. In case of odd results, consult local gurus." (require 'sendmail) (feedmail-say-debug ">in-> feedmail-buffer-to-sendmail %s" addr-listoid) @@ -1657,7 +1657,7 @@ local gurus." (declare-function smtp-via-smtp "ext:smtp" (sender recipients smtp-text-buffer)) (defvar smtp-server) -;; FLIM's smtp.el pointed out to me by Kenichi Handa <handa@etl.go.jp> +;; FLIM's smtp.el pointed out to me by Kenichi Handa <handa@gnu.org> (defun feedmail-buffer-to-smtp (prepped errors-to addr-listoid) "Function which actually calls smtp-via-smtp to send buffer as e-mail." (feedmail-say-debug ">in-> feedmail-buffer-to-smtp %s" addr-listoid) @@ -1737,7 +1737,7 @@ insertion.") (declare-function vm-mail "ext:vm" (&optional to subject)) -(defun feedmail-vm-mail-mode (&optional arg) +(defun feedmail-vm-mail-mode (&optional _) "Make something like a buffer that has been created via `vm-mail'. The optional argument is ignored and is just for argument compatibility with `feedmail-queue-runner-mode-setter'. This function is suitable for being @@ -1745,9 +1745,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: -\(setq auto-mode-alist - (cons \\='(\"\\\\.fqm$\" . feedmail-vm-mail-mode) auto-mode-alist)) -" + (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) @@ -2150,19 +2148,8 @@ you can set `feedmail-queue-reminder-alist' to nil." feedmail-prompt-before-queue-user-alist )) -(defun feedmail-queue-runner-prompt () - "Ask whether to queue, send immediately, or return to editing a message, etc." - (feedmail-say-debug ">in-> feedmail-queue-runner-prompt") - (feedmail-queue-send-edit-prompt-inner - feedmail-ask-before-queue-default - feedmail-ask-before-queue-prompt - feedmail-ask-before-queue-reprompt - 'feedmail-message-action-help - feedmail-prompt-before-queue-standard-alist - feedmail-prompt-before-queue-user-alist - )) (defun feedmail-queue-send-edit-prompt-inner (default prompt reprompt helper - standard-alist user-alist) + standard-alist user-alist) (feedmail-say-debug ">in-> feedmail-queue-send-edit-prompt-inner") ;; Some implementation ideas here came from the userlock.el code (or defining-kbd-macro (discard-input)) @@ -2181,7 +2168,7 @@ you can set `feedmail-queue-reminder-alist' to nil." (let ((inhibit-quit t) (cursor-in-echo-area t) (echo-keystrokes 0)) (read-char-exclusive)))) (if (= user-sez help-char) - (setq answer '(^ . helper)) + (setq answer (cons '^ helper)) (if (or (eq user-sez ?\C-m) (eq user-sez ?\C-j) (eq user-sez ?y)) (setq user-sez d-char)) ;; these char-to-int things are because of some @@ -2209,8 +2196,7 @@ you can set `feedmail-queue-reminder-alist' to nil." ;; emacs convention is that scroll-up moves text up, window down (feedmail-say-debug ">in-> feedmail-scroll-buffer %s" direction) (save-selected-window - (let ((signal-error-on-buffer-boundary nil) - (fqm-window (display-buffer (if buffy buffy (current-buffer))))) + (let ((fqm-window (display-buffer (if buffy buffy (current-buffer))))) (select-window fqm-window) (if (eq direction 'up) (if (pos-visible-in-window-p (point-max) fqm-window) @@ -2380,7 +2366,7 @@ mapped to mostly alphanumerics for safety." (defun feedmail-rfc822-date (arg-time) (feedmail-say-debug ">in-> feedmail-rfc822-date %s" arg-time) - (let ((time (if arg-time arg-time (current-time))) + (let ((time (or arg-time (current-time))) (system-time-locale "C")) (concat (format-time-string "%a, %e %b %Y %T " time) @@ -2697,8 +2683,10 @@ fiddle-plex, as described in the documentation for the variable (save-excursion (if feedmail-enable-spray (mapcar - (lambda (feedmail-spray-this-address) - (let ((spray-buffer (get-buffer-create " *FQM Outgoing Email Spray*"))) + (lambda (address) + (let ((feedmail-spray-this-address address) + (spray-buffer + (get-buffer-create " *FQM Outgoing Email Spray*"))) (with-current-buffer spray-buffer (erase-buffer) ;; not life's most efficient methodology, but spraying isn't @@ -2712,7 +2700,8 @@ fiddle-plex, as described in the documentation for the variable ;; Message-Id:s, but I doubt that anyone cares, ;; practically. If someone complains about it, I'll ;; add it. - (feedmail-fiddle-list-of-spray-fiddle-plexes feedmail-spray-address-fiddle-plex-list) + (feedmail-fiddle-list-of-spray-fiddle-plexes + feedmail-spray-address-fiddle-plex-list) ;; this (let ) is just in case some buffer eater ;; is cheating and using the global variable name instead ;; of its argument to find the buffer @@ -2823,16 +2812,13 @@ return that value." (defun feedmail-default-date-generator (maybe-file) "Default function for generating Date: header contents." (feedmail-say-debug ">in-> feedmail-default-date-generator") - (when maybe-file - (feedmail-say-debug (concat "4 cre " (feedmail-rfc822-date (nth 4 (file-attributes maybe-file))))) - (feedmail-say-debug (concat "5 mod " (feedmail-rfc822-date (nth 5 (file-attributes maybe-file))))) - (feedmail-say-debug (concat "6 sta " (feedmail-rfc822-date (nth 6 (file-attributes maybe-file)))))) - (let ((date-time)) - (if (and (not feedmail-queue-use-send-time-for-date) maybe-file) - (setq date-time (nth 5 (file-attributes maybe-file)))) - (feedmail-rfc822-date date-time)) - ) - + (let ((attr (and maybe-file (file-attributes maybe-file)))) + (when attr + (feedmail-say-debug (concat "4 cre " (feedmail-rfc822-date (file-attribute-access-time attr)))) + (feedmail-say-debug (concat "5 mod " (feedmail-rfc822-date (file-attribute-modification-time attr)))) + (feedmail-say-debug (concat "6 sta " (feedmail-rfc822-date (file-attribute-status-change-time attr))))) + (feedmail-rfc822-date (and attr (not feedmail-queue-use-send-time-for-date) + (file-attribute-modification-time attr))))) (defun feedmail-fiddle-date (maybe-file) "Fiddle Date:. See documentation of `feedmail-date-generator'." @@ -2882,7 +2868,8 @@ probably not appropriate for you." (concat (if (equal (match-beginning 1) (match-end 1)) "" "-") end-stuff)) (setq end-stuff (concat "@" end-stuff))) (if (and (not feedmail-queue-use-send-time-for-message-id) maybe-file) - (setq date-time (nth 5 (file-attributes maybe-file)))) + (setq date-time (file-attribute-modification-time + (file-attributes maybe-file)))) (format "<%d-%s%s%s>" (mod (random) 10000) (format-time-string "%a%d%b%Y%H%M%S" date-time) @@ -3147,13 +3134,17 @@ been weeded out." (identity address-list))) -(defun feedmail-one-last-look (feedmail-prepped-text-buffer) +(defun feedmail-one-last-look (buffer) "Offer the user one last chance to give it up." (feedmail-say-debug ">in-> feedmail-one-last-look") (save-excursion + ;; FIXME: switch-to-buffer may fail or pop up a new frame + ;; (in minibuffer-only frames, for example) and save-window-excursion + ;; won't delete the newly created frame upon exit! (save-window-excursion - (switch-to-buffer feedmail-prepped-text-buffer) - (if (and (fboundp 'y-or-n-p-with-timeout) (numberp feedmail-confirm-outgoing-timeout)) + (switch-to-buffer buffer) + (if (and (fboundp 'y-or-n-p-with-timeout) + (numberp feedmail-confirm-outgoing-timeout)) (y-or-n-p-with-timeout "FQM: Send this email? " (abs feedmail-confirm-outgoing-timeout) diff --git a/lisp/mail/flow-fill.el b/lisp/mail/flow-fill.el index 8451315a12e..ed6a2df87dc 100644 --- a/lisp/mail/flow-fill.el +++ b/lisp/mail/flow-fill.el @@ -1,4 +1,4 @@ -;;; flow-fill.el --- interpret RFC2646 "flowed" text +;;; flow-fill.el --- interpret RFC2646 "flowed" text -*- lexical-binding:t -*- ;; Copyright (C) 2000-2019 Free Software Foundation, Inc. @@ -49,7 +49,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (defcustom fill-flowed-display-column 'fill-column "Column beyond which format=flowed lines are wrapped, when displayed. @@ -166,74 +165,15 @@ RFC 2646 suggests 66 characters for readability." (forward-line 1) nil)))))))) -;; Test vectors. - -(defvar show-trailing-whitespace) - -(defvar fill-flowed-encode-tests - `( - ;; The syntax of each list element is: - ;; (INPUT . EXPECTED-OUTPUT) - (,(concat - "> Thou villainous ill-breeding spongy dizzy-eyed \n" - "> reeky elf-skinned pigeon-egg! \n" - ">> Thou artless swag-bellied milk-livered \n" - ">> dismal-dreaming idle-headed scut!\n" - ">>> Thou errant folly-fallen spleeny reeling-ripe \n" - ">>> unmuzzled ratsbane!\n" - ">>>> Henceforth, the coding style is to be strictly \n" - ">>>> enforced, including the use of only upper case.\n" - ">>>>> I've noticed a lack of adherence to the coding \n" - ">>>>> styles, of late.\n" - ">>>>>> Any complaints?") - . - ,(concat - "> Thou villainous ill-breeding spongy dizzy-eyed reeky elf-skinned\n" - "> pigeon-egg! \n" - ">> Thou artless swag-bellied milk-livered dismal-dreaming idle-headed\n" - ">> scut!\n" - ">>> Thou errant folly-fallen spleeny reeling-ripe unmuzzled ratsbane!\n" - ">>>> Henceforth, the coding style is to be strictly enforced,\n" - ">>>> including the use of only upper case.\n" - ">>>>> I've noticed a lack of adherence to the coding styles, of late.\n" - ">>>>>> Any complaints?\n" - )) - ;; (,(concat - ;; "\n" - ;; "> foo\n" - ;; "> \n" - ;; "> \n" - ;; "> bar\n") - ;; . - ;; ,(concat - ;; "\n" - ;; "> foo bar\n")) - )) +(make-obsolete-variable 'fill-flowed-encode-tests nil "27.1") +(defvar fill-flowed-encode-tests) (defun fill-flowed-test () (interactive "") - (switch-to-buffer (get-buffer-create "*Format=Flowed test output*")) - (erase-buffer) - (setq show-trailing-whitespace t) - (dolist (test fill-flowed-encode-tests) - (let (start output) - (insert "***** BEGIN TEST INPUT *****\n") - (insert (car test)) - (insert "***** END TEST INPUT *****\n\n") - (insert "***** BEGIN TEST OUTPUT *****\n") - (setq start (point)) - (insert (car test)) - (save-restriction - (narrow-to-region start (point)) - (fill-flowed)) - (setq output (buffer-substring start (point-max))) - (insert "***** END TEST OUTPUT *****\n") - (unless (string= output (cdr test)) - (insert "\n***** BEGIN TEST EXPECTED OUTPUT *****\n") - (insert (cdr test)) - (insert "***** END TEST EXPECTED OUTPUT *****\n")) - (insert "\n\n"))) - (goto-char (point-max))) + (declare (obsolete nil "27.1")) + (user-error (concat "This function is obsolete. Please see " + "test/lisp/mail/flow-fill-tests.el " + "in the Emacs source tree"))) (provide 'flow-fill) diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el index be3a878f832..fc74122ecd2 100644 --- a/lisp/mail/footnote.el +++ b/lisp/mail/footnote.el @@ -1,8 +1,9 @@ -;;; footnote.el --- footnote support for message mode +;;; footnote.el --- footnote support for message mode -*- lexical-binding:t -*- ;; Copyright (C) 1997, 2000-2019 Free Software Foundation, Inc. -;; Author: Steven L Baur <steve@xemacs.org> +;; Author: Steven L Baur <steve@xemacs.org> (1997-2011) +;; Boruch Baum <boruch_baum@gmx.com> (2017-) ;; Keywords: mail, news ;; Version: 0.19 @@ -29,9 +30,36 @@ ;; [1] Footnotes look something like this. Along with some decorative ;; stuff. -;; TODO: -;; Reasonable Undo support. -;; more language styles. +;;;; TODO: +;; + Reasonable Undo support. +;; - could use an `apply' entry in the buffer-undo-list to be warned when +;; a footnote we inserted is removed via undo. +;; - should try to handle the more general problem of deleting/removing +;; footnotes via standard editing commands rather than via footnote +;; commands. +;; + more language styles. +;; + The key sequence 'C-c ! a C-y C-c ! b' should auto-fill the +;; footnote in adaptive fill mode. This does not seem to be a bug in +;; `adaptive-fill' because it behaves that way on all point movements +;; + Handle footmode mode elegantly in all modes, even if that means refuses to +;; accept the burden. For example, in a programming language mode, footnotes +;; should be commented. +;; + Manually autofilling the a first footnote should not cause it to +;; wrap into the footnote section tag +;; + Current solution adds a second newline after the section tag, so it is +;; clearly a separate paragraph. There may be stylistic objections to this. +;; + Footnotes with multiple paragraphs should not have their first +;; line out-dented. +;; + Upon leaving footnote area, perform an auto-fill on an entire +;; footnote (including multiple paragraphs), or on entire footnote area. +;; + fill-paragraph takes arg REGION, but seemingly only when called +;; interactively. +;; + At some point, it became necessary to change `footnote-section-tag-regexp' +;; to remove its trailing space. (Adaptive fill side-effect?) +;; + useful for lazy testing +;; (setq footnote-narrow-to-footnotes-when-editing t) +;; (setq footnote-section-tag "Footnotes: ") +;; (setq footnote-section-tag-regexp "Footnotes\\(\\[.\\]\\)?:") ;;; Code: @@ -45,115 +73,113 @@ (defcustom footnote-mode-line-string " FN" "String to display in modes section of the mode-line." - :type 'string - :group 'footnote) - -(defcustom footnote-mode-hook nil - "Hook functions run when footnote-mode is activated." - :type 'hook - :group 'footnote) + :type 'string) (defcustom footnote-narrow-to-footnotes-when-editing nil "If non-nil, narrow to footnote text body while editing a footnote." - :type 'boolean - :group 'footnote) + :type 'boolean) (defcustom footnote-prompt-before-deletion t "If non-nil, prompt before deleting a footnote. There is currently no way to undo deletions." - :type 'boolean - :group 'footnote) + :type 'boolean) (defcustom footnote-spaced-footnotes t "If non-nil, insert an empty line between footnotes. Customizing this variable has no effect on buffers already displaying footnotes." - :type 'boolean - :group 'footnote) + :type 'boolean) (defcustom footnote-use-message-mode t ; Nowhere used. "If non-nil, assume Footnoting will be done in `message-mode'." - :type 'boolean - :group 'footnote) + :type 'boolean) (defcustom footnote-body-tag-spacing 2 "Number of spaces separating a footnote body tag and its text. Customizing this variable has no effect on buffers already displaying footnotes." - :type 'integer - :group 'footnote) + :type 'integer) (defcustom footnote-prefix [(control ?c) ?!] - "Prefix key to use for Footnote command in Footnote minor mode. + "Prefix key to use for Footnote commands in Footnote minor mode. The value of this variable is checked as part of loading Footnote mode. After that, changing the prefix key requires manipulating keymaps." - :type 'key-sequence - :group 'footnote) + :type 'key-sequence) ;;; Interface variables that probably shouldn't be changed -(defcustom footnote-section-tag "Footnotes: " +(defcustom footnote-section-tag "Footnotes:" "Tag inserted at beginning of footnote section. If you set this to the empty string, no tag is inserted and the value of `footnote-section-tag-regexp' is ignored. Customizing this variable has no effect on buffers already displaying footnotes." - :type 'string - :group 'footnote) + :version "27.1" + :type 'string) -(defcustom footnote-section-tag-regexp "Footnotes\\(\\[.\\]\\)?: " +(defcustom footnote-section-tag-regexp + ;; Even if `footnote-section-tag' has a trailing space, let's not require it + ;; here, since it might be trimmed by various commands. + "Footnotes\\(\\[.\\]\\)?:" "Regexp which indicates the start of a footnote section. This variable is disregarded when `footnote-section-tag' is the empty string. Customizing this variable has no effect on buffers already displaying footnotes." - :type 'regexp - :group 'footnote) + :version "27.1" + :type 'regexp) ;; The following three should be consumed by footnote styles. (defcustom footnote-start-tag "[" "String used to denote start of numbered footnote. Should not be set to the empty string. Customizing this variable has no effect on buffers already displaying footnotes." - :type 'string - :group 'footnote) + :type 'string) (defcustom footnote-end-tag "]" "String used to denote end of numbered footnote. Should not be set to the empty string. Customizing this variable has no effect on buffers already displaying footnotes." - :type 'string - :group 'footnote) + :type 'string) -(defcustom footnote-signature-separator (if (boundp 'message-signature-separator) - message-signature-separator - "^-- $") +(defcustom footnote-signature-separator + (if (boundp 'message-signature-separator) + message-signature-separator + "^-- $") "Regexp used by Footnote mode to recognize signatures." - :type 'regexp - :group 'footnote) + :type 'regexp) -;;; Private variables +(defcustom footnote-align-to-fn-text t + "How to left-align footnote text. +If nil, footnote text is to be aligned flush left with left side +of the footnote number. If non-nil, footnote text is to be aligned +left with the first character of footnote text." + :type 'boolean) -(defvar footnote-style-number nil - "Footnote style represented as an index into footnote-style-alist.") -(make-variable-buffer-local 'footnote-style-number) +;;; Private variables -(defvar footnote-text-marker-alist nil - "List of markers pointing to text of footnotes in message buffer.") -(make-variable-buffer-local 'footnote-text-marker-alist) +(defvar-local footnote-style-number nil + "Footnote style represented as an index into `footnote-style-alist'.") -(defvar footnote-pointer-marker-alist nil - "List of markers pointing to footnote pointers in message buffer.") -(make-variable-buffer-local 'footnote-pointer-marker-alist) +(defvar-local footnote--markers-alist nil + "List of (FN TEXT . POINTERS). +Where FN is the footnote number, TEXT is a marker pointing to +the footnote's text, and POINTERS is a list of markers pointing +to the places from which the footnote is referenced. +Both TEXT and POINTERS points right *before* the [...]") (defvar footnote-mouse-highlight 'highlight + ;; FIXME: This `highlight' property is not currently used. + ;; We should use `mouse-face' and make mouse clicks work on them. "Text property name to enable mouse over highlight.") +(defvar footnote-mode) + ;;; Default styles ;;; NUMERIC (defconst footnote-numeric-regexp "[0-9]+" "Regexp for digits.") -(defun Footnote-numeric (n) +(defun footnote--numeric (n) "Numeric footnote style. Use Arabic numerals for footnoting." (int-to-string n)) @@ -165,7 +191,7 @@ Use Arabic numerals for footnoting." (defconst footnote-english-upper-regexp "[A-Z]+" "Regexp for upper case English alphabet.") -(defun Footnote-english-upper (n) +(defun footnote--english-upper (n) "Upper case English footnoting. Wrapping around the alphabet implies successive repetitions of letters." (let* ((ltr (mod (1- n) (length footnote-english-upper))) @@ -184,7 +210,7 @@ Wrapping around the alphabet implies successive repetitions of letters." (defconst footnote-english-lower-regexp "[a-z]+" "Regexp of lower case English alphabet.") -(defun Footnote-english-lower (n) +(defun footnote--english-lower (n) "Lower case English footnoting. Wrapping around the alphabet implies successive repetitions of letters." (let* ((ltr (mod (1- n) (length footnote-english-lower))) @@ -202,27 +228,28 @@ Wrapping around the alphabet implies successive repetitions of letters." (50 . "l") (100 . "c") (500 . "d") (1000 . "m")) "List of roman numerals with their values.") -(defconst footnote-roman-lower-regexp "[ivxlcdm]+" +(defconst footnote-roman-lower-regexp + (concat "[" (mapconcat #'cdr footnote-roman-lower-list "") "]+") "Regexp of roman numerals.") -(defun Footnote-roman-lower (n) +(defun footnote--roman-lower (n) "Generic Roman number footnoting." - (Footnote-roman-common n footnote-roman-lower-list)) + (footnote--roman-common n footnote-roman-lower-list)) ;;; ROMAN UPPER (defconst footnote-roman-upper-list - '((1 . "I") (5 . "V") (10 . "X") - (50 . "L") (100 . "C") (500 . "D") (1000 . "M")) + (mapcar (lambda (x) (cons (car x) (upcase (cdr x)))) + footnote-roman-lower-list) "List of roman numerals with their values.") -(defconst footnote-roman-upper-regexp "[IVXLCDM]+" +(defconst footnote-roman-upper-regexp (upcase footnote-roman-lower-regexp) "Regexp of roman numerals. Not complete") -(defun Footnote-roman-upper (n) +(defun footnote--roman-upper (n) "Generic Roman number footnoting." - (Footnote-roman-common n footnote-roman-upper-list)) + (footnote--roman-common n footnote-roman-upper-list)) -(defun Footnote-roman-common (n footnote-roman-list) +(defun footnote--roman-common (n footnote-roman-list) "Lower case Roman footnoting." (let* ((our-list footnote-roman-list) (rom-lngth (length our-list)) @@ -257,22 +284,22 @@ Wrapping around the alphabet implies successive repetitions of letters." ;; (message "pairs are: rom-low: %S, rom-high: %S, rom-div: %S" ;; rom-low-pair rom-high-pair rom-div-pair) (cond - ((< n 0) (error "Footnote-roman-common called with n < 0")) + ((< n 0) (error "footnote--roman-common called with n < 0")) ((= n 0) "") ((= n (car rom-low-pair)) (cdr rom-low-pair)) ((= n (car rom-high-pair)) (cdr rom-high-pair)) ((= (car rom-low-pair) (car rom-high-pair)) (concat (cdr rom-low-pair) - (Footnote-roman-common + (footnote--roman-common (- n (car rom-low-pair)) footnote-roman-list))) ((>= rom-div 0) (concat (cdr rom-div-pair) (cdr rom-high-pair) - (Footnote-roman-common + (footnote--roman-common (- n (- (car rom-high-pair) (car rom-div-pair))) footnote-roman-list))) (t (concat (cdr rom-low-pair) - (Footnote-roman-common + (footnote--roman-common (- n (car rom-low-pair)) footnote-roman-list))))))) @@ -285,7 +312,7 @@ Wrapping around the alphabet implies successive repetitions of letters." (defconst footnote-latin-regexp (concat "[" footnote-latin-string "]") "Regexp for Latin-1 footnoting characters.") -(defun Footnote-latin (n) +(defun footnote--latin (n) "Latin-1 footnote style. Use a range of Latin-1 non-ASCII characters for footnoting." (string (aref footnote-latin-string @@ -299,7 +326,7 @@ Use a range of Latin-1 non-ASCII characters for footnoting." (defconst footnote-unicode-regexp (concat "[" footnote-unicode-string "]+") "Regexp for Unicode footnoting characters.") -(defun Footnote-unicode (n) +(defun footnote--unicode (n) "Unicode footnote style. Use Unicode characters for footnoting." (let (modulus result done) @@ -310,18 +337,72 @@ Use Unicode characters for footnoting." (push (aref footnote-unicode-string modulus) result)) (apply #'string result))) +;; Hebrew + +(defconst footnote-hebrew-numeric + '( + ("א" "ב" "ג" "ד" "ה" "ו" "ז" "ח" "ט") + ("י" "כ" "ל" "מ" "נ" "ס" "ע" "פ" "צ") + ("ק" "ר" "ש" "ת" "תק" "תר" "תש" "תת" "תתק"))) + +(defconst footnote-hebrew-numeric-regex + (let ((numchars (string-to-list + (apply #'concat (apply #'append footnote-hebrew-numeric))))) + (rx-to-string `(1+ (in ?' ,@numchars))))) +;; (defconst footnote-hebrew-numeric-regex "\\([אבגדהוזחט]'\\)?\\(ת\\)?\\(ת\\)?\\([קרשת]\\)?\\([טיכלמנסעפצ]\\)?\\([אבגדהוזחט]\\)?") + +(defun footnote--hebrew-numeric (n) + "Supports 9999 footnotes, then rolls over." + (let* ((n (+ (mod n 10000) (/ n 10000))) + (thousands (/ n 1000)) + (hundreds (/ (mod n 1000) 100)) + (tens (/ (mod n 100) 10)) + (units (mod n 10)) + (special (cond + ((not (= tens 1)) nil) + ((= units 5) "טו") + ((= units 6) "טז")))) + (concat + (when (/= 0 thousands) + (concat (nth (1- thousands) (nth 0 footnote-hebrew-numeric)) "'")) + (when (/= 0 hundreds) + (nth (1- hundreds) (nth 2 footnote-hebrew-numeric))) + (or special + (concat + (when (/= 0 tens) (nth (1- tens) (nth 1 footnote-hebrew-numeric))) + (when (/= 0 units) (nth (1- units) (nth 0 footnote-hebrew-numeric)))))))) + +(defconst footnote-hebrew-symbolic + '( + "א" "ב" "ג" "ד" "ה" "ו" "ז" "ח" "ט" "י" "כ" "ל" "מ" "נ" "ס" "ע" "פ" "צ" "ק" "ר" "ש" "ת")) + +(defconst footnote-hebrew-symbolic-regex + (concat "[" (apply #'concat footnote-hebrew-symbolic) "]")) + +(defun footnote--hebrew-symbolic (n) + "Only 22 elements, per the style of eg. 'פירוש שפתי חכמים על רש״י'. +Proceeds from `י' to `כ', from `צ' to `ק'. After `ת', rolls over to `א'." + (nth (mod (1- n) 22) footnote-hebrew-symbolic)) + ;;; list of all footnote styles (defvar footnote-style-alist - `((numeric Footnote-numeric ,footnote-numeric-regexp) - (english-lower Footnote-english-lower ,footnote-english-lower-regexp) - (english-upper Footnote-english-upper ,footnote-english-upper-regexp) - (roman-lower Footnote-roman-lower ,footnote-roman-lower-regexp) - (roman-upper Footnote-roman-upper ,footnote-roman-upper-regexp) - (latin Footnote-latin ,footnote-latin-regexp) - (unicode Footnote-unicode ,footnote-unicode-regexp)) + `((numeric footnote--numeric ,footnote-numeric-regexp) + (english-lower footnote--english-lower ,footnote-english-lower-regexp) + (english-upper footnote--english-upper ,footnote-english-upper-regexp) + (roman-lower footnote--roman-lower ,footnote-roman-lower-regexp) + (roman-upper footnote--roman-upper ,footnote-roman-upper-regexp) + (latin footnote--latin ,footnote-latin-regexp) + (unicode footnote--unicode ,footnote-unicode-regexp) + (hebrew-numeric footnote--hebrew-numeric ,footnote-hebrew-numeric-regex) + (hebrew-symbolic footnote--hebrew-symbolic ,footnote-hebrew-symbolic-regex)) "Styles of footnote tags available. -By default only boring Arabic numbers, English letters and Roman Numerals -are available.") +By default, Arabic numbers, English letters, Roman Numerals, +Latin and Unicode superscript characters, and Hebrew numerals +are available. +Each element of the list should be of the form (NAME FUNCTION REGEXP) +where NAME is a symbol, FUNCTION takes a footnote number and +returns the corresponding representation in that style as a string, +and REGEXP should be a regexp that matches any output of FUNCTION.") (defcustom footnote-style 'numeric "Default style used for footnoting. @@ -332,6 +413,8 @@ roman-lower == i, ii, iii, iv, v, ... roman-upper == I, II, III, IV, V, ... latin == ¹ ² ³ º ª § ¶ unicode == ¹, ², ³, ... +hebrew-numeric == א, ב, ..., יא, ..., תקא... +hebrew-symbolic == א, ב, ..., י, כ, ..., צ, ק, ..., ת, א See also variables `footnote-start-tag' and `footnote-end-tag'. Note: some characters in the unicode style may not show up @@ -339,373 +422,365 @@ properly if the default font does not contain those characters. Customizing this variable has no effect on buffers already displaying footnotes. To change the style of footnotes in such a -buffer use the command `Footnote-set-style'." +buffer use the command `footnote-set-style'." :type (cons 'choice (mapcar (lambda (x) (list 'const (car x))) - footnote-style-alist)) - :group 'footnote) + footnote-style-alist))) ;;; Style utilities & functions -(defun Footnote-style-p (style) - "Return non-nil if style is a valid style known to `footnote-mode'." - (assq style footnote-style-alist)) -(defun Footnote-index-to-string (index) +(defun footnote--index-to-string (index) "Convert a binary index into a string to display as a footnote. Conversion is done based upon the current selected style." - (let ((alist (if (Footnote-style-p footnote-style) - (assq footnote-style footnote-style-alist) - (nth 0 footnote-style-alist)))) + (let ((alist (or (assq footnote-style footnote-style-alist) + (nth 0 footnote-style-alist)))) (funcall (nth 1 alist) index))) -(defun Footnote-current-regexp () +(defun footnote--current-regexp (&optional index-regexp) "Return the regexp of the index of the current style." - (concat (nth 2 (or (assq footnote-style footnote-style-alist) - (nth 0 footnote-style-alist))) - "*")) - -(defun Footnote-refresh-footnotes (&optional index-regexp) + (let ((regexp (or index-regexp + (nth 2 (or (assq footnote-style footnote-style-alist) + (nth 0 footnote-style-alist)))))) + (concat + (regexp-quote footnote-start-tag) "\\(" + ;; Hack to avoid repetition of repetition. + ;; FIXME: I'm not sure the added * makes sense at all; there is + ;; always a single number within the footnote-{start,end}-tag pairs. + (if (string-match "[^\\]\\\\\\{2\\}*[*+?]\\'" regexp) + (substring regexp 0 -1) + regexp) + "*\\)" (regexp-quote footnote-end-tag)))) + +(defun footnote--refresh-footnotes (&optional index-regexp) "Redraw all footnotes. -You must call this or arrange to have this called after changing footnote -styles." - (unless index-regexp - (setq index-regexp (Footnote-current-regexp))) - (save-excursion - ;; Take care of the pointers first - (let ((i 0) locn alist) - (while (setq alist (nth i footnote-pointer-marker-alist)) - (setq locn (cdr alist)) - (while locn - (goto-char (car locn)) +You must call this or arrange to have this called after changing +footnote styles." + (let ((fn-regexp (footnote--current-regexp index-regexp))) + (save-excursion + (pcase-dolist (`(,fn ,text . ,pointers) footnote--markers-alist) + ;; Take care of the pointers first. + (dolist (locn pointers) + (goto-char locn) ;; Try to handle the case where `footnote-start-tag' and ;; `footnote-end-tag' are the same string. - (when (looking-back (concat - (regexp-quote footnote-start-tag) - "\\(" index-regexp "+\\)" - (regexp-quote footnote-end-tag)) - (line-beginning-position)) + (when (looking-at fn-regexp) (replace-match (propertize (concat footnote-start-tag - (Footnote-index-to-string (1+ i)) + (footnote--index-to-string fn) footnote-end-tag) - 'footnote-number (1+ i) footnote-mouse-highlight t) - nil "\\1")) - (setq locn (cdr locn))) - (setq i (1+ i)))) - - ;; Now take care of the text section - (let ((i 0) alist) - (while (setq alist (nth i footnote-text-marker-alist)) - (goto-char (cdr alist)) - (when (looking-at (concat - (regexp-quote footnote-start-tag) - "\\(" index-regexp "+\\)" - (regexp-quote footnote-end-tag))) + 'footnote-number fn footnote-mouse-highlight t) + t t))) + + ;; Now take care of the text section + (goto-char text) + (when (looking-at fn-regexp) (replace-match (propertize (concat footnote-start-tag - (Footnote-index-to-string (1+ i)) + (footnote--index-to-string fn) footnote-end-tag) - 'footnote-number (1+ i)) - nil "\\1")) - (setq i (1+ i)))))) - -(defun Footnote-assoc-index (key alist) - "Give index of key in alist." - (let ((i 0) (max (length alist)) rc) - (while (and (null rc) - (< i max)) - (when (eq key (car (nth i alist))) - (setq rc i)) - (setq i (1+ i))) - rc)) + 'footnote-number fn) + t t)))))) -(defun Footnote-cycle-style () +(defun footnote-cycle-style () "Select next defined footnote style." (interactive) - (let ((old (Footnote-assoc-index footnote-style footnote-style-alist)) - (max (length footnote-style-alist)) - idx) - (setq idx (1+ old)) - (when (>= idx max) - (setq idx 0)) - (setq footnote-style (car (nth idx footnote-style-alist))) - (Footnote-refresh-footnotes (nth 2 (nth old footnote-style-alist))))) - -(defun Footnote-set-style (&optional style) + (let ((old-desc (assq footnote-style footnote-style-alist))) + (setq footnote-style (caar (or (cdr (memq old-desc footnote-style-alist)) + footnote-style-alist))) + (footnote--refresh-footnotes (nth 2 old-desc)) + (message "Style set to %s" footnote-style))) + +(defun footnote-set-style (style) "Select a specific style." (interactive (list (intern (completing-read "Footnote Style: " - obarray #'Footnote-style-p 'require-match)))) - (let ((old (Footnote-assoc-index footnote-style footnote-style-alist))) + footnote-style-alist nil 'require-match)))) + (let ((old-desc (assq footnote-style footnote-style-alist))) (setq footnote-style style) - (Footnote-refresh-footnotes (nth 2 (nth old footnote-style-alist))))) + (footnote--refresh-footnotes (nth 2 old-desc)))) ;; Internal functions -(defun Footnote-insert-numbered-footnote (arg &optional mousable) - "Insert numbered footnote at (point)." +(defun footnote--insert-numbered-footnote (arg &optional mousable) + "Insert numbered footnote at point. +Return a marker pointing to the beginning of the [...]." (let ((string (concat footnote-start-tag - (Footnote-index-to-string arg) - footnote-end-tag))) - (insert-before-markers + (footnote--index-to-string arg) + footnote-end-tag)) + (pos (point))) + (insert (if mousable (propertize string 'footnote-number arg footnote-mouse-highlight t) - (propertize string 'footnote-number arg))))) + (propertize string 'footnote-number arg))) + (copy-marker pos t))) -(defun Footnote-renumber (from to pointer-alist text-alist) +(defun footnote--renumber (to alist-elem) "Renumber a single footnote." - (let* ((posn-list (cdr pointer-alist))) - (setcar pointer-alist to) - (setcar text-alist to) - (while posn-list - (goto-char (car posn-list)) - (when (looking-back (concat (regexp-quote footnote-start-tag) - (Footnote-current-regexp) - (regexp-quote footnote-end-tag)) - (line-beginning-position)) - (replace-match - (propertize + (unless (equal to (car alist-elem)) ;Nothing to do. + (let* ((fn-regexp (footnote--current-regexp))) + (setcar alist-elem to) + (dolist (posn (cddr alist-elem)) + (goto-char posn) + (when (looking-at fn-regexp) + (replace-match + (propertize + (concat footnote-start-tag + (footnote--index-to-string to) + footnote-end-tag) + 'footnote-number to footnote-mouse-highlight t)))) + (goto-char (cadr alist-elem)) + (when (looking-at fn-regexp) + (replace-match + (propertize (concat footnote-start-tag - (Footnote-index-to-string to) + (footnote--index-to-string to) footnote-end-tag) - 'footnote-number to footnote-mouse-highlight t))) - (setq posn-list (cdr posn-list))) - (goto-char (cdr text-alist)) - (when (looking-at (concat (regexp-quote footnote-start-tag) - (Footnote-current-regexp) - (regexp-quote footnote-end-tag))) - (replace-match - (propertize - (concat footnote-start-tag - (Footnote-index-to-string to) - footnote-end-tag) - 'footnote-number to))))) - -;; Not needed? -(defun Footnote-narrow-to-footnotes () + 'footnote-number to)))))) + +(defun footnote--narrow-to-footnotes () "Restrict text in buffer to show only text of footnotes." - (interactive) ; testing - (goto-char (point-max)) - (when (re-search-backward footnote-signature-separator nil t) - (let ((end (point))) - (cond - ((and (not (string-equal footnote-section-tag "")) - (re-search-backward - (concat "^" footnote-section-tag-regexp) nil t)) - (narrow-to-region (point) end)) - (footnote-text-marker-alist - (narrow-to-region (cdar footnote-text-marker-alist) end)))))) - -(defun Footnote-goto-char-point-max () + (interactive) ; testing + (narrow-to-region (footnote--get-area-point-min) + (footnote--get-area-point-max))) + +(defun footnote--goto-char-point-max () "Move to end of buffer or prior to start of .signature." (goto-char (point-max)) (or (re-search-backward footnote-signature-separator nil t) (point))) -(defun Footnote-insert-text-marker (arg locn) - "Insert a marker pointing to footnote ARG, at buffer location LOCN." - (let ((marker (make-marker))) - (unless (assq arg footnote-text-marker-alist) - (set-marker marker locn) - (setq footnote-text-marker-alist - (cons (cons arg marker) footnote-text-marker-alist)) - (setq footnote-text-marker-alist - (Footnote-sort footnote-text-marker-alist))))) - -(defun Footnote-insert-pointer-marker (arg locn) - "Insert a marker pointing to footnote ARG, at buffer location LOCN." - (let ((marker (make-marker)) - alist) - (set-marker marker locn) - (if (setq alist (assq arg footnote-pointer-marker-alist)) - (setf alist - (cons marker (cdr alist))) - (setq footnote-pointer-marker-alist - (cons (cons arg (list marker)) footnote-pointer-marker-alist)) - (setq footnote-pointer-marker-alist - (Footnote-sort footnote-pointer-marker-alist))))) - -(defun Footnote-insert-footnote (arg) +(defun footnote--insert-markers (arg text ptr) + "Insert the markers of new footnote ARG." + (cl-assert (and (numberp arg) (markerp text) (markerp ptr))) + (cl-assert (not (assq arg footnote--markers-alist))) + (push `(,arg ,text ,ptr) footnote--markers-alist) + (setq footnote--markers-alist + (footnote--sort footnote--markers-alist))) + +(defun footnote--goto-first () + "Go to beginning of footnote area and return non-nil if successful. +Presumes we're within the footnote area already." + (cond + ((not (string-equal footnote-section-tag "")) + (re-search-backward + (concat "^" footnote-section-tag-regexp) nil t)) + (footnote--markers-alist + (goto-char (cadr (car footnote--markers-alist)))))) + +(defun footnote--insert-footnote (arg) "Insert a footnote numbered ARG, at (point)." (push-mark) - (Footnote-insert-pointer-marker arg (point)) - (Footnote-insert-numbered-footnote arg t) - (Footnote-goto-char-point-max) - (if (cond - ((not (string-equal footnote-section-tag "")) - (re-search-backward (concat "^" footnote-section-tag-regexp) nil t)) - (footnote-text-marker-alist - (goto-char (cdar footnote-text-marker-alist)))) - (save-restriction - (when footnote-narrow-to-footnotes-when-editing - (Footnote-narrow-to-footnotes)) - (Footnote-goto-footnote (1- arg)) ; evil, FIXME (less evil now) - ;; (message "Inserting footnote %d" arg) - (unless - (or (eq arg 1) - (when (re-search-forward - (if footnote-spaced-footnotes - "\n\n" - (concat "\n" - (regexp-quote footnote-start-tag) - (Footnote-current-regexp) - (regexp-quote footnote-end-tag))) - nil t) - (unless (beginning-of-line) t)) - (Footnote-goto-char-point-max) - (cond - ((not (string-equal footnote-section-tag "")) - (re-search-backward - (concat "^" footnote-section-tag-regexp) nil t)) - (footnote-text-marker-alist - (goto-char (cdar footnote-text-marker-alist))))))) - (unless (looking-at "^$") - (insert "\n")) - (when (eobp) - (insert "\n")) - (unless (string-equal footnote-section-tag "") - (insert footnote-section-tag "\n"))) - (let ((old-point (point))) - (Footnote-insert-numbered-footnote arg nil) - (Footnote-insert-text-marker arg old-point))) - -(defun Footnote-sort (list) - (sort list (lambda (e1 e2) - (< (car e1) (car e2))))) - -(defun Footnote-text-under-cursor () - "Return the number of footnote if in footnote text. + (let ((ptr (footnote--insert-numbered-footnote arg t))) + (footnote--goto-char-point-max) + (if (footnote--goto-first) + (save-restriction + (when footnote-narrow-to-footnotes-when-editing + (footnote--narrow-to-footnotes)) + (footnote-goto-footnote (1- arg)) ; evil, FIXME (less evil now) + ;; (message "Inserting footnote %d" arg) + (or (eq arg 1) + (when (re-search-forward + (if footnote-spaced-footnotes + "\n\n" + (concat "\n" (footnote--current-regexp))) + nil t) + (beginning-of-line) + t) + (footnote--goto-char-point-max) + (footnote--goto-first))) + (unless (looking-at "^$") + (insert "\n")) + (when (eobp) + (insert "\n")) + (unless (string-equal footnote-section-tag "") + (insert footnote-section-tag "\n"))) + (let ((text (footnote--insert-numbered-footnote arg nil))) + (footnote--insert-markers arg text ptr)))) + +(defun footnote--sort (list) + (sort list #'car-less-than-car)) + +(defun footnote--text-under-cursor () + "Return the number of the current footnote if in footnote text. Return nil if the cursor is not positioned over the text of a footnote." - (when (and (let ((old-point (point))) - (save-excursion - (save-restriction - (Footnote-narrow-to-footnotes) - (and (>= old-point (point-min)) - (<= old-point (point-max)))))) - footnote-text-marker-alist - (>= (point) (cdar footnote-text-marker-alist))) - (let ((i 1) - alist-txt rc) - (while (and (setq alist-txt (nth i footnote-text-marker-alist)) - (null rc)) - (when (< (point) (cdr alist-txt)) - (setq rc (car (nth (1- i) footnote-text-marker-alist)))) - (setq i (1+ i))) - (when (and (null rc) - (null alist-txt)) - (setq rc (car (nth (1- i) footnote-text-marker-alist)))) - rc))) - -(defun Footnote-under-cursor () + (when (<= (point) (footnote--get-area-point-max)) + (let ((result nil)) + (pcase-dolist (`(,fn ,text . ,_) footnote--markers-alist) + (if (<= text (point)) + (setq result fn))) + result))) + +(defun footnote--under-cursor () "Return the number of the footnote underneath the cursor. Return nil if the cursor is not over a footnote." (or (get-text-property (point) 'footnote-number) - (Footnote-text-under-cursor))) + (footnote--text-under-cursor))) + +(defun footnote--calc-fn-alignment-column () + "Calculate the left alignment for footnote text." + ;; FIXME: Maybe it would be better to go to the footnote's beginning and + ;; see at which column it starts. + (+ footnote-body-tag-spacing + (string-width + (concat footnote-start-tag footnote-end-tag + (footnote--index-to-string + (caar (last footnote--markers-alist))))))) + +(defun footnote--fill-prefix-string () + "Return the fill prefix to be used by footnote mode." + ;; TODO: Prefix to this value other prefix strings, such as those + ;; designating a comment line, a message response, or a boxquote. + (make-string (footnote--calc-fn-alignment-column) ?\s)) + +(defun footnote--point-in-body-p () + "Return non-nil if point is in the buffer text area, +i.e. before the beginning of the footnote area." + (< (point) (footnote--get-area-point-min))) + +(defun footnote--get-area-point-min (&optional before-tag) + "Return start of the first footnote. +If there is no footnote area, returns `point-max'. +With optional arg BEFORE-TAG, return position of the `footnote-section-tag' +instead, if applicable." + (cond + ;; FIXME: Shouldn't we use `footnote--get-area-point-max' instead? + ((not footnote--markers-alist) (point-max)) + ((not before-tag) (cadr (car footnote--markers-alist))) + ((string-equal footnote-section-tag "") (cadr (car footnote--markers-alist))) + (t + (save-excursion + (goto-char (cadr (car footnote--markers-alist))) + (if (re-search-backward (concat "^" footnote-section-tag-regexp) nil t) + (point) + (message "Footnote section tag not found!") + ;; This `else' should never happen, and indicates an error, + ;; ie. footnotes already exist and a footnote-section-tag is defined, + ;; but the section tag hasn't been found. We choose to assume that the + ;; user deleted it intentionally and wants us to behave in this buffer + ;; as if the section tag was set "", so we do that, now. + ;;(setq footnote-section-tag "") + ;; + ;; HOWEVER: The rest of footnote mode does not currently honor or + ;; account for this. + ;; + ;; To illustrate the difference in behavior, create a few footnotes, + ;; delete the section tag, and create another footnote. Then undo, + ;; comment the above line (that sets the tag to ""), re-evaluate this + ;; function, and repeat. + ;; + ;; TODO: integrate sanity checks at reasonable operational points. + (point)))))) + +(defun footnote--get-area-point-max () + "Return the end of footnote area. +This is either `point-max' or the start of a `.signature' string, as +defined by variable `footnote-signature-separator'. If there is no +footnote area, returns `point-max'." + (save-excursion (footnote--goto-char-point-max))) + +(defun footnote--adaptive-fill-function (orig-fun) + (or + (and + footnote-mode + footnote-align-to-fn-text + (footnote--text-under-cursor) + ;; (not (footnote--point-in-body-p)) + ;; (< (point) (footnote--signature-area-start-point)) + (footnote--fill-prefix-string)) + ;; If not within a footnote's text, fallback to the default. + (funcall orig-fun))) + +(defun footnote--fill-paragraph (orig-fun justify) + (if (not (footnote--text-under-cursor)) + (funcall orig-fun justify) + (let ((fill-paragraph-function nil) + (fill-prefix (if footnote-align-to-fn-text + (footnote--fill-prefix-string) + "")) + (paragraph-start "\\[")) + (fill-paragraph justify)))) ;;; User functions -(defun Footnote-make-hole () +(defun footnote--make-hole () + "Make room in the alist for a new footnote at point. +Return the footnote number to use." (save-excursion - (let ((i 0) - (notes (length footnote-pointer-marker-alist)) - alist-ptr alist-txt rc) - (while (< i notes) - (setq alist-ptr (nth i footnote-pointer-marker-alist)) - (setq alist-txt (nth i footnote-text-marker-alist)) - (when (< (point) (- (cadr alist-ptr) 3)) + (let (rc) + (dolist (alist-elem footnote--markers-alist) + (when (<= (point) (cl-caddr alist-elem)) (unless rc - (setq rc (car alist-ptr))) + (setq rc (car alist-elem))) (save-excursion (message "Renumbering from %s to %s" - (Footnote-index-to-string (car alist-ptr)) - (Footnote-index-to-string - (1+ (car alist-ptr)))) - (Footnote-renumber (car alist-ptr) - (1+ (car alist-ptr)) - alist-ptr - alist-txt))) - (setq i (1+ i))) - rc))) - -(defun Footnote-add-footnote (&optional arg) + (footnote--index-to-string (car alist-elem)) + (footnote--index-to-string + (1+ (car alist-elem)))) + (footnote--renumber (1+ (car alist-elem)) + alist-elem)))) + (or rc + (1+ (or (caar (last footnote--markers-alist)) 0)))))) + +(defun footnote-add-footnote () "Add a numbered footnote. The number the footnote receives is dependent upon the relative location of any other previously existing footnotes. If the variable `footnote-narrow-to-footnotes-when-editing' is set, the buffer is narrowed to the footnote body. The restriction is removed -by using `Footnote-back-to-message'." - (interactive "*P") - (let ((num - (if footnote-text-marker-alist - (if (< (point) (cl-cadar (last footnote-pointer-marker-alist))) - (Footnote-make-hole) - (1+ (caar (last footnote-text-marker-alist)))) - 1))) +by using `footnote-back-to-message'." + (interactive "*") + (let ((num (footnote--make-hole))) (message "Adding footnote %d" num) - (Footnote-insert-footnote num) - (insert-before-markers (make-string footnote-body-tag-spacing ? )) - (let ((opoint (point))) - (save-excursion - (insert-before-markers - (if footnote-spaced-footnotes - "\n\n" - "\n")) - (when footnote-narrow-to-footnotes-when-editing - (Footnote-narrow-to-footnotes))) - ;; Emacs/XEmacs bug? save-excursion doesn't restore point when using - ;; insert-before-markers. - (goto-char opoint)))) - -(defun Footnote-delete-footnote (&optional arg) + (footnote--insert-footnote num) + (insert (make-string footnote-body-tag-spacing ? )) + (save-excursion + (insert + (if footnote-spaced-footnotes + "\n\n" + "\n")) + (when footnote-narrow-to-footnotes-when-editing + (footnote--narrow-to-footnotes))))) + +(defun footnote-delete-footnote (&optional arg) "Delete a numbered footnote. With no parameter, delete the footnote under (point). With ARG specified, delete the footnote with that number." (interactive "*P") (unless arg - (setq arg (Footnote-under-cursor))) + (setq arg (footnote--under-cursor))) (when (and arg (or (not footnote-prompt-before-deletion) (y-or-n-p (format "Really delete footnote %d?" arg)))) - (let (alist-ptr alist-txt locn) - (setq alist-ptr (assq arg footnote-pointer-marker-alist)) - (setq alist-txt (assq arg footnote-text-marker-alist)) - (unless (and alist-ptr alist-txt) - (error "Can't delete footnote %d" arg)) - (setq locn (cdr alist-ptr)) - (while (car locn) + (let ((alist-elem (or (assq arg footnote--markers-alist) + (error "Can't delete footnote %d" arg))) + (fn-regexp (footnote--current-regexp))) + (dolist (locn (cddr alist-elem)) (save-excursion - (goto-char (car locn)) - (when (looking-back (concat (regexp-quote footnote-start-tag) - (Footnote-current-regexp) - (regexp-quote footnote-end-tag)) - (line-beginning-position)) - (delete-region (match-beginning 0) (match-end 0)))) - (setq locn (cdr locn))) + (goto-char locn) + (when (looking-at fn-regexp) + (delete-region (match-beginning 0) (match-end 0))))) (save-excursion - (goto-char (cdr alist-txt)) + (goto-char (cadr alist-elem)) (delete-region (point) (if footnote-spaced-footnotes (search-forward "\n\n" nil t) - (save-restriction + (save-restriction ; <= 2017-12 Boruch: WHY?? I see no narrowing / widening here. (end-of-line) (next-single-char-property-change - (point) 'footnote-number nil (Footnote-goto-char-point-max)))))) - (setq footnote-pointer-marker-alist - (delq alist-ptr footnote-pointer-marker-alist)) - (setq footnote-text-marker-alist - (delq alist-txt footnote-text-marker-alist)) - (Footnote-renumber-footnotes) - (when (and (null footnote-text-marker-alist) - (null footnote-pointer-marker-alist)) + (point) 'footnote-number nil (footnote--goto-char-point-max)))))) + (setq footnote--markers-alist + (delq alist-elem footnote--markers-alist)) + (if footnote--markers-alist + (footnote-renumber-footnotes) (save-excursion (if (not (string-equal footnote-section-tag "")) - (let* ((end (Footnote-goto-char-point-max)) + (let* ((end (footnote--goto-char-point-max)) (start (1- (re-search-backward (concat "^" footnote-section-tag-regexp) nil t)))) @@ -715,67 +790,64 @@ delete the footnote with that number." (delete-region start (if (< end (point-max)) end (point-max)))) - (Footnote-goto-char-point-max) + (footnote--goto-char-point-max) (when (looking-back "\n\n" (- (point) 2)) (kill-line -1)))))))) -(defun Footnote-renumber-footnotes (&optional arg) +(defun footnote-renumber-footnotes () "Renumber footnotes, starting from 1." - (interactive "*P") + (interactive "*") (save-excursion - (let ((i 0) - (notes (length footnote-pointer-marker-alist)) - alist-ptr alist-txt) - (while (< i notes) - (setq alist-ptr (nth i footnote-pointer-marker-alist)) - (setq alist-txt (nth i footnote-text-marker-alist)) - (unless (= (1+ i) (car alist-ptr)) - (Footnote-renumber (car alist-ptr) (1+ i) alist-ptr alist-txt)) + (let ((i 1)) + (dolist (alist-elem footnote--markers-alist) + (footnote--renumber i alist-elem) (setq i (1+ i)))))) -(defun Footnote-goto-footnote (&optional arg) +(defun footnote-goto-footnote (&optional arg) "Jump to the text of a footnote. With no parameter, jump to the text of the footnote under (point). With ARG specified, jump to the text of that footnote." (interactive "P") (unless arg - (setq arg (Footnote-under-cursor))) - (let ((footnote (assq arg footnote-text-marker-alist))) + (setq arg (footnote--under-cursor))) + (let ((footnote (assq arg footnote--markers-alist))) (cond (footnote - (goto-char (cdr footnote))) + (goto-char (cadr footnote))) ((eq arg 0) (goto-char (point-max)) (cond ((not (string-equal footnote-section-tag "")) (re-search-backward (concat "^" footnote-section-tag-regexp)) (forward-line 1)) - (footnote-text-marker-alist - (goto-char (cdar footnote-text-marker-alist))))) + (footnote--markers-alist + (goto-char (cadr (car footnote--markers-alist)))))) (t (error "I don't see a footnote here"))))) -(defun Footnote-back-to-message (&optional arg) +(defun footnote-back-to-message () "Move cursor back to footnote referent. If the cursor is not over the text of a footnote, point is not changed. If the buffer was narrowed due to `footnote-narrow-to-footnotes-when-editing' being set it is automatically widened." - (interactive "P") - (let ((note (Footnote-text-under-cursor))) + (interactive) + (let ((note (footnote--text-under-cursor))) (when note (when footnote-narrow-to-footnotes-when-editing (widen)) - (goto-char (cadr (assq note footnote-pointer-marker-alist)))))) + (goto-char (cl-caddr (assq note footnote--markers-alist))) + (when (looking-at (footnote--current-regexp)) + (goto-char (match-end 0)))))) (defvar footnote-mode-map (let ((map (make-sparse-keymap))) - (define-key map "a" 'Footnote-add-footnote) - (define-key map "b" 'Footnote-back-to-message) - (define-key map "c" 'Footnote-cycle-style) - (define-key map "d" 'Footnote-delete-footnote) - (define-key map "g" 'Footnote-goto-footnote) - (define-key map "r" 'Footnote-renumber-footnotes) - (define-key map "s" 'Footnote-set-style) + (define-key map "a" #'footnote-add-footnote) + (define-key map "b" #'footnote-back-to-message) + (define-key map "c" #'footnote-cycle-style) + (define-key map "d" #'footnote-delete-footnote) + (define-key map "g" #'footnote-goto-footnote) + (define-key map "r" #'footnote-renumber-footnotes) + (define-key map "s" #'footnote-set-style) map)) (defvar footnote-minor-mode-map @@ -784,12 +856,26 @@ being set it is automatically widened." map) "Keymap used for binding footnote minor mode.") +(defmacro footnote--local-advice (mode variable function) + "Add advice to a variable holding buffer-local functions. +Typical use would be to advice variables like +`fill-paragraph-function' from minor modes. + +MODE is the minor mode symbol, VARIABLE is the variable to get +advice, and FUNCTION is what'll be added as an :around advice." + `(progn + (unless ,variable + ;; nil and `ignore' have the same semantics for adaptive-fill-function, + ;; but only `ignore' behaves correctly with add/remove-function. + (setq-local ,variable #'ignore)) + (remove-function (local ',variable) #',function) + (when ,mode + (add-function :around (local ',variable) + #',function)))) + ;;;###autoload (define-minor-mode footnote-mode "Toggle Footnote mode. -With a prefix argument ARG, enable Footnote mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Footnote mode is a buffer-local minor mode. If enabled, it provides footnote support for `message-mode'. To get started, @@ -797,9 +883,12 @@ play around with the following keys: \\{footnote-minor-mode-map}" :lighter footnote-mode-line-string :keymap footnote-minor-mode-map - ;; (filladapt-mode t) + (footnote--local-advice footnote-mode adaptive-fill-function + footnote--adaptive-fill-function) + (footnote--local-advice footnote-mode fill-paragraph-function + footnote--fill-paragraph) (when footnote-mode - ;; (Footnote-setup-keybindings) + ;; (footnote-setup-keybindings) (make-local-variable 'footnote-style) (make-local-variable 'footnote-body-tag-spacing) (make-local-variable 'footnote-spaced-footnotes) @@ -807,7 +896,9 @@ play around with the following keys: (make-local-variable 'footnote-section-tag-regexp) (make-local-variable 'footnote-start-tag) (make-local-variable 'footnote-end-tag) + (make-local-variable 'adaptive-fill-function) + ;; Filladapt was an XEmacs package which is now in GNU ELPA. (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/hashcash.el b/lisp/mail/hashcash.el index 9fdc7ea756c..60689529974 100644 --- a/lisp/mail/hashcash.el +++ b/lisp/mail/hashcash.el @@ -1,4 +1,4 @@ -;;; hashcash.el --- Add hashcash payments to email +;;; hashcash.el --- Add hashcash payments to email -*- lexical-binding:t -*- ;; Copyright (C) 2003-2005, 2007-2019 Free Software Foundation, Inc. @@ -47,7 +47,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) ; for case +(eval-when-compile (require 'cl-lib)) (defgroup hashcash nil "Hashcash configuration." @@ -133,18 +133,18 @@ For example, you may want to set this to (\"-Z2\") to reduce header length." (declare-function message-narrow-to-headers-or-head "message" ()) (declare-function message-fetch-field "message" (header &optional not-all)) -(declare-function message-goto-eoh "message" ()) +(declare-function message-goto-eoh "message" (&optional interactive)) (declare-function message-narrow-to-headers "message" ()) (defun hashcash-token-substring () (save-excursion (let ((token "")) - (loop + (cl-loop (setq token (concat token (buffer-substring (point) (hashcash-point-at-eol)))) (goto-char (hashcash-point-at-eol)) (forward-char 1) - (unless (looking-at "[ \t]") (return token)) + (unless (looking-at "[ \t]") (cl-return token)) (while (looking-at "[ \t]") (forward-char 1)))))) (defun hashcash-payment-required (addr) @@ -182,8 +182,7 @@ Return immediately. Call CALLBACK with process and result when ready." (setq hashcash-process-alist (cons (cons process (current-buffer)) hashcash-process-alist)) - (set-process-filter process `(lambda (process output) - (funcall ,callback process output)))) + (set-process-filter process callback)) (funcall callback nil nil))) (defun hashcash-check-payment (token str val) @@ -244,8 +243,9 @@ Only start calculation. Results are inserted when ready." (hashcash-generate-payment-async (hashcash-payment-to arg) (hashcash-payment-required arg) - `(lambda (process payment) - (hashcash-insert-payment-async-2 ,(current-buffer) process payment))))) + (let ((buf (current-buffer))) + (lambda (process payment) + (hashcash-insert-payment-async-2 buf process payment)))))) (defun hashcash-insert-payment-async-2 (buffer process pay) (when (buffer-live-p buffer) @@ -298,7 +298,7 @@ BUFFER defaults to the current buffer." (let* ((split (split-string token ":")) (key (if (< (hashcash-version token) 1.2) (nth 1 split) - (case (string-to-number (nth 0 split)) + (pcase (string-to-number (nth 0 split)) (0 (nth 2 split)) (1 (nth 3 split)))))) (cond ((null resource) diff --git a/lisp/mail/ietf-drums.el b/lisp/mail/ietf-drums.el index bc0fc2b74e6..29752cb5c28 100644 --- a/lisp/mail/ietf-drums.el +++ b/lisp/mail/ietf-drums.el @@ -1,4 +1,4 @@ -;;; ietf-drums.el --- Functions for parsing RFC 2822 headers +;;; ietf-drums.el --- Functions for parsing RFC 2822 headers -*- lexical-binding:t -*- ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. @@ -37,7 +37,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defvar ietf-drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177" "US-ASCII control characters excluding CR, LF and white space.") @@ -78,10 +78,10 @@ backslash and doublequote.") (defun ietf-drums-token-to-list (token) "Translate TOKEN into a list of characters." (let ((i 0) - b e c out range) + b c out range) (while (< i (length token)) (setq c (aref token i)) - (incf i) + (cl-incf i) (cond ((eq c ?-) (if b @@ -90,7 +90,7 @@ backslash and doublequote.") (range (while (<= b c) (push (make-char 'ascii b) out) - (incf b)) + (cl-incf b)) (setq range nil)) ((= i (length token)) (push (make-char 'ascii c) out)) @@ -115,7 +115,7 @@ backslash and doublequote.") (setq c (char-after)) (cond ((eq c ?\") - (condition-case err + (condition-case nil (forward-sexp 1) (error (goto-char (point-max))))) ((eq c ?\() @@ -185,8 +185,12 @@ STRING is assumed to be a string that is extracted from the Content-Transfer-Encoding header of a mail." (ietf-drums-remove-garbage (inline (ietf-drums-strip string)))) -(defun ietf-drums-parse-address (string) - "Parse STRING and return a MAILBOX / DISPLAY-NAME pair." +(declare-function rfc2047-decode-string "rfc2047" (string &optional address-mime)) + +(defun ietf-drums-parse-address (string &optional decode) + "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." (with-temp-buffer (let (display-name mailbox c display-string) (ietf-drums-init string) @@ -236,7 +240,9 @@ the Content-Transfer-Encoding header of a mail." (cons (mapconcat 'identity (nreverse display-name) "") (ietf-drums-get-comment string))) - (cons mailbox display-string))))) + (cons mailbox (if decode + (rfc2047-decode-string display-string) + display-string)))))) (defun ietf-drums-parse-addresses (string &optional rawp) "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs. @@ -288,7 +294,7 @@ a list of address strings." (defun ietf-drums-parse-date (string) "Return an Emacs time spec from STRING." - (apply 'encode-time (parse-time-string string))) + (encode-time (parse-time-string string))) (defun ietf-drums-narrow-to-header () "Narrow to the header section in the current buffer." diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el index 9fcc2707d75..c1e90c3dcb8 100644 --- a/lisp/mail/mail-extr.el +++ b/lisp/mail/mail-extr.el @@ -293,7 +293,7 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." ;; multipart names. ;; #### should . be in here? (defconst mail-extr-all-letters - (purecopy (concat mail-extr-all-letters-but-separators "---"))) + (purecopy (concat mail-extr-all-letters-but-separators "-"))) ;; Any character that can start a name. ;; Keep this set as minimal as possible. @@ -305,19 +305,11 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." (defconst mail-extr-leading-garbage "\\W+") -;; (defconst mail-extr-non-name-chars -;; (purecopy (concat "^" mail-extr-all-letters "."))) ;; (defconst mail-extr-non-begin-name-chars ;; (purecopy (concat "^" mail-extr-first-letters))) ;; (defconst mail-extr-non-end-name-chars ;; (purecopy (concat "^" mail-extr-last-letters))) -;; Matches an initial not followed by both a period and a space. -;; (defconst mail-extr-bad-initials-pattern -;; (purecopy -;; (format "\\(\\([^%s]\\|\\`\\)[%s]\\)\\(\\.\\([^ ]\\)\\| \\|\\([^%s .]\\)\\|\\'\\)" -;; mail-extr-all-letters mail-extr-first-letters mail-extr-all-letters))) - ;; Matches periods used instead of spaces. Must not match the period ;; following an initial. (defconst mail-extr-bad-dot-pattern @@ -391,7 +383,7 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." ;; Matches telephone extensions. (defconst mail-extr-telephone-extension-pattern (purecopy - "\\(\\([Ee]xt\\|\\|[Tt]ph\\|[Tt]el\\|[Xx]\\).?\\)? *\\+?[0-9][- 0-9]+")) + "\\(\\([Ee]xt\\|[Tt]ph\\|[Tt]el\\|[Xx]\\)\\.?\\)? *\\+?[0-9][- 0-9]+")) ;; Matches ham radio call signs. ;; Help from: Mat Maessen N2NJZ <maessm@rpi.edu>, Mark Feit @@ -654,7 +646,7 @@ Unless NO-REPLACE is true, at each of the positions in LIST-SYMBOL (< ch ,beg-symbol)) ,@(if no-replace nil - `((mail-extr-nuke-char-at ch))) + '((mail-extr-nuke-char-at ch))) (setcar temp nil)) (setq temp (cdr temp))) (setq ,list-symbol (delq nil ,list-symbol)))) @@ -715,7 +707,13 @@ one recipients, all but the first is ignored. ADDRESS may be a string or a buffer. If it is a buffer, the visible \(narrowed) portion of the buffer will be interpreted as the address. \(This feature exists so that the clever caller might be able to avoid -consing a string.)" +consing a string.) + +This function is primarily meant for when you're displaying the +result to the user: Many prettifications are applied to the +result returned. If you want to decode an address for further +non-display use, you should probably use +`mail-header-parse-address' instead." (let ((canonicalization-buffer (get-buffer-create " *canonical address*")) (extraction-buffer (get-buffer-create " *extract address components*")) value-list) diff --git a/lisp/mail/mail-utils.el b/lisp/mail/mail-utils.el index 0d489499f59..fd00dd19bc2 100644 --- a/lisp/mail/mail-utils.el +++ b/lisp/mail/mail-utils.el @@ -41,7 +41,7 @@ often correct parser." If this is nil, it is set the first time you compose a reply, to a value which excludes your own email address. -Matching addresses are excluded from the CC field in replies, and +Matching addresses are excluded from the Cc field in replies, and also the To field, unless this would leave an empty To field." :type '(choice regexp (const :tag "Your Name" nil)) :group 'mail) @@ -284,11 +284,13 @@ comma-separated list, and return the pruned list." ;;;###autoload -(defun mail-fetch-field (field-name &optional last all list) +(defun mail-fetch-field (field-name &optional last all list delete) "Return the value of the header field whose type is FIELD-NAME. If second arg LAST is non-nil, use the last field of type FIELD-NAME. If third arg ALL is non-nil, concatenate all such fields with commas between. If 4th arg LIST is non-nil, return a list of all such fields. +If 5th arg DELETE is non-nil, delete all header lines that are +included in the result. The buffer should be narrowed to just the header, else false matches may be returned from the message body." (save-excursion @@ -311,7 +313,9 @@ matches may be returned from the message body." (setq value (concat value (if (string= value "") "" ", ") (buffer-substring-no-properties - opoint (point))))))) + opoint (point))))) + (if delete + (delete-region (point-at-bol) (point))))) (if list value (and (not (string= value "")) value))) @@ -324,7 +328,10 @@ matches may be returned from the message body." ;; Back up over newline, then trailing spaces or tabs (forward-char -1) (skip-chars-backward " \t" opoint) - (buffer-substring-no-properties opoint (point))))))))) + (prog1 + (buffer-substring-no-properties opoint (point)) + (if delete + (delete-region (point-at-bol) (1+ (point)))))))))))) ;; Parse a list of tokens separated by commas. ;; It runs from point to the end of the visible part of the buffer. diff --git a/lisp/mail/mailabbrev.el b/lisp/mail/mailabbrev.el index ee48b2cd021..d59df88c688 100644 --- a/lisp/mail/mailabbrev.el +++ b/lisp/mail/mailabbrev.el @@ -25,7 +25,7 @@ ;;; Commentary: -;; This file ensures that, when the point is in a To:, CC:, BCC:, or From: +;; This file ensures that, when the point is in a To:, Cc:, Bcc:, or From: ;; field, word-abbrevs are defined for each of your mail aliases. These ;; aliases will be defined from your .mailrc file (or the file specified by ;; `mail-personal-alias-file') if it exists. Your mail aliases will @@ -134,9 +134,6 @@ ;;;###autoload (define-minor-mode mail-abbrevs-mode "Toggle abbrev expansion of mail aliases (Mail Abbrevs mode). -With a prefix argument ARG, enable Mail Abbrevs mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Mail Abbrevs mode is a global minor mode. When enabled, abbrev-like expansion is performed when editing certain mail @@ -166,7 +163,8 @@ no aliases, which is represented by this being a table with no entries.)") (defun mail-abbrevs-sync-aliases () (when mail-personal-alias-file (if (file-exists-p mail-personal-alias-file) - (let ((modtime (nth 5 (file-attributes mail-personal-alias-file)))) + (let ((modtime (file-attribute-modification-time + (file-attributes mail-personal-alias-file)))) (if (not (equal mail-abbrev-modtime modtime)) (progn (setq mail-abbrev-modtime modtime) @@ -179,7 +177,8 @@ no aliases, which is represented by this being a table with no entries.)") (file-exists-p mail-personal-alias-file)) (progn (setq mail-abbrev-modtime - (nth 5 (file-attributes mail-personal-alias-file))) + (file-attribute-modification-time + (file-attributes mail-personal-alias-file))) (build-mail-abbrevs))) (mail-abbrevs-sync-aliases) (add-function :around (local 'abbrev-expand-function) @@ -414,7 +413,7 @@ with a space." ;;; Syntax tables and abbrev-expansion (defcustom mail-abbrev-mode-regexp - "^\\(Resent-\\)?\\(To\\|From\\|CC\\|BCC\\|Reply-to\\):" + "^\\(Resent-\\)?\\(To\\|From\\|Cc\\|Bcc\\|Reply-To\\):" "Regexp matching mail headers in which mail abbrevs should be expanded. This string will be handed to `looking-at' with point at the beginning of the current line; if it matches, abbrev mode will be turned on, otherwise @@ -477,7 +476,7 @@ of a mail alias. The value is set up, buffer-local, when first needed.") ;; Necessary for `message-read-from-minibuffer' to work. (window-minibuffer-p)) - ;; We are in a To: (or CC:, or whatever) header or a minibuffer, + ;; We are in a To: (or Cc:, or whatever) header or a minibuffer, ;; and should use word-abbrevs to expand mail aliases. (let ((local-abbrev-table mail-abbrevs)) diff --git a/lisp/mail/mailalias.el b/lisp/mail/mailalias.el index 981f1450da7..8bb42634892 100644 --- a/lisp/mail/mailalias.el +++ b/lisp/mail/mailalias.el @@ -50,14 +50,18 @@ When t this still needs to be initialized.") (defvar mail-address-field-regexp - "^\\(Resent-\\)?\\(To\\|From\\|CC\\|BCC\\|Reply-to\\):") + "^\\(Resent-\\)?\\(To\\|From\\|Cc\\|Bcc\\|Reply-To\\):") -(defvar pattern) +;; `pattern' is bound dynamically before evaluating the forms in +;; `mail-complete-alist' and may be part of user customizations of +;; that variable. +(with-suppressed-warnings ((lexical pattern)) + (defvar pattern)) (defcustom mail-complete-alist ;; Don't refer to mail-address-field-regexp here; ;; that confuses some things such as cus-dep.el. - '(("^\\(Resent-\\)?\\(To\\|From\\|CC\\|BCC\\|Reply-to\\):" + '(("^\\(Resent-\\)?\\(To\\|From\\|Cc\\|Bcc\\|Reply-To\\):" . (mail-get-names pattern)) ("Newsgroups:" . (if (boundp 'gnus-active-hashtb) gnus-active-hashtb @@ -169,7 +173,7 @@ When t this still needs to be initialized.") (defun expand-mail-aliases (beg end &optional exclude) "Expand all mail aliases in suitable header fields found between BEG and END. If interactive, expand in header fields. -Suitable header fields are `To', `From', `CC' and `BCC', `Reply-to', and +Suitable header fields are `To', `From', `Cc' and `Bcc', `Reply-To', and their `Resent-' variants. Optional second arg EXCLUDE may be a regular expression defining text to be diff --git a/lisp/mail/mailheader.el b/lisp/mail/mailheader.el index 936f53e96a5..8aec1940a7e 100644 --- a/lisp/mail/mailheader.el +++ b/lisp/mail/mailheader.el @@ -99,7 +99,8 @@ value." headers) ;; Advertised part of the interface; see mail-header, mail-header-set. -(defvar headers) +(with-suppressed-warnings ((lexical headers)) + (defvar headers)) (defsubst mail-header (header &optional header-alist) "Return the value associated with header HEADER in HEADER-ALIST. diff --git a/lisp/mail/mspools.el b/lisp/mail/mspools.el index 9aaf86d401c..b1cbd9e5497 100644 --- a/lisp/mail/mspools.el +++ b/lisp/mail/mspools.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1997, 2001-2019 Free Software Foundation, Inc. ;; Author: Stephen Eglen <stephen@gnu.org> -;; Maintainer: Stephen Eglen <stephen@gnu.org> ;; Created: 22 Jan 1997 ;; Keywords: mail ;; location: http://www.anc.ed.ac.uk/~stephen/emacs/ @@ -387,7 +386,7 @@ nil." (let ((file (concat mspools-folder-directory spool)) size) (setq file (or (file-symlink-p file) file)) - (setq size (nth 7 (file-attributes file))) + (setq size (file-attribute-size (file-attributes file))) ;; size could be nil if the sym-link points to a non-existent file ;; so check this first. (if (and size (> size 0)) diff --git a/lisp/mail/qp.el b/lisp/mail/qp.el index 5b497411886..803d78602e5 100644 --- a/lisp/mail/qp.el +++ b/lisp/mail/qp.el @@ -115,8 +115,7 @@ encode lines starting with \"From\"." (setq class "\010-\012\014\040-\074\076-\177")) (save-excursion (goto-char from) - (if (re-search-forward (string-to-multibyte "[^\x0-\x7f\x80-\xff]") - to t) + (if (re-search-forward "[^\x0-\x7f\x80-\xff]" to t) (error "Multibyte character in QP encoding region")) (save-restriction (narrow-to-region from to) diff --git a/lisp/mail/rfc2047.el b/lisp/mail/rfc2047.el index a1c65cbe930..a02201ec323 100644 --- a/lisp/mail/rfc2047.el +++ b/lisp/mail/rfc2047.el @@ -290,11 +290,10 @@ Should be called narrowed to the head of the message." (let ((rfc2047-encoding-type 'mime)) (rfc2047-encode-region (point) (point-max)))) ((eq method 'default) - (if (and (default-value 'enable-multibyte-characters) - mail-parse-charset) + (if mail-parse-charset (encode-coding-region (point) (point-max) mail-parse-charset))) - ;; We get this when CC'ing messages to newsgroups with + ;; We get this when Cc'ing messages to newsgroups with ;; 8-bit names. The group name mail copy just got ;; unconditionally encoded. Previously, it would ask ;; whether to encode, which was quite confusing for the @@ -305,18 +304,17 @@ Should be called narrowed to the head of the message." ;; in accordance with changes elsewhere. ((null method) (rfc2047-encode-region (point) (point-max))) -;;; ((null method) -;;; (if (or (message-options-get -;;; 'rfc2047-encode-message-header-encode-any) -;;; (message-options-set -;;; 'rfc2047-encode-message-header-encode-any -;;; (y-or-n-p -;;; "Some texts are not encoded. Encode anyway?"))) -;;; (rfc2047-encode-region (point-min) (point-max)) -;;; (error "Cannot send unencoded text"))) + ;; ((null method) + ;; (if (or (message-options-get + ;; 'rfc2047-encode-message-header-encode-any) + ;; (message-options-set + ;; 'rfc2047-encode-message-header-encode-any + ;; (y-or-n-p + ;; "Some texts are not encoded. Encode anyway?"))) + ;; (rfc2047-encode-region (point-min) (point-max)) + ;; (error "Cannot send unencoded text"))) ((mm-coding-system-p method) - (when (default-value 'enable-multibyte-characters) - (encode-coding-region (point) (point-max) method))) + (encode-coding-region (point) (point-max) method)) ;; Hm. (t))) (goto-char (point-max)))))))) @@ -734,28 +732,31 @@ Point moves to the end of the region." (save-restriction (narrow-to-region b e) (goto-char (point-min)) - (let ((break nil) - (qword-break nil) - (first t) - (bol (save-restriction - (widen) - (point-at-bol)))) + (let* ((break nil) + (qword-break nil) + (bol (save-restriction + (widen) + (line-beginning-position))) + ;; This function is either called with the Header: name in + ;; the region or not. If it's not in the region, then we + ;; may already have a space. + (first (or (= bol (point)) + (save-restriction + (widen) + (save-excursion + (not (re-search-backward "[ \t]" bol t))))))) (while (not (eobp)) (when (and (or break qword-break) (> (- (point) bol) 76)) - (goto-char (or break qword-break)) - (setq break nil - qword-break nil) - (skip-chars-backward " \t") - (if (looking-at "[ \t]") - (insert ?\n) - (insert "\n ")) - (setq bol (1- (point))) - ;; Don't break before the first non-LWSP characters. - (skip-chars-forward " \t") - (unless (eobp) - (forward-char 1))) + ;; We have a line longer than 76 characters, so break the + ;; line. + (setq bol (rfc2047--break-line break qword-break) + break nil + qword-break nil)) + ;; See whether we're at a point where we can break the line + ;; (if it turns out to be too long). (cond + ;; New line, so there's nothing to break. ((eq (char-after) ?\n) (forward-char 1) (setq bol (point) @@ -764,12 +765,19 @@ Point moves to the end of the region." (skip-chars-forward " \t") (unless (or (eobp) (eq (char-after) ?\n)) (forward-char 1))) + ;; CR in CRLF; shouldn't really as this function shouldn't be + ;; called after encoding for line transmission. ((eq (char-after) ?\r) (forward-char 1)) + ;; Whitespace -- possible break point. ((memq (char-after) '(? ?\t)) (skip-chars-forward " \t") - (unless first ;; Don't break just after the header name. + ;; Don't break just after the header name. + (if first + (setq first nil) (setq break (point)))) + ;; If the header has been encoded (with RFC2047 encoding, + ;; which looks like "=?utf-8?Q?F=C3=B3?=". ((not break) (if (not (looking-at "=\\?[^=]")) (if (eq (char-after) ?=) @@ -779,23 +787,28 @@ Point moves to the end of the region." (unless (= (point) b) (setq qword-break (point))) (skip-chars-forward "^ \t\n\r"))) + ;; Look for the next LWSP (i.e., whitespace character). (t - (skip-chars-forward "^ \t\n\r"))) - (setq first nil)) + (skip-chars-forward "^ \t\n\r")))) (when (and (or break qword-break) (> (- (point) bol) 76)) - (goto-char (or break qword-break)) - (setq break nil - qword-break nil) - (if (or (> 0 (skip-chars-backward " \t")) - (looking-at "[ \t]")) - (insert ?\n) - (insert "\n ")) - (setq bol (1- (point))) - ;; Don't break before the first non-LWSP characters. - (skip-chars-forward " \t") - (unless (eobp) - (forward-char 1)))))) + ;; Finally, after the loop, we have a line longer than 76 + ;; characters, so break the line. + (rfc2047--break-line break qword-break))))) + +(defun rfc2047--break-line (break qword-break) + (goto-char (or break qword-break)) + (skip-chars-backward " \t") + (if (looking-at "[ \t]") + (insert ?\n) + (insert "\n ")) + (prog1 + ;; Return beginning-of-line. + (1- (point)) + ;; Don't break before the first non-LWSP characters. + (skip-chars-forward " \t") + (unless (eobp) + (forward-char 1)))) (defun rfc2047-unfold-field () "Fold the current line." diff --git a/lisp/mail/rfc2231.el b/lisp/mail/rfc2231.el index 31112a7505a..6ddb2964e51 100644 --- a/lisp/mail/rfc2231.el +++ b/lisp/mail/rfc2231.el @@ -1,4 +1,4 @@ -;;; rfc2231.el --- Functions for decoding rfc2231 headers +;;; rfc2231.el --- Functions for decoding rfc2231 headers -*- lexical-binding:t -*- ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. @@ -22,7 +22,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'ietf-drums) (require 'rfc2047) (autoload 'mm-encode-body "mm-bodies") @@ -181,7 +181,7 @@ must never cause a Lisp error." ;; Now collect and concatenate continuation parameters. (let ((cparams nil) elem) - (loop for (attribute value part encoded) + (cl-loop for (attribute value part encoded) in (sort parameters (lambda (e1 e2) (< (or (caddr e1) 0) (or (caddr e2) 0)))) @@ -223,7 +223,7 @@ These look like: (mm-with-unibyte-buffer (insert value) (goto-char (point-min)) - (while (re-search-forward "%\\([0-9A-Fa-f][0-9A-Fa-f]\\)" nil t) + (while (re-search-forward "%\\([[:xdigit:]][[:xdigit:]]\\)" nil t) (insert (prog1 (string-to-number (match-string 1) 16) @@ -291,7 +291,7 @@ the result of this function." (insert param "*=") (while (not (eobp)) (insert (if (>= num 0) " " "") - param "*" (format "%d" (incf num)) "*=") + param "*" (format "%d" (cl-incf num)) "*=") (forward-line 1)))) (spacep (goto-char (point-min)) diff --git a/lisp/mail/rmail-spam-filter.el b/lisp/mail/rmail-spam-filter.el index 36e50693fb1..86217e5dd5c 100644 --- a/lisp/mail/rmail-spam-filter.el +++ b/lisp/mail/rmail-spam-filter.el @@ -251,7 +251,7 @@ it from rmail file. Called for each new message retrieved by (setq message-subject (mail-fetch-field "Subject")) (setq message-content-type (mail-fetch-field "Content-Type")) (setq message-spam-status (mail-fetch-field "X-Spam-Status"))) - ;; Check for blind CC condition. Set vars such that while + ;; Check for blind cc condition. Set vars such that while ;; loop will be bypassed and spam condition will trigger. (and rsf-no-blind-cc (null message-recipients) diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index a740c4bfa23..91291b8d330 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -191,9 +191,6 @@ Its name should end with a slash." :group 'rmail-retrieve :type '(choice (const nil) string)) -(define-obsolete-variable-alias 'rmail-pop-password - 'rmail-remote-password "22.1") - (defcustom rmail-remote-password nil "Password to use when reading mail from a remote server. This setting is ignored for mailboxes whose URL already contains a password." @@ -202,9 +199,6 @@ This setting is ignored for mailboxes whose URL already contains a password." :group 'rmail-retrieve :version "22.1") -(define-obsolete-variable-alias 'rmail-pop-password-required - 'rmail-remote-password-required "22.1") - (defcustom rmail-remote-password-required nil "Non-nil if a password is required when reading mail from a remote server." :type 'boolean @@ -857,7 +851,7 @@ that knows the exact ordering of the \\( \\) subexpressions.") (beginning-of-line) (end-of-line) (1 font-lock-comment-delimiter-face nil t) (5 font-lock-comment-face nil t))) - '("^\\(X-[a-z0-9-]+\\|In-reply-to\\|Date\\):.*\\(\n[ \t]+.*\\)*$" + '("^\\(X-[a-z0-9-]+\\|In-Reply-To\\|Date\\):.*\\(\n[ \t]+.*\\)*$" . 'rmail-header-name)))) "Additional expressions to highlight in Rmail mode.") @@ -1331,8 +1325,7 @@ Instead, these commands are available: (let ((finding-rmail-file (not (eq major-mode 'rmail-mode)))) (rmail-mode-2) (when (and finding-rmail-file - (null coding-system-for-read) - (default-value 'enable-multibyte-characters)) + (null coding-system-for-read)) (let ((rmail-enable-multibyte t)) (rmail-require-mime-maybe) (rmail-convert-file-maybe) @@ -1759,7 +1752,7 @@ not be a new one). It returns non-nil if it got any new messages." (or (eq buffer-undo-list t) (setq buffer-undo-list nil)) (let ((all-files (if file-name (list file-name) rmail-inbox-list)) - (rmail-enable-multibyte (default-value 'enable-multibyte-characters)) + (rmail-enable-multibyte t) found) (unwind-protect (progn @@ -2035,10 +2028,10 @@ Value is the size of the newly read mail after conversion." "the remote server" proto))) ((and (file-exists-p tofile) - (/= 0 (nth 7 (file-attributes tofile)))) + (/= 0 (file-attribute-size (file-attributes tofile)))) (message "Getting mail from %s..." tofile)) ((and (file-exists-p file) - (/= 0 (nth 7 (file-attributes file)))) + (/= 0 (file-attribute-size (file-attributes file)))) (message "Getting mail from %s..." file))) ;; Set TOFILE if have not already done so, and ;; rename or copy the file FILE to TOFILE if and as appropriate. @@ -2582,7 +2575,7 @@ the message. Point is at the beginning of the message." (save-excursion (setq deleted-head (cons (if (and (search-forward (concat rmail-attribute-header ": ") message-end t) - (looking-at "?D")) + (looking-at "\\?D")) ?D ?\s) deleted-head)))) @@ -3400,21 +3393,15 @@ Interactively, empty argument means use same regexp used last time." (defun rmail-simplified-subject (&optional msgnum) "Return the simplified subject of message MSGNUM (or current message). -Simplifying the subject means stripping leading and trailing whitespace, -and typical reply prefixes such as Re:." - (let ((subject (or (rmail-get-header "Subject" msgnum) ""))) +Simplifying the subject means stripping leading and trailing +whitespace, replacing whitespace runs with a single space and +removing prefixes such as Re:, Fwd: and so on and mailing list +tags such as [tag]." + (let ((subject (or (rmail-get-header "Subject" msgnum) "")) + (regexp "\\`[ \t\n]*\\(\\(\\w\\{1,3\\}:\\|\\[[^]]+]\\)[ \t\n]+\\)*")) (setq subject (rfc2047-decode-string subject)) - (if (string-match "\\`[ \t]+" subject) - (setq subject (substring subject (match-end 0)))) - (if (string-match rmail-reply-regexp subject) - (setq subject (substring subject (match-end 0)))) - (if (string-match "[ \t]+\\'" subject) - (setq subject (substring subject 0 (match-beginning 0)))) - ;; If Subject is long, mailers will break it into several lines at - ;; arbitrary places, so normalize whitespace by replacing every - ;; run of whitespace characters with a single space. - (setq subject (replace-regexp-in-string "[ \t\n]+" " " subject)) - subject)) + (setq subject (replace-regexp-in-string regexp "" subject)) + (replace-regexp-in-string "[ \t\n]+" " " subject))) (defun rmail-simplified-subject-regexp () "Return a regular expression matching the current simplified subject. @@ -3803,7 +3790,7 @@ original message into it." (defun rmail-reply (just-sender) "Reply to the current message. -Normally include CC: to all other recipients of original message; +Normally include Cc: to all other recipients of original message; prefix argument means ignore them. While composing the reply, use \\[mail-yank-original] to yank the original message into it." (interactive "P") @@ -3837,7 +3824,7 @@ use \\[mail-yank-original] to yank the original message into it." (unless just-sender (if (mail-fetch-field "mail-followup-to" nil t) ;; If this header field is present, use it instead of the - ;; To and CC fields. + ;; To and Cc fields. (setq to (mail-fetch-field "mail-followup-to" nil t)) (setq cc (or (mail-fetch-field "cc" nil t) "") to (or (mail-fetch-field "to" nil t) "")))))) @@ -4140,6 +4127,7 @@ typically for purposes of moderating a list." "^ *---+ +Original message follows +---+ *$\\|" "^ *---+ +Your message follows +---+ *$\\|" "^|? *---+ +Message text follows: +---+ *|?$\\|" + "^ *---+ +This is a copy of \\w+ message, including all the headers.*---+ *\n *---+ +The body of the message is [0-9]+ characters long; only the first *\n *---+ +[0-9]+ or so are included here\\. *$\\|" "^ *---+ +This is a copy of \\w+ message, including all the headers.*---+ *$") "A regexp that matches the separator before the text of a failed message.") @@ -4288,7 +4276,7 @@ specifying headers which should not be copied into the new message." (if mail-self-blind (if resending (insert "Resent-Bcc: " (user-login-name) "\n") - (insert "BCC: " (user-login-name) "\n")))) + (insert "Bcc: " (user-login-name) "\n")))) (goto-char (point-min)) (mail-position-on-field (if resending "Resent-To" "To") t)))))) @@ -4528,7 +4516,7 @@ encoded string (and the same mask) will decode the string." (if (= curmask 0) (setq curmask mask)) (setq charmask (% curmask 256)) - (setq curmask (lsh curmask -8)) + (setq curmask (ash curmask -8)) (aset string-vector i (logxor charmask (aref string-vector i))) (setq i (1+ i))) (concat string-vector))) @@ -4556,6 +4544,9 @@ Argument MIME is non-nil if this is a mime message." (unless armor-end (error "Encryption armor beginning has no matching end")) + (setq armor-start (move-marker (make-marker) armor-start)) + (setq armor-end (move-marker (make-marker) armor-end)) + (goto-char armor-start) ;; Because epa--find-coding-system-for-mime-charset not autoloaded. @@ -4588,15 +4579,16 @@ Argument MIME is non-nil if this is a mime message." (mail-unquote-printable-region armor-start (- (point-max) after-end)))) - ;; Decrypt it, maybe in place, maybe making new buffer. - (epa-decrypt-region - armor-start (- (point-max) after-end) - ;; Call back this function to prepare the output. - (lambda () - (let ((inhibit-read-only t)) - (delete-region armor-start (- (point-max) after-end)) - (goto-char armor-start) - (current-buffer)))) + (condition-case nil + (epa-decrypt-region + armor-start (- (point-max) after-end) + ;; Call back this function to prepare the output. + (lambda () + (let ((inhibit-read-only t)) + (delete-region armor-start (- (point-max) after-end)) + (goto-char armor-start) + (current-buffer)))) + (error nil)) (list armor-start (- (point-max) after-end) mime armor-end-regexp @@ -4632,9 +4624,14 @@ Argument MIME is non-nil if this is a mime message." (goto-char (point-min)) (while (re-search-forward "-----BEGIN PGP MESSAGE-----$" nil t) (let ((coding-system-for-read coding-system-for-read) - (case-fold-search t)) - - (push (rmail-epa-decrypt-1 mime) decrypts))) + (case-fold-search t) + (armor-start (match-beginning 0))) + ;; Don't decrypt an armor that was copied into + ;; the message from a message it is a reply to. + (or (equal (buffer-substring (line-beginning-position) + armor-start) + "> ") + (push (rmail-epa-decrypt-1 mime) decrypts)))) (when (and decrypts (eq major-mode 'rmail-mode)) (rmail-add-label "decrypt")) diff --git a/lisp/mail/rmailmm.el b/lisp/mail/rmailmm.el index af528135ccb..95977e826d7 100644 --- a/lisp/mail/rmailmm.el +++ b/lisp/mail/rmailmm.el @@ -836,7 +836,8 @@ directly." size (car bulk-data)) (if (stringp (aref body 0)) (setq data (aref body 0)) - (setq data (string-as-unibyte (buffer-string))) + (setq data (buffer-string)) + (cl-assert (not (multibyte-string-p data))) (aset body 0 data) (rmail-mime-set-bulk-data entity) (delete-region (point-min) (point-max))) diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el index 1a6f4e55fbc..12d37615d6b 100644 --- a/lisp/mail/rmailout.el +++ b/lisp/mail/rmailout.el @@ -56,6 +56,13 @@ The function `rmail-delete-unwanted-fields' uses this, ignoring case." regexp) :group 'rmail-output) +(defcustom rmail-output-reset-deleted-flag nil + "Non-nil means reset the \"deleted\" flag when outputting a message to a file." + :type '(choice (const :tag "Output with the \"deleted\" flag reset" t) + (const :tag "Output with the \"deleted\" flag intact" nil)) + :version "27.1" + :group 'rmail-output) + (defun rmail-output-read-file-name () "Read the file name to use for `rmail-output'. Set `rmail-default-file' to this name as well as returning it. @@ -472,9 +479,15 @@ buffer, updates it accordingly. This command always outputs the complete message header, even if the header display is currently pruned. +If `rmail-output-reset-deleted-flag' is non-nil, the message's +deleted flag is reset in the message appended to the destination +file. Otherwise, the appended message will remain marked as +deleted if it was deleted before invoking this command. + Optional prefix argument COUNT (default 1) says to output that many consecutive messages, starting with the current one (ignoring -deleted messages). If `rmail-delete-after-output' is non-nil, deletes +deleted messages, unless `rmail-output-reset-deleted-flag' is +non-nil). If `rmail-delete-after-output' is non-nil, deletes messages after output. The optional third argument NOATTRIBUTE, if non-nil, says not to @@ -533,30 +546,47 @@ from a non-Rmail buffer. In this case, COUNT is ignored." (if (zerop rmail-total-messages) (error "No messages to output")) (let ((orig-count count) - beg end) + beg end delete-attr-reset-p) (while (> count 0) - (setq beg (rmail-msgbeg rmail-current-message) - end (rmail-msgend rmail-current-message)) - ;; All access to the buffer's local variables is now finished... - (save-excursion - ;; ... so it is ok to go to a different buffer. - (if (rmail-buffers-swapped-p) (set-buffer rmail-view-buffer)) - (setq cur (current-buffer)) - (save-restriction - (widen) - (with-temp-buffer - (insert-buffer-substring cur beg end) - (if babyl-format - (rmail-output-as-babyl file-name noattribute) - (rmail-output-as-mbox file-name noattribute))))) + (when (and rmail-output-reset-deleted-flag + (rmail-message-deleted-p rmail-current-message)) + (rmail-set-attribute rmail-deleted-attr-index nil) + (setq delete-attr-reset-p t)) + ;; Make sure we undo our messing with the DELETED attribute. + (unwind-protect + (progn + (setq beg (rmail-msgbeg rmail-current-message) + end (rmail-msgend rmail-current-message)) + ;; All access to the buffer's local variables is now finished... + (save-excursion + ;; ... so it is ok to go to a different buffer. + (if (rmail-buffers-swapped-p) (set-buffer rmail-view-buffer)) + (setq cur (current-buffer)) + (save-restriction + (widen) + (with-temp-buffer + (insert-buffer-substring cur beg end) + (if babyl-format + (rmail-output-as-babyl file-name noattribute) + (rmail-output-as-mbox file-name noattribute)))))) + (if delete-attr-reset-p + (rmail-set-attribute rmail-deleted-attr-index t))) (or noattribute ; mark message as "filed" (rmail-set-attribute rmail-filed-attr-index t)) (setq count (1- count)) (let ((next-message-p - (if rmail-delete-after-output - (rmail-delete-forward) - (if (> count 0) - (rmail-next-undeleted-message 1)))) + (if rmail-output-reset-deleted-flag + (progn + (if rmail-delete-after-output + (rmail-delete-message)) + (if (> count 0) + (let ((msgnum rmail-current-message)) + (rmail-next-message 1) + (eq rmail-current-message (1+ msgnum))))) + (if rmail-delete-after-output + (rmail-delete-forward) + (if (> count 0) + (rmail-next-undeleted-message 1))))) (num-appended (- orig-count count))) (if (and (> count 0) (not next-message-p)) (error "Only %d message%s appended" num-appended diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el index 2ed01a00df6..79a322c1d91 100644 --- a/lisp/mail/rmailsum.el +++ b/lisp/mail/rmailsum.el @@ -390,8 +390,17 @@ SUBJECT is a regular expression." ;;;###autoload (defun rmail-summary-by-senders (senders) "Display a summary of all messages whose \"From\" field matches SENDERS. -SENDERS is a regular expression." - (interactive "sSenders to summarize by: ") +SENDERS is a regular expression. The default for SENDERS matches the +sender of the current messsage." + (interactive + (let* ((def (rmail-get-header "From")) + ;; We quote the default argument, because if it contains regexp + ;; special characters (eg "?"), it can fail to match itself. + (sender (regexp-quote def)) + (prompt (concat "Senders to summarize by (regexp" + (if sender ", default this message's sender" "") + "): "))) + (list (read-string prompt nil nil sender)))) (rmail-new-summary (concat "senders " senders) (list 'rmail-summary-by-senders senders) 'rmail-message-senders-p senders)) @@ -1306,11 +1315,7 @@ advance to the next message." (select-window rmail-buffer-window) (prog1 ;; Is EOB visible in the buffer? - (save-excursion - (let ((ht (window-height))) - (move-to-window-line (- ht 2)) - (end-of-line) - (eobp))) + (pos-visible-in-window-p (point-max)) (select-window rmail-summary-window))) (if (not rmail-summary-scroll-between-messages) (error "End of buffer") @@ -1333,10 +1338,7 @@ move to the previous message." (select-window rmail-buffer-window) (prog1 ;; Is BOB visible in the buffer? - (save-excursion - (move-to-window-line 0) - (beginning-of-line) - (bobp)) + (pos-visible-in-window-p (point-min)) (select-window rmail-summary-window))) (if (not rmail-summary-scroll-between-messages) (error "Beginning of buffer") @@ -1626,7 +1628,7 @@ original message into it." (defun rmail-summary-reply (just-sender) "Reply to the current message. -Normally include CC: to all other recipients of original message; +Normally include Cc: to all other recipients of original message; prefix argument means ignore them. While composing the reply, use \\[mail-yank-original] to yank the original message into it." (interactive "P") diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el index 21c85dae2cf..1da33a43eb8 100644 --- a/lisp/mail/sendmail.el +++ b/lisp/mail/sendmail.el @@ -1,4 +1,4 @@ -;;; sendmail.el --- mail sending commands for Emacs +;;; sendmail.el --- mail sending commands for Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1985-1986, 1992-1996, 1998, 2000-2019 Free Software ;; Foundation, Inc. @@ -39,7 +39,6 @@ (defcustom mail-setup-with-from t "Non-nil means insert `From:' field when setting up the message." :type 'boolean - :group 'sendmail :version "22.1") (defcustom sendmail-program @@ -51,11 +50,10 @@ (t "sendmail"))) "Program used to send messages." :version "24.1" ; add executable-find, remove fakemail - :group 'mail :type 'file) ;;;###autoload -(defcustom mail-from-style 'default +(defcustom mail-from-style 'angles "Specifies how \"From:\" fields look. If nil, they contain just the return address like: @@ -72,8 +70,10 @@ Otherwise, most addresses look like `angles', but they look like (const parens) (const angles) (const default)) - :version "20.3" - :group 'sendmail) + :version "27.1") +(make-obsolete-variable + 'mail-from-style + "only the `angles' value is valid according to RFC2822." "27.1" 'set) ;;;###autoload (defcustom mail-specify-envelope-from nil @@ -86,8 +86,7 @@ privileged operation. This variable affects sendmail and smtpmail -- if you use feedmail to send mail, see instead the variable `feedmail-deduce-envelope-from'." :version "21.1" - :type 'boolean - :group 'sendmail) + :type 'boolean) (defcustom mail-envelope-from nil "If non-nil, designate the envelope-from address when sending mail. @@ -99,16 +98,14 @@ being sent is used), or nil (in which case the value of :version "21.1" :type '(choice (string :tag "From-name") (const :tag "Use From: header from message" header) - (const :tag "Use `user-mail-address'" nil)) - :group 'sendmail) + (const :tag "Use `user-mail-address'" nil))) ;;;###autoload (defcustom mail-self-blind nil - "Non-nil means insert BCC to self in messages to be sent. + "Non-nil means insert Bcc to self in messages to be sent. This is done when the message is initialized, -so you can remove or alter the BCC field to override the default." - :type 'boolean - :group 'sendmail) +so you can remove or alter the Bcc field to override the default." + :type 'boolean) ;;;###autoload (defcustom mail-interactive t @@ -119,8 +116,7 @@ so you can remove or alter the BCC field to override the default." "Non-nil means when sending a message wait for and display errors. Otherwise, let mailer send back a message to report errors." :type 'boolean - :version "23.1" ; changed from nil to t - :group 'sendmail) + :version "23.1") ; changed from nil to t (defcustom mail-yank-ignored-headers (concat "^" @@ -135,7 +131,6 @@ Otherwise, let mailer send back a message to report errors." ":") "Delete these headers from old message when it's inserted in a reply." :type 'regexp - :group 'sendmail :version "23.1") ;; Useful to set in site-init.el @@ -144,7 +139,7 @@ Otherwise, let mailer send back a message to report errors." ;; Assume smtpmail is the preferred choice if it's already configured. (if (and (boundp 'smtpmail-smtp-server) smtpmail-smtp-server) - 'smtpmail-send-it 'sendmail-query-once) + #'smtpmail-send-it #'sendmail-query-once) "Function to call to send the current buffer as mail. The headers should be delimited by a line which is not a valid RFC 822 (or later) header or continuation line, @@ -157,14 +152,12 @@ This is used by the default mail-sending commands. See also (function-item feedmail-send-it :tag "Use Feedmail package") (function-item mailclient-send-it :tag "Use Mailclient package") function) - :version "24.1" - :group 'sendmail) + :version "24.1") ;;;###autoload (defcustom mail-header-separator (purecopy "--text follows this line--") "Line used to separate headers from text in messages being composed." - :type 'string - :group 'sendmail) + :type 'string) ;; Set up mail-header-separator for use as a category text property. (put 'mail-header-separator 'rear-nonsticky '(category)) @@ -180,16 +173,14 @@ This is used by the default mail-sending commands. See also "Name of file to write all outgoing messages in, or nil for none. This is normally an mbox file, but for backwards compatibility may also be a Babyl file." - :type '(choice file (const nil)) - :group 'sendmail) + :type '(choice file (const nil))) ;;;###autoload (defcustom mail-default-reply-to nil - "Address to insert as default Reply-to field of outgoing messages. + "Address to insert as default Reply-To field of outgoing messages. If nil, it will be initialized from the REPLYTO environment variable when you first send mail." - :type '(choice (const nil) string) - :group 'sendmail) + :type '(choice (const nil) string)) (defcustom mail-alias-file nil "If non-nil, the name of a file to use instead of the sendmail default. @@ -198,8 +189,7 @@ feature from that of defining aliases in `.mailrc' to be expanded in Emacs. This variable has no effect unless your system uses sendmail as its mailer. The default file is defined in sendmail's configuration file, e.g. `/etc/aliases'." - :type '(choice (const :tag "Sendmail default" nil) file) - :group 'sendmail) + :type '(choice (const :tag "Sendmail default" nil) file)) ;;;###autoload (defcustom mail-personal-alias-file (purecopy "~/.mailrc") @@ -207,15 +197,13 @@ The default file is defined in sendmail's configuration file, e.g. This file typically should be in same format as the `.mailrc' file used by the `Mail' or `mailx' program. This file need not actually exist." - :type '(choice (const nil) file) - :group 'sendmail) + :type '(choice (const nil) file)) ;;;###autoload (defcustom mail-setup-hook nil "Normal hook, run each time a new outgoing message is initialized." :type 'hook - :options '(fortune-to-signature spook mail-abbrevs-setup) - :group 'sendmail) + :options '(fortune-to-signature spook mail-abbrevs-setup)) ;;;###autoload (defvar mail-aliases t @@ -233,24 +221,13 @@ The alias definitions in the file have this form: (defcustom mail-yank-prefix "> " "Prefix insert on lines of yanked message being replied to. If this is nil, use indentation, as specified by `mail-indentation-spaces'." - :type '(choice (const nil) string) - :group 'sendmail) + :type '(choice (const nil) string)) ;;;###autoload (defcustom mail-indentation-spaces 3 "Number of spaces to insert at the beginning of each cited line. Used by `mail-yank-original' via `mail-indent-citation'." - :type 'integer - :group 'sendmail) - -(defvar mail-yank-hooks nil - "Obsolete hook for modifying a citation just inserted in the mail buffer. -Each hook function can find the citation between (point) and (mark t). -And each hook function should leave point and mark around the citation -text as modified. -This is a normal hook, misnamed for historical reasons. -It is obsolete and mail agents should no longer use it.") -(make-obsolete-variable 'mail-yank-hooks 'mail-citation-hook "19.34") + :type 'integer) ;;;###autoload (defcustom mail-citation-hook nil @@ -263,8 +240,7 @@ in the cited portion of the message. If this hook is entirely empty (nil), a default action is taken instead of no action." - :type 'hook - :group 'sendmail) + :type 'hook) (defvar mail-citation-header nil "While running `mail-citation-hook', this variable holds the message header. @@ -279,7 +255,6 @@ It should match whatever sort of citation prefixes you want to handle, with whitespace before and after; it should also match just whitespace. The default value matches citations like `foo-bar>' plus whitespace." :type 'regexp - :group 'sendmail :version "24.1") (defvar mail-abbrevs-loaded nil) @@ -376,6 +351,7 @@ By default, this is the file specified by `mail-personal-alias-file'." t) ;;;###autoload (defcustom mail-signature t "Text inserted at end of mail buffer when a message is initialized. +If nil, no signature is inserted. If t, it means to insert the contents of the file `mail-signature-file'. If a string, that string is inserted. (To make a proper signature, the string should begin with \\n\\n-- \\n, @@ -385,15 +361,13 @@ and should insert whatever you want to insert." :type '(choice (const :tag "None" nil) (const :tag "Use `.signature' file" t) (string :tag "String to insert") - (sexp :tag "Expression to evaluate")) - :group 'sendmail) + (sexp :tag "Expression to evaluate"))) (put 'mail-signature 'risky-local-variable t) ;;;###autoload (defcustom mail-signature-file (purecopy "~/.signature") "File containing the text inserted at end of mail buffer." - :type 'file - :group 'sendmail) + :type 'file) ;;;###autoload (defcustom mail-default-directory (purecopy "~/") @@ -403,7 +377,6 @@ This directory is used for auto-save files of Mail mode buffers. Note that Message mode does not use this variable; it auto-saves in `message-auto-save-directory'." :type '(directory :tag "Directory") - :group 'sendmail :version "22.1") (defvar mail-reply-action nil) @@ -416,16 +389,14 @@ in `message-auto-save-directory'." "A string containing header lines, to be inserted in outgoing messages. It can contain newlines, and should end in one. It is inserted before you edit the message, so you can edit or delete the lines." - :type '(choice (const nil) string) - :group 'sendmail) + :type '(choice (const nil) string)) (defcustom mail-bury-selects-summary t "If non-nil, try to show Rmail summary buffer after returning from mail. The functions \\[mail-send-on-exit] or \\[mail-dont-send] select the Rmail summary buffer before returning, if it exists and this variable is non-nil." - :type 'boolean - :group 'sendmail) + :type 'boolean) (defcustom mail-send-nonascii 'mime "Specify whether to allow sending non-ASCII characters in mail. @@ -435,14 +406,12 @@ If t, that means do allow it. nil means don't allow it. The default is `mime'. Including non-ASCII characters in a mail message can be problematical for the recipient, who may not know how to decode them properly." - :type '(choice (const t) (const nil) (const query) (const mime)) - :group 'sendmail) + :type '(choice (const t) (const nil) (const query) (const mime))) (defcustom mail-use-dsn nil "Ask MTA for notification of failed, delayed or successful delivery. Note that only some MTAs (currently only recent versions of Sendmail) support Delivery Status Notification." - :group 'sendmail :type '(repeat (radio (const :tag "Failure" failure) (const :tag "Delay" delay) (const :tag "Success" success))) @@ -479,7 +448,7 @@ by Emacs.)") (cite-prefix "[:alpha:]") (cite-suffix (concat cite-prefix "0-9_.@-`'\""))) (list '("^\\(To\\|Newsgroups\\):" . font-lock-function-name-face) - '("^\\(B?CC\\|Reply-to\\|Mail-\\(reply\\|followup\\)-to\\):" . font-lock-keyword-face) + '("^\\(B?Cc\\|Reply-To\\|Mail-\\(Reply\\|Followup\\)-To\\):" . font-lock-keyword-face) '("^\\(Subject:\\)[ \t]*\\(.+\\)?" (1 font-lock-comment-face) ;; (2 font-lock-type-face nil t) @@ -499,7 +468,7 @@ by Emacs.)") (beginning-of-line) (end-of-line) (1 font-lock-comment-delimiter-face nil t) (5 font-lock-comment-face nil t))) - '("^\\(X-[A-Za-z0-9-]+\\|In-reply-to\\):.*\\(\n[ \t]+.*\\)*$" + '("^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):.*\\(\n[ \t]+.*\\)*$" . font-lock-string-face)))) "Additional expressions to highlight in Mail mode.") @@ -511,9 +480,13 @@ This also saves the value of `send-mail-function' via Customize." ;; If send-mail-function is already setup, we're incorrectly called ;; a second time, probably because someone's using an old value ;; of send-mail-function. - (when (eq send-mail-function 'sendmail-query-once) - (sendmail-query-user-about-smtp)) - (funcall send-mail-function)) + (if (not (eq send-mail-function #'sendmail-query-once)) + (funcall send-mail-function) + (let ((function (sendmail-query-user-about-smtp))) + (funcall function) + (when (y-or-n-p "Save this mail sending choice?") + (setq send-mail-function function) + (customize-save-variable 'send-mail-function function))))) (defun sendmail-query-user-about-smtp () (let* ((options `(("mail client" . mailclient-send-it) @@ -558,12 +531,13 @@ This also saves the value of `send-mail-function' via Customize." (completing-read (format "Send mail via (default %s): " (caar options)) options nil 'require-match nil nil (car options)))))) - (customize-save-variable 'send-mail-function - (cdr (assoc-string choice options t))))) + ;; Return the choice. + (cdr (assoc-string choice options t)))) (defun sendmail-sync-aliases () (when mail-personal-alias-file - (let ((modtime (nth 5 (file-attributes mail-personal-alias-file)))) + (let ((modtime (file-attribute-modification-time + (file-attributes mail-personal-alias-file)))) (or (equal mail-alias-modtime modtime) (setq mail-alias-modtime modtime mail-aliases t))))) @@ -571,8 +545,8 @@ This also saves the value of `send-mail-function' via Customize." ;;;###autoload (define-mail-user-agent 'sendmail-user-agent - 'sendmail-user-agent-compose - 'mail-send-and-exit) + #'sendmail-user-agent-compose + #'mail-send-and-exit) ;;;###autoload (defun sendmail-user-agent-compose (&optional to subject other-headers @@ -616,7 +590,7 @@ This also saves the value of `send-mail-function' via Customize." (kill-local-variable 'buffer-file-coding-system) ;; This doesn't work for enable-multibyte-characters. ;; (kill-local-variable 'enable-multibyte-characters) - (set-buffer-multibyte (default-value 'enable-multibyte-characters)) + (set-buffer-multibyte t) (if current-input-method (deactivate-input-method)) @@ -644,7 +618,7 @@ This also saves the value of `send-mail-function' via Customize." (newline)) (if cc (let ((fill-prefix "\t") - (address-start (progn (insert "CC: ") (point)))) + (address-start (progn (insert "Cc: ") (point)))) (insert cc "\n") (fill-region-as-paragraph address-start (point-max)) (goto-char (point-max)) @@ -654,7 +628,7 @@ This also saves the value of `send-mail-function' via Customize." (let ((fill-prefix "\t") (fill-column 78) (address-start (point))) - (insert "In-reply-to: " in-reply-to "\n") + (insert "In-Reply-To: " in-reply-to "\n") (fill-region-as-paragraph address-start (point-max)) (goto-char (point-max)) (unless (bolp) @@ -663,11 +637,11 @@ This also saves the value of `send-mail-function' via Customize." (if mail-default-headers (insert mail-default-headers)) (if mail-default-reply-to - (insert "Reply-to: " mail-default-reply-to "\n")) + (insert "Reply-To: " mail-default-reply-to "\n")) (if mail-self-blind - (insert "BCC: " user-mail-address "\n")) + (insert "Bcc: " user-mail-address "\n")) (if mail-archive-file-name - (insert "FCC: " mail-archive-file-name "\n")) + (insert "Fcc: " mail-archive-file-name "\n")) (put-text-property (point) (progn (insert mail-header-separator "\n") @@ -687,7 +661,6 @@ This also saves the value of `send-mail-function' via Customize." "Hook run by Mail mode. When composing a mail, this runs immediately after creating, or switching to, the `*mail*' buffer. See also `mail-setup-hook'." - :group 'sendmail :type 'hook :options '(footnote-mode)) @@ -703,8 +676,8 @@ Like Text Mode but with these additional commands: Here are commands that move to a header field (and create it if there isn't): \\[mail-to] move to To: \\[mail-subject] move to Subj: - \\[mail-bcc] move to BCC: \\[mail-cc] move to CC: - \\[mail-fcc] move to FCC: \\[mail-reply-to] move to Reply-To: + \\[mail-bcc] move to Bcc: \\[mail-cc] move to Cc: + \\[mail-fcc] move to Fcc: \\[mail-reply-to] move to Reply-To: \\[mail-mail-reply-to] move to Mail-Reply-To: \\[mail-mail-followup-to] move to Mail-Followup-To: \\[mail-text] move to message text. @@ -724,10 +697,8 @@ Turning on Mail mode runs the normal hooks `text-mode-hook' and (make-local-variable 'font-lock-defaults) (setq font-lock-defaults '(mail-font-lock-keywords t t)) (make-local-variable 'paragraph-separate) - (make-local-variable 'normal-auto-fill-function) - (setq normal-auto-fill-function 'mail-mode-auto-fill) - (make-local-variable 'fill-paragraph-function) - (setq fill-paragraph-function 'mail-mode-fill-paragraph) + (setq-local normal-auto-fill-function #'mail-mode-auto-fill) + (setq-local fill-paragraph-function #'mail-mode-fill-paragraph) ;; Allow using comment commands to add/remove quoting (this only does ;; anything if mail-yank-prefix is set to a non-nil value). (set (make-local-variable 'comment-start) mail-yank-prefix) @@ -786,8 +757,12 @@ Concretely: replace the first blank line in the header with the separator." (defun mail-sendmail-undelimit-header () "Remove header separator to put the message in correct form for sendmail. Leave point at the start of the delimiter line." - (rfc822-goto-eoh) - (delete-region (point) (progn (end-of-line) (point)))) + (goto-char (point-min)) + (when (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n") + nil t) + (replace-match "\n")) + (rfc822-goto-eoh)) (defun mail-mode-auto-fill () "Carry out Auto Fill for Mail mode. @@ -876,16 +851,14 @@ Prefix arg means don't delete this window." (defcustom mail-send-hook nil "Hook run just before sending a message." :type 'hook - :options '(flyspell-mode-off) - :group 'sendmail) + :options '(flyspell-mode-off)) ;;;###autoload (defcustom mail-mailing-lists nil "List of mailing list addresses the user is subscribed to. The variable is used to trigger insertion of the \"Mail-Followup-To\" header when sending a message to a mailing list." - :type '(repeat string) - :group 'sendmail) + :type '(repeat string)) (declare-function mml-to-mime "mml" ()) @@ -911,7 +884,7 @@ the user from the mailer." (regexp-opt mail-mailing-lists t) "\\(?:[[:space:];,]\\|\\'\\)")))) (mail-combine-fields "To") - (mail-combine-fields "CC") + (mail-combine-fields "Cc") ;; If there are mailing lists defined (when ml (save-excursion @@ -934,7 +907,7 @@ the user from the mailer." (push e l))) (split-string new-header-values ",[[:space:]]+" t)) - (mapconcat 'identity l ", ")) + (mapconcat #'identity l ", ")) "\n")) ;; Add Mail-Reply-To if none yet (unless (mail-fetch-field "mail-reply-to") @@ -1141,7 +1114,7 @@ to combine them into one, and does so if the user says y." ;; Try to preserve alignment of contents of the field (let ((prefix-length (length (match-string 0)))) (replace-match " ") - (dotimes (i (1- prefix-length)) + (dotimes (_ (1- prefix-length)) (insert " "))))))) (set-marker first-to-end nil)))))) @@ -1181,6 +1154,9 @@ Return non-nil if and only if some part of the header is encoded." This is a suitable value for `send-mail-function'. It sends using the external program defined by `sendmail-program'." (require 'mail-utils) + ;; FIXME: A lot of the work done here seems out-of-place (e.g. it should + ;; happen regardless of the method used to send, whether via SMTP of + ;; /usr/bin/sendmail or anything else). (let ((errbuf (if mail-interactive (generate-new-buffer " sendmail errors") 0)) @@ -1218,6 +1194,8 @@ external program defined by `sendmail-program'." (expand-mail-aliases (point-min) delimline)) (goto-char (point-min)) ;; Ignore any blank lines in the header + ;; FIXME: mail-header-end should have stopped at an empty line, + ;; so the regexp below should never match before delimline! (while (and (re-search-forward "\n\n\n*" delimline t) (< (point) delimline)) (replace-match "\n")) @@ -1226,7 +1204,7 @@ external program defined by `sendmail-program'." ;; the message specially. (let ((case-fold-search t)) (goto-char (point-min)) - (while (re-search-forward "^Resent-\\(to\\|cc\\|bcc\\):" delimline t) + (while (re-search-forward "^Resent-\\(To\\|Cc\\|Bcc\\):" delimline t) ;; Put a list of such addresses in resend-to-addresses. (setq resend-to-addresses (save-restriction @@ -1238,7 +1216,7 @@ external program defined by `sendmail-program'." (point))) (append (mail-parse-comma-list) resend-to-addresses))) - ;; Delete Resent-BCC ourselves + ;; Delete Resent-Bcc ourselves (if (save-excursion (beginning-of-line) (looking-at "resent-bcc")) (delete-region (line-beginning-position) @@ -1301,9 +1279,9 @@ external program defined by `sendmail-program'." (goto-char (1+ delimline)) (if (eval mail-mailer-swallows-blank-line) (newline)) - ;; Find and handle any FCC fields. + ;; Find and handle any Fcc fields. (goto-char (point-min)) - (if (re-search-forward "^FCC:" delimline t) + (if (re-search-forward "^Fcc:" delimline t) (progn (setq fcc-was-found t) (mail-do-fcc delimline))) @@ -1342,11 +1320,11 @@ external program defined by `sendmail-program'." '("-t") ) (if mail-use-dsn - (list "-N" (mapconcat 'symbol-name + (list "-N" (mapconcat #'symbol-name mail-use-dsn ","))) ) ) - (exit-value (apply 'call-process-region args))) + (exit-value (apply #'call-process-region args))) (cond ((or (null exit-value) (eq 0 exit-value))) ((numberp exit-value) (setq error t) @@ -1377,8 +1355,8 @@ external program defined by `sendmail-program'." (autoload 'rmail-output-to-rmail-buffer "rmailout") (defun mail-do-fcc (header-end) - "Find and act on any FCC: headers in the current message before HEADER-END. -If a buffer is visiting the FCC file, append to it before + "Find and act on any Fcc: headers in the current message before HEADER-END. +If a buffer is visiting the Fcc file, append to it before offering to save it, if it was modified initially. If this is an Rmail buffer, update Rmail as needed. If there is no buffer, just append to the file, in Babyl format if necessary." @@ -1390,7 +1368,7 @@ just append to the file, in Babyl format if necessary." (save-excursion (goto-char (point-min)) (let ((case-fold-search t)) - (while (re-search-forward "^FCC:[ \t]*" header-end t) + (while (re-search-forward "^Fcc:[ \t]*" header-end t) (push (buffer-substring (point) (progn (end-of-line) @@ -1469,7 +1447,7 @@ just append to the file, in Babyl format if necessary." ;; If the file is a Babyl file, convert the message to ;; Babyl format. Even though Rmail no longer uses ;; Babyl, this code can remain for the time being, on - ;; the off-chance one FCCs to a Babyl file that has + ;; the off-chance one Fccs to a Babyl file that has ;; not yet been converted to mbox. (let ((coding-system-for-write (or rmail-file-coding-system 'emacs-mule))) @@ -1490,7 +1468,7 @@ just append to the file, in Babyl format if necessary." (set-visited-file-modtime))))))))) (defun mail-sent-via () - "Make a Sent-via header line from each To or CC header line." + "Make a Sent-via header line from each To or Cc header line." (declare (obsolete "nobody can remember what it is for." "24.1")) (interactive) (save-excursion @@ -1525,7 +1503,7 @@ just append to the file, in Babyl format if necessary." (mail-position-on-field "Subject")) (defun mail-cc () - "Move point to end of CC field, creating it if necessary." + "Move point to end of Cc field, creating it if necessary." (interactive) (expand-abbrev) (or (mail-position-on-field "cc" t) @@ -1533,20 +1511,20 @@ just append to the file, in Babyl format if necessary." (insert "\nCC: ")))) (defun mail-bcc () - "Move point to end of BCC field, creating it if necessary." + "Move point to end of Bcc field, creating it if necessary." (interactive) (expand-abbrev) (or (mail-position-on-field "bcc" t) (progn (mail-position-on-field "to") - (insert "\nBCC: ")))) + (insert "\nBcc: ")))) (defun mail-fcc (folder) - "Add a new FCC field, with file name completion." + "Add a new Fcc field, with file name completion." (interactive "FFolder carbon copy: ") (expand-abbrev) - (or (mail-position-on-field "fcc" t) ;Put new field after exiting FCC. + (or (mail-position-on-field "fcc" t) ;Put new field after exiting Fcc. (mail-position-on-field "to")) - (insert "\nFCC: " folder)) + (insert "\nFcc: " folder)) (defun mail-reply-to () "Move point to end of Reply-To field, creating it if necessary." @@ -1717,8 +1695,6 @@ and don't delete any header fields." (rfc822-goto-eoh) (point)))))) (run-hooks 'mail-citation-hook))) - (mail-yank-hooks - (run-hooks 'mail-yank-hooks)) (t (mail-indent-citation))))) ;; This is like exchange-point-and-mark, but doesn't activate the mark. @@ -1787,9 +1763,7 @@ and don't delete any header fields." (rfc822-goto-eoh) (point)))))) (run-hooks 'mail-citation-hook)) - (if mail-yank-hooks - (run-hooks 'mail-yank-hooks) - (mail-indent-citation)))))))) + (mail-indent-citation))))))) (defun mail-split-line () "Split current line, moving portion beyond point vertically down. @@ -1818,7 +1792,7 @@ If the current line has `mail-yank-prefix', insert it on the new line." (or (bolp) (newline)) (goto-char start)))) -(define-obsolete-function-alias 'mail-attach-file 'mail-insert-file "24.1") +(define-obsolete-function-alias 'mail-attach-file #'mail-insert-file "24.1") (declare-function mml-attach-file "mml" (file &optional type description disposition)) @@ -1853,13 +1827,13 @@ Various special commands starting with C-c are available in sendmail mode to move to message header fields: \\{mail-mode-map} -If `mail-self-blind' is non-nil, a BCC to yourself is inserted +If `mail-self-blind' is non-nil, a Bcc to yourself is inserted when the message is initialized. If `mail-default-reply-to' is non-nil, it should be an address (a string); -a Reply-to: field with that address is inserted. +a Reply-To: field with that address is inserted. -If `mail-archive-file-name' is non-nil, an FCC field with that file name +If `mail-archive-file-name' is non-nil, an Fcc field with that file name is inserted. The normal hook `mail-setup-hook' is run after the message is @@ -1958,6 +1932,7 @@ The seventh argument ACTIONS is a list of actions to take ;; Require dired so that dired-trivial-filenames does not get ;; unbound on exit from the let. (require 'dired) + (defvar dired-trivial-filenames) (let ((dired-trivial-filenames t)) (dired-other-window wildcard (concat dired-listing-switches " -t"))) (rename-buffer "*Auto-saved Drafts*" t) @@ -2077,9 +2052,4 @@ you can move to one of them and type C-c C-c to recover that one." ;; Do not add anything but external entries on this page. (provide 'sendmail) - -;; Local Variables: -;; byte-compile-dynamic: t -;; End: - ;;; sendmail.el ends here diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el index 5502e7cfa64..f6fd1cd65eb 100644 --- a/lisp/mail/smtpmail.el +++ b/lisp/mail/smtpmail.el @@ -1,9 +1,9 @@ -;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail +;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail -*- lexical-binding:t -*- ;; Copyright (C) 1995-1996, 2001-2019 Free Software Foundation, Inc. ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp> -;; Maintainer: Simon Josefsson <simon@josefsson.org> +;; Maintainer: emacs-devel@gnu.org ;; w32 Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu> ;; ESMTP support: Simon Leinen <simon@switch.ch> ;; Hacked by Mike Taylor, 11th October 1999 to add support for @@ -70,34 +70,29 @@ (defcustom smtpmail-default-smtp-server nil "Specify default SMTP server. This only has effect if you specify it before loading the smtpmail library." - :type '(choice (const nil) string) - :group 'smtpmail) + :type '(choice (const nil) string)) (defcustom smtpmail-smtp-server (or (getenv "SMTPSERVER") smtpmail-default-smtp-server) "The name of the host running SMTP server." - :type '(choice (const nil) string) - :group 'smtpmail) + :type '(choice (const nil) string)) (defcustom smtpmail-smtp-service 25 "SMTP service port number. The default value would be \"smtp\" or 25." - :type '(choice (integer :tag "Port") (string :tag "Service")) - :group 'smtpmail) + :type '(choice (integer :tag "Port") (string :tag "Service"))) (defcustom smtpmail-smtp-user nil "User name to use when looking up credentials in the authinfo file. If non-nil, only consider credentials for the specified user." :version "24.1" - :type '(choice (const nil) string) - :group 'smtpmail) + :type '(choice (const nil) string)) (defcustom smtpmail-local-domain nil "Local domain name without a host name. If the function `system-name' returns the full internet address, don't define this value." - :type '(choice (const nil) string) - :group 'smtpmail) + :type '(choice (const nil) string)) (defcustom smtpmail-stream-type nil "Type of SMTP connections to use. @@ -105,7 +100,6 @@ This may be either nil (upgrade with STARTTLS if possible), `starttls' (refuse to send if STARTTLS isn't available), `plain' (never use STARTTLS), or `ssl' (to use TLS/SSL)." :version "24.1" - :group 'smtpmail :type '(choice (const :tag "Possibly upgrade to STARTTLS" nil) (const :tag "Always use STARTTLS" starttls) (const :tag "Never use STARTTLS" plain) @@ -119,54 +113,57 @@ not include an @-sign, so that each RCPT TO address is fully qualified. Don't bother to set this unless you have get an error like: Sending failed; 501 <someone>: recipient address must contain a domain." - :type '(choice (const nil) string) - :group 'smtpmail) + :type '(choice (const nil) string)) (defcustom smtpmail-debug-info nil "Whether to print info in buffer *trace of SMTP session to <somewhere>*. See also `smtpmail-debug-verb' which determines if the SMTP protocol should be verbose as well." - :type 'boolean - :group 'smtpmail) + :type 'boolean) (defcustom smtpmail-debug-verb nil "Whether this library sends the SMTP VERB command or not. The commands enables verbose information from the SMTP server." - :type 'boolean - :group 'smtpmail) + :type 'boolean) (defcustom smtpmail-code-conv-from nil "Coding system for encoding outgoing mail. Used for the value of `sendmail-coding-system' when -`select-message-coding-system' is called. " - :type 'coding-system - :group 'smtpmail) +`select-message-coding-system' is called." + :type 'coding-system) (defcustom smtpmail-queue-mail nil "Non-nil means mail is queued; otherwise it is sent immediately. If queued, it is stored in the directory `smtpmail-queue-dir' and sent with `smtpmail-send-queued-mail'." - :type 'boolean - :group 'smtpmail) + :type 'boolean) (defcustom smtpmail-queue-dir "~/Mail/queued-mail/" - "Directory where `smtpmail.el' stores queued mail." - :type 'directory - :group 'smtpmail) + "Directory where `smtpmail.el' stores queued mail. +This directory should not be writable by other users." + :type 'directory) (defcustom smtpmail-warn-about-unknown-extensions nil "If set, print warnings about unknown SMTP extensions. This is mainly useful for development purposes, to learn about new SMTP extensions that might be useful to support." :type 'boolean - :version "21.1" - :group 'smtpmail) + :version "21.1") (defcustom smtpmail-queue-index-file "index" "File name of queued mail index. This is relative to `smtpmail-queue-dir'." - :type 'string - :group 'smtpmail) + :type 'string) + +(defcustom smtpmail-servers-requiring-authorization nil + "Regexp matching servers that require authorization. +Normally smtpmail will try first to send emails via SMTP without +user/password credentials, and then retry using credentials if +the server says that it requires it. If the server name matches +this regexp, smtpmail will send over the credentials on the first +attempt." + :type '(choice regexp (const :tag "None" nil)) + :version "27.1") ;; End of customizable variables. @@ -179,9 +176,11 @@ This is relative to `smtpmail-queue-dir'." ;; Buffer-local variable. (defvar smtpmail-read-point) -(defconst smtpmail-auth-supported '(cram-md5 plain login) +(defvar smtpmail-auth-supported '(cram-md5 plain login) "List of supported SMTP AUTH mechanisms. -The list is in preference order.") +The list is in preference order. +Every element should have a matching `cl-defmethod' for +for `smtpmail-try-auth-method'.") (defvar smtpmail-mail-address nil "Value to use for envelope-from address for mail from ambient buffer.") @@ -320,11 +319,11 @@ The list is in preference order.") (goto-char (1+ delimline)) (if (eval mail-mailer-swallows-blank-line) (newline)) - ;; Find and handle any FCC fields. + ;; Find and handle any Fcc fields. (goto-char (point-min)) - (if (re-search-forward "^FCC:" delimline t) + (if (re-search-forward "^Fcc:" delimline t) ;; Force `mail-do-fcc' to use the encoding of the mail - ;; buffer to encode outgoing messages on FCC files. + ;; buffer to encode outgoing messages on Fcc files. (let ((coding-system-for-write ;; mbox files must have Unix EOLs. (coding-system-change-eol-conversion @@ -359,9 +358,7 @@ The list is in preference order.") smtpmail-queue-dir)) (file-data (convert-standard-filename file-data)) (file-elisp (concat file-data ".el")) - (buffer-data (create-file-buffer file-data)) - (buffer-elisp (create-file-buffer file-elisp)) - (buffer-scratch "*queue-mail*")) + (buffer-data (create-file-buffer file-data))) (unless (file-exists-p smtpmail-queue-dir) (make-directory smtpmail-queue-dir t)) (with-current-buffer buffer-data @@ -376,22 +373,16 @@ The list is in preference order.") nil t) (insert-buffer-substring tembuf) (write-file file-data) - (set-buffer buffer-elisp) - (erase-buffer) - (insert (concat - "(setq smtpmail-recipient-address-list '" + (write-region + (concat "(setq smtpmail-recipient-address-list '" (prin1-to-string smtpmail-recipient-address-list) - ")\n")) - (write-file file-elisp) - (set-buffer (generate-new-buffer buffer-scratch)) - (insert (concat file-data "\n")) - (append-to-file (point-min) - (point-max) - (expand-file-name smtpmail-queue-index-file - smtpmail-queue-dir))) - (kill-buffer buffer-scratch) - (kill-buffer buffer-data) - (kill-buffer buffer-elisp)))) + ")\n") + nil file-elisp nil 'silent) + (write-region (concat file-data "\n") nil + (expand-file-name smtpmail-queue-index-file + smtpmail-queue-dir) + t 'silent)) + (kill-buffer buffer-data)))) (kill-buffer tembuf) (if (bufferp errbuf) (kill-buffer errbuf))))) @@ -412,7 +403,20 @@ The list is in preference order.") (while (not (eobp)) (setq file-data (buffer-substring (point) (line-end-position))) (setq file-elisp (concat file-data ".el")) - (load file-elisp) + ;; FIXME: Avoid `load' which can execute arbitrary code and is hence + ;; a source of security holes. Better read the file and extract the + ;; data "by hand". + ;;(load file-elisp) + (with-temp-buffer + (insert-file-contents file-elisp) + (goto-char (point-min)) + (pcase (read (current-buffer)) + (`(setq smtpmail-recipient-address-list ',v) + (skip-chars-forward " \n\t") + (unless (eobp) (message "Ignoring trailing text in %S" + file-elisp)) + (setq smtpmail-recipient-address-list v)) + (sexp (error "Unexpected code in %S: %S" file-elisp sexp)))) ;; Insert the message literally: it is already encoded as per ;; the MIME headers, and code conversions might guess the ;; encoding wrongly. @@ -510,8 +514,7 @@ The list is in preference order.") (user (plist-get auth-info :user)) (password (plist-get auth-info :secret)) (save-function (and ask-for-password - (plist-get auth-info :save-function))) - ret) + (plist-get auth-info :save-function)))) (when (functionp password) (setq password (funcall password))) (when (and user @@ -532,7 +535,10 @@ The list is in preference order.") (when (functionp password) (setq password (funcall password))) (let ((result (catch 'done - (smtpmail-try-auth-method process mech user password)))) + (if (and mech user password) + (smtpmail-try-auth-method process mech user password) + ;; No mechanism, or no credentials. + mech)))) (if (stringp result) (progn (auth-source-forget+ :host host :port port) @@ -541,51 +547,52 @@ The list is in preference order.") (funcall save-function)) result)))) -(defun smtpmail-try-auth-method (process mech user password) - (let (ret) - (cond - ((or (not mech) - (not user) - (not password)) - ;; No mechanism, or no credentials. - mech) - ((eq mech 'cram-md5) - (setq ret (smtpmail-command-or-throw process "AUTH CRAM-MD5")) - (when (eq (car ret) 334) - (let* ((challenge (substring (cadr ret) 4)) - (decoded (base64-decode-string challenge)) - (hash (rfc2104-hash 'md5 64 16 password decoded)) - (response (concat user " " hash)) - ;; Osamu Yamane <yamane@green.ocn.ne.jp>: - ;; SMTP auth fails because the SMTP server identifies - ;; only the first part of the string (delimited by - ;; new line characters) as a response from the - ;; client, and the rest as distinct commands. - - ;; In my case, the response string is 80 characters - ;; long. Without the no-line-break option for - ;; `base64-encode-string', only the first 76 characters - ;; are taken as a response to the server, and the - ;; authentication fails. - (encoded (base64-encode-string response t))) - (smtpmail-command-or-throw process encoded)))) - ((eq mech 'login) - (smtpmail-command-or-throw process "AUTH LOGIN") - (smtpmail-command-or-throw process (base64-encode-string user t)) - (smtpmail-command-or-throw process (base64-encode-string password t))) - ((eq mech 'plain) - ;; We used to send an empty initial request, and wait for an - ;; empty response, and then send the password, but this - ;; violate a SHOULD in RFC 2222 paragraph 5.1. Note that this - ;; is not sent if the server did not advertise AUTH PLAIN in - ;; the EHLO response. See RFC 2554 for more info. - (smtpmail-command-or-throw - process - (concat "AUTH PLAIN " - (base64-encode-string (concat "\0" user "\0" password) t)) - 235)) - (t - (error "Mechanism %s not implemented" mech))))) +(cl-defgeneric smtpmail-try-auth-method (_process mech _user _password) + "Perform authentication of type MECH for USER with PASSWORD. +MECH should be one of the values in `smtpmail-auth-supported'. +USER and PASSWORD should be non-nil." + (error "Mechanism %S not implemented" mech)) + +(cl-defmethod smtpmail-try-auth-method + (process (_mech (eql cram-md5)) user password) + (let ((ret (smtpmail-command-or-throw process "AUTH CRAM-MD5"))) + (when (eq (car ret) 334) + (let* ((challenge (substring (cadr ret) 4)) + (decoded (base64-decode-string challenge)) + (hash (rfc2104-hash 'md5 64 16 password decoded)) + (response (concat user " " hash)) + ;; Osamu Yamane <yamane@green.ocn.ne.jp>: + ;; SMTP auth fails because the SMTP server identifies + ;; only the first part of the string (delimited by + ;; new line characters) as a response from the + ;; client, and the rest as distinct commands. + + ;; In my case, the response string is 80 characters + ;; long. Without the no-line-break option for + ;; `base64-encode-string', only the first 76 characters + ;; are taken as a response to the server, and the + ;; authentication fails. + (encoded (base64-encode-string response t))) + (smtpmail-command-or-throw process encoded))))) + +(cl-defmethod smtpmail-try-auth-method + (process (_mech (eql login)) user password) + (smtpmail-command-or-throw process "AUTH LOGIN") + (smtpmail-command-or-throw process (base64-encode-string user t)) + (smtpmail-command-or-throw process (base64-encode-string password t))) + +(cl-defmethod smtpmail-try-auth-method + (process (_mech (eql plain)) user password) + ;; We used to send an empty initial request, and wait for an + ;; empty response, and then send the password, but this + ;; violate a SHOULD in RFC 2222 paragraph 5.1. Note that this + ;; is not sent if the server did not advertise AUTH PLAIN in + ;; the EHLO response. See RFC 2554 for more info. + (smtpmail-command-or-throw + process + (concat "AUTH PLAIN " + (base64-encode-string (concat "\0" user "\0" password) t)) + 235)) (defun smtpmail-response-code (string) (when string @@ -664,11 +671,16 @@ Returns an error if the server cannot be contacted." (and from (cadr (mail-extract-address-components from)))) (smtpmail-user-mail-address))) - response-code process-buffer result auth-mechanisms (supported-extensions '())) + + (when (and smtpmail-servers-requiring-authorization + (string-match-p smtpmail-servers-requiring-authorization + smtpmail-smtp-server)) + (setq ask-for-password t)) + (unwind-protect (catch 'done ;; get or create the trace buffer @@ -681,7 +693,9 @@ Returns an error if the server cannot be contacted." (setq buffer-undo-list t) (erase-buffer)) - ;; open the connection to the server + ;; Open the connection to the server. + ;; FIXME: Should we use raw-text-dos coding system to handle the r\n + ;; for us? (let ((coding-system-for-read 'binary) (coding-system-for-write 'binary)) (setq result @@ -718,9 +732,8 @@ Returns an error if the server cannot be contacted." (throw 'done (format "Connection not allowed: %s" greeting)))) (with-current-buffer process-buffer - (set-buffer-process-coding-system 'raw-text-unix 'raw-text-unix) - (make-local-variable 'smtpmail-read-point) - (setq smtpmail-read-point (point-min)) + (set-process-coding-system process 'raw-text-unix 'raw-text-unix) + (setq-local smtpmail-read-point (point-min)) (let* ((capabilities (plist-get (cdr result) :capabilities)) (code (smtpmail-response-code capabilities))) @@ -943,8 +956,7 @@ Returns an error if the server cannot be contacted." (if (and (multibyte-string-p data) smtpmail-code-conv-from) - (setq data (string-as-multibyte - (encode-coding-string data smtpmail-code-conv-from)))) + (setq data (encode-coding-string data smtpmail-code-conv-from))) (if smtpmail-debug-info (insert data "\r\n")) @@ -990,9 +1002,9 @@ Returns an error if the server cannot be contacted." ;; RESENT-* fields should stop processing of regular fields. (save-excursion (setq addr-regexp - (if (re-search-forward "^Resent-\\(to\\|cc\\|bcc\\):" + (if (re-search-forward "^Resent-\\(To\\|Cc\\|Bcc\\):" header-end t) - "^Resent-\\(to\\|cc\\|bcc\\):" + "^Resent-\\(To\\|Cc\\|Bcc\\):" "^\\(To:\\|Cc:\\|Bcc:\\)"))) (while (re-search-forward addr-regexp header-end t) @@ -1025,14 +1037,14 @@ Returns an error if the server cannot be contacted." (setq smtpmail-recipient-address-list recipient-address-list)))))) (defun smtpmail-do-bcc (header-end) - "Delete [Resent-]BCC: and their continuation lines from the header area. -There may be multiple BCC: lines, and each may have arbitrarily + "Delete [Resent-]Bcc: and their continuation lines from the header area. +There may be multiple Bcc: lines, and each may have arbitrarily many continuation lines." (let ((case-fold-search t)) (save-excursion (goto-char (point-min)) - ;; iterate over all BCC: lines - (while (re-search-forward "^\\(RESENT-\\)?BCC:" header-end t) + ;; iterate over all Bcc: lines + (while (re-search-forward "^\\(RESENT-\\)?Bcc:" header-end t) (delete-region (match-beginning 0) (progn (forward-line 1) (point))) ;; get rid of any continuation lines diff --git a/lisp/mail/supercite.el b/lisp/mail/supercite.el index 4809c33abc4..ce00a7cf665 100644 --- a/lisp/mail/supercite.el +++ b/lisp/mail/supercite.el @@ -634,12 +634,7 @@ the list should be unique." (deallocate-event event)) (setq quit-flag nil) (signal 'quit '()))) - (let ((char - (if (featurep 'xemacs) - (let* ((key (and (key-press-event-p event) (event-key event))) - (char (and key (event-to-character event)))) - char) - event)) + (let ((char event) elt) (if char (setq char (downcase char))) (cond @@ -651,9 +646,7 @@ the list should be unique." nil) (t (message "%s%s" p (single-key-description event)) - (if (featurep 'xemacs) - (ding nil 'y-or-n-p) - (ding)) + (ding) (discard-input) (if (eq p prompt) (setq p (concat "Try again. " prompt))))))) @@ -709,7 +702,11 @@ the list should be unique." "Regi frame for glomming mail header information.") (put 'sc-mail-glom-frame 'risky-local-variable t) -(defvar curline) ; dynamic bondage +;; This variable is bound dynamically before calling the forms in the +;; `sc-mail-glom-frame' variable, and is part of the advertised +;; interface. +(with-suppressed-warnings ((lexical curline)) + (defvar curline)) ;; regi functions @@ -1887,8 +1884,7 @@ and `sc-post-hook' is run after the guts of this function." ;; grab point and mark since the region is probably not active when ;; this function gets automatically called. we want point to be a ;; mark so any deleting before point works properly - (let* ((zmacs-regions nil) ; for XEemacs - (mark-active t) ; for Emacs + (let* ((mark-active t) (point (point-marker)) (mark (copy-marker (mark-marker)))) diff --git a/lisp/mail/uce.el b/lisp/mail/uce.el index d0837d90ea1..7225cda6c0e 100644 --- a/lisp/mail/uce.el +++ b/lisp/mail/uce.el @@ -338,7 +338,7 @@ You might need to set `uce-mail-reader' before using this." (if mail-default-headers (insert mail-default-headers)) (if mail-default-reply-to - (insert "Reply-to: " mail-default-reply-to "\n")) + (insert "Reply-To: " mail-default-reply-to "\n")) (insert mail-header-separator "\n") ;; Insert all our text. Then go back to the place where we started. (if to (setq to (point))) diff --git a/lisp/mail/uudecode.el b/lisp/mail/uudecode.el index a78202938e4..9ccdceeeb3f 100644 --- a/lisp/mail/uudecode.el +++ b/lisp/mail/uudecode.el @@ -1,4 +1,4 @@ -;;; uudecode.el -- elisp native uudecode +;;; uudecode.el -- elisp native uudecode -*- lexical-binding:t -*- ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. @@ -24,13 +24,10 @@ ;;; Code: -(eval-when-compile (require 'cl)) - -(eval-and-compile - (defalias 'uudecode-char-int - (if (fboundp 'char-int) - 'char-int - 'identity))) +(defalias 'uudecode-char-int + (if (fboundp 'char-int) + 'char-int + 'identity)) (defgroup uudecode nil "Decoding of uuencoded data." @@ -41,19 +38,16 @@ "Non-nil value should be a string that names a uu decoder. The program should expect to read uu data on its standard input and write the converted data to its standard output." - :type 'string - :group 'uudecode) + :type 'string) (defcustom uudecode-decoder-switches nil "List of command line flags passed to `uudecode-decoder-program'." - :group 'uudecode :type '(repeat string)) (defcustom uudecode-use-external (executable-find uudecode-decoder-program) "Use external uudecode program." :version "22.1" - :group 'uudecode :type 'boolean) (defconst uudecode-alphabet "\040-\140") @@ -78,7 +72,7 @@ input and write the converted data to its standard output." If FILE-NAME is non-nil, save the result to FILE-NAME. The program used is specified by `uudecode-decoder-program'." (interactive "r\nP") - (let ((cbuf (current-buffer)) tempfile firstline status) + (let ((cbuf (current-buffer)) tempfile firstline) (save-excursion (goto-char start) (when (re-search-forward uudecode-begin-line nil t) @@ -100,17 +94,13 @@ used is specified by `uudecode-decoder-program'." (make-temp-name "uu") uudecode-temporary-file-directory)))) (let ((cdir default-directory) - (default-process-coding-system - (if (featurep 'xemacs) - ;; In XEmacs, nil is not a valid coding system. - '(binary . binary) - nil))) + (default-process-coding-system nil)) (unwind-protect (with-temp-buffer (insert "begin 600 " (file-name-nondirectory tempfile) "\n") (insert-buffer-substring cbuf firstline end) (cd (file-name-directory tempfile)) - (apply 'call-process-region + (apply #'call-process-region (point-min) (point-max) uudecode-decoder-program @@ -128,20 +118,6 @@ used is specified by `uudecode-decoder-program'." (message "Can not uudecode"))) (ignore-errors (or file-name (delete-file tempfile)))))) -(eval-and-compile - (defalias 'uudecode-string-to-multibyte - (cond - ((featurep 'xemacs) - 'identity) - ((fboundp 'string-to-multibyte) - 'string-to-multibyte) - (t - (lambda (string) - "Return a multibyte string with the same individual chars as string." - (mapconcat - (lambda (ch) (string-as-multibyte (char-to-string ch))) - string "")))))) - ;;;###autoload (defun uudecode-decode-region-internal (start end &optional file-name) "Uudecode region between START and END without using an external program. @@ -188,12 +164,12 @@ If FILE-NAME is non-nil, save the result to FILE-NAME." (cond ((= counter 4) (setq result (cons (concat - (char-to-string (lsh bits -16)) - (char-to-string (logand (lsh bits -8) 255)) + (char-to-string (ash bits -16)) + (char-to-string (logand (ash bits -8) 255)) (char-to-string (logand bits 255))) result)) (setq bits 0 counter 0)) - (t (setq bits (lsh bits 6))))))) + (t (setq bits (ash bits 6))))))) (cond (done) ((> 0 remain) @@ -205,24 +181,24 @@ If FILE-NAME is non-nil, save the result to FILE-NAME." ((= counter 3) (setq result (cons (concat - (char-to-string (logand (lsh bits -16) 255)) - (char-to-string (logand (lsh bits -8) 255))) + (char-to-string (logand (ash bits -16) 255)) + (char-to-string (logand (ash bits -8) 255))) result))) ((= counter 2) (setq result (cons - (char-to-string (logand (lsh bits -10) 255)) + (char-to-string (logand (ash bits -10) 255)) result)))) (skip-chars-forward non-data-chars end)) (if file-name (with-temp-file file-name - (unless (featurep 'xemacs) (set-buffer-multibyte nil)) - (insert (apply 'concat (nreverse result)))) + (set-buffer-multibyte nil) + (insert (apply #'concat (nreverse result)))) (or (markerp end) (setq end (set-marker (make-marker) end))) (goto-char start) (if enable-multibyte-characters (dolist (x (nreverse result)) - (insert (uudecode-string-to-multibyte x))) - (insert (apply 'concat (nreverse result)))) + (insert (decode-coding-string x 'binary))) + (insert (apply #'concat (nreverse result)))) (delete-region (point) end)))))) ;;;###autoload diff --git a/lisp/mail/yenc.el b/lisp/mail/yenc.el index f7a12d6c9e2..75b62c14117 100644 --- a/lisp/mail/yenc.el +++ b/lisp/mail/yenc.el @@ -1,4 +1,4 @@ -;;; yenc.el --- elisp native yenc decoder +;;; yenc.el --- elisp native yenc decoder -*- lexical-binding:t -*- ;; Copyright (C) 2002-2019 Free Software Foundation, Inc. @@ -32,7 +32,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defconst yenc-begin-line "^=ybegin.*$") @@ -97,14 +97,14 @@ (cond ((or (eq char ?\r) (eq char ?\n))) ((eq char ?=) - (setq char (char-after (incf first))) + (setq char (char-after (cl-incf first))) (with-current-buffer work-buffer (insert-char (mod (- char 106) 256) 1))) (t (with-current-buffer work-buffer ;;(insert-char (mod (- char 42) 256) 1) (insert-char (aref yenc-decoding-vector char) 1)))) - (incf first)) + (cl-incf first)) (setq bytes (buffer-size work-buffer)) (unless (and (= (cdr (assq 'size header-alist)) bytes) (= (cdr (assq 'size footer-alist)) bytes)) diff --git a/lisp/makesum.el b/lisp/makesum.el index 10ad78ea174..50f5d63871f 100644 --- a/lisp/makesum.el +++ b/lisp/makesum.el @@ -1,4 +1,4 @@ -;;; makesum.el --- generate key binding summary for Emacs +;;; makesum.el --- generate key binding summary for Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1985, 2001-2019 Free Software Foundation, Inc. @@ -59,15 +59,14 @@ Previous contents of that buffer are killed first." (while (search-forward "C-i" nil t) (replace-match "TAB")) (goto-char (point-min)) - (if (re-search-forward "^Local Bindings:" nil t) - (progn - (forward-char -1) - (insert " for " (format-mode-line cur-mode) " Mode") - (while (search-forward "??\n" nil t) - (delete-region (point) - (progn - (forward-line -1) - (point)))))) + (when (re-search-forward "^Local Bindings:" nil t) + (forward-char -1) + (insert " for " (format-mode-line cur-mode) " Mode") + (while (search-forward "??\n" nil t) + (delete-region (point) + (progn + (forward-line -1) + (point))))) (goto-char (point-min)) (insert "Emacs command summary, " (substring (current-time-string) 0 10) ".\n") @@ -84,28 +83,25 @@ Previous contents of that buffer are killed first." (message "Making command summary...done")) (defun double-column (start end) + "Reformat buffer contents from START to END into two columns." (interactive "r") - (let (half line lines nlines + (let (half lines + (nlines (count-lines start end)) (from-end (- (point-max) end))) - (setq nlines (count-lines start end)) - (if (<= nlines 1) - nil + (when (> nlines 1) (setq half (/ (1+ nlines) 2)) (goto-char start) (save-excursion (forward-line half) - (while (< half nlines) - (setq half (1+ half)) - (setq line (buffer-substring (point) (line-end-position))) - (setq lines (cons line lines)) + (dotimes (_ (- nlines half)) + (push (buffer-substring (point) (line-end-position)) + lines) (delete-region (point) (progn (forward-line 1) (point))))) - (setq lines (nreverse lines)) - (while lines - (end-of-line) + (dolist (line (nreverse lines)) + (end-of-line) (indent-to 41) - (insert (car lines)) - (forward-line 1) - (setq lines (cdr lines)))) + (insert line) + (forward-line 1))) (goto-char (- (point-max) from-end)))) (provide 'makesum) diff --git a/lisp/man.el b/lisp/man.el index 409fadb66b8..d52ca2156d2 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -1157,7 +1157,7 @@ See the variable `Man-notify-method' for the different notification behaviors." (let ((saved-frame (with-current-buffer man-buffer Man-original-frame))) (pcase Man-notify-method - (`newframe + ('newframe ;; Since we run asynchronously, perhaps while Emacs is waiting ;; for input, we must not leave a different buffer current. We ;; can't rely on the editor command loop to reselect the @@ -1168,25 +1168,25 @@ See the variable `Man-notify-method' for the different notification behaviors." (set-window-dedicated-p (frame-selected-window frame) t) (or (display-multi-frame-p frame) (select-frame frame))))) - (`pushy + ('pushy (switch-to-buffer man-buffer)) - (`bully + ('bully (and (frame-live-p saved-frame) (select-frame saved-frame)) (pop-to-buffer man-buffer) (delete-other-windows)) - (`aggressive + ('aggressive (and (frame-live-p saved-frame) (select-frame saved-frame)) (pop-to-buffer man-buffer)) - (`friendly + ('friendly (and (frame-live-p saved-frame) (select-frame saved-frame)) (display-buffer man-buffer 'not-this-window)) - (`polite + ('polite (beep) (message "Manual buffer %s is ready" (buffer-name man-buffer))) - (`quiet + ('quiet (message "Manual buffer %s is ready" (buffer-name man-buffer))) (_ ;; meek (message "")) @@ -1206,10 +1206,7 @@ Same for the ANSI bold and normal escape sequences." (interactive) (goto-char (point-min)) ;; Fontify ANSI escapes. - (let ((ansi-color-apply-face-function - (lambda (beg end face) - (when face - (put-text-property beg end 'face face)))) + (let ((ansi-color-apply-face-function #'ansi-color-apply-text-property-face) (ansi-color-map Man-ansi-color-map)) (ansi-color-apply-on-region (point-min) (point-max))) ;; Other highlighting. @@ -1220,31 +1217,33 @@ Same for the ANSI bold and normal escape sequences." (goto-char (point-min)) (while (and (search-forward "__\b\b" nil t) (not (eobp))) (backward-delete-char 4) - (put-text-property (point) (1+ (point)) 'face 'Man-underline)) + (put-text-property (point) (1+ (point)) + 'font-lock-face 'Man-underline)) (goto-char (point-min)) (while (search-forward "\b\b__" nil t) (backward-delete-char 4) - (put-text-property (1- (point)) (point) 'face 'Man-underline)))) + (put-text-property (1- (point)) (point) + 'font-lock-face 'Man-underline)))) (goto-char (point-min)) (while (and (search-forward "_\b" nil t) (not (eobp))) (backward-delete-char 2) - (put-text-property (point) (1+ (point)) 'face 'Man-underline)) + (put-text-property (point) (1+ (point)) 'font-lock-face 'Man-underline)) (goto-char (point-min)) (while (search-forward "\b_" nil t) (backward-delete-char 2) - (put-text-property (1- (point)) (point) 'face 'Man-underline)) + (put-text-property (1- (point)) (point) 'font-lock-face 'Man-underline)) (goto-char (point-min)) (while (re-search-forward "\\(.\\)\\(\b+\\1\\)+" nil t) (replace-match "\\1") - (put-text-property (1- (point)) (point) 'face 'Man-overstrike)) + (put-text-property (1- (point)) (point) 'font-lock-face 'Man-overstrike)) (goto-char (point-min)) (while (re-search-forward "o\b\\+\\|\\+\bo" nil t) (replace-match "o") - (put-text-property (1- (point)) (point) 'face 'bold)) + (put-text-property (1- (point)) (point) 'font-lock-face 'bold)) (goto-char (point-min)) (while (re-search-forward "[-|]\\(\b[-|]\\)+" nil t) (replace-match "+") - (put-text-property (1- (point)) (point) 'face 'bold)) + (put-text-property (1- (point)) (point) 'font-lock-face 'bold)) ;; When the header is longer than the manpage name, groff tries to ;; condense it to a shorter line interspersed with ^H. Remove ^H with ;; their preceding chars (but don't put Man-overstrike). (Bug#5566) @@ -1258,7 +1257,7 @@ Same for the ANSI bold and normal escape sequences." (while (re-search-forward Man-heading-regexp nil t) (put-text-property (match-beginning 0) (match-end 0) - 'face 'Man-overstrike)))) + 'font-lock-face 'Man-overstrike)))) (defun Man-highlight-references (&optional xref-man-type) "Highlight the references on mouse-over. @@ -1538,16 +1537,16 @@ The following key bindings are currently in effect in the buffer: (set (make-local-variable 'bookmark-make-record-function) 'Man-bookmark-make-record)) -(defsubst Man-build-section-alist () +(defun Man-build-section-list () "Build the list of manpage sections." - (setq Man--sections nil) + (setq Man--sections ()) (goto-char (point-min)) (let ((case-fold-search nil)) - (while (re-search-forward Man-heading-regexp (point-max) t) + (while (re-search-forward Man-heading-regexp nil t) (let ((section (match-string 1))) (unless (member section Man--sections) (push section Man--sections))) - (forward-line 1))) + (forward-line))) (setq Man--sections (nreverse Man--sections))) (defsubst Man-build-references-alist () @@ -1828,7 +1827,7 @@ Specify which REFERENCE to use; default is based on word at point." (widen) (goto-char page-start) (narrow-to-region page-start page-end) - (Man-build-section-alist) + (Man-build-section-list) (Man-build-references-alist) (goto-char (point-min))))) diff --git a/lisp/master.el b/lisp/master.el index 671b3357a93..36384a8df07 100644 --- a/lisp/master.el +++ b/lisp/master.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. ;; Author: Alex Schroeder <alex@gnu.org> -;; Maintainer: Alex Schroeder <alex@gnu.org> ;; Version: 1.0.2 ;; Keywords: comm @@ -73,9 +72,6 @@ You can set this variable using `master-set-slave'.") ;;;###autoload (define-minor-mode master-mode "Toggle Master mode. -With a prefix argument ARG, enable Master mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. When Master mode is enabled, you can scroll the slave buffer using the following commands: diff --git a/lisp/mb-depth.el b/lisp/mb-depth.el index 9fecd47b611..61673ee8562 100644 --- a/lisp/mb-depth.el +++ b/lisp/mb-depth.el @@ -58,9 +58,6 @@ The prompt should already have been inserted." ;;;###autoload (define-minor-mode minibuffer-depth-indicate-mode "Toggle Minibuffer Depth Indication mode. -With a prefix argument ARG, enable Minibuffer Depth Indication -mode if ARG is positive, and disable it otherwise. If called -from Lisp, enable the mode if ARG is omitted or nil. Minibuffer Depth Indication mode is a global minor mode. When enabled, any recursive use of the minibuffer will show the diff --git a/lisp/md4.el b/lisp/md4.el index ef15e2ce907..7091c206893 100644 --- a/lisp/md4.el +++ b/lisp/md4.el @@ -91,15 +91,15 @@ strings containing the character 0." (let* ((h1 (+ (car a) (,func (car b) (car c) (car d)) (car xk) (car ac))) (l1 (+ (cdr a) (,func (cdr b) (cdr c) (cdr d)) (cdr xk) (cdr ac))) - (h2 (logand 65535 (+ h1 (lsh l1 -16)))) + (h2 (logand 65535 (+ h1 (ash l1 -16)))) (l2 (logand 65535 l1)) ;; cyclic shift of 32 bits integer (h3 (logand 65535 (if (> s 15) - (+ (lsh h2 (- s 32)) (lsh l2 (- s 16))) - (+ (lsh h2 s) (lsh l2 (- s 16)))))) + (+ (ash h2 (- s 32)) (ash l2 (- s 16))) + (+ (ash h2 s) (ash l2 (- s 16)))))) (l3 (logand 65535 (if (> s 15) - (+ (lsh l2 (- s 32)) (lsh h2 (- s 16))) - (+ (lsh l2 s) (lsh h2 (- s 16))))))) + (+ (ash l2 (- s 32)) (ash h2 (- s 16))) + (+ (ash l2 s) (ash h2 (- s 16))))))) (cons h3 l3)))) (md4-make-step md4-round1 md4-F) @@ -110,7 +110,7 @@ strings containing the character 0." "Return 32-bit sum of 32-bit integers X and Y." (let ((h (+ (car x) (car y))) (l (+ (cdr x) (cdr y)))) - (cons (logand 65535 (+ h (lsh l -16))) (logand 65535 l)))) + (cons (logand 65535 (+ h (ash l -16))) (logand 65535 l)))) (defsubst md4-and (x y) (cons (logand (car x) (car y)) (logand (cdr x) (cdr y)))) @@ -185,8 +185,8 @@ The resulting MD4 value is placed in `md4-buffer'." (let ((int32s (make-vector 16 0)) (i 0) j) (while (< i 16) (setq j (* i 4)) - (aset int32s i (cons (+ (aref seq (+ j 2)) (lsh (aref seq (+ j 3)) 8)) - (+ (aref seq j) (lsh (aref seq (1+ j)) 8)))) + (aset int32s i (cons (+ (aref seq (+ j 2)) (ash (aref seq (+ j 3)) 8)) + (+ (aref seq j) (ash (aref seq (1+ j)) 8)))) (setq i (1+ i))) int32s)) @@ -197,7 +197,7 @@ The resulting MD4 value is placed in `md4-buffer'." "Pack 16 bits integer in 2 bytes string as little endian." (let ((str (make-string 2 0))) (aset str 0 (logand int16 255)) - (aset str 1 (lsh int16 -8)) + (aset str 1 (ash int16 -8)) str)) (defun md4-pack-int32 (int32) @@ -207,20 +207,20 @@ integers (cons high low)." (let ((str (make-string 4 0)) (h (car int32)) (l (cdr int32))) (aset str 0 (logand l 255)) - (aset str 1 (lsh l -8)) + (aset str 1 (ash l -8)) (aset str 2 (logand h 255)) - (aset str 3 (lsh h -8)) + (aset str 3 (ash h -8)) str)) (defun md4-unpack-int16 (str) (if (eq 2 (length str)) - (+ (lsh (aref str 1) 8) (aref str 0)) + (+ (ash (aref str 1) 8) (aref str 0)) (error "%s is not 2 bytes long" str))) (defun md4-unpack-int32 (str) (if (eq 4 (length str)) - (cons (+ (lsh (aref str 3) 8) (aref str 2)) - (+ (lsh (aref str 1) 8) (aref str 0))) + (cons (+ (ash (aref str 3) 8) (aref str 2)) + (+ (ash (aref str 1) 8) (aref str 0))) (error "%s is not 4 bytes long" str))) (provide 'md4) diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index 82023cbaa08..389234e9751 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -277,6 +277,15 @@ ;; The Edit->Search->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] + '(menu-item "Forward Symbol at Point..." isearch-forward-symbol-at-point + :help "Search forward for a symbol found at point")) + (bindings--define-key menu [isearch-forward-symbol] + '(menu-item "Forward Symbol..." isearch-forward-symbol + :help "Search forward for a symbol as you type it")) + (bindings--define-key menu [isearch-forward-word] + '(menu-item "Forward Word..." isearch-forward-word + :help "Search forward for a word as you type it")) (bindings--define-key menu [isearch-backward-regexp] '(menu-item "Backward Regexp..." isearch-backward-regexp :help "Search backwards for a regular expression as you type it")) @@ -300,7 +309,7 @@ menu-bar-separator) (bindings--define-key menu [tags-continue] - '(menu-item "Continue Tags Search" tags-loop-continue + '(menu-item "Continue Tags Search" fileloop-continue :help "Continue last tags search operation")) (bindings--define-key menu [tags-srch] '(menu-item "Search Tagged Files..." tags-search @@ -349,7 +358,7 @@ (defvar menu-bar-replace-menu (let ((menu (make-sparse-keymap "Replace"))) (bindings--define-key menu [tags-repl-continue] - '(menu-item "Continue Replace" tags-loop-continue + '(menu-item "Continue Replace" fileloop-continue :help "Continue last tags replace operation")) (bindings--define-key menu [tags-repl] '(menu-item "Replace in Tagged Files..." tags-query-replace @@ -423,15 +432,15 @@ (let ((menu (make-sparse-keymap "Edit"))) (bindings--define-key menu [props] - `(menu-item "Text Properties" facemenu-menu)) + '(menu-item "Text Properties" facemenu-menu)) ;; ns-win.el said: Add spell for platform consistency. (if (featurep 'ns) (bindings--define-key menu [spell] - `(menu-item "Spell" ispell-menu-map))) + '(menu-item "Spell" ispell-menu-map))) (bindings--define-key menu [fill] - `(menu-item "Fill" fill-region + '(menu-item "Fill" fill-region :enable (and mark-active (not buffer-read-only)) :help "Fill text in region to fit between left and right margin")) @@ -440,7 +449,7 @@ menu-bar-separator) (bindings--define-key menu [bookmark] - `(menu-item "Bookmarks" menu-bar-bookmark-map)) + '(menu-item "Bookmarks" menu-bar-bookmark-map)) (bindings--define-key menu [goto] `(menu-item "Go To" ,menu-bar-goto-menu)) @@ -1379,11 +1388,7 @@ mail status in mode line")) ;; It is better not to use backquote here, ;; because that makes a bootstrapping problem ;; if you need to recompile all the Lisp files using interpreted code. - `(menu-item "Multilingual Environment" ,mule-menu-keymap - ;; Most of the MULE menu actually does make sense in - ;; unibyte mode, e.g. language selection. - ;; :visible '(default-value 'enable-multibyte-characters) - )) + `(menu-item "Multilingual Environment" ,mule-menu-keymap)) ;;(setq menu-bar-final-items (cons 'mule menu-bar-final-items)) ;;(bindings--define-key menu [preferences] ;; `(menu-item "Preferences" ,menu-bar-preferences-menu @@ -1697,18 +1702,14 @@ mail status in mode line")) (bindings--define-key menu [mule-diag] '(menu-item "Show All of Mule Status" mule-diag - :visible (default-value 'enable-multibyte-characters) :help "Display multilingual environment settings")) (bindings--define-key menu [describe-coding-system-briefly] '(menu-item "Describe Coding System (Briefly)" - describe-current-coding-system-briefly - :visible (default-value 'enable-multibyte-characters))) + describe-current-coding-system-briefly)) (bindings--define-key menu [describe-coding-system] - '(menu-item "Describe Coding System..." describe-coding-system - :visible (default-value 'enable-multibyte-characters))) + '(menu-item "Describe Coding System..." describe-coding-system)) (bindings--define-key menu [describe-input-method] '(menu-item "Describe Input Method..." describe-input-method - :visible (default-value 'enable-multibyte-characters) :help "Keyboard layout for specific input method")) (bindings--define-key menu [describe-language-environment] `(menu-item "Describe Language Environment" @@ -2143,9 +2144,9 @@ It must accept a buffer as its only required argument.") ;; Make the menu of buffers proper. (setq buffers-menu (let ((i 0) - (limit (if (and (integerp buffers-menu-max-size) - (> buffers-menu-max-size 1)) - buffers-menu-max-size most-positive-fixnum)) + (limit (and (integerp buffers-menu-max-size) + (> buffers-menu-max-size 1) + buffers-menu-max-size)) alist) ;; Put into each element of buffer-list ;; the name for actual display, @@ -2169,7 +2170,7 @@ It must accept a buffer as its only required argument.") alist) ;; If requested, list only the N most recently ;; selected buffers. - (when (= limit (setq i (1+ i))) + (when (eql limit (setq i (1+ i))) (setq buffers nil))))) (list (menu-bar-buffer-vector alist)))) @@ -2293,9 +2294,6 @@ It must accept a buffer as its only required argument.") (define-minor-mode menu-bar-mode "Toggle display of a menu bar on each frame (Menu Bar mode). -With a prefix argument ARG, enable Menu Bar mode if ARG is -positive, and disable it otherwise. If called from Lisp, also -enable Menu Bar mode if ARG is omitted or nil. This command applies to all frames that exist and frames to be created in the future." @@ -2364,6 +2362,7 @@ FROM-MENU-BAR, if non-nil, means we are dropping one of menu-bar's menus." (let* ((map (cond ((keymapp menu) menu) ((and (listp menu) (keymapp (car menu))) menu) + ((not (listp menu)) nil) (t (let* ((map (easy-menu-create-menu (car menu) (cdr menu))) (filter (when (symbolp map) (plist-get (get map 'menu-prop) :filter)))) @@ -2432,7 +2431,7 @@ form ((XOFFSET YOFFSET) WINDOW), or nil. If nil, the current mouse position is used, or nil if there is no mouse." (pcase position ;; nil -> mouse cursor position - (`nil + ('nil (let ((mp (mouse-pixel-position))) (list (list (cadr mp) (cddr mp)) (car mp)))) ;; Value returned from `event-end' or `posn-at-point'. @@ -2461,9 +2460,12 @@ first (leftmost) menu-bar item; you can select other items by typing This is meant to be used only for debugging TTY menus.") -(defun menu-bar-open (&optional frame) +(defun menu-bar-open (&optional frame initial-x) "Start key navigation of the menu bar in FRAME. +Optional argument INITIAL-X gives the X coordinate of the +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 @@ -2471,7 +2473,8 @@ 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) + (interactive + (list nil (prefix-numeric-value current-prefix-arg))) (let ((type (framep (or frame (selected-frame))))) (cond ((eq type 'x) (x-menu-bar-open frame)) @@ -2484,7 +2487,7 @@ If FRAME is nil or not given, use the selected frame." ;; menu item that should be removed when we exit the minibuffer. (force-mode-line-update) (redisplay) - (let* ((x tty-menu--initial-menu-x) + (let* ((x (max initial-x tty-menu--initial-menu-x)) (menu (menu-bar-menu-at-x-y x 0 frame))) (popup-menu (or (lookup-key-ignore-too-long diff --git a/lisp/mh-e/mh-acros.el b/lisp/mh-e/mh-acros.el index ce5c7a65929..3bbf509989d 100644 --- a/lisp/mh-e/mh-acros.el +++ b/lisp/mh-e/mh-acros.el @@ -61,8 +61,8 @@ particular, the expansion of (setf (gethash ...) ...) used functions in \"cl\" at run time. This macro recognizes that and loads \"cl\" appropriately." (if (eq (car (macroexpand '(setf (gethash foo bar) baz))) 'cl-puthash) - `(require 'cl) - `(eval-when-compile (require 'cl)))) + '(require 'cl) + '(eval-when-compile (require 'cl)))) ;;;###mh-autoload (defmacro mh-do-in-gnu-emacs (&rest body) @@ -90,9 +90,10 @@ loads \"cl\" appropriately." "Create function NAME. If FUNCTION exists, then NAME becomes an alias for FUNCTION. Otherwise, create function NAME with ARG-LIST and BODY." - `(if (fboundp ',function) - (defalias ',name ',function) - (defun ,name ,arg-list ,@body))) + `(defalias ',name + (if (fboundp ',function) + ',function + (lambda ,arg-list ,@body)))) (put 'defun-mh 'lisp-indent-function 'defun) (put 'defun-mh 'doc-string-elt 4) @@ -127,11 +128,11 @@ XEmacs and versions of GNU Emacs before 21.1 require 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))) + '(and (boundp 'zmacs-regions) zmacs-regions (region-active-p))) ((not check-transient-mark-mode-flag) ;GNU Emacs - `(and (boundp 'mark-active) mark-active)) + '(and (boundp 'mark-active) mark-active)) (t ;GNU Emacs - `(and (boundp 'transient-mark-mode) transient-mark-mode + '(and (boundp 'transient-mark-mode) transient-mark-mode (boundp 'mark-active) mark-active)))) ;; Shush compiler. @@ -142,6 +143,8 @@ check if variable `transient-mark-mode' is active." ;;;###mh-autoload (defmacro mh-defstruct (name-spec &rest fields) + ;; FIXME: Use `cl-defstruct' instead: shouldn't emit warnings any + ;; more nor depend on run-time CL functions. "Replacement for `defstruct' from the \"cl\" package. The `defstruct' in the \"cl\" library produces compiler warnings, and generates code that uses functions present in \"cl\" at @@ -159,15 +162,17 @@ more details." (constructor (or (and (consp name-spec) (cadr (assoc :constructor (cdr name-spec)))) (intern (format "make-%s" struct-name)))) - (field-names (mapcar #'(lambda (x) (if (atom x) x (car x))) fields)) - (field-init-forms (mapcar #'(lambda (x) (and (consp x) (cadr x))) - fields)) + (fields (mapcar (lambda (x) + (if (atom x) + (list x nil) + (list (car x) (cadr x)))) + fields)) + (field-names (mapcar #'car fields)) (struct (gensym "S")) (x (gensym "X")) (y (gensym "Y"))) `(progn - (defun* ,constructor (&key ,@(mapcar* #'(lambda (x y) (list x y)) - field-names field-init-forms)) + (defun* ,constructor (&key ,@fields) (list (quote ,struct-name) ,@field-names)) (defun ,predicate (arg) (and (consp arg) (eq (car arg) (quote ,struct-name)))) diff --git a/lisp/mh-e/mh-alias.el b/lisp/mh-e/mh-alias.el index 7b44db60378..c6cdfc40c94 100644 --- a/lisp/mh-e/mh-alias.el +++ b/lisp/mh-e/mh-alias.el @@ -78,10 +78,9 @@ If ARG is non-nil, set timestamp with the current time." (function (lambda (file) (when (and file (file-exists-p file)) - (setq stamp (nth 5 (file-attributes file))) - (or (> (car stamp) (car mh-alias-tstamp)) - (and (= (car stamp) (car mh-alias-tstamp)) - (> (cadr stamp) (cadr mh-alias-tstamp))))))) + (setq stamp (file-attribute-modification-time + (file-attributes file))) + (time-less-p mh-alias-tstamp stamp)))) (mh-alias-filenames t))))))) (defun mh-alias-filenames (arg) @@ -339,7 +338,7 @@ NO-COMMA-SWAP is non-nil." ;; Two words -> first.last (downcase (format "%s.%s" (match-string 1 string) (match-string 2 string)))) - ((string-match "^\\([-a-zA-Z0-9._]+\\)@[-a-zA-z0-9_]+\\.+[a-zA-Z0-9]+$" + ((string-match "^\\([-a-zA-Z0-9._]+\\)@[-a-zA-Z0-9_]+\\.+[a-zA-Z0-9]+$" string) ;; email only -> downcase username (downcase (match-string 1 string))) diff --git a/lisp/mh-e/mh-buffers.el b/lisp/mh-e/mh-buffers.el index 3c0c481495e..13a1901b69f 100644 --- a/lisp/mh-e/mh-buffers.el +++ b/lisp/mh-e/mh-buffers.el @@ -4,7 +4,6 @@ ;; Inc. ;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> ;; Keywords: mail ;; See: mh-e.el diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el index c51052dc3f4..a5614f52550 100644 --- a/lisp/mh-e/mh-comp.el +++ b/lisp/mh-e/mh-comp.el @@ -4,7 +4,6 @@ ;; Inc. ;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> ;; Keywords: mail ;; See: mh-e.el @@ -77,6 +76,14 @@ Default is \"components\". If not an absolute file name, the file is searched for first in the user's MH directory, then in the system MH lib directory.") +(defvar mh-dist-formfile "distcomps" + "Name of file to be used as a skeleton for redistributing messages. + +Default is \"distcomps\". + +If not an absolute file name, the file is searched for first in the +user's MH directory, then in the system MH lib directory.") + (defvar mh-repl-formfile "replcomps" "Name of file to be used as a skeleton for replying to messages. @@ -305,24 +312,26 @@ message and scan line." (file-name buffer-file-name) (config mh-previous-window-config) (coding-system-for-write - (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)) - 'iso-latin-1)))) + (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)) + 'iso-latin-1))))) ;; 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 ;; message in your +outbox, and best of all doesn't break threading for ;; the recipient if you reply to a message in your +outbox. (setq mh-send-args (concat "-msgid " mh-send-args)) - ;; The default BCC encapsulation will make a MIME message unreadable. + ;; The default Bcc encapsulation will make a MIME message unreadable. ;; With nmh use the -mime arg to prevent this. (if (and (mh-variant-p 'nmh) (mh-goto-header-field "Bcc:") @@ -411,7 +420,7 @@ See also `mh-send'." (interactive (list (mh-get-msg-num t))) (let* ((from-folder mh-current-folder) (config (current-window-configuration)) - (components-file (mh-bare-components)) + (components-file (mh-bare-components mh-comp-formfile)) (draft (cond ((and mh-draft-folder (equal from-folder mh-draft-folder)) (pop-to-buffer (find-file-noselect (mh-msg-filename message)) @@ -602,7 +611,7 @@ See also `mh-compose-forward-as-mime-flag', (goto-char (mh-mail-header-end)) (while (re-search-forward - "^#forw \\[\\([^]]+\\)\\] \\(+\\S-+\\) \\(.*\\)$" + "^#forw \\[\\([^]]+\\)\\] \\(\\+\\S-+\\) \\(.*\\)$" (point-max) t) (let ((description (if (equal (match-string 1) "forwarded messages") @@ -647,15 +656,16 @@ Original message has headers FROM and SUBJECT." (format mh-forward-subject-format from subject)) ;;;###mh-autoload -(defun mh-redistribute (to cc &optional message) +(defun mh-redistribute (to cc identity &optional message) "Redistribute a message. This command is similar in function to forwarding mail, but it does not allow you to edit the message, nor does it add your name to the \"From\" header field. It appears to the recipient as if the message had come from the original sender. When you run this -command, you are prompted for the TO and CC recipients. The -default MESSAGE is the current message. +command, you are prompted for the TO and CC recipients. You are +also prompted for the sending IDENTITY to use. The default +MESSAGE is the current message. Also investigate the command \\[mh-edit-again] for another way to redistribute messages. @@ -666,6 +676,9 @@ The hook `mh-annotate-msg-hook' is run after annotating the message and scan line." (interactive (list (mh-read-address "Redist-To: ") (mh-read-address "Redist-Cc: ") + (if mh-identity-list + (mh-select-identity mh-identity-default) + nil) (mh-get-msg-num t))) (or message (setq message (mh-get-msg-num t))) @@ -675,14 +688,51 @@ message and scan line." (if mh-redist-full-contents-flag (mh-msg-filename message) nil) - nil))) - (mh-goto-header-end 0) - (insert "Resent-To: " to "\n") - (if (not (equal cc "")) (insert "Resent-cc: " cc "\n")) - (mh-clean-msg-header - (point-min) - "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Sender:\\|^Date:\\|^From:" - nil) + nil)) + (from (mh-identity-field identity "From")) + (fcc (mh-identity-field identity "Fcc")) + (bcc (mh-identity-field identity "Bcc")) + comp-fcc comp-to comp-cc comp-bcc) + (if mh-redist-full-contents-flag + (mh-clean-msg-header + (point-min) + "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Date:\\|^Resent-.*:" + nil)) + ;; Read fields from the distcomps file and put them in our + ;; draft. For "To", "Cc", "Bcc", and "Fcc", multiple headers are + ;; combined into a single header with comma-separated entries. + ;; 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 + (function + (lambda (header-field) + (let ((field (car header-field)) + (value (cdr header-field)) + (case-fold-search t)) + (cond + ((string-match field "^Resent-Fcc$") + (setq comp-fcc value)) + ((string-match field "^Resent-From$") + (or from + (setq from value))) + ((string-match field "^Resent-To$") + (setq comp-to value)) + ((string-match field "^Resent-Cc$") + (setq comp-cc value)) + ((string-match field "^Resent-Bcc$") + (setq comp-bcc value)) + ((string-match field "^Resent-.*$") + (mh-insert-fields field value)))))) + (mh-components-to-list components-file)) + (delete-file components-file)) + (mh-insert-fields "Resent-To:" (mapconcat 'identity (list to comp-to) ", ") + "Resent-Cc:" (mapconcat 'identity (list cc comp-cc) ", ") + "Resent-Fcc:" (mapconcat 'identity (list fcc + comp-fcc) ", ") + "Resent-Bcc:" (mapconcat 'identity (list bcc + comp-bcc) ", ") + "Resent-From:" from) (save-buffer) (message "Redistributing...") (let ((env "mhdist=1")) @@ -700,7 +750,8 @@ message and scan line." ;; Annotate... (mh-annotate-msg message folder mh-note-dist "-component" "Resent:" - "-text" (format "\"%s %s\"" to cc))) + "-text" (format "\"To: %s Cc: %s From: %s\"" + to cc from))) (kill-buffer draft) (message "Redistributing...done")))) @@ -896,7 +947,7 @@ CONFIG is the window configuration before sending mail." (message "Composing a message...") (let ((draft (mh-read-draft "message" - (mh-bare-components) + (mh-bare-components mh-comp-formfile) t))) (mh-insert-fields "To:" to "Subject:" subject "Cc:" cc) (goto-char (point-max)) @@ -906,23 +957,25 @@ CONFIG is the window configuration before sending mail." (mh-letter-mode-message) (mh-letter-adjust-point)))) -(defun mh-bare-components () - "Generate a temporary, clean components file and return its path." - ;; Let comp(1) create the skeleton for us. This is particularly +(defun mh-bare-components (formfile) + "Generate a temporary, clean components file from FORMFILE. +Return the path to the temporary file." + ;; Let comp(1) create the skeleton for us. This is particularly ;; important with nmh-1.5, because its default "components" needs - ;; some processing before it can be used. Unfortunately, comp(1) - ;; doesn't have a -build option. So, to avoid the possibility of - ;; clobbering an existing draft, create a temporary directory and - ;; use it as the drafts folder. Then copy the skeleton to a regular - ;; temp file, and return the regular temp file. + ;; some processing before it can be used. Unfortunately, comp(1) + ;; didn't have a -build option until later versions of nmh. So, to + ;; avoid the possibility of clobbering an existing draft, create + ;; a temporary directory and use it as the drafts folder. Then + ;; copy the skeleton to a regular temp file, and return the + ;; regular temp file. (let (new (temp-folder (make-temp-file (concat mh-user-path "draftfolder.") t))) (mh-exec-cmd "comp" "-nowhatnowproc" "-draftfolder" (format "+%s" (file-name-nondirectory temp-folder)) - (if (stringp mh-comp-formfile) - (list "-form" mh-comp-formfile))) + (if (stringp formfile) + (list "-form" formfile))) (setq new (make-temp-file "comp.")) (rename-file (concat temp-folder "/" "1") new t) ;; The temp folder could contain various metadata files. Rather @@ -1056,6 +1109,7 @@ letter." (defun mh-insert-x-mailer () "Append an X-Mailer field to the header. The versions of MH-E, Emacs, and MH are shown." + (or mh-variant-in-use (mh-variant-set mh-variant)) ;; Lazily initialize mh-x-mailer-string. (when (and mh-insert-x-mailer-flag (null mh-x-mailer-string)) (setq mh-x-mailer-string diff --git a/lisp/mh-e/mh-compat.el b/lisp/mh-e/mh-compat.el index d84d3320426..a459d27ee2d 100644 --- a/lisp/mh-e/mh-compat.el +++ b/lisp/mh-e/mh-compat.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2006-2019 Free Software Foundation, Inc. ;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> ;; Keywords: mail ;; See: mh-e.el @@ -65,7 +64,8 @@ Simulate NOERROR argument in XEmacs which lacks it." Case is ignored if CASE-FOLD is non-nil. This function is used by Emacs versions that lack `assoc-string', introduced in Emacs 22." - (if case-fold + ;; 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))) @@ -307,7 +307,8 @@ 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." - (replace-in-string string regexp rep literal)) + (if (featurep 'xemacs) ; silence Emacs compiler + (replace-in-string string regexp rep literal))) (defun-mh mh-test-completion test-completion (string collection &optional predicate) diff --git a/lisp/mh-e/mh-e.el b/lisp/mh-e/mh-e.el index ee938166931..c70e11e773a 100644 --- a/lisp/mh-e/mh-e.el +++ b/lisp/mh-e/mh-e.el @@ -4,7 +4,6 @@ ;; Software Foundation, Inc. ;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> ;; Version: 8.6+git ;; Keywords: mail @@ -410,6 +409,8 @@ gnus-version) (require 'gnus) gnus-version) +(defvar mh-variant) + ;;;###autoload (defun mh-version () "Display version information about MH-E and the MH mail handling system." @@ -430,6 +431,7 @@ gnus-version) ;; Emacs version. (insert (emacs-version) "\n\n") ;; MH version. + (or mh-variant-in-use (mh-variant-set mh-variant)) (if mh-variant-in-use (insert mh-variant-in-use "\n" " mh-progs:\t" mh-progs "\n" @@ -876,6 +878,7 @@ variant." (defun mh-variant-p (&rest variants) "Return t if variant is any of VARIANTS. Currently known variants are `MH', `nmh', and `gnu-mh'." + (or mh-variant-in-use (mh-variant-set mh-variant)) (let ((variant-in-use (cadr (assoc 'variant (assoc mh-variant-in-use (mh-variants)))))) (not (null (member variant-in-use variants))))) @@ -941,6 +944,8 @@ finally GNU mailutils MH." (when (not (mh-variant-set-variant variant)) (message "Warning: %s variant not found. Autodetecting..." variant) (mh-variant-set 'autodetect))) + ((null valid-list) + (message "Unknown variant %s; can't find MH anywhere" variant)) (t (message "Unknown variant %s; use %s" variant @@ -972,6 +977,7 @@ necessary and can actually cause problems." :set (lambda (symbol value) (set-default symbol value) ;Done in mh-variant-set-variant! (mh-variant-set value)) + :initialize 'custom-initialize-default :group 'mh-e :package-version '(MH-E . "8.0")) diff --git a/lisp/mh-e/mh-folder.el b/lisp/mh-e/mh-folder.el index e4429df501a..5b4c34fb6a8 100644 --- a/lisp/mh-e/mh-folder.el +++ b/lisp/mh-e/mh-folder.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2002-2003, 2005-2019 Free Software Foundation, Inc. ;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> ;; Keywords: mail ;; See: mh-e.el @@ -519,7 +518,7 @@ font-lock is done highlighting.") (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) + '(if (and (featurep 'scrollbar) (fboundp 'set-specifier)) (set-specifier horizontal-scrollbar-visible-p nil (cons (current-buffer) nil))))) diff --git a/lisp/mh-e/mh-funcs.el b/lisp/mh-e/mh-funcs.el index d9b3dc8233f..9f603c0c710 100644 --- a/lisp/mh-e/mh-funcs.el +++ b/lisp/mh-e/mh-funcs.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1993, 1995, 2001-2019 Free Software Foundation, Inc. ;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> ;; Keywords: mail ;; See: mh-e.el @@ -357,6 +356,8 @@ Arguments are IGNORED (for `revert-buffer')." (yes-or-no-p "Undo all commands in folder? ")) (setq mh-delete-list nil mh-refile-list nil + mh-blacklist nil + mh-whitelist nil mh-seq-list nil mh-next-direction 'forward) (with-mh-folder-updating (nil) diff --git a/lisp/mh-e/mh-identity.el b/lisp/mh-e/mh-identity.el index 8469843e3fc..1d929e8f990 100644 --- a/lisp/mh-e/mh-identity.el +++ b/lisp/mh-e/mh-identity.el @@ -132,6 +132,33 @@ valid header field." 'mh-identity-handler-default)) ;;;###mh-autoload +(defun mh-select-identity (default) + "Prompt for and return an identity. +If DEFAULT is non-nil, it will be used if the user doesn't enter a +different identity. + +See `mh-identity-list'." + (let (identity) + (setq identity + (completing-read + "Identity: " + (cons '("None") + (mapcar 'list (mapcar 'car mh-identity-list))) + nil t default nil default)) + (if (eq identity "None") + nil + identity))) + +;;;###mh-autoload +(defun mh-identity-field (identity field) + "Return the specified FIELD of the given IDENTITY. + +See `mh-identity-list'." + (let* ((pers-list (cadr (assoc identity mh-identity-list))) + (value (cdr (assoc field pers-list)))) + value)) + +;;;###mh-autoload (defun mh-insert-identity (identity &optional maybe-insert) "Insert fields specified by given IDENTITY. diff --git a/lisp/mh-e/mh-junk.el b/lisp/mh-e/mh-junk.el index 8266d96ca69..db80f90494e 100644 --- a/lisp/mh-e/mh-junk.el +++ b/lisp/mh-e/mh-junk.el @@ -108,8 +108,7 @@ message(s) as specified by the option `mh-junk-disposition'." (mh-iterate-on-range msg range (message "Blacklisting message %d..." msg) (funcall (symbol-function blacklist-func) msg) - (message "Blacklisting message %d...done" msg)) - (mh-next-msg))) + (message "Blacklisting message %d...done" msg)))) ;;;###mh-autoload (defun mh-junk-whitelist (range) @@ -164,8 +163,7 @@ classified as spam (see the option `mh-junk-program')." (mh-iterate-on-range msg range (message "Whitelisting message %d..." msg) (funcall (symbol-function whitelist-func) msg) - (message "Whitelisting message %d...done" msg)) - (mh-next-msg))) + (message "Whitelisting message %d...done" msg)))) diff --git a/lisp/mh-e/mh-letter.el b/lisp/mh-e/mh-letter.el index 4906c98bb89..46762f12fd3 100644 --- a/lisp/mh-e/mh-letter.el +++ b/lisp/mh-e/mh-letter.el @@ -4,7 +4,6 @@ ;; Inc. ;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> ;; Keywords: mail ;; See: mh-e.el @@ -60,17 +59,6 @@ (to . mh-alias-letter-expand-alias)) "Alist of header fields and completion functions to use.") -(defvar mh-yank-hooks nil - "Obsolete hook for modifying a citation just inserted in the mail buffer. - -Each hook function can find the citation between point and mark. -And each hook function should leave point and mark around the -citation text as modified. - -This is a normal hook, misnamed for historical reasons. -It is obsolete and is only used if `mail-citation-hook' is nil.") -(mh-make-obsolete-variable 'mh-yank-hooks 'mail-citation-hook "19.34") - ;;; Letter Menu @@ -972,8 +960,6 @@ Otherwise, simply insert MH-INS-STRING before each line." (sc-cite-original)) (mail-citation-hook (run-hooks 'mail-citation-hook)) - (mh-yank-hooks ;old hook name - (run-hooks 'mh-yank-hooks)) (t (or (bolp) (forward-line 1)) (while (< (point) (point-max)) diff --git a/lisp/mh-e/mh-limit.el b/lisp/mh-e/mh-limit.el index 27dda79484d..ee6fa83abb6 100644 --- a/lisp/mh-e/mh-limit.el +++ b/lisp/mh-e/mh-limit.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2001-2003, 2006-2019 Free Software Foundation, Inc. ;; Author: Peter S. Galbraith <psg@debian.org> -;; Maintainer: Bill Wohler <wohler@newt.com> ;; Keywords: mail ;; See: mh-e.el diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el index bb7bf826497..6f126967fec 100644 --- a/lisp/mh-e/mh-mime.el +++ b/lisp/mh-e/mh-mime.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1993, 1995, 2001-2019 Free Software Foundation, Inc. ;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> ;; Keywords: mail ;; See: mh-e.el @@ -75,7 +74,7 @@ ;;;###mh-autoload (defmacro mh-buffer-data () "Convenience macro to get the MIME data structures of the current buffer." - `(gethash (current-buffer) mh-globals-hash)) + '(gethash (current-buffer) mh-globals-hash)) ;; Structure to keep track of MIME handles on a per buffer basis. (mh-defstruct (mh-buffer-data (:conc-name mh-mime-) diff --git a/lisp/mh-e/mh-scan.el b/lisp/mh-e/mh-scan.el index cd689d62509..8c1a07dadc6 100644 --- a/lisp/mh-e/mh-scan.el +++ b/lisp/mh-e/mh-scan.el @@ -4,7 +4,6 @@ ;; Inc. ;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> ;; Keywords: mail ;; See: mh-e.el diff --git a/lisp/mh-e/mh-search.el b/lisp/mh-e/mh-search.el index 1a14f4f3dc3..ca74b2e936e 100644 --- a/lisp/mh-e/mh-search.el +++ b/lisp/mh-e/mh-search.el @@ -495,16 +495,16 @@ group of results." (let ((point (point))) (forward-line (if backward-flag 0 1)) (cond ((if backward-flag - (re-search-backward "^+" (point-min) t) - (re-search-forward "^+" (point-max) t)) + (re-search-backward "^\\+" (point-min) t) + (re-search-forward "^\\+" (point-max) t)) (beginning-of-line)) ((and (if backward-flag (goto-char (point-max)) (goto-char (point-min))) nil)) ((if backward-flag - (re-search-backward "^+" (point-min) t) - (re-search-forward "^+" (point-max) t)) + (re-search-backward "^\\+" (point-min) t) + (re-search-forward "^\\+" (point-max) t)) (beginning-of-line)) (t (goto-char point)))))) @@ -717,7 +717,7 @@ parsed." ((equal token "and") (push 'and op-stack)) ((equal token ")") (multiple-value-setq (op-stack operand-stack) - (values-list (mh-index-evaluate op-stack operand-stack))) + (cl-values-list (mh-index-evaluate op-stack operand-stack))) (when (eq (car op-stack) 'not) (setq op-stack (cdr op-stack)) (push `(not ,(pop operand-stack)) operand-stack)) @@ -1429,7 +1429,7 @@ being the list of messages originally from that folder." (setq which-func-mode t)) (let ((alist ())) (goto-char (point-min)) - (while (re-search-forward "^+" nil t) + (while (re-search-forward "^\\+" nil t) (save-excursion (beginning-of-line) (push (cons (buffer-substring-no-properties diff --git a/lisp/mh-e/mh-seq.el b/lisp/mh-e/mh-seq.el index f7d7c627953..9989dc9f1c7 100644 --- a/lisp/mh-e/mh-seq.el +++ b/lisp/mh-e/mh-seq.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1993, 1995, 2001-2019 Free Software Foundation, Inc. ;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> ;; Keywords: mail ;; See: mh-e.el diff --git a/lisp/mh-e/mh-show.el b/lisp/mh-e/mh-show.el index 84a7a817065..4f7068156ef 100644 --- a/lisp/mh-e/mh-show.el +++ b/lisp/mh-e/mh-show.el @@ -4,7 +4,6 @@ ;; Inc. ;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> ;; Keywords: mail ;; See: mh-e.el @@ -375,8 +374,8 @@ still visible.\n") (cond ((not normal-exit) (set-window-configuration config)) ,(if dont-return - `(t (setq mh-previous-window-config config)) - `((and (get-buffer cur-buffer-name) + '(t (setq mh-previous-window-config config)) + '((and (get-buffer cur-buffer-name) (window-live-p (get-buffer-window (get-buffer cur-buffer-name)))) (pop-to-buffer (get-buffer cur-buffer-name) nil))))))))) @@ -774,7 +773,7 @@ operation." ("^\\(Apparently-To:\\|Newsgroups:\\)\\(.*\\)" (1 'default) (2 'mh-show-cc)) - ("^\\(In-reply-to\\|Date\\):\\(.*\\)$" + ("^\\(In-Reply-To\\|Date\\):\\(.*\\)$" (1 'default) (2 'mh-show-date)) (mh-letter-header-font-lock diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el index dd4f6037050..fc661c882ee 100644 --- a/lisp/mh-e/mh-speed.el +++ b/lisp/mh-e/mh-speed.el @@ -163,7 +163,7 @@ The optional arguments from speedbar are IGNORED." (speedbar-change-expand-button-char ?-) (add-text-properties (mh-line-beginning-position) (1+ (line-beginning-position)) - `(mh-expanded t))))))) + '(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]. @@ -199,7 +199,7 @@ created." (1+ (mh-line-beginning-position)))) (add-text-properties (mh-line-beginning-position) (1+ (line-beginning-position)) - `(mh-folder nil mh-expanded nil mh-children-p t mh-level 0)) + '(mh-folder nil mh-expanded nil mh-children-p t mh-level 0)) (mh-speed-stealth-update t) (when (> mh-speed-update-interval 0) (mh-speed-flists nil)))) @@ -452,7 +452,7 @@ be handled next." (substring output position line-end)) mh-speed-partial-line "") (multiple-value-setq (folder unseen total) - (values-list + (cl-values-list (mh-parse-flist-output-line line mh-speed-current-folder))) (when (and folder unseen total (let ((old-pair (gethash folder mh-speed-flists-cache))) @@ -568,7 +568,7 @@ The function invalidates the latest ancestor that is present." (mh-speedbar-change-expand-button-char ?+) (add-text-properties (mh-line-beginning-position) (1+ (mh-line-beginning-position)) - `(mh-children-p t))) + '(mh-children-p t))) (when (get-text-property (mh-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 7d35bc61de8..0fc560b90d0 100644 --- a/lisp/mh-e/mh-thread.el +++ b/lisp/mh-e/mh-thread.el @@ -647,20 +647,17 @@ Only information about messages in MSG-LIST are added to the tree." (defun mh-thread-set-tables (folder) "Use the tables of FOLDER in current buffer." - (mh-flet - ((mh-get-table (symbol) - (with-current-buffer folder - (symbol-value symbol)))) - (setq mh-thread-id-hash (mh-get-table 'mh-thread-id-hash)) - (setq mh-thread-subject-hash (mh-get-table 'mh-thread-subject-hash)) - (setq mh-thread-id-table (mh-get-table 'mh-thread-id-table)) - (setq mh-thread-id-index-map (mh-get-table 'mh-thread-id-index-map)) - (setq mh-thread-index-id-map (mh-get-table 'mh-thread-index-id-map)) - (setq mh-thread-scan-line-map (mh-get-table 'mh-thread-scan-line-map)) - (setq mh-thread-subject-container-hash - (mh-get-table 'mh-thread-subject-container-hash)) - (setq mh-thread-duplicates (mh-get-table 'mh-thread-duplicates)) - (setq mh-thread-history (mh-get-table 'mh-thread-history)))) + (dolist (v '(mh-thread-id-hash + mh-thread-subject-hash + mh-thread-id-table + mh-thread-id-index-map + mh-thread-index-id-map + mh-thread-scan-line-map + mh-thread-subject-container-hash + mh-thread-duplicates + mh-thread-history)) + ;; Emacs >= 22.1: (buffer-local-value v folder). + (set v (with-current-buffer folder (symbol-value v))))) (defun mh-thread-process-in-reply-to (reply-to-header) "Extract message id's from REPLY-TO-HEADER. diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el index 7cba9a5f417..0938729e788 100644 --- a/lisp/mh-e/mh-utils.el +++ b/lisp/mh-e/mh-utils.el @@ -4,7 +4,6 @@ ;; Inc. ;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> ;; Keywords: mail ;; See: mh-e.el @@ -177,6 +176,7 @@ been set. This hook can be used the change the value of these variables if you need to run with different values between MH and MH-E." (unless mh-find-path-run + (or mh-variant-in-use (mh-variant-set mh-variant)) ;; Sanity checks. (if (and (getenv "MH") (not (file-readable-p (getenv "MH")))) diff --git a/lisp/mh-e/mh-xface.el b/lisp/mh-e/mh-xface.el index 9a03fef1108..4ff84a66f76 100644 --- a/lisp/mh-e/mh-xface.el +++ b/lisp/mh-e/mh-xface.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2002-2003, 2005-2019 Free Software Foundation, Inc. ;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> ;; Keywords: mail ;; See: mh-e.el @@ -197,7 +196,7 @@ The directories are searched for in the order they appear in the list.") (mh-funcall-if-exists ietf-drums-parse-address from-field)))) (host (and from - (string-match "\\([^+]*\\)\\(+.*\\)?@\\(.*\\)" from) + (string-match "\\([^+]*\\)\\(\\+.*\\)?@\\(.*\\)" from) (downcase (match-string 3 from)))) (user (and host (downcase (match-string 1 from)))) (canonical-address (format "%s@%s" user host)) diff --git a/lisp/midnight.el b/lisp/midnight.el index 86c1e219f02..fa41d80a69e 100644 --- a/lisp/midnight.el +++ b/lisp/midnight.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1998, 2001-2019 Free Software Foundation, Inc. ;; Author: Sam Steingold <sds@gnu.org> -;; Maintainer: Sam Steingold <sds@gnu.org> ;; Created: 1998-05-18 ;; Keywords: utilities diff --git a/lisp/minibuf-eldef.el b/lisp/minibuf-eldef.el index 244cfd57b4e..7fd08ab2e99 100644 --- a/lisp/minibuf-eldef.el +++ b/lisp/minibuf-eldef.el @@ -163,9 +163,6 @@ been set up by `minibuf-eldef-setup-minibuffer'." ;;;###autoload (define-minor-mode minibuffer-electric-default-mode "Toggle Minibuffer Electric Default mode. -With a prefix argument ARG, enable Minibuffer Electric Default -mode if ARG is positive, and disable it otherwise. If called -from Lisp, enable the mode if ARG is omitted or nil. Minibuffer Electric Default mode is a global minor mode. When enabled, minibuffer prompts that show a default value only show diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 67c691ca212..52455ccc40c 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -269,7 +269,7 @@ the form (concat S2 S)." (+ beg (- (length s1) (length s2)))) . ,(and (eq (car-safe res) 'boundaries) (cddr res))))) ((stringp res) - (if (string-prefix-p s2 string completion-ignore-case) + (if (string-prefix-p s2 res completion-ignore-case) (concat s1 (substring res (length s2))))) ((eq action t) (let ((bounds (completion-boundaries str table pred ""))) @@ -682,9 +682,9 @@ for use at QPOS." ;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b)) ;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun)) (define-obsolete-function-alias - 'complete-in-turn 'completion-table-in-turn "23.1") + 'complete-in-turn #'completion-table-in-turn "23.1") (define-obsolete-function-alias - 'dynamic-completion-table 'completion-table-dynamic "23.1") + 'dynamic-completion-table #'completion-table-dynamic "23.1") ;;; Minibuffer completion @@ -693,6 +693,9 @@ for use at QPOS." :link '(custom-manual "(emacs)Minibuffer") :group 'environment) +(defvar minibuffer-message-properties nil + "Text properties added to the text shown by `minibuffer-message'.") + (defun minibuffer-message (message &rest args) "Temporarily display MESSAGE at the end of the minibuffer. The text is displayed for `minibuffer-message-timeout' seconds, @@ -702,7 +705,7 @@ If ARGS are provided, then pass MESSAGE through `format-message'." (if (not (minibufferp (current-buffer))) (progn (if args - (apply 'message message args) + (apply #'message message args) (message "%s" message)) (prog1 (sit-for (or minibuffer-message-timeout 1000000)) (message nil))) @@ -714,6 +717,10 @@ If ARGS are provided, then pass MESSAGE through `format-message'." (copy-sequence message) (concat " [" message "]"))) (when args (setq message (apply #'format-message message args))) + (unless (or (null minibuffer-message-properties) + ;; Don't overwrite the face properties the caller has set + (text-properties-at 0 message)) + (setq message (apply #'propertize message minibuffer-message-properties))) (let ((ol (make-overlay (point-max) (point-max) nil t t)) ;; A quit during sit-for normally only interrupts the sit-for, ;; but since minibuffer-message is used at the end of a command, @@ -735,7 +742,8 @@ If ARGS are provided, then pass MESSAGE through `format-message'." (defun minibuffer-completion-contents () "Return the user input in a minibuffer before point as a string. -In Emacs-22, that was what completion commands operated on." +In Emacs 22, that was what completion commands operated on. +If the current buffer is not a minibuffer, return everything before point." (declare (obsolete nil "24.4")) (buffer-substring (minibuffer-prompt-end) (point))) @@ -793,6 +801,11 @@ Additionally the user can use the char \"*\" as a glob pattern.") I.e. when completing \"foo_bar\" (where _ is the position of point), it will consider all completions candidates matching the glob pattern \"*foo*bar*\".") + (flex + completion-flex-try-completion completion-flex-all-completions + "Completion of an in-order subset of characters. +When completing \"foo\" the glob \"*f*o*o*\" is used, so that +\"foo\" can complete to \"frodo\".") (initials completion-initials-try-completion completion-initials-all-completions "Completion of acronyms and initialisms. @@ -840,7 +853,9 @@ styles for specific categories, such as files, buffers, etc." (defvar completion-category-defaults '((buffer (styles . (basic substring))) (unicode-name (styles . (basic substring))) - (project-file (styles . (basic substring))) + ;; A new style that combines substring and pcm might be better, + ;; e.g. one that does not anchor to bos. + (project-file (styles . (substring))) (info-menu (styles . (basic substring)))) "Default settings for specific completion categories. Each entry has the shape (CATEGORY . ALIST) where ALIST is @@ -1008,7 +1023,7 @@ completion candidates than this number." (defvar-local completion-all-sorted-completions nil) (defvar-local completion--all-sorted-completions-location nil) -(defvar completion-cycling nil) +(defvar completion-cycling nil) ;Function that takes down the cycling map. (defvar completion-fail-discreetly nil "If non-nil, stay quiet when there is no match.") @@ -1040,7 +1055,7 @@ when the buffer's text is already an exact match." (let* ((string (buffer-substring beg end)) (md (completion--field-metadata beg)) (comp (funcall (or try-completion-function - 'completion-try-completion) + #'completion-try-completion) string minibuffer-completion-table minibuffer-completion-predicate @@ -1133,7 +1148,7 @@ when the buffer's text is already an exact match." ;; Show the completion table, if requested. ((not exact) (if (pcase completion-auto-help - (`lazy (eq this-command last-command)) + ('lazy (eq this-command last-command)) (_ completion-auto-help)) (minibuffer-completion-help beg end) (completion--message "Next char not unique"))) @@ -1193,7 +1208,7 @@ scroll the window of possible completions." (defun completion--cache-all-sorted-completions (beg end comps) (add-hook 'after-change-functions - 'completion--flush-all-sorted-completions nil t) + #'completion--flush-all-sorted-completions nil t) (setq completion--all-sorted-completions-location (cons (copy-marker beg) (copy-marker end))) (setq completion-all-sorted-completions comps)) @@ -1203,8 +1218,10 @@ scroll the window of possible completions." (or (> start (cdr completion--all-sorted-completions-location)) (< end (car completion--all-sorted-completions-location)))) (remove-hook 'after-change-functions - 'completion--flush-all-sorted-completions t) - (setq completion-cycling nil) + #'completion--flush-all-sorted-completions t) + ;; Remove the transient map if applicable. + (when completion-cycling + (funcall (prog1 completion-cycling (setq completion-cycling nil)))) (setq completion-all-sorted-completions nil))) (defun completion--metadata (string base md-at-point table pred) @@ -1244,15 +1261,23 @@ scroll the window of possible completions." (setq all (delete-dups all)) (setq last (last all)) - (setq all (if sort-fun (funcall sort-fun all) - ;; Prefer shorter completions, by default. - (sort all (lambda (c1 c2) (< (length c1) (length c2)))))) - ;; Prefer recently used completions. - (when (minibufferp) - (let ((hist (symbol-value minibuffer-history-variable))) - (setq all (sort all (lambda (c1 c2) - (> (length (member c1 hist)) - (length (member c2 hist)))))))) + (cond + (sort-fun + (setq all (funcall sort-fun all))) + (t + ;; Prefer shorter completions, by default. + (setq all (sort all (lambda (c1 c2) (< (length c1) (length c2))))) + (if (minibufferp) + ;; Prefer recently used completions and put the default, if + ;; it exists, on top. + (let ((hist (symbol-value minibuffer-history-variable))) + (setq all + (sort all + (lambda (c1 c2) + (cond ((equal c1 minibuffer-default) t) + ((equal c2 minibuffer-default) nil) + (t (> (length (member c1 hist)) + (length (member c2 hist)))))))))))) ;; Cache the result. This is not just for speed, but also so that ;; repeated calls to minibuffer-force-complete can cycle through ;; all possibilities. @@ -1262,16 +1287,23 @@ scroll the window of possible completions." (defun minibuffer-force-complete-and-exit () "Complete the minibuffer with first of the matches and exit." (interactive) - (minibuffer-force-complete) + ;; If `completion-cycling' is t, then surely a + ;; `minibuffer-force-complete' has already executed. This is not + ;; just for speed: the extra rotation caused by the second + ;; unnecessary call would mess up the final result value + ;; (bug#34116). + (unless completion-cycling + (minibuffer-force-complete nil nil 'dont-cycle)) (completion--complete-and-exit (minibuffer-prompt-end) (point-max) #'exit-minibuffer ;; If the previous completion completed to an element which fails ;; test-completion, then we shouldn't exit, but that should be rare. (lambda () (minibuffer-message "Incomplete")))) -(defun minibuffer-force-complete (&optional start end) +(defun minibuffer-force-complete (&optional start end dont-cycle) "Complete the minibuffer to an exact match. -Repeated uses step through the possible completions." +Repeated uses step through the possible completions. +DONT-CYCLE tells the function not to setup cycling." (interactive) (setq minibuffer-scroll-window nil) ;; FIXME: Need to deal with the extra-size issue here as well. @@ -1284,7 +1316,7 @@ Repeated uses step through the possible completions." (base (+ start (or (cdr (last all)) 0)))) (cond ((not (consp all)) - (completion--message + (completion--message (if all "No more completions" "No completions"))) ((not (consp (cdr all))) (let ((done (equal (car all) (buffer-substring-no-properties base end)))) @@ -1295,38 +1327,39 @@ Repeated uses step through the possible completions." (completion--replace base end (car all)) (setq end (+ base (length (car all)))) (completion--done (buffer-substring-no-properties start (point)) 'sole) - ;; Set cycling after modifying the buffer since the flush hook resets it. - (setq completion-cycling t) (setq this-command 'completion-at-point) ;For completion-in-region. - ;; If completing file names, (car all) may be a directory, so we'd now - ;; have a new set of possible completions and might want to reset - ;; completion-all-sorted-completions to nil, but we prefer not to, - ;; so that repeated calls minibuffer-force-complete still cycle - ;; through the previous possible completions. - (let ((last (last all))) - (setcdr last (cons (car all) (cdr last))) - (completion--cache-all-sorted-completions start end (cdr all))) - ;; Make sure repeated uses cycle, even though completion--done might - ;; have added a space or something that moved us outside of the field. - ;; (bug#12221). - (let* ((table minibuffer-completion-table) - (pred minibuffer-completion-predicate) - (extra-prop completion-extra-properties) - (cmd - (lambda () "Cycle through the possible completions." - (interactive) - (let ((completion-extra-properties extra-prop)) - (completion-in-region start (point) table pred))))) - (set-transient-map - (let ((map (make-sparse-keymap))) - (define-key map [remap completion-at-point] cmd) - (define-key map (vector last-command-event) cmd) - map))))))) + ;; Set cycling after modifying the buffer since the flush hook resets it. + (unless dont-cycle + ;; If completing file names, (car all) may be a directory, so we'd now + ;; have a new set of possible completions and might want to reset + ;; completion-all-sorted-completions to nil, but we prefer not to, + ;; so that repeated calls minibuffer-force-complete still cycle + ;; through the previous possible completions. + (let ((last (last all))) + (setcdr last (cons (car all) (cdr last))) + (completion--cache-all-sorted-completions start end (cdr all))) + ;; Make sure repeated uses cycle, even though completion--done might + ;; have added a space or something that moved us outside of the field. + ;; (bug#12221). + (let* ((table minibuffer-completion-table) + (pred minibuffer-completion-predicate) + (extra-prop completion-extra-properties) + (cmd + (lambda () "Cycle through the possible completions." + (interactive) + (let ((completion-extra-properties extra-prop)) + (completion-in-region start (point) table pred))))) + (setq completion-cycling + (set-transient-map + (let ((map (make-sparse-keymap))) + (define-key map [remap completion-at-point] cmd) + (define-key map (vector last-command-event) cmd) + map))))))))) (defvar minibuffer-confirm-exit-commands '(completion-at-point minibuffer-complete minibuffer-complete-word PC-complete PC-complete-word) - "A list of commands which cause an immediately following + "List of commands which cause an immediately following `minibuffer-complete-and-exit' to ask for extra confirmation.") (defun minibuffer-complete-and-exit () @@ -1539,7 +1572,7 @@ horizontally in alphabetical order, rather than down the screen." Uses columns to keep the listing readable but compact. It also eliminates runs of equal strings." (when (consp strings) - (let* ((length (apply 'max + (let* ((length (apply #'max (mapcar (lambda (s) (if (consp s) (+ (string-width (car s)) @@ -1712,7 +1745,8 @@ It can find the completion buffer in `standard-output'." (with-temp-buffer (let ((standard-output (current-buffer)) (completion-setup-hook nil)) - (display-completion-list completions common-substring)) + (with-suppressed-warnings ((callargs display-completion-list)) + (display-completion-list completions common-substring))) (princ (buffer-string))) (with-current-buffer standard-output @@ -1830,12 +1864,7 @@ variables.") ;; window, mark it as softly-dedicated, so bury-buffer in ;; minibuffer-hide-completions will know whether to ;; delete the window or not. - (display-buffer-mark-dedicated 'soft) - ;; Disable `pop-up-windows' temporarily to allow - ;; `display-buffer--maybe-pop-up-frame-or-window' - ;; in the display actions below to pop up a frame - ;; if `pop-up-frames' is non-nil, but not to pop up a window. - (pop-up-windows nil)) + (display-buffer-mark-dedicated 'soft)) (with-displayed-buffer-window "*Completions*" ;; This is a copy of `display-buffer-fallback-action' @@ -1843,7 +1872,7 @@ variables.") ;; with `display-buffer-at-bottom'. `((display-buffer--maybe-same-window display-buffer-reuse-window - display-buffer--maybe-pop-up-frame-or-window + display-buffer--maybe-pop-up-frame ;; Use `display-buffer-below-selected' for inline completions, ;; but not in the minibuffer (e.g. in `eval-expression') ;; for which `display-buffer-at-bottom' is used. @@ -2105,9 +2134,9 @@ a completion function or god knows what else.") ;; like comint-completion-at-point or mh-letter-completion-at-point, which ;; could be sometimes safe and sometimes misbehaving (and sometimes neither). (if (pcase which - (`all t) - (`safe (member fun completion--capf-safe-funs)) - (`optimist (not (member fun completion--capf-misbehave-funs)))) + ('all t) + ('safe (member fun completion--capf-safe-funs)) + ('optimist (not (member fun completion--capf-misbehave-funs)))) (let ((res (funcall fun))) (cond ((and (consp res) (not (functionp res))) @@ -2278,7 +2307,7 @@ Useful to give the user default values that won't be substituted." (if (and (not (file-name-quoted-p filename)) (file-name-absolute-p filename) (string-match-p (if (memq system-type '(windows-nt ms-dos)) - "[/\\\\]~" "/~") + "[/\\]~" "/~") (file-local-name filename))) (file-name-quote filename) (minibuffer--double-dollars filename))) @@ -2292,7 +2321,7 @@ Useful to give the user default values that won't be substituted." ;; We can't reuse env--substitute-vars-regexp because we need to match only ;; potentially-unfinished envvars at end of string. (concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)" - "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'")) + "\\$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'")) (defun completion--embedded-envvar-table (string _pred action) "Completion table for envvars embedded in a string. @@ -2333,7 +2362,7 @@ same as `substitute-in-file-name'." (match-beginning 0))))))) (t (if (eq (aref string (1- beg)) ?{) - (setq table (apply-partially 'completion-table-with-terminator + (setq table (apply-partially #'completion-table-with-terminator "}" table))) ;; Even if file-name completion is case-insensitive, we want ;; envvar completion to be case-sensitive. @@ -2467,7 +2496,7 @@ except that it passes the file name through `substitute-in-file-name'.") #'completion--file-name-table) "Internal subroutine for `read-file-name'. Do not call this.") -(defvar read-file-name-function 'read-file-name-default +(defvar read-file-name-function #'read-file-name-default "The function called by `read-file-name' to do its work. It should accept the same arguments as `read-file-name'.") @@ -2732,17 +2761,9 @@ See `read-file-name' for the meaning of the arguments." (if (string= val1 (cadr file-name-history)) (pop file-name-history) (setcar file-name-history val1))) - (if add-to-history - ;; Add the value to the history--but not if it matches - ;; the last value already there. - (let ((val1 (minibuffer-maybe-quote-filename val))) - (unless (and (consp file-name-history) - (equal (car file-name-history) val1)) - (setq file-name-history - (cons val1 - (if history-delete-duplicates - (delete val1 file-name-history) - file-name-history))))))) + (when add-to-history + (add-to-history 'file-name-history + (minibuffer-maybe-quote-filename val)))) val)))) (defun internal-complete-buffer-except (&optional buffer) @@ -2750,8 +2771,8 @@ See `read-file-name' for the meaning of the arguments." BUFFER nil or omitted means use the current buffer. Like `internal-complete-buffer', but removes BUFFER from the completion list." (let ((except (if (stringp buffer) buffer (buffer-name buffer)))) - (apply-partially 'completion-table-with-predicate - 'internal-complete-buffer + (apply-partially #'completion-table-with-predicate + #'internal-complete-buffer (lambda (name) (not (equal (if (consp name) (car name) name) except))) nil))) @@ -2958,26 +2979,6 @@ or a symbol, see `completion-pcm--merge-completions'." ;; It should be avoided properly, but it's so easy to remove it here. (delete "" (nreverse pattern))))) -(defun completion-pcm--optimize-pattern (p) - ;; Remove empty strings in a separate phase since otherwise a "" - ;; might prevent some other optimization, as in '(any "" any). - (setq p (delete "" p)) - (let ((n '())) - (while p - (pcase p - (`(,(and s1 (pred stringp)) ,(and s2 (pred stringp)) . ,rest) - (setq p (cons (concat s1 s2) rest))) - (`(,(and p1 (pred symbolp)) ,(and p2 (guard (eq p1 p2))) . ,_) - (setq p (cdr p))) - (`(star ,(pred symbolp) . ,rest) (setq p `(star . ,rest))) - (`(,(pred symbolp) star . ,rest) (setq p `(star . ,rest))) - (`(point ,(or `any `any-delim) . ,rest) (setq p `(point . ,rest))) - (`(,(or `any `any-delim) point . ,rest) (setq p `(point . ,rest))) - (`(any ,(or `any `any-delim) . ,rest) (setq p `(any . ,rest))) - (`(,(pred symbolp)) (setq p nil)) ;Implicit terminating `any'. - (_ (push (pop p) n)))) - (nreverse n))) - (defun completion-pcm--pattern->regex (pattern &optional group) (let ((re (concat "\\`" @@ -2999,6 +3000,17 @@ or a symbol, see `completion-pcm--merge-completions'." (setq re (replace-match "" t t re 1))) re)) +(defun completion-pcm--pattern-point-idx (pattern) + "Return index of subgroup corresponding to `point' element of PATTERN. +Return nil if there's no such element." + (let ((idx nil) + (i 0)) + (dolist (x pattern) + (unless (stringp x) + (cl-incf i) + (if (eq x 'point) (setq idx i)))) + idx)) + (defun completion-pcm--all-completions (prefix pattern table pred) "Find all completions for PATTERN in TABLE obeying PRED. PATTERN is as returned by `completion-pcm--string->pattern'." @@ -3028,9 +3040,21 @@ PATTERN is as returned by `completion-pcm--string->pattern'." (when (string-match-p regex c) (push c poss))) (nreverse poss)))))) +(defvar flex-score-match-tightness 100 + "Controls how the `flex' completion style scores its matches. + +Value is a positive number. Values smaller than one make the +scoring formula value matches scattered along the string, while +values greater than one make the formula value tighter matches. +I.e \"foo\" matches both strings \"barbazfoo\" and \"fabrobazo\", +which are of equal length, but only a value greater than one will +score the former (which has one \"hole\") higher than the +latter (which has two).") + (defun completion-pcm--hilit-commonality (pattern completions) (when completions - (let* ((re (completion-pcm--pattern->regex pattern '(point))) + (let* ((re (completion-pcm--pattern->regex pattern 'group)) + (point-idx (completion-pcm--pattern-point-idx pattern)) (case-fold-search completion-ignore-case)) (mapcar (lambda (str) @@ -3038,15 +3062,70 @@ PATTERN is as returned by `completion-pcm--string->pattern'." (setq str (copy-sequence str)) (unless (string-match re str) (error "Internal error: %s does not match %s" re str)) - (let ((pos (or (match-beginning 1) (match-end 0)))) - (put-text-property 0 pos + (let* ((pos (if point-idx (match-beginning point-idx) (match-end 0))) + (md (match-data)) + (start (pop md)) + (end (pop md)) + (len (length str)) + ;; To understand how this works, consider these bad + ;; ascii(tm) diagrams showing how the pattern \"foo\" + ;; flex-matches \"fabrobazo" and + ;; \"barfoobaz\": + + ;; f abr o baz o + ;; + --- + --- + + + ;; bar foo baz + ;; --- +++ --- + + ;; Where + indicates parts where the pattern matched, + ;; - where it didn't match. The score is a number + ;; bound by ]0..1]: the higher the better and only a + ;; perfect match (pattern equals string) will have + ;; score 1. The formula takes the form of a quotient. + ;; For the numerator, we use the number of +, i.e. the + ;; length of the pattern. For the denominator, it + ;; sums (1+ (/ (grouplen - 1) + ;; flex-score-match-tightness)) across all groups of + ;; -, sums one to that total, and then multiples by + ;; the length of the string. + (score-numerator 0) + (score-denominator 0) + (last-b 0) + (update-score + (lambda (a b) + "Update score variables given match range (A B)." + (setq + score-numerator (+ score-numerator (- b a))) + (unless (= a last-b) + (setq + score-denominator (+ score-denominator + 1 + (/ (- a last-b 1) + flex-score-match-tightness + 1.0)))) + (setq + last-b b)))) + (funcall update-score start start) + (while md + (funcall update-score start (car md)) + (put-text-property start (pop md) + 'font-lock-face 'completions-common-part + str) + (setq start (pop md))) + (funcall update-score len len) + (put-text-property start end 'font-lock-face 'completions-common-part str) (if (> (length str) pos) (put-text-property pos (1+ pos) - 'font-lock-face 'completions-first-difference - str))) - str) + 'font-lock-face 'completions-first-difference + str)) + (unless (zerop (length str)) + (put-text-property + 0 1 'completion-score + (/ score-numerator (* len (1+ score-denominator)) 1.0) str))) + str) completions)))) (defun completion-pcm--find-all-completions (string table pred point @@ -3327,7 +3406,12 @@ the same set of elements." ;;; Substring completion ;; Mostly derived from the code of `basic' completion. -(defun completion-substring--all-completions (string table pred point) +(defun completion-substring--all-completions + (string table pred point &optional transform-pattern-fn) + "Match the presumed substring STRING to the entries in TABLE. +Respect PRED and POINT. The pattern used is a PCM-style +substring pattern, but it be massaged by TRANSFORM-PATTERN-FN, if +that is non-nil." (let* ((beforepoint (substring string 0 point)) (afterpoint (substring string point)) (bounds (completion-boundaries beforepoint table pred afterpoint)) @@ -3338,6 +3422,9 @@ the same set of elements." (pattern (if (not (stringp (car basic-pattern))) basic-pattern (cons 'prefix basic-pattern))) + (pattern (if transform-pattern-fn + (funcall transform-pattern-fn pattern) + pattern)) (all (completion-pcm--all-completions prefix pattern table pred))) (list all pattern prefix suffix (car bounds)))) @@ -3357,6 +3444,52 @@ the same set of elements." (nconc (completion-pcm--hilit-commonality pattern all) (length prefix))))) +;;; "flex" completion, also known as flx/fuzzy/scatter completion +;; Completes "foo" to "frodo" and "farfromsober" + +(defun completion-flex--make-flex-pattern (pattern) + "Convert PCM-style PATTERN into PCM-style flex pattern. + +This turns + (prefix \"foo\" point) +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." + (mapcan (lambda (elem) + (if (stringp elem) + (mapcan (lambda (char) + (list (string char) 'any)) + elem) + (list elem))) + pattern)) + +(defun completion-flex-try-completion (string table pred point) + "Try to flex-complete STRING in TABLE given PRED and POINT." + (pcase-let ((`(,all ,pattern ,prefix ,suffix ,_carbounds) + (completion-substring--all-completions + string table pred point + #'completion-flex--make-flex-pattern))) + (if minibuffer-completing-file-name + (setq all (completion-pcm--filename-try-filter all))) + ;; Try some "merging", meaning add as much as possible to the + ;; user's pattern without losing any possible matches in `all'. + ;; i.e this will augment "cfi" to "config" if all candidates + ;; contain the substring "config". FIXME: this still won't + ;; augment "foo" to "froo" when matching "frodo" and + ;; "farfromsober". + (completion-pcm--merge-try pattern all prefix suffix))) + +(defun completion-flex-all-completions (string table pred point) + "Get flex-completions of STRING in TABLE, given PRED and POINT." + (pcase-let ((`(,all ,pattern ,prefix ,_suffix ,_carbounds) + (completion-substring--all-completions + string table pred point + #'completion-flex--make-flex-pattern))) + (when all + (nconc (completion-pcm--hilit-commonality pattern all) + (length prefix))))) + ;; Initials completion ;; Complete /ums to /usr/monnier/src or lch to list-command-history. @@ -3399,7 +3532,7 @@ the same set of elements." (when newstr (completion-pcm-try-completion newstr table pred (length newstr))))) -(defvar completing-read-function 'completing-read-default +(defvar completing-read-function #'completing-read-default "The function called by `completing-read' to do its work. It should accept the same arguments as `completing-read'.") diff --git a/lisp/mouse.el b/lisp/mouse.el index 3660a1deb24..4a532a15e5f 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -29,6 +29,8 @@ ;;; Code: +(eval-when-compile (require 'rect)) + ;;; Utility functions. ;; Indent track-mouse like progn. @@ -41,8 +43,7 @@ (defcustom mouse-yank-at-point nil "If non-nil, mouse yank commands yank at point instead of at click." - :type 'boolean - :group 'mouse) + :type 'boolean) (defcustom mouse-drag-copy-region nil "If non-nil, copy to kill-ring upon mouse adjustments of the region. @@ -50,16 +51,15 @@ This affects `mouse-save-then-kill' (\\[mouse-save-then-kill]) in addition to mouse drags." :type 'boolean - :version "24.1" - :group 'mouse) + :version "24.1") (defcustom mouse-1-click-follows-link 450 "Non-nil means that clicking Mouse-1 on a link follows the link. With the default setting, an ordinary Mouse-1 click on a link performs the same action as Mouse-2 on that link, while a longer -Mouse-1 click \(hold down the Mouse-1 button for more than 450 -milliseconds) performs the original Mouse-1 binding \(which +Mouse-1 click (hold down the Mouse-1 button for more than 450 +milliseconds) performs the original Mouse-1 binding (which typically sets point where you click the mouse). If value is an integer, the time elapsed between pressing and @@ -83,8 +83,7 @@ packages. See `mouse-on-link-p' for details." :type '(choice (const :tag "Disabled" nil) (const :tag "Double click" double) (number :tag "Single click time limit" :value 450) - (other :tag "Single click" t)) - :group 'mouse) + (other :tag "Single click" t))) (defcustom mouse-1-click-in-non-selected-windows t "If non-nil, a Mouse-1 click also follows links in non-selected windows. @@ -93,58 +92,64 @@ If nil, a Mouse-1 click on a link in a non-selected window performs the normal mouse-1 binding, typically selects the window and sets point at the click position." :type 'boolean - :version "22.1" - :group 'mouse) + :version "22.1") + +(defvar mouse--last-down nil) (defun mouse--down-1-maybe-follows-link (&optional _prompt) + (when mouse-1-click-follows-link + (setq mouse--last-down (cons (car-safe last-input-event) (current-time)))) + nil) + +(defun mouse--click-1-maybe-follows-link (&optional _prompt) "Turn `mouse-1' events into `mouse-2' events if follows-link. -Expects to be bound to `down-mouse-1' in `key-translation-map'." - (when (and mouse-1-click-follows-link - (eq (if (eq mouse-1-click-follows-link 'double) - 'double-down-mouse-1 'down-mouse-1) - (car-safe last-input-event))) - (let ((action (mouse-on-link-p (event-start last-input-event)))) - (when (and action - (or mouse-1-click-in-non-selected-windows - (eq (selected-window) - (posn-window (event-start last-input-event))))) - (let ((timedout - (sit-for (if (numberp mouse-1-click-follows-link) - (/ (abs mouse-1-click-follows-link) 1000.0) - 0)))) - (if (if (and (numberp mouse-1-click-follows-link) - (>= mouse-1-click-follows-link 0)) - timedout (not timedout)) - nil - ;; Use read-key so it works for xterm-mouse-mode! - (let ((event (read-key))) - (if (eq (car-safe event) - (if (eq mouse-1-click-follows-link 'double) - 'double-mouse-1 'mouse-1)) - (progn - ;; Turn the mouse-1 into a mouse-2 to follow links, - ;; but only if ‘mouse-on-link-p’ hasn’t returned a - ;; string or vector (see its docstring). - (if (or (stringp action) (vectorp action)) - (push (aref action 0) unread-command-events) - (let ((newup (if (eq mouse-1-click-follows-link 'double) - 'double-mouse-2 'mouse-2))) - ;; If mouse-2 has never been done by the user, it - ;; doesn't have the necessary property to be - ;; interpreted correctly. - (unless (get newup 'event-kind) - (put newup 'event-kind (get (car event) 'event-kind))) - (push (cons newup (cdr event)) unread-command-events))) - ;; Don't change the down event, only the up-event - ;; (bug#18212). - nil) - (push event unread-command-events) - nil)))))))) +Expects to be bound to `(double-)mouse-1' in `key-translation-map'." + (and mouse--last-down + (pcase mouse-1-click-follows-link + ('nil nil) + ('double (eq 'double-mouse-1 (car-safe last-input-event))) + (_ (and (eq 'mouse-1 (car-safe last-input-event)) + (or (not (numberp mouse-1-click-follows-link)) + (funcall (if (< mouse-1-click-follows-link 0) + (lambda (a b) (time-less-p b a)) + #'time-less-p) + (time-since (cdr mouse--last-down)) + (/ (abs mouse-1-click-follows-link) 1000.0)))))) + (eq (car mouse--last-down) + (event-convert-list (list 'down (car-safe last-input-event)))) + (let* ((action (mouse-on-link-p (event-start last-input-event)))) + (when (and action + (or mouse-1-click-in-non-selected-windows + (eq (selected-window) + (posn-window (event-start last-input-event))))) + ;; Turn the mouse-1 into a mouse-2 to follow links, + ;; but only if ‘mouse-on-link-p’ hasn’t returned a + ;; string or vector (see its docstring). + (if (arrayp action) + (vector (aref action 0)) + (let ((newup (if (eq mouse-1-click-follows-link 'double) + 'double-mouse-2 'mouse-2))) + ;; If mouse-2 has never been done by the user, it + ;; doesn't have the necessary property to be + ;; interpreted correctly. + (unless (get newup 'event-kind) + (put newup 'event-kind + (get (car last-input-event) 'event-kind))) + ;; Modify the event in-place, otherwise we can get a prefix + ;; added again, so a click on the header-line turns + ;; into a [header-line header-line mouse-2] :-(. + ;; See fake_prefixed_keys in src/keyboard.c's. + (setf (car last-input-event) newup) + (vector last-input-event))))))) (define-key key-translation-map [down-mouse-1] #'mouse--down-1-maybe-follows-link) (define-key key-translation-map [double-down-mouse-1] #'mouse--down-1-maybe-follows-link) +(define-key key-translation-map [mouse-1] + #'mouse--click-1-maybe-follows-link) +(define-key key-translation-map [double-mouse-1] + #'mouse--click-1-maybe-follows-link) ;; Provide a mode-specific menu on a mouse button. @@ -168,7 +173,10 @@ items `Turn Off' and `Help'." (mouse-menu-non-singleton menu) (if (fboundp mm-fun) ; bug#20201 `(keymap - ,indicator + ,(format "%s - %s" indicator + (capitalize + (replace-regexp-in-string + "-" " " (format "%S" minor-mode)))) (turn-off menu-item "Turn off minor mode" ,mm-fun) (help menu-item "Help for minor mode" (lambda () (interactive) @@ -921,7 +929,6 @@ Nil means keep point at the position clicked (region end); non-nil means move point to beginning of region." :type '(choice (const :tag "Don't move point" nil) (const :tag "Move point to beginning of region" t)) - :group 'mouse :version "26.1") (defun mouse-set-point (event &optional promote-to-region) @@ -1027,8 +1034,7 @@ this many seconds between scroll steps. Scrolling stops when you move the mouse back into the window, or release the button. This variable's value may be non-integral. Setting this to zero causes Emacs to scroll as fast as it can." - :type 'number - :group 'mouse) + :type 'number) (defcustom mouse-scroll-min-lines 1 "The minimum number of lines scrolled by dragging mouse out of window. @@ -1037,8 +1043,7 @@ scrolling repeatedly. The number of lines scrolled per repetition is normally equal to the number of lines beyond the window edge that the mouse has moved. However, it always scrolls at least the number of lines specified by this variable." - :type 'integer - :group 'mouse) + :type 'integer) (defun mouse-scroll-subr (window jump &optional overlay start) "Scroll the window WINDOW, JUMP lines at a time, until new input arrives. @@ -1111,6 +1116,10 @@ its value is returned." (if (consp pos) (let ((w (posn-window pos)) (pt (posn-point pos)) (str (posn-string pos))) + ;; FIXME: When STR has a `category' property and there's another + ;; `category' property at PT, we should probably disregard the + ;; `category' property at PT while doing the (get-char-property + ;; pt property w)! (or (and str (get-text-property (cdr str) property (car str))) ;; Mouse clicks in the fringe come with a position in @@ -1144,19 +1153,15 @@ The resulting value determine whether POS is inside a link: is a non-nil `mouse-face' property at POS. Return t in this case. - If the value is a function, FUNC, POS is inside a link if -the call \(FUNC POS) returns non-nil. Return the return value -from that call. Arg is \(posn-point POS) if POS is a mouse event. +the call (FUNC POS) returns non-nil. Return the return value +from that call. Arg is (posn-point POS) if POS is a mouse event. - Otherwise, return the value itself. The return value is interpreted as follows: -- If it is a string, the mouse-1 event is translated into the -first character of the string, i.e. the action of the mouse-1 -click is the local or global binding of that character. - -- If it is a vector, the mouse-1 event is translated into the -first element of that vector, i.e. the action of the mouse-1 +- If it is an array, the mouse-1 event is translated into the +first element of that array, i.e. the action of the mouse-1 click is the local or global binding of that event. - Otherwise, the mouse-1 event is translated into a mouse-2 event @@ -1612,8 +1617,8 @@ if `mouse-drag-copy-region' is non-nil)" (if mouse-drag-copy-region ;; Region already saved in the previous click; ;; don't make a duplicate entry, just delete. - (delete-region (mark t) (point)) - (kill-region (mark t) (point))) + (funcall region-extract-function 'delete-only) + (kill-region (mark t) (point) 'region)) (setq mouse-selection-click-count 0) (setq mouse-save-then-kill-posn nil)) @@ -1638,7 +1643,7 @@ if `mouse-drag-copy-region' is non-nil)" (mouse-set-region-1) (when mouse-drag-copy-region ;; Region already copied to kill-ring once, so replace. - (kill-new (filter-buffer-substring (mark t) (point)) t)) + (kill-new (funcall region-extract-function nil) t)) ;; Arrange for a repeated mouse-3 to kill the region. (setq mouse-save-then-kill-posn click-pt))) @@ -1953,8 +1958,7 @@ When there is no region, this function does nothing." "Number of buffers in one pane (submenu) of the buffer menu. If we have lots of buffers, divide them into groups of `mouse-buffer-menu-maxlen' and make a pane (or submenu) for each one." - :type 'integer - :group 'mouse) + :type 'integer) (defcustom mouse-buffer-menu-mode-mult 4 "Group the buffers by the major mode groups on \\[mouse-buffer-menu]? @@ -1964,13 +1968,12 @@ will split the buffer menu by the major modes (see Set to 1 (or even 0!) if you want to group by major mode always, and to a large number if you prefer a mixed multitude. The default is 4." :type 'integer - :group 'mouse :version "20.3") (defvar mouse-buffer-menu-mode-groups (mapcar (lambda (arg) (cons (purecopy (car arg)) (purecopy (cdr arg)))) '(("Info\\|Help\\|Apropos\\|Man" . "Help") - ("\\bVM\\b\\|\\bMH\\b\\|Message\\|Mail\\|Group\\|Score\\|Summary\\|Article" + ("\\bVM\\b\\|\\bMH\\b\\|Message\\b\\|Mail\\|Group\\|Score\\|Summary\\|Article" . "Mail/News") ("\\<C\\>" . "C") ("ObjC" . "C") @@ -2362,8 +2365,7 @@ region, text is copied instead of being cut." modifier)) '(alt super hyper shift control meta)) (other :tag "Enable dragging the region" t)) - :version "26.1" - :group 'mouse) + :version "26.1") (defcustom mouse-drag-and-drop-region-cut-when-buffers-differ nil "If non-nil, cut text also when source and destination buffers differ. @@ -2372,8 +2374,7 @@ the text in the source buffer alone when dropping it in a different buffer. If this is non-nil, it will cut the text just as it does when dropping text in the source buffer." :type 'boolean - :version "26.1" - :group 'mouse) + :version "26.1") (defcustom mouse-drag-and-drop-region-show-tooltip 256 "If non-nil, text is shown by a tooltip in a graphic display. @@ -2383,8 +2384,7 @@ tooltip. If this is an integer (as with the default value of 256), it will show that many characters of the dragged text in a tooltip." :type 'integer - :version "26.1" - :group 'mouse) + :version "26.1") (defcustom mouse-drag-and-drop-region-show-cursor t "If non-nil, move point with mouse cursor during dragging. @@ -2393,16 +2393,18 @@ Otherwise, it will move point together with the mouse cursor and, in addition, temporarily highlight the original region with the `mouse-drag-and-drop-region' face." :type 'boolean - :version "26.1" - :group 'mouse) + :version "26.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 highlight the original region when `mouse-drag-and-drop-region-show-cursor' is non-nil." - :version "26.1" - :group 'mouse) + :version "26.1") + +(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)) (defun mouse-drag-and-drop-region (event) "Move text in the region to point where mouse is dragged to. @@ -2424,7 +2426,13 @@ is copied instead of being cut." (buffer (current-buffer)) (window (selected-window)) (text-from-read-only buffer-read-only) - (mouse-drag-and-drop-overlay (make-overlay start end)) + ;; Use multiple overlays to cover cases where the region has more + ;; than one boundary. + (mouse-drag-and-drop-overlays (mapcar (lambda (bounds) + (make-overlay (car bounds) + (cdr bounds))) + (region-bounds))) + (region-noncontiguous (region-noncontiguous-p)) point-to-paste point-to-paste-read-only window-to-paste @@ -2468,7 +2476,7 @@ is copied instead of being cut." ;; Obtain the dragged text in region. When the loop was ;; skipped, value-selection remains nil. (unless value-selection - (setq value-selection (buffer-substring start end)) + (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 @@ -2481,12 +2489,14 @@ is copied instead of being cut." value-selection)))) ;; Check if selected text is read-only. - (setq text-from-read-only (or text-from-read-only - (get-text-property start 'read-only) - (not (equal - (next-single-char-property-change - start 'read-only nil end) - end))))) + (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. @@ -2512,13 +2522,34 @@ is copied instead of being cut." ;; 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 mouse-drag-and-drop-overlay) + (and (eq (overlay-buffer (car mouse-drag-and-drop-overlays)) buffer-to-paste) - (<= (overlay-start mouse-drag-and-drop-overlay) - point-to-paste) - (<= point-to-paste - (overlay-end mouse-drag-and-drop-overlay))))) + (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 @@ -2537,8 +2568,9 @@ is copied instead of being cut." (t 'bar))) (when cursor-in-text-area - (overlay-put mouse-drag-and-drop-overlay - 'face 'mouse-drag-and-drop-region) + (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))))) @@ -2594,7 +2626,9 @@ is copied instead of being cut." (select-window window) (goto-char point) (setq deactivate-mark nil) - (activate-mark)) + (activate-mark) + (when region-noncontiguous + (rectangle-mark-mode))) ;; Modify buffers. (t ;; * DESTINATION BUFFER:: @@ -2603,11 +2637,14 @@ is copied instead of being cut." (setq window-exempt window-to-paste) (goto-char point-to-paste) (push-mark) - (insert value-selection) + (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)) + (activate-mark) + (when region-noncontiguous + (rectangle-mark-mode))) ;; * SOURCE BUFFER:: ;; Set back the original text as region or delete the original @@ -2617,8 +2654,9 @@ is copied instead of being cut." ;; remove the original text. (when no-modifier-on-drop (let (deactivate-mark) - (delete-region (overlay-start mouse-drag-and-drop-overlay) - (overlay-end mouse-drag-and-drop-overlay)))) + (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. @@ -2628,15 +2666,17 @@ is copied instead of being cut." (if mouse-drag-and-drop-region-cut-when-buffers-differ ;; Remove the dragged text from source buffer like ;; operation `cut'. - (delete-region (overlay-start mouse-drag-and-drop-overlay) - (overlay-end mouse-drag-and-drop-overlay)) + (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. - (delete-overlay mouse-drag-and-drop-overlay) + (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. diff --git a/lisp/mpc.el b/lisp/mpc.el index 7253843d2f5..8e557ed2b35 100644 --- a/lisp/mpc.el +++ b/lisp/mpc.el @@ -1017,7 +1017,7 @@ If PLAYLIST is t or nil or missing, use the main playlist." (text (if (eq info 'self) (symbol-name tag) (pcase tag - ((or `Time `Duration) + ((or 'Time 'Duration) (let ((time (cdr (or (assq 'time info) (assq 'Time info))))) (setq pred (list nil)) ;Just assume it's never eq. (when time @@ -1025,7 +1025,7 @@ If PLAYLIST is t or nil or missing, use the main playlist." (string-match ":" time)) (substring time (match-end 0)) time))))) - (`Cover + ('Cover (let ((dir (file-name-directory (cdr (assq 'file info))))) ;; (debug) (push `(equal ',dir (file-name-directory (cdr (assq 'file info)))) pred) @@ -2403,10 +2403,38 @@ This is used so that they can be compared with `eq', which is needed for (interactive) (mpc-cmd-pause "0")) +(defun mpc-read-seek (prompt) + "Read a seek time. +Returns a string suitable for MPD \"seekcur\" protocol command." + (let* ((str (read-from-minibuffer prompt nil nil nil nil nil t)) + (seconds "\\(?1:[[:digit:]]+\\(?:\\.[[:digit:]]*\\)?\\)") + (minsec (concat "\\(?2:[[:digit:]]+\\):" seconds "?")) + (hrminsec (concat "\\(?3:[[:digit:]]+\\):\\(?:" minsec "?\\|:\\)")) + time sign) + (setq str (string-trim str)) + (when (memq (string-to-char str) '(?+ ?-)) + (setq sign (string (string-to-char str))) + (setq str (substring str 1))) + (setq time + ;; `string-to-number' returns 0 on failure + (cond + ((string-match (concat "^" hrminsec "$") str) + (+ (* 3600 (string-to-number (match-string 3 str))) + (* 60 (string-to-number (or (match-string 2 str) ""))) + (string-to-number (or (match-string 1 str) "")))) + ((string-match (concat "^" minsec "$") str) + (+ (* 60 (string-to-number (match-string 2 str))) + (string-to-number (match-string 1 str)))) + ((string-match (concat "^" seconds "$") str) + (string-to-number (match-string 1 str))) + (t (user-error "Invalid time")))) + (setq time (number-to-string time)) + (if (null sign) time (concat sign time)))) + (defun mpc-seek-current (pos) "Seek within current track." (interactive - (list (read-string "Position to go ([+-]seconds): "))) + (list (mpc-read-seek "Position to go ([+-][[H:]M:]seconds): "))) (mpc-cmd-seekcur pos)) (defun mpc-toggle-play () @@ -2527,7 +2555,6 @@ If stopped, start playback." (defvar mpc--faster-toggle-forward nil) (defvar mpc--faster-acceleration 0.5) (defun mpc--faster-toggle (speedup step) - (setq speedup (float speedup)) (if mpc--faster-toggle-timer (mpc--faster-stop) (mpc-status-refresh) (mpc-proc-sync) @@ -2554,7 +2581,7 @@ If stopped, start playback." (setq songtime (string-to-number (cdr (assq 'time mpc-status)))) (setq songduration (mpc--songduration)) - (setq oldtime (float-time))) + (setq oldtime (current-time))) ((and (>= songtime songduration) mpc--faster-toggle-forward) ;; Skip to the beginning of the next song. (if (not (equal (cdr (assq 'state mpc-status)) "play")) @@ -2573,14 +2600,16 @@ If stopped, start playback." (lambda () (setq songid (cdr (assq 'songid mpc-status))) (setq songtime (setq songduration (mpc--songduration))) - (setq oldtime (float-time)) + (setq oldtime (current-time)) (mpc-proc-cmd (list "seekid" songid songtime))))))) (t (setq speedup (+ speedup mpc--faster-acceleration)) (let ((newstep - (truncate (* speedup (- (float-time) oldtime))))) + (truncate + (* speedup + (float-time (time-since oldtime)))))) (if (<= newstep 1) (setq newstep 1)) - (setq oldtime (+ oldtime (/ newstep speedup))) + (setq oldtime (time-add oldtime (/ newstep speedup))) (if (not mpc--faster-toggle-forward) (setq newstep (- newstep))) (setq songtime (min songduration (+ songtime newstep))) diff --git a/lisp/msb.el b/lisp/msb.el index ccc5f54738c..1d43dc0dfac 100644 --- a/lisp/msb.el +++ b/lisp/msb.el @@ -64,7 +64,7 @@ ;; Larry Rosenberg <ljr@ictv.com> ;; Will Henney <will@astroscu.unam.mx> ;; Jari Aalto <jaalto@tre.tele.nokia.fi> -;; Michael Kifer <kifer@sbkifer.cs.sunysb.edu> +;; Michael Kifer <kifer@cs.stonybrook.edu> ;; Gael Marziou <gael@gnlab030.grenoble.hp.com> ;; Dave Gillespie <daveg@thymus.synaptics.com> ;; Alon Albert <alon@milcse.rtsg.mot.com> @@ -1132,9 +1132,6 @@ variable `msb-menu-cond'." ;;;###autoload (define-minor-mode msb-mode "Toggle Msb mode. -With a prefix argument ARG, enable Msb mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. This mode overrides the binding(s) of `mouse-buffer-menu' to provide a different buffer menu using the function `msb'." diff --git a/lisp/mwheel.el b/lisp/mwheel.el index 2186595ddb4..dfea55374b0 100644 --- a/lisp/mwheel.el +++ b/lisp/mwheel.el @@ -1,7 +1,6 @@ ;;; mwheel.el --- Wheel mouse support ;; Copyright (C) 1998, 2000-2019 Free Software Foundation, Inc. -;; Maintainer: William M. Perry <wmperry@gnu.org> ;; Keywords: mouse ;; Package: emacs @@ -22,22 +21,22 @@ ;;; Commentary: -;; This code will enable the use of the infamous 'wheel' on the new -;; crop of mice. Under XFree86 and the XSuSE X Servers, the wheel -;; events are sent as button4/button5 events. +;; This enables the use of the mouse wheel (or scroll wheel) in Emacs. +;; Under X11/X.Org, the wheel events are sent as button4/button5 +;; events. +;; It is already enabled by default on most graphical displays. You +;; can toggle it with M-x mouse-wheel-mode. + +;;; Code: + +;; Implementation note: +;; ;; I for one would prefer some way of converting the button4/button5 ;; events into different event types, like 'mwheel-up' or ;; 'mwheel-down', but I cannot find a way to do this very easily (or ;; portably), so for now I just live with it. -;; To enable this code, simply put this at the top of your .emacs -;; file: -;; -;; (mouse-wheel-mode 1) - -;;; Code: - (require 'custom) (require 'timer) @@ -52,38 +51,25 @@ ;; Sync the bindings. (when (bound-and-true-p mouse-wheel-mode) (mouse-wheel-mode 1))) -(defvar mouse-wheel-down-button 4) -(make-obsolete-variable 'mouse-wheel-down-button - 'mouse-wheel-down-event - "22.1") (defcustom mouse-wheel-down-event (if (or (featurep 'w32-win) (featurep 'ns-win)) 'wheel-up - (intern (format "mouse-%s" mouse-wheel-down-button))) + 'mouse-4) "Event used for scrolling down." :group 'mouse :type 'symbol :set 'mouse-wheel-change-button) -(defvar mouse-wheel-up-button 5) -(make-obsolete-variable 'mouse-wheel-up-button - 'mouse-wheel-up-event - "22.1") (defcustom mouse-wheel-up-event (if (or (featurep 'w32-win) (featurep 'ns-win)) 'wheel-down - (intern (format "mouse-%s" mouse-wheel-up-button))) + 'mouse-5) "Event used for scrolling up." :group 'mouse :type 'symbol :set 'mouse-wheel-change-button) -(defvar mouse-wheel-click-button 2) -(make-obsolete-variable 'mouse-wheel-click-button - 'mouse-wheel-click-event - "22.1") -(defcustom mouse-wheel-click-event - (intern (format "mouse-%s" mouse-wheel-click-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 happen that text is accidentally yanked into the buffer when @@ -322,10 +308,7 @@ non-Windows systems." (defvar mwheel-installed-bindings nil) (define-minor-mode mouse-wheel-mode - "Toggle mouse wheel support (Mouse Wheel mode). -With a prefix argument ARG, enable Mouse Wheel mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil." + "Toggle mouse wheel support (Mouse Wheel mode)." :init-value t ;; We'd like to use custom-initialize-set here so the setup is done ;; before dumping, but at the point where the defcustom is evaluated, @@ -351,6 +334,7 @@ the mode if ARG is omitted or nil." ;; preloaded ;;;###autoload (defun mwheel-install (&optional uninstall) "Enable mouse wheel support." + (declare (obsolete mouse-wheel-mode "27.1")) (mouse-wheel-mode (if uninstall -1 1))) (provide 'mwheel) diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index f400c562939..b0a1e1799f5 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -1,4 +1,4 @@ -;;; ange-ftp.el --- transparent FTP support for GNU Emacs +;;; ange-ftp.el --- transparent FTP support for GNU Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1989-1996, 1998, 2000-2019 Free Software Foundation, ;; Inc. @@ -1168,7 +1168,7 @@ only return the directory part of FILE." (ange-ftp-parse-netrc) (catch 'found-one (maphash - (lambda (host val) + (lambda (host _val) (if (ange-ftp-lookup-passwd host user) (throw 'found-one host))) ange-ftp-user-hashtable) (save-match-data @@ -1361,11 +1361,13 @@ only return the directory part of FILE." (ange-ftp-real-expand-file-name ange-ftp-netrc-filename))) (setq attr (ange-ftp-real-file-attributes file))) (if (and attr ; file exists. - (not (equal (nth 5 attr) ange-ftp-netrc-modtime))) ; file changed + (not (equal (file-attribute-modification-time attr) + ange-ftp-netrc-modtime))) ; file changed (save-match-data (if (or ange-ftp-disable-netrc-security-check - (and (eq (nth 2 attr) (user-uid)) ; Same uids. - (string-match ".r..------" (nth 8 attr)))) + (and (eq (file-attribute-user-id attr) (user-uid)) ; Same uids. + (string-match ".r..------" + (file-attribute-modes attr)))) (with-current-buffer ;; we are cheating a bit here. I'm trying to do the equivalent ;; of find-file on the .netrc file, but then nuke it afterwards. @@ -1389,7 +1391,8 @@ only return the directory part of FILE." (ange-ftp-message "%s either not owned by you or badly protected." ange-ftp-netrc-filename) (sit-for 1)) - (setq ange-ftp-netrc-modtime (nth 5 attr)))))) + (setq ange-ftp-netrc-modtime + (file-attribute-modification-time attr)))))) ;; Return a list of prefixes of the form 'user@host:' to be used when ;; completion is done in the root directory. @@ -1399,14 +1402,14 @@ only return the directory part of FILE." (save-match-data (let (res) (maphash - (lambda (key value) + (lambda (key _value) (if (string-match "\\`[^/]*\\(/\\).*\\'" key) (let ((host (substring key 0 (match-beginning 1))) (user (substring key (match-end 1)))) (push (concat user "@" host ":") res)))) ange-ftp-passwd-hashtable) (maphash - (lambda (host user) (push (concat host ":") res)) + (lambda (host _user) (push (concat host ":") res)) ange-ftp-user-hashtable) (or res (list nil))))) @@ -1684,7 +1687,7 @@ good, skip, fatal, or unknown." ange-ftp-process-result ange-ftp-process-result-line))))))) -(defun ange-ftp-process-sentinel (proc str) +(defun ange-ftp-process-sentinel (proc _str) "When FTP process changes state, nuke all file-entries in cache." (let ((name (process-name proc))) (when (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)\\*" name) @@ -1733,7 +1736,7 @@ good, skip, fatal, or unknown." (defvar ange-ftp-gwp-running t) (defvar ange-ftp-gwp-status nil) -(defun ange-ftp-gwp-sentinel (proc str) +(defun ange-ftp-gwp-sentinel (_proc _str) (setq ange-ftp-gwp-running nil)) (defun ange-ftp-gwp-filter (proc str) @@ -1873,7 +1876,7 @@ been queued with no result. CONT will still be called, however." (interactive "sHost: ") (if ange-ftp-nslookup-program (let ((default-directory - (if (file-accessible-directory-p default-directory) + (if (ange-ftp-real-file-accessible-directory-p default-directory) default-directory exec-directory)) ;; It would be nice to make process-connection-type nil, @@ -1916,7 +1919,7 @@ on the gateway machine to do the FTP instead." ;; default-directory. (file-name-handler-alist) (default-directory - (if (file-accessible-directory-p default-directory) + (if (ange-ftp-real-file-accessible-directory-p default-directory) default-directory exec-directory)) proc) @@ -1986,7 +1989,7 @@ on the gateway machine to do the FTP instead." (make-local-variable 'comint-password-prompt-regexp) ;; This is a regexp that can't match anything. ;; ange-ftp has its own ways of handling passwords. - (setq comint-password-prompt-regexp "\\`a\\`") + (setq comint-password-prompt-regexp regexp-unmatchable) (make-local-variable 'paragraph-start) (setq paragraph-start comint-prompt-regexp)) @@ -2676,7 +2679,7 @@ The main reason for this alist is to deal with file versions in VMS.") (defmacro ange-ftp-parse-filename () ;;Extract the filename from the current line of a dired-like listing. - `(save-match-data + '(save-match-data (let ((eol (progn (end-of-line) (point)))) (beginning-of-line) (if (re-search-forward directory-listing-before-filename-regexp eol t) @@ -2725,7 +2728,7 @@ The main reason for this alist is to deal with file versions in VMS.") ;; seem to believe in the F-switch (if (or (and symlink (string-match "@\\'" file)) (and directory (string-match "/\\'" file)) - (and executable (string-match "*\\'" file)) + (and executable (string-match "\\*\\'" file)) (and socket (string-match "=\\'" file))) (setq file (substring file 0 -1))))) (puthash file (or symlink directory) tbl) @@ -2758,7 +2761,7 @@ match subdirectories as well.") (defmacro ange-ftp-dl-parser () ;; Parse the current buffer, which is assumed to be a descriptive ;; listing, and return a hashtable. - `(let ((tbl (make-hash-table :test 'equal))) + '(let ((tbl (make-hash-table :test 'equal))) (while (not (eobp)) (puthash (buffer-substring (point) @@ -2868,7 +2871,6 @@ NO-ERROR, if a listing for DIRECTORY cannot be obtained." ;; 2. The syntax of FILE and DIR make it impossible that FILE could be a valid ;; subdirectory. This is of course an OS dependent judgment. -(defvar dired-local-variables-file) (defmacro ange-ftp-allow-child-lookup (dir file) `(not (let* ((efile ,file) ; expand once. @@ -2877,10 +2879,6 @@ NO-ERROR, if a listing for DIRECTORY cannot be obtained." (host-type (ange-ftp-host-type (car parsed)))) (or - ;; Deal with dired - (and (boundp 'dired-local-variables-file) ; in the dired-x package - (stringp dired-local-variables-file) - (string-equal dired-local-variables-file efile)) ;; No dots in dir names in vms. (and (eq host-type 'vms) (string-match "\\." efile)) @@ -3247,7 +3245,8 @@ system TYPE.") ;; tell the process filter what size the transfer will be. (let ((attr (file-attributes temp))) (if attr - (ange-ftp-set-xfer-size host user (nth 7 attr)))) + (ange-ftp-set-xfer-size host user + (file-attribute-size attr)))) ;; put or append the file. (let ((result (ange-ftp-send-cmd host user @@ -3373,6 +3372,13 @@ system TYPE.") (file-error nil)) (ange-ftp-real-file-symlink-p file))) +(defun ange-ftp-file-regular-p (file) + ;; Reuse Tramp's implementation. + (if (ange-ftp-ftp-name file) + (and (file-exists-p file) + (eq ?- (aref (file-attribute-modes (file-attributes file)) 0))) + (ange-ftp-real-file-regular-p file))) + (defun ange-ftp-file-exists-p (name) (setq name (expand-file-name name)) (if (ange-ftp-ftp-name name) @@ -3404,6 +3410,10 @@ system TYPE.") file-ent)) (ange-ftp-real-file-directory-p name))) +(defun ange-ftp-file-accessible-directory-p (name) + (and (file-directory-p name) + (file-readable-p name))) + (defun ange-ftp-directory-files (directory &optional full match &rest v19-args) (setq directory (expand-file-name directory)) @@ -3441,9 +3451,9 @@ system TYPE.") (let ((part (ange-ftp-get-file-part file)) (files (ange-ftp-get-files (file-name-directory file)))) (if (ange-ftp-hash-entry-exists-p part files) - (let ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (name (nth 2 parsed)) + (let (;; (host (nth 0 parsed)) + ;; (user (nth 1 parsed)) + ;; (name (nth 2 parsed)) (dirp (gethash part files)) (inode (gethash file ange-ftp-inodes-hashtable))) (unless inode @@ -3475,8 +3485,8 @@ system TYPE.") (let ((f1-parsed (ange-ftp-ftp-name f1)) (f2-parsed (ange-ftp-ftp-name f2))) (if (or f1-parsed f2-parsed) - (let ((f1-mt (nth 5 (file-attributes f1))) - (f2-mt (nth 5 (file-attributes f2)))) + (let ((f1-mt (file-attribute-modification-time (file-attributes f1))) + (f2-mt (file-attribute-modification-time (file-attributes f2)))) (cond ((null f1-mt) nil) ((null f2-mt) t) (t (time-less-p f2-mt f1-mt)))) @@ -3776,7 +3786,8 @@ so return the size on the remote host exactly. See RFC 3659." ;; tell the process filter what size the file is. (let ((attr (file-attributes (or temp2 filename)))) (if attr - (ange-ftp-set-xfer-size t-host t-user (nth 7 attr)))) + (ange-ftp-set-xfer-size t-host t-user + (file-attribute-size attr)))) (ange-ftp-send-cmd t-host @@ -3829,7 +3840,7 @@ so return the size on the remote host exactly. See RFC 3659." (ange-ftp-call-cont cont result line))) (defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists - keep-date preserve-uid-gid + keep-date _preserve-uid-gid _preserve-selinux-context) (interactive "fCopy file: \nFCopy %s to file: \np") (ange-ftp-copy-file-internal filename @@ -4266,7 +4277,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") nil t nil - "-c" + shell-command-switch (format "compress -f -c < %s > %s" tmp1 tmp2)) (and ange-ftp-process-verbose (ange-ftp-message "Compressing %s...done" abbr)) @@ -4302,7 +4313,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") nil t nil - "-c" + shell-command-switch (format "uncompress -c < %s > %s" tmp1 tmp2)) (and ange-ftp-process-verbose (ange-ftp-message "Uncompressing %s...done" abbr)) @@ -4385,10 +4396,13 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (put 'directory-files-and-attributes 'ange-ftp 'ange-ftp-directory-files-and-attributes) (put 'file-directory-p 'ange-ftp 'ange-ftp-file-directory-p) +(put 'file-accessible-directory-p 'ange-ftp + 'ange-ftp-file-accessible-directory-p) (put 'file-writable-p 'ange-ftp 'ange-ftp-file-writable-p) (put 'file-readable-p 'ange-ftp 'ange-ftp-file-readable-p) (put 'file-executable-p 'ange-ftp 'ange-ftp-file-executable-p) (put 'file-symlink-p 'ange-ftp 'ange-ftp-file-symlink-p) +(put 'file-regular-p 'ange-ftp 'ange-ftp-file-regular-p) (put 'delete-file 'ange-ftp 'ange-ftp-delete-file) (put 'verify-visited-file-modtime 'ange-ftp 'ange-ftp-verify-visited-file-modtime) @@ -4427,6 +4441,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") ;; We can handle process-file in a restricted way (just for chown). ;; Nothing possible for `start-file-process'. +(put 'exec-path 'ange-ftp 'ignore) +(put 'make-process 'ange-ftp 'ignore) (put 'process-file 'ange-ftp 'ange-ftp-process-file) (put 'start-file-process 'ange-ftp 'ignore) (put 'shell-command 'ange-ftp 'ange-ftp-shell-command) @@ -4469,6 +4485,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (ange-ftp-run-real-handler 'directory-files-and-attributes args)) (defun ange-ftp-real-file-directory-p (&rest args) (ange-ftp-run-real-handler 'file-directory-p args)) +(defun ange-ftp-real-file-accessible-directory-p (&rest args) + (ange-ftp-run-real-handler 'file-accessible-directory-p args)) (defun ange-ftp-real-file-writable-p (&rest args) (ange-ftp-run-real-handler 'file-writable-p args)) (defun ange-ftp-real-file-readable-p (&rest args) @@ -4477,6 +4495,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (ange-ftp-run-real-handler 'file-executable-p args)) (defun ange-ftp-real-file-symlink-p (&rest args) (ange-ftp-run-real-handler 'file-symlink-p args)) +(defun ange-ftp-real-file-regular-p (&rest args) + (ange-ftp-run-real-handler 'file-regular-p args)) (defun ange-ftp-real-delete-file (&rest args) (ange-ftp-run-real-handler 'delete-file args)) (defun ange-ftp-real-verify-visited-file-modtime (&rest args) @@ -5199,7 +5219,7 @@ Other orders of $ and _ seem to all work just fine.") ";\\([0-9]+\\)$")) (version 0)) (maphash - (lambda (name val) + (lambda (name _val) (and (string-match regexp name) (setq version (max version diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index cc7c11e4391..6382e66f615 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -131,9 +131,36 @@ :group 'external :group 'comm) +(defvar browse-url--browser-defcustom-type + '(choice + (function-item :tag "Emacs W3" :value browse-url-w3) + (function-item :tag "eww" :value eww-browse-url) + (function-item :tag "Mozilla" :value browse-url-mozilla) + (function-item :tag "Firefox" :value browse-url-firefox) + (function-item :tag "Google Chrome" :value browse-url-chrome) + (function-item :tag "Chromium" :value browse-url-chromium) + (function-item :tag "Epiphany" :value browse-url-epiphany) + (function-item :tag "Conkeror" :value browse-url-conkeror) + (function-item :tag "Text browser in an xterm window" + :value browse-url-text-xterm) + (function-item :tag "Text browser in an Emacs window" + :value browse-url-text-emacs) + (function-item :tag "KDE" :value browse-url-kde) + (function-item :tag "Elinks" :value browse-url-elinks) + (function-item :tag "Specified by `Browse Url Generic Program'" + :value browse-url-generic) + (function-item :tag "Default Windows browser" + :value browse-url-default-windows-browser) + (function-item :tag "Default macOS browser" + :value browse-url-default-macosx-browser) + (function-item :tag "Default browser" + :value browse-url-default-browser) + (function :tag "Your own function") + (alist :tag "Regexp/function association list" + :key-type regexp :value-type function))) + ;;;###autoload -(defcustom browse-url-browser-function - 'browse-url-default-browser +(defcustom browse-url-browser-function 'browse-url-default-browser "Function to display the current buffer in a WWW browser. This is used by the `browse-url-at-point', `browse-url-at-mouse', and `browse-url-of-file' commands. @@ -143,34 +170,17 @@ If the value is not a function it should be a list of pairs associated with the first REGEXP which matches the current URL. The function is passed the URL and any other args of `browse-url'. The last regexp should probably be \".\" to specify a default browser." - :type '(choice - (function-item :tag "Emacs W3" :value browse-url-w3) - (function-item :tag "eww" :value eww-browse-url) - (function-item :tag "Mozilla" :value browse-url-mozilla) - (function-item :tag "Firefox" :value browse-url-firefox) - (function-item :tag "Google Chrome" :value browse-url-chrome) - (function-item :tag "Chromium" :value browse-url-chromium) - (function-item :tag "Epiphany" :value browse-url-epiphany) - (function-item :tag "Conkeror" :value browse-url-conkeror) - (function-item :tag "Text browser in an xterm window" - :value browse-url-text-xterm) - (function-item :tag "Text browser in an Emacs window" - :value browse-url-text-emacs) - (function-item :tag "KDE" :value browse-url-kde) - (function-item :tag "Elinks" :value browse-url-elinks) - (function-item :tag "Specified by `Browse Url Generic Program'" - :value browse-url-generic) - (function-item :tag "Default Windows browser" - :value browse-url-default-windows-browser) - (function-item :tag "Default macOS browser" - :value browse-url-default-macosx-browser) - (function-item :tag "Default browser" - :value browse-url-default-browser) - (function :tag "Your own function") - (alist :tag "Regexp/function association list" - :key-type regexp :value-type function)) - :version "24.1" - :group 'browse-url) + :type browse-url--browser-defcustom-type + :version "24.1") + +(defcustom browse-url-secondary-browser-function 'browse-url-default-browser + "Function used to launch an alternative browser. +This should usually be an external browser (that is, not eww or +w3m), used as the secondary browser choice, and is typically used +when giving a prefix argument to the URL-opening command (in +those modes that support this (for instance, eww/shr)." + :version "27.1" + :type browse-url--browser-defcustom-type) (defcustom browse-url-mailto-function 'browse-url-mail "Function to display mailto: links. @@ -181,8 +191,7 @@ be used instead." :type '(choice (function-item :tag "Emacs Mail" :value browse-url-mail) (function-item :tag "None" nil)) - :version "24.1" - :group 'browse-url) + :version "24.1") (defcustom browse-url-man-function 'browse-url-man "Function to display man: links." @@ -190,8 +199,28 @@ be used instead." (function-item :tag "Emacs Man" :value browse-url-man) (const :tag "None" nil) (function :tag "Other function")) - :version "26.1" - :group 'browse-url) + :version "26.1") + +(defcustom browse-url-button-regexp + (concat + "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|" + "nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)" + "\\(//[-a-z0-9_.]+:[0-9]*\\)?" + (let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]") + (punct "!?:;.,")) + (concat + "\\(?:" + ;; Match paired parentheses, e.g. in Wikipedia URLs: + ;; http://thread.gmane.org/47B4E3B2.3050402@gmail.com + "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" + "\\(?:" "[" chars punct "]+" "[" chars "]" "\\)?" + "\\|" + "[" chars punct "]+" "[" chars "]" + "\\)")) + "\\)") + "Regular expression that matches URLs." + :version "27.1" + :type 'regexp) (defcustom browse-url-netscape-program "netscape" ;; Info about netscape-remote from Karl Berry. @@ -202,15 +231,13 @@ The free program `netscape-remote' from 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 - :group 'browse-url) + :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")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (make-obsolete-variable 'browse-url-netscape-arguments nil "25.1") @@ -218,33 +245,27 @@ system, given vroot.h from the same directory, with cc flags "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")) - - :group 'browse-url) + :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)) - :group 'browse-url) + :type '(choice string (const :tag "Default" nil))) (defcustom browse-url-mozilla-program "mozilla" "The name by which to invoke Mozilla." - :type 'string - :group 'browse-url) + :type 'string) (defcustom browse-url-mozilla-arguments nil "A list of strings to pass to Mozilla as arguments." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (defcustom browse-url-mozilla-startup-arguments browse-url-mozilla-arguments "A list of strings to pass to Mozilla when it starts up. Defaults to the value of `browse-url-mozilla-arguments' at the time `browse-url' is loaded." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (defcustom browse-url-firefox-program (let ((candidates '("icecat" "iceweasel" "firefox"))) @@ -252,20 +273,17 @@ Defaults to the value of `browse-url-mozilla-arguments' at the time (setq candidates (cdr candidates))) (or (car candidates) "firefox")) "The name by which to invoke Firefox or a variant of it." - :type 'string - :group 'browse-url) + :type 'string) (defcustom browse-url-firefox-arguments nil "A list of strings to pass to Firefox (or variant) as arguments." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (defcustom browse-url-firefox-startup-arguments browse-url-firefox-arguments "A list of strings to pass to Firefox (or variant) when it starts up. Defaults to the value of `browse-url-firefox-arguments' at the time `browse-url' is loaded." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (make-obsolete-variable 'browse-url-firefox-startup-arguments "it no longer has any effect." "24.5") @@ -277,14 +295,12 @@ Defaults to the value of `browse-url-firefox-arguments' at the time (or (car candidates) "chromium")) "The name by which to invoke the Chrome browser." :type 'string - :version "25.1" - :group 'browse-url) + :version "25.1") (defcustom browse-url-chrome-arguments nil "A list of strings to pass to Google Chrome as arguments." :type '(repeat (string :tag "Argument")) - :version "25.1" - :group 'browse-url) + :version "25.1") (defcustom browse-url-chromium-program (let ((candidates '("chromium" "chromium-browser"))) @@ -293,26 +309,22 @@ Defaults to the value of `browse-url-firefox-arguments' at the time (or (car candidates) "chromium")) "The name by which to invoke Chromium." :type 'string - :version "24.1" - :group 'browse-url) + :version "24.1") (defcustom browse-url-chromium-arguments nil "A list of strings to pass to Chromium as arguments." :type '(repeat (string :tag "Argument")) - :version "24.1" - :group 'browse-url) + :version "24.1") (defcustom browse-url-galeon-program "galeon" "The name by which to invoke Galeon." - :type 'string - :group 'browse-url) + :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")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (make-obsolete-variable 'browse-url-galeon-arguments nil "25.1") @@ -320,27 +332,23 @@ Defaults to the value of `browse-url-firefox-arguments' at the time "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")) - :group 'browse-url) + :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 Epiphany." - :type 'string - :group 'browse-url) + :type 'string) (defcustom browse-url-epiphany-arguments nil "A list of strings to pass to Epiphany as arguments." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (defcustom browse-url-epiphany-startup-arguments browse-url-epiphany-arguments "A list of strings to pass to Epiphany when it starts up. Defaults to the value of `browse-url-epiphany-arguments' at the time `browse-url' is loaded." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) ;; GNOME means of invoking either Mozilla or Netscape. (defvar browse-url-gnome-moz-program "gnome-moz-remote") @@ -350,8 +358,7 @@ Defaults to the value of `browse-url-epiphany-arguments' at the time (defcustom browse-url-gnome-moz-arguments '() "A list of strings passed to the GNOME mozilla viewer as arguments." :version "21.1" - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (make-obsolete-variable 'browse-url-gnome-moz-arguments nil "25.1") @@ -359,30 +366,26 @@ Defaults to the value of `browse-url-epiphany-arguments' at the time "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-mozilla' is asked to open it in a new window." - :type 'boolean - :group 'browse-url) + :type 'boolean) (defcustom browse-url-firefox-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-firefox' is asked to open it in a new window." - :type 'boolean - :group 'browse-url) + :type 'boolean) (defcustom browse-url-conkeror-new-window-is-buffer nil "Whether to open up new windows in a buffer or a new window. If non-nil, then open the URL in a new buffer rather than a new window if `browse-url-conkeror' is asked to open it in a new window." :version "25.1" - :type 'boolean - :group 'browse-url) + :type 'boolean) (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 - :group 'browse-url) + :type 'boolean) (make-obsolete-variable 'browse-url-galeon-new-window-is-tab nil "25.1") @@ -390,16 +393,14 @@ If non-nil, then open the URL in a new tab rather than a new window if "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 - :group 'browse-url) + :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 - :group 'browse-url) + :type 'boolean) (make-obsolete-variable 'browse-url-netscape-new-window-is-tab nil "25.1") @@ -407,42 +408,36 @@ window." "Non-nil means always open a new browser window with appropriate browsers. Passing an interactive argument to \\[browse-url], or specific browser commands reverses the effect of this variable." - :type 'boolean - :group 'browse-url) + :type 'boolean) (defcustom browse-url-mosaic-program "xmosaic" "The name by which to invoke Mosaic (or mMosaic)." :type 'string - :version "20.3" - :group 'browse-url) + :version "20.3") (make-obsolete-variable 'browse-url-mosaic-program nil "25.1") (defcustom browse-url-mosaic-arguments nil "A list of strings to pass to Mosaic as arguments." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (make-obsolete-variable 'browse-url-mosaic-arguments nil "25.1") (defcustom browse-url-mosaic-pidfile "~/.mosaicpid" "The name of the pidfile created by Mosaic." - :type 'string - :group 'browse-url) + :type 'string) (make-obsolete-variable 'browse-url-mosaic-pidfile nil "25.1") (defcustom browse-url-conkeror-program "conkeror" "The name by which to invoke Conkeror." :type 'string - :version "25.1" - :group 'browse-url) + :version "25.1") (defcustom browse-url-conkeror-arguments nil "A list of strings to pass to Conkeror as arguments." :version "25.1" - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (defcustom browse-url-filename-alist `(("^/\\(ftp@\\|anonymous@\\)?\\([^:/]+\\):/*" . "ftp://\\2/") @@ -473,26 +468,22 @@ address to an HTTP URL: :type '(repeat (cons :format "%v" (regexp :tag "Regexp") (string :tag "Replacement"))) - :version "25.1" - :group 'browse-url) + :version "25.1") (defcustom browse-url-save-file nil "If non-nil, save the buffer before displaying its file. Used by the `browse-url-of-file' command." - :type 'boolean - :group 'browse-url) + :type 'boolean) (defcustom browse-url-of-file-hook nil "Hook run after `browse-url-of-file' has asked a browser to load a file." - :type 'hook - :group 'browse-url) + :type 'hook) (defcustom browse-url-CCI-port 3003 "Port to access XMosaic via CCI. This can be any number between 1024 and 65535 but must correspond to the value set in the browser." - :type 'integer - :group 'browse-url) + :type 'integer) (make-obsolete-variable 'browse-url-CCI-port nil "25.1") @@ -500,8 +491,7 @@ the value set in the browser." "Host to access XMosaic via CCI. This should be the host name of the machine running XMosaic with CCI enabled. The port number should be set in `browse-url-CCI-port'." - :type 'string - :group 'browse-url) + :type 'string) (make-obsolete-variable 'browse-url-CCI-host nil "25.1") @@ -511,57 +501,48 @@ enabled. The port number should be set in `browse-url-CCI-port'." (defcustom browse-url-xterm-program "xterm" "The name of the terminal emulator used by `browse-url-text-xterm'. This might, for instance, be a separate color version of xterm." - :type 'string - :group 'browse-url) + :type 'string) (defcustom browse-url-xterm-args nil "A list of strings defining options for `browse-url-xterm-program'. These might set its size, for instance." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (defcustom browse-url-gnudoit-program "gnudoit" "The name of the `gnudoit' program used by `browse-url-w3-gnudoit'." - :type 'string - :group 'browse-url) + :type 'string) (defcustom browse-url-gnudoit-args '("-q") "A list of strings defining options for `browse-url-gnudoit-program'. These might set the port, for instance." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (defcustom browse-url-generic-program nil "The name of the browser program used by `browse-url-generic'." - :type '(choice string (const :tag "None" nil)) - :group 'browse-url) + :type '(choice string (const :tag "None" nil))) (defcustom browse-url-generic-args nil "A list of strings defining options for `browse-url-generic-program'." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (defcustom browse-url-temp-dir temporary-file-directory "The name of a directory for browse-url's temporary files. Such files are generated by functions like `browse-url-of-region'. You might want to set this to somewhere with restricted read permissions for privacy's sake." - :type 'string - :group 'browse-url) + :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 - :group 'browse-url) + :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 - :group 'browse-url :version "23.1") (defcustom browse-url-text-emacs-args (and (not window-system) @@ -572,8 +553,7 @@ The default is none in a window system, otherwise `-show_cursor' to indicate the position of the current link in the absence of highlighting, assuming the normal default for showing the cursor." :type '(repeat (string :tag "Argument")) - :version "23.1" - :group 'browse-url) + :version "23.1") (defcustom browse-url-text-input-field 'avoid "Action on selecting an existing text browser buffer at an input field. @@ -586,36 +566,30 @@ down (this *won't* always work)." :type '(choice (const :tag "Move to try to avoid field" :value avoid) (const :tag "Disregard" :value nil) (const :tag "Warn, don't emit URL" :value warn)) - :version "23.1" - :group 'browse-url) + :version "23.1") (defcustom browse-url-text-input-attempts 10 "How many times to try to move down from a series of text browser input fields." :type 'integer - :version "23.1" - :group 'browse-url) + :version "23.1") (defcustom browse-url-text-input-delay 0.2 "Seconds to wait for a text browser between moves down from an input field." :type 'number - :version "23.1" - :group 'browse-url) + :version "23.1") (defcustom browse-url-kde-program "kfmclient" "The name by which to invoke the KDE web browser." :type 'string - :version "21.1" - :group 'browse-url) + :version "21.1") (defcustom browse-url-kde-args '("openURL") "A list of strings defining options for `browse-url-kde-program'." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (defcustom browse-url-elinks-wrapper '("xterm" "-e") "Wrapper command prepended to the Elinks command-line." - :type '(repeat (string :tag "Wrapper")) - :group 'browse-url) + :type '(repeat (string :tag "Wrapper"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; URL encoding @@ -713,8 +687,7 @@ 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 (default-value 'enable-multibyte-characters) - (or file-name-coding-system + (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 "[*\"()',=;?% ]")) @@ -1257,18 +1230,16 @@ used instead of `browse-url-new-window-flag'." (defvar url-handler-regexp) ;;;###autoload -(defun browse-url-emacs (url &optional _new-window) - "Ask Emacs to load URL into a buffer and show it in another window." +(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 +currently selected window instead." (interactive (browse-url-interactive-arg "URL: ")) (require 'url-handlers) (let ((file-name-handler-alist (cons (cons url-handler-regexp 'url-file-handler) file-name-handler-alist))) - ;; Ignore `new-window': with all other browsers the URL is always shown - ;; in another window than the current Emacs one since it's shown in - ;; another application's window. - ;; (if new-window (find-file-other-window url) (find-file url)) - (find-file-other-window url))) + (if same-window (find-file url) (find-file-other-window url)))) ;;;###autoload (defun browse-url-gnome-moz (url &optional new-window) @@ -1676,6 +1647,67 @@ from `browse-url-elinks-wrapper'." (error "Unrecognized exit-code %d of process `elinks'" exit-status)))) +;;; 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.") + +(defface browse-url-button + '((t :inherit link)) + "Face for browse-url buttons (i.e., links)." + :version "27.1") + +(defun browse-url-add-buttons () + "Add clickable buttons to the text following point in the current buffer. +Everything that matches `browse-url-button-regexp' will be made +clickable and will use `browse-url' to open the URLs in question." + (let ((inhibit-read-only t)) + (save-excursion + (while (re-search-forward browse-url-button-regexp nil t) + (add-text-properties (match-beginning 0) + (match-end 0) + `(help-echo "Open the URL under point" + keymap ,browse-url-button-map + face browse-url-button + button t + category browse-url + browse-url-data ,(match-string 0))))))) + +(defun browse-url-button-open (&optional external mouse-event) + "Follow the link under point using `browse-url'. +If EXTERNAL (the prefix if used interactively), open with the +external browser instead of the default one." + (interactive (list current-prefix-arg last-nonmenu-event)) + (mouse-set-point mouse-event) + (let ((url (get-text-property (point) 'browse-url-data))) + (unless url + (error "No URL under point")) + (if external + (funcall browse-url-secondary-browser-function url) + (browse-url url)))) + +(defun browse-url-button-open-url (url) + "Open URL using `browse-url'. +If `current-prefix-arg' is non-nil, use +`browse-url-secondary-browser-function' instead." + (if current-prefix-arg + (funcall browse-url-secondary-browser-function url) + (browse-url url))) + +(defun browse-url-button-copy () + "Copy the URL under point" + (interactive) + (let ((url (get-text-property (point) 'browse-url-data))) + (unless url + (error "No URL under point")) + (kill-new url) + (message "Copied %s" url))) + (provide 'browse-url) ;;; browse-url.el ends here diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 25e5d4dccc3..3820cd49f2b 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -41,9 +41,16 @@ (defvar dbus-message-type-method-return) (defvar dbus-message-type-error) (defvar dbus-message-type-signal) -(defvar dbus-debug) (defvar dbus-registered-objects-table) +;; The following symbols are defined in dbusbind.c. We need them also +;; when Emacs is compiled without D-Bus support. +(unless (boundp 'dbus-error) + (define-error 'dbus-error "D-Bus error")) + +(unless (boundp 'dbus-debug) + (defvar dbus-debug nil)) + ;; Pacify byte compiler. (eval-when-compile (require 'cl-lib)) diff --git a/lisp/net/dig.el b/lisp/net/dig.el index ad47982cc8e..ab199bd81c5 100644 --- a/lisp/net/dig.el +++ b/lisp/net/dig.el @@ -133,9 +133,7 @@ Buffer should contain output generated by `dig-invoke'." (define-derived-mode dig-mode special-mode "Dig" "Major mode for displaying dig output." (buffer-disable-undo) - (unless (featurep 'xemacs) - (set (make-local-variable 'font-lock-defaults) - '(dig-font-lock-keywords t))) + (setq-local font-lock-defaults '(dig-font-lock-keywords t)) (when (featurep 'font-lock) ;; FIXME: what is this for?? --Stef (font-lock-set-defaults)) diff --git a/lisp/net/dns.el b/lisp/net/dns.el index f6a804a6e86..9b0fd7235a2 100644 --- a/lisp/net/dns.el +++ b/lisp/net/dns.el @@ -106,7 +106,7 @@ updated. Set this variable to t to disable the check.") (defun dns-read-string-name (string buffer) (with-temp-buffer - (unless (featurep 'xemacs) (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (insert string) (goto-char (point-min)) (dns-read-name buffer))) @@ -117,7 +117,7 @@ updated. Set this variable to t to disable the check.") length) (while (not ended) (setq length (dns-read-bytes 1)) - (if (= 192 (logand length (lsh 3 6))) + (if (= 192 (logand length (ash 3 6))) (let ((offset (+ (* (logand 63 length) 256) (dns-read-bytes 1)))) (save-excursion @@ -140,21 +140,21 @@ updated. Set this variable to t to disable the check.") "Write a DNS packet according to SPEC. If TCP-P, the first two bytes of the package with be the length field." (with-temp-buffer - (unless (featurep 'xemacs) (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (dns-write-bytes (dns-get 'id spec) 2) (dns-write-bytes (logior - (lsh (if (dns-get 'response-p spec) 1 0) -7) - (lsh + (ash (if (dns-get 'response-p spec) 1 0) 7) + (ash (cond ((eq (dns-get 'opcode spec) 'query) 0) ((eq (dns-get 'opcode spec) 'inverse-query) 1) ((eq (dns-get 'opcode spec) 'status) 2) (t (error "No such opcode: %s" (dns-get 'opcode spec)))) - -3) - (lsh (if (dns-get 'authoritative-p spec) 1 0) -2) - (lsh (if (dns-get 'truncated-p spec) 1 0) -1) - (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0))) + 3) + (ash (if (dns-get 'authoritative-p spec) 1 0) 2) + (ash (if (dns-get 'truncated-p spec) 1 0) 1) + (ash (if (dns-get 'recursion-desired-p spec) 1 0) 0))) (dns-write-bytes (cond ((eq (dns-get 'response-code spec) 'no-error) 0) @@ -191,27 +191,27 @@ If TCP-P, the first two bytes of the package with be the length field." (defun dns-read (packet) (with-temp-buffer - (unless (featurep 'xemacs) (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (let ((spec nil) queries answers authorities additionals) (insert packet) (goto-char (point-min)) (push (list 'id (dns-read-bytes 2)) spec) (let ((byte (dns-read-bytes 1))) - (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t)) + (push (list 'response-p (if (zerop (logand byte (ash 1 7))) nil t)) spec) - (let ((opcode (logand byte (lsh 7 3)))) + (let ((opcode (logand byte (ash 7 3)))) (push (list 'opcode (cond ((eq opcode 0) 'query) ((eq opcode 1) 'inverse-query) ((eq opcode 2) 'status))) spec)) - (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2))) + (push (list 'authoritative-p (if (zerop (logand byte (ash 1 2))) nil t)) spec) - (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t)) + (push (list 'truncated-p (if (zerop (logand byte (ash 1 2))) nil t)) spec) (push (list 'recursion-desired-p - (if (zerop (logand byte (lsh 1 0))) nil t)) spec)) + (if (zerop (logand byte (ash 1 0))) nil t)) spec)) (let ((rc (logand (dns-read-bytes 1) 15))) (push (list 'response-code (cond @@ -268,7 +268,7 @@ If TCP-P, the first two bytes of the package with be the length field." (point (point))) (prog1 (with-temp-buffer - (unless (featurep 'xemacs) (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (insert string) (goto-char (point-min)) (cond @@ -356,26 +356,21 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." ;;; Interface functions. (defmacro dns-make-network-process (server) - (if (featurep 'xemacs) - `(let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (open-network-stream "dns" (current-buffer) - ,server "domain" 'udp)) - `(let ((server ,server) - (coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (if (fboundp 'make-network-process) - (make-network-process - :name "dns" - :coding 'binary - :buffer (current-buffer) - :host server - :service "domain" - :type 'datagram) - ;; Older versions of Emacs doesn't have - ;; `make-network-process', so we fall back on opening a TCP - ;; connection to the DNS server. - (open-network-stream "dns" (current-buffer) server "domain"))))) + `(let ((server ,server) + (coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (if (fboundp 'make-network-process) + (make-network-process + :name "dns" + :coding 'binary + :buffer (current-buffer) + :host server + :service "domain" + :type 'datagram) + ;; Older versions of Emacs doesn't have + ;; `make-network-process', so we fall back on opening a TCP + ;; connection to the DNS server. + (open-network-stream "dns" (current-buffer) server "domain")))) (defvar dns-cache (make-vector 4096 0)) @@ -409,7 +404,7 @@ If REVERSEP, look up an IP address." (if (not dns-servers) (message "No DNS server configuration found") (with-temp-buffer - (unless (featurep 'xemacs) (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (let ((process (condition-case () (dns-make-network-process (car dns-servers)) (error @@ -417,8 +412,6 @@ If REVERSEP, look up an IP address." "dns: Got an error while trying to talk to %s" (car dns-servers)) nil))) - (tcp-p (and (not (fboundp 'make-network-process)) - (not (featurep 'xemacs)))) (step 100) (times (* dns-timeout 1000)) (id (random 65000))) @@ -428,20 +421,16 @@ If REVERSEP, look up an IP address." (dns-write `((id ,id) (opcode query) (queries ((,name (type ,type)))) - (recursion-desired-p t)) - tcp-p)) + (recursion-desired-p t)))) (while (and (zerop (buffer-size)) (> times 0)) - (sit-for (/ step 1000.0)) - (accept-process-output process 0 step) + (let ((step-sec (/ step 1000.0))) + (sit-for step-sec) + (accept-process-output process step-sec)) (setq times (- times step))) (condition-case nil (delete-process process) (error nil)) - (when (and tcp-p - (>= (buffer-size) 2)) - (goto-char (point-min)) - (delete-region (point) (+ (point) 2))) (when (and (>= (buffer-size) 2) ;; We had a time-out. (> times 0)) diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el index 39b6ca9cdb9..59a4637eb80 100644 --- a/lisp/net/eudc-bob.el +++ b/lisp/net/eudc-bob.el @@ -25,8 +25,15 @@ ;;; Commentary: +;; eudc-bob.el presents binary entries in LDAP results in interactive +;; ways. For example, it will display JPEG binary data as an inline +;; image in the results buffer. See also +;; https://tools.ietf.org/html/rfc2798. + ;;; Usage: -;; See the corresponding info file + +;; The eudc-bob interactive functions are invoked when the user +;; interacts with an `eudc-query-form' results buffer. ;;; Code: @@ -148,40 +155,21 @@ display a button." "Toggle inline display of an image." (interactive) (when (eudc-bob-can-display-inline-images) - (cond ((featurep 'xemacs) - (let ((overlays (append (overlays-at (1- (point))) - (overlays-at (point)))) - overlay glyph) - (setq overlay (car overlays)) - (while (and overlay - (not (setq glyph (overlay-get overlay 'glyph)))) - (setq overlays (cdr overlays)) - (setq overlay (car overlays))) - (if overlay - (if (overlay-get overlay 'end-glyph) - (progn - (overlay-put overlay 'end-glyph nil) - (overlay-put overlay 'invisible nil)) - (overlay-put overlay 'end-glyph glyph) - (overlay-put overlay 'invisible t))))) - (t - (let* ((overlays (append (overlays-at (1- (point))) - (overlays-at (point)))) - image) - - ;; Search overlay with an image. - (while (and overlays (null image)) - (let ((prop (overlay-get (car overlays) 'eudc-image))) - (if (eq 'image (car-safe prop)) - (setq image prop) - (setq overlays (cdr overlays))))) - - ;; Toggle that overlay's image display. - (when overlays - (let ((overlay (car overlays))) - (overlay-put overlay 'display - (if (overlay-get overlay 'display) - nil image))))))))) + (let* ((overlays (append (overlays-at (1- (point))) + (overlays-at (point)))) + image) + ;; Search overlay with an image. + (while (and overlays (null image)) + (let ((prop (overlay-get (car overlays) 'eudc-image))) + (if (eq 'image (car-safe prop)) + (setq image prop) + (setq overlays (cdr overlays))))) + ;; Toggle that overlay's image display. + (when overlays + (let ((overlay (car overlays))) + (overlay-put overlay 'display + (if (overlay-get overlay 'display) + nil image))))))) (defun eudc-bob-display-audio (data) "Display a button for audio DATA." @@ -265,25 +253,19 @@ display a button." (interactive "@e") (run-hooks 'activate-menubar-hook) (eudc-jump-to-event event) - (if (featurep 'xemacs) - (progn - (run-hooks 'activate-popup-menu-hook) - (popup-menu (eudc-bob-menu))) - (let ((result (x-popup-menu t (eudc-bob-menu))) - command) - (if result - (progn - (setq command (lookup-key (eudc-bob-menu) - (apply 'vector result))) - (command-execute command)))))) + (let ((result (x-popup-menu t (eudc-bob-menu))) + command) + (if result + (progn + (setq command (lookup-key (eudc-bob-menu) + (apply 'vector result))) + (command-execute command))))) (setq eudc-bob-generic-keymap (let ((map (make-sparse-keymap))) (define-key map "s" 'eudc-bob-save-object) (define-key map "!" 'eudc-bob-pipe-object-to-external-program) - (define-key map (if (featurep 'xemacs) - [button3] - [down-mouse-3]) 'eudc-bob-popup-menu) + (define-key map [down-mouse-3] 'eudc-bob-popup-menu) map)) (setq eudc-bob-image-keymap @@ -294,25 +276,19 @@ display a button." (setq eudc-bob-sound-keymap (let ((map (make-sparse-keymap))) (define-key map [return] 'eudc-bob-play-sound-at-point) - (define-key map (if (featurep 'xemacs) - [button2] - [down-mouse-2]) 'eudc-bob-play-sound-at-mouse) + (define-key map [down-mouse-2] 'eudc-bob-play-sound-at-mouse) map)) (setq eudc-bob-url-keymap (let ((map (make-sparse-keymap))) (define-key map [return] 'browse-url-at-point) - (define-key map (if (featurep 'xemacs) - [button2] - [down-mouse-2]) 'browse-url-at-mouse) + (define-key map [down-mouse-2] 'browse-url-at-mouse) map)) (setq eudc-bob-mail-keymap (let ((map (make-sparse-keymap))) (define-key map [return] 'goto-address-at-point) - (define-key map (if (featurep 'xemacs) - [button2] - [down-mouse-2]) 'goto-address-at-point) + (define-key map [down-mouse-2] 'goto-address-at-point) map)) (set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap) @@ -320,19 +296,18 @@ display a button." ;; If the first arguments can be nil here, then these 3 can be ;; defconsts once more. -(when (not (featurep 'xemacs)) - (easy-menu-define eudc-bob-generic-menu - eudc-bob-generic-keymap - "" - eudc-bob-generic-menu) - (easy-menu-define eudc-bob-image-menu - eudc-bob-image-keymap - "" - eudc-bob-image-menu) - (easy-menu-define eudc-bob-sound-menu - eudc-bob-sound-keymap - "" - eudc-bob-sound-menu)) +(easy-menu-define eudc-bob-generic-menu + eudc-bob-generic-keymap + "" + eudc-bob-generic-menu) +(easy-menu-define eudc-bob-image-menu + eudc-bob-image-keymap + "" + eudc-bob-image-menu) +(easy-menu-define eudc-bob-sound-menu + eudc-bob-sound-keymap + "" + eudc-bob-sound-menu) ;;;###autoload (defun eudc-display-generic-binary (data) diff --git a/lisp/net/eudc-hotlist.el b/lisp/net/eudc-hotlist.el index 05ea4903877..19788ba16cc 100644 --- a/lisp/net/eudc-hotlist.el +++ b/lisp/net/eudc-hotlist.el @@ -55,11 +55,6 @@ These are the special commands of this mode: t -- Transpose the server at point and the previous one q -- Commit the changes and quit. x -- Quit without committing the changes." - (when (featurep 'xemacs) - (setq mode-popup-menu eudc-hotlist-menu) - (when (featurep 'menubar) - (set-buffer-menubar current-menubar) - (add-submenu nil (cons "EUDC-Hotlist" (cdr (cdr eudc-hotlist-menu)))))) (setq buffer-read-only t)) ;;;###autoload @@ -179,10 +174,9 @@ These are the special commands of this mode: ["Save and Quit" eudc-hotlist-quit-edit t] ["Exit without Saving" kill-this-buffer t])) -(when (not (featurep 'xemacs)) - (easy-menu-define eudc-hotlist-emacs-menu +(easy-menu-define eudc-hotlist-emacs-menu eudc-hotlist-mode-map "" - eudc-hotlist-menu)) + eudc-hotlist-menu) ;;; eudc-hotlist.el ends here diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index bc550fbc113..3c9c01d0f96 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -1,4 +1,4 @@ -;;; eudc.el --- Emacs Unified Directory Client +;;; eudc.el --- Emacs Unified Directory Client -*- lexical-binding:t -*- ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. @@ -47,7 +47,7 @@ (require 'wid-edit) -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) (eval-and-compile (if (not (fboundp 'make-overlay)) @@ -68,6 +68,7 @@ (defvar eudc-mode-map (let ((map (make-sparse-keymap))) + (set-keymap-parent map widget-keymap) (define-key map "q" 'kill-current-buffer) (define-key map "x" 'kill-current-buffer) (define-key map "f" 'eudc-query-form) @@ -75,7 +76,6 @@ (define-key map "n" 'eudc-move-to-next-record) (define-key map "p" 'eudc-move-to-previous-record) map)) -(set-keymap-parent eudc-mode-map widget-keymap) (defvar mode-popup-menu) @@ -158,25 +158,6 @@ properties on the list." (setq plist (cdr (cdr plist)))) default)) -(if (not (fboundp 'split-string)) - (defun split-string (string &optional pattern) - "Return a list of substrings of STRING which are separated by PATTERN. -If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." - (or pattern - (setq pattern "[ \f\t\n\r\v]+")) - (let (parts (start 0)) - (when (string-match pattern string 0) - (if (> (match-beginning 0) 0) - (setq parts (cons (substring string 0 (match-beginning 0)) nil))) - (setq start (match-end 0)) - (while (and (string-match pattern string start) - (> (match-end 0) start)) - (setq parts (cons (substring string start (match-beginning 0)) parts) - start (match-end 0)))) - (nreverse (if (< start (length string)) - (cons (substring string start) parts) - parts))))) - (defun eudc-replace-in-string (str regexp newtext) "Replace all matches in STR for REGEXP with NEWTEXT. Value is the new string." @@ -314,7 +295,7 @@ accordingly. Otherwise it is set to its EUDC default binding" (defun eudc-update-local-variables () "Update all EUDC variables according to their local settings." (interactive) - (mapcar 'eudc-update-variable eudc-local-vars)) + (mapcar #'eudc-update-variable eudc-local-vars)) (eudc-default-set 'eudc-query-function nil) (eudc-default-set 'eudc-list-attributes-function nil) @@ -378,7 +359,7 @@ BEG and END delimit the text which is to be replaced." (let ((replacement)) (setq replacement (completing-read "Multiple matches found; choose one: " - (mapcar 'list choices))) + (mapcar #'list choices))) (delete-region beg end) (insert replacement))) @@ -415,7 +396,7 @@ underscore characters are replaced by spaces." (if match (cdr match) (capitalize - (mapconcat 'identity + (mapconcat #'identity (split-string (symbol-name attribute) "_") " "))))) @@ -432,7 +413,7 @@ if any, is called to print the value in cdr of FIELD." (progn (eval (list (cdr match) val)) (insert "\n")) - (mapcar + (mapc (function (lambda (val-elem) (indent-to col) @@ -598,9 +579,10 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'." (setq result (eudc-add-field-to-records (cons (car field) (mapconcat - 'identity + #'identity (cdr field) - "\n")) result))) + "\n")) + result))) ((eq 'duplicate method) (setq result (eudc-distribute-field-on-records field result))))))) @@ -613,12 +595,9 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'." (mapcar (function (lambda (rec) - (if (eval (cons 'and - (mapcar - (function - (lambda (attr) - (consp (assq attr rec)))) - attrs))) + (if (cl-every (lambda (attr) + (consp (assq attr rec))) + attrs) rec))) records))) @@ -632,25 +611,14 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'." (defun eudc-distribute-field-on-records (field records) "Duplicate each individual record in RECORDS according to value of FIELD. Each copy is added a new field containing one of the values of FIELD." - (let (result - (values (cdr field))) - ;; Uniquify values first - (while values - (setcdr values (delete (car values) (cdr values))) - (setq values (cdr values))) - (mapc - (function - (lambda (value) - (let ((result-list (copy-sequence records))) - (setq result-list (eudc-add-field-to-records - (cons (car field) value) - result-list)) - (setq result (append result-list result)) - ))) - (cdr field)) + (let (result) + (dolist (value (delete-dups (cdr field))) ;; Uniquify values first. + (setq result (nconc (eudc-add-field-to-records + (cons (car field) value) + records) + result))) result)) - (define-derived-mode eudc-mode special-mode "EUDC" "Major mode used in buffers displaying the results of directory queries. There is no sense in calling this command from a buffer other than @@ -662,9 +630,7 @@ These are the special commands of EUDC mode: n -- Move to next record. p -- Move to previous record. b -- Insert record at point into the BBDB database." - (if (not (featurep 'xemacs)) - (easy-menu-define eudc-emacs-menu eudc-mode-map "" (eudc-menu)) - (setq mode-popup-menu (eudc-menu)))) + (easy-menu-define eudc-emacs-menu eudc-mode-map "" (eudc-menu))) ;;}}} @@ -776,8 +742,8 @@ otherwise a list of symbols is returned." (setq query-alist (cdr query-alist))) query) (if eudc-protocol-has-default-query-attributes - (mapconcat 'identity words " ") - (list (cons 'name (mapconcat 'identity words " "))))))) + (mapconcat #'identity words " ") + (list (cons 'name (mapconcat #'identity words " "))))))) (defun eudc-extract-n-word-formats (format-list n) "Extract a list of N-long formats from FORMAT-LIST. @@ -836,7 +802,6 @@ see `eudc-inline-expansion-servers'" "[ \t]+")) query-formats response - response-string response-strings (eudc-former-server eudc-server) (eudc-former-protocol eudc-protocol) @@ -894,20 +859,18 @@ see `eudc-inline-expansion-servers'" (error "No match") ;; Process response through eudc-inline-expansion-format - (while response - (setq response-string - (apply 'format - (car eudc-inline-expansion-format) - (mapcar (function - (lambda (field) - (or (cdr (assq field (car response))) - ""))) - (eudc-translate-attribute-list - (cdr eudc-inline-expansion-format))))) - (if (> (length response-string) 0) - (setq response-strings - (cons response-string response-strings))) - (setq response (cdr response))) + (dolist (r response) + (let ((response-string + (apply #'format + (car eudc-inline-expansion-format) + (mapcar (function + (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)))) (if (or (and replace (not eudc-expansion-overwrites-query)) @@ -923,7 +886,7 @@ see `eudc-inline-expansion-servers'" (eudc-select response-strings beg end)) ((eq eudc-multiple-match-handling-method 'all) (delete-region beg end) - (insert (mapconcat 'identity response-strings ", "))) + (insert (mapconcat #'identity response-strings ", "))) ((eq eudc-multiple-match-handling-method 'abort) (error "There is more than one match for the query"))))) (or (and (equal eudc-server eudc-former-server) @@ -943,10 +906,9 @@ queries the server for the existing fields and displays a corresponding form." prompts widget (width 0) - inhibit-read-only pt) (switch-to-buffer buffer) - (setq inhibit-read-only t) + (let ((inhibit-read-only t)) (erase-buffer) (kill-all-local-variables) (make-local-variable 'eudc-form-widget-list) @@ -960,11 +922,10 @@ queries the server for the existing fields and displays a corresponding form." (widget-insert "Protocol : " (symbol-name eudc-protocol) "\n") ;; Build the list of prompts (setq prompts (if eudc-use-raw-directory-names - (mapcar 'symbol-name (eudc-translate-attribute-list fields)) + (mapcar #'symbol-name (eudc-translate-attribute-list fields)) (mapcar (function (lambda (field) - (or (and (assq field eudc-user-attribute-names-alist) - (cdr (assq field eudc-user-attribute-names-alist))) + (or (cdr (assq field eudc-user-attribute-names-alist)) (capitalize (symbol-name field))))) fields))) ;; Loop over prompt strings to find the longest one @@ -1008,7 +969,7 @@ queries the server for the existing fields and displays a corresponding form." "Quit") (goto-char pt) (use-local-map widget-keymap) - (widget-setup)) + (widget-setup))) ) (defun eudc-bookmark-server (server protocol) @@ -1177,60 +1138,41 @@ queries the server for the existing fields and displays a corresponding form." eudc-tail-menu))) (defun eudc-install-menu () - (cond - ((and (featurep 'xemacs) (featurep 'menubar)) - (add-submenu '("Tools") (eudc-menu))) - ((not (featurep 'xemacs)) - (cond - ((fboundp 'easy-menu-create-menu) - (define-key - global-map - [menu-bar tools directory-search] - (cons "Directory Servers" - (easy-menu-create-menu "Directory Servers" (cdr (eudc-menu)))))) - ((fboundp 'easy-menu-add-item) - (let ((menu (eudc-menu))) - (easy-menu-add-item nil '("tools") (easy-menu-create-menu (car menu) - (cdr menu))))) - ((fboundp 'easy-menu-create-keymaps) - (easy-menu-define eudc-menu-map eudc-mode-map "Directory Client Menu" (eudc-menu)) - (define-key - global-map - [menu-bar tools eudc] - (cons "Directory Servers" - (easy-menu-create-keymaps "Directory Servers" - (cdr (eudc-menu)))))) - (t - (error "Unknown version of easymenu")))) - )) - + (define-key + global-map + [menu-bar tools directory-search] + (cons "Directory Servers" + (easy-menu-create-menu "Directory Servers" (cdr (eudc-menu)))))) ;;; Load time initializations : -;;; Load the options file +;; Load the options file (if (and (not noninteractive) (and (locate-library eudc-options-file) (progn (message "") t)) ; Remove mode line message (not (featurep 'eudc-options-file))) (load eudc-options-file)) -;;; Install the full menu +;; Install the full menu (unless (featurep 'infodock) (eudc-install-menu)) -;;; The following installs a short menu for EUDC at XEmacs startup. +;; The following installs a short menu for EUDC at Emacs startup. ;;;###autoload (defun eudc-load-eudc () "Load the Emacs Unified Directory Client. This does nothing except loading eudc by autoload side-effect." (interactive) + ;; FIXME: By convention, loading a file should "do nothing significant" + ;; since Emacs may occasionally load a file for "frivolous" reasons + ;; (e.g. to find a docstring), so having a function which just loads + ;; the file doesn't seem very useful. nil) ;;;###autoload -(cond - ((not (featurep 'xemacs)) +(progn (defvar eudc-tools-menu (let ((map (make-sparse-keymap "Directory Servers"))) (define-key map [phone] @@ -1255,34 +1197,6 @@ This does nothing except loading eudc by autoload side-effect." :help ,(purecopy "Load the Emacs Unified Directory Client"))) map)) (fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu))) - (t - (let ((menu '("Directory Servers" - ["Load Hotlist of Servers" eudc-load-eudc t] - ["New Server" eudc-set-server t] - ["---" nil nil] - ["Query with Form" eudc-query-form t] - ["Expand Inline Query" eudc-expand-inline t] - ["---" nil nil] - ["Get Email" eudc-get-email t] - ["Get Phone" eudc-get-phone t]))) - (if (not (featurep 'eudc-autoloads)) - (if (featurep 'xemacs) - (if (and (featurep 'menubar) - (not (featurep 'infodock))) - (add-submenu '("Tools") menu)) - (require 'easymenu) - (cond - ((fboundp 'easy-menu-add-item) - (easy-menu-add-item nil '("tools") - (easy-menu-create-menu (car menu) - (cdr menu)))) - ((fboundp 'easy-menu-create-keymaps) - (define-key - global-map - [menu-bar tools eudc] - (cons "Directory Servers" - (easy-menu-create-keymaps "Directory Servers" - (cdr menu))))))))))) ;;}}} diff --git a/lisp/net/eudcb-bbdb.el b/lisp/net/eudcb-bbdb.el index b99bea0fe8d..f91d0af858d 100644 --- a/lisp/net/eudcb-bbdb.el +++ b/lisp/net/eudcb-bbdb.el @@ -47,10 +47,13 @@ BBDB < 3 used `net'; BBDB >= 3 uses `mail'." ;; This just-in-time translation permits upgrading from BBDB 2 to ;; BBDB 3 without restarting Emacs. - (if (and (eq field-symbol 'net) - (eudc--using-bbdb-3-or-newer-p)) - 'mail - field-symbol)) + (cond ((and (eq field-symbol 'net) + (eudc--using-bbdb-3-or-newer-p)) + 'mail) + ((and (eq field-symbol 'company) + (eudc--using-bbdb-3-or-newer-p)) + 'organization) + (t field-symbol))) (defvar eudc-bbdb-attributes-translation-alist '((name . lastname) @@ -124,18 +127,31 @@ BBDB < 3 used `net'; BBDB >= 3 uses `mail'." (declare-function bbdb-record-addresses "ext:bbdb" t) ; via bbdb-defstruct (declare-function bbdb-records "ext:bbdb" (&optional dont-check-disk already-in-db-buffer)) +(declare-function bbdb-record-notes "ext:bbdb" t) ; via bbdb-defstruct + +;; External, BBDB >= 3. +(declare-function bbdb-phone-label "ext:bbdb" t) ; via bbdb-defstruct +(declare-function bbdb-record-phone "ext:bbdb" t) ; via bbdb-defstruct +(declare-function bbdb-record-address "ext:bbdb" t) ; via bbdb-defstruct +(declare-function bbdb-record-xfield "ext:bbdb" t) ; via bbdb-defstruct (defun eudc-bbdb-extract-phones (record) (require 'bbdb) (mapcar (function (lambda (phone) (if eudc-bbdb-use-locations-as-attribute-names - (cons (intern (bbdb-phone-location phone)) + (cons (intern (if (eudc--using-bbdb-3-or-newer-p) + (bbdb-phone-label phone) + (bbdb-phone-location phone))) (bbdb-phone-string phone)) (cons 'phones (format "%s: %s" - (bbdb-phone-location phone) + (if (eudc--using-bbdb-3-or-newer-p) + (bbdb-phone-label phone) + (bbdb-phone-location phone)) (bbdb-phone-string phone)))))) - (bbdb-record-phones record))) + (if (eudc--using-bbdb-3-or-newer-p) + (bbdb-record-phone record) + (bbdb-record-phones record)))) (defun eudc-bbdb-extract-addresses (record) (require 'bbdb) @@ -157,7 +173,9 @@ BBDB < 3 used `net'; BBDB >= 3 uses `mail'." (cons (intern (bbdb-address-location address)) val) (cons 'addresses (concat (bbdb-address-location address) "\n" val)))) - (bbdb-record-addresses record)))) + (if (eudc--using-bbdb-3-or-newer-p) + (bbdb-record-address record) + (bbdb-record-addresses record))))) (defun eudc-bbdb-format-record-as-result (record) "Format the BBDB RECORD as a EUDC query result record. @@ -176,7 +194,11 @@ The record is filtered according to `eudc-bbdb-current-return-attributes'" (setq val (eudc-bbdb-extract-phones record))) ((eq attr 'addresses) (setq val (eudc-bbdb-extract-addresses record))) - ((memq attr '(firstname lastname aka company net notes)) + ((eq attr 'notes) + (if (eudc--using-bbdb-3-or-newer-p) + (setq val (bbdb-record-xfield record 'notes)) + (setq val (bbdb-record-notes record)))) + ((memq attr '(firstname lastname aka company net)) (setq val (eval (list (intern (concat "bbdb-record-" diff --git a/lisp/net/eudcb-mab.el b/lisp/net/eudcb-mab.el index dbee16e1e22..0202b173bb5 100644 --- a/lisp/net/eudcb-mab.el +++ b/lisp/net/eudcb-mab.el @@ -53,15 +53,15 @@ RETURN-ATTRS is a list of attributes to return, defaulting to (let ((fmt-string "%ln:%fn:%p:%e") (mab-buffer (get-buffer-create " *mab contacts*")) - (modified (nth 5 (file-attributes eudc-contacts-file))) + (modified (file-attribute-modification-time + (file-attributes eudc-contacts-file))) result) (with-current-buffer mab-buffer (make-local-variable 'eudc-buffer-time) (goto-char (point-min)) (when (or (eobp) (time-less-p eudc-buffer-time modified)) (erase-buffer) - (call-process (executable-find "contacts") nil t nil - "-H" "-l" "-f" fmt-string) + (call-process "contacts" nil t nil "-H" "-l" "-f" fmt-string) (setq eudc-buffer-time modified)) (goto-char (point-min)) (while (not (eobp)) diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 1cc4557ce1a..77e6cec9b04 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -29,7 +29,7 @@ (require 'shr) (require 'url) (require 'url-queue) -(require 'url-util) ; for url-get-url-at-point +(require 'thingatpt) (require 'mm-url) (require 'puny) (eval-when-compile (require 'subr-x)) ;; for string-trim @@ -64,17 +64,17 @@ ;;;###autoload (defcustom eww-suggest-uris '(eww-links-at-point - url-get-url-at-point + thing-at-point-url-at-point eww-current-url) "List of functions called to form the list of default URIs for `eww'. Each of the elements is a function returning either a string or a list of strings. The results will be joined into a single list with duplicate entries (if any) removed." - :version "25.1" + :version "27.1" :group 'eww :type 'hook :options '(eww-links-at-point - url-get-url-at-point + thing-at-point-url-at-point eww-current-url)) (defcustom eww-bookmarks-directory user-emacs-directory @@ -186,17 +186,17 @@ See also `eww-form-checkbox-selected-symbol'." :group 'eww) (defface eww-form-text - '((t (:background "#505050" - :foreground "white" - :box (:line-width 1)))) + '((t :background "#505050" + :foreground "white" + :box (:line-width 1))) "Face for eww text inputs." :version "24.4" :group 'eww) (defface eww-form-textarea - '((t (:background "#C0C0C0" - :foreground "black" - :box (:line-width 1)))) + '((t :background "#C0C0C0" + :foreground "black" + :box (:line-width 1))) "Face for eww textarea inputs." :version "24.4" :group 'eww) @@ -218,11 +218,21 @@ See also `eww-form-checkbox-selected-symbol'." (defvar eww-data nil) (defvar eww-history nil) (defvar eww-history-position 0) +(defvar eww-prompt-history nil) (defvar eww-local-regex "localhost" "When this regex is found in the URL, it's not a keyword but an address.") +(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.") + (defvar eww-link-keymap + (let ((map (copy-keymap shr-map))) + (define-key map "\r" 'eww-follow-link) + map)) + +(defvar eww-image-link-keymap (let ((map (copy-keymap shr-image-map))) (define-key map "\r" 'eww-follow-link) map)) @@ -241,21 +251,29 @@ This list can be customized via `eww-suggest-uris'." (nreverse uris))) ;;;###autoload -(defun eww (url) +(defun eww (url &optional arg) "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'." +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." (interactive (let* ((uris (eww-suggested-uris)) (prompt (concat "Enter URL or keywords" (if uris (format " (default %s)" (car uris)) "") ": "))) - (list (read-string prompt nil nil uris)))) + (list (read-string prompt nil 'eww-prompt-history uris) + (prefix-numeric-value current-prefix-arg)))) (setq url (eww--dwim-expand-url url)) (pop-to-buffer-same-window - (if (eq major-mode 'eww-mode) - (current-buffer) - (get-buffer-create "*eww*"))) + (cond + ((eq arg 4) + (generate-new-buffer "*eww*")) + ((eq major-mode 'eww-mode) + (current-buffer)) + (t + (get-buffer-create "*eww*")))) (eww-setup-buffer) ;; Check whether the domain only uses "Highly Restricted" Unicode ;; IDNA characters. If not, transform to punycode to indicate that @@ -263,16 +281,22 @@ word(s) will be searched for via `eww-search-prefix'." (let ((parsed (url-generic-parse-url url))) (when (url-host parsed) (unless (puny-highly-restrictive-domain-p (url-host parsed)) - (setf (url-host parsed) (puny-encode-domain (url-host parsed))) - (setq url (url-recreate-url parsed))))) + (setf (url-host parsed) (puny-encode-domain (url-host parsed))))) + ;; When the URL is on the form "http://a/../../../g", chop off all + ;; the leading "/.."s. + (when (url-filename parsed) + (while (string-match "\\`/[.][.]/" (url-filename parsed)) + (setf (url-filename parsed) (substring (url-filename parsed) 3)))) + (setq url (url-recreate-url parsed))) (plist-put eww-data :url url) (plist-put eww-data :title "") (eww-update-header-line-format) (let ((inhibit-read-only t)) (insert (format "Loading %s..." url)) (goto-char (point-min))) - (url-retrieve url 'eww-render - (list url nil (current-buffer)))) + (let ((url-mime-accept-string eww-accept-content-types)) + (url-retrieve url 'eww-render + (list url nil (current-buffer))))) (defun eww--dwim-expand-url (url) (setq url (string-trim url)) @@ -349,9 +373,6 @@ Currently this means either text/html or application/xhtml+xml." "application/xhtml+xml"))) (defun eww-render (status url &optional point buffer encode) - (let ((redirect (plist-get status :redirect))) - (when redirect - (setq url redirect))) (let* ((headers (eww-parse-headers)) (content-type (mail-header-parse-content-type @@ -364,12 +385,19 @@ Currently this means either text/html or application/xhtml+xml." (eww-detect-charset (eww-html-p (car content-type))) "utf-8")))) (data-buffer (current-buffer)) + (shr-target-id (url-target (url-generic-parse-url url))) last-coding-system-used) + (let ((redirect (plist-get status :redirect))) + (when redirect + (setq url redirect))) (with-current-buffer buffer ;; Save the https peer status. (plist-put eww-data :peer (plist-get status :peer)) ;; Make buffer listings more informative. - (setq list-buffers-directory url)) + (setq list-buffers-directory url) + ;; Let the URL library have a handle to the current URL for + ;; referer purposes. + (setq url-current-lastloc (url-generic-parse-url url))) (unwind-protect (progn (cond @@ -447,10 +475,10 @@ Currently this means either text/html or application/xhtml+xml." (condition-case nil (decode-coding-region (point) (point-max) encode) (coding-system-error nil)) - (save-excursion - ;; Remove CRLF before parsing. - (while (re-search-forward "\r$" nil t) - (replace-match "" t t))) + (save-excursion + ;; Remove CRLF and replace NUL with � before parsing. + (while (re-search-forward "\\(\r$\\)\\|\0" nil t) + (replace-match (if (match-beginning 1) "" "�") t t))) (libxml-parse-html-region (point) (point-max)))))) (source (and (null document) (buffer-substring (point) (point-max))))) @@ -460,7 +488,6 @@ Currently this means either text/html or application/xhtml+xml." (plist-put eww-data :dom document) (let ((inhibit-read-only t) (inhibit-modification-hooks t) - (shr-target-id (url-target (url-generic-parse-url url))) (shr-external-rendering-functions (append shr-external-rendering-functions @@ -547,7 +574,11 @@ Currently this means either text/html or application/xhtml+xml." (eww-handle-link dom) (let ((start (point))) (shr-tag-a dom) - (put-text-property start (point) 'keymap eww-link-keymap))) + (put-text-property start (point) + 'keymap + (if (mm-images-in-region-p start (point)) + eww-image-link-keymap + eww-link-keymap)))) (defun eww-update-header-line-format () (setq header-line-format @@ -731,7 +762,10 @@ the like." most-negative-fixnum) (or (dom-attr result :eww-readability-score) most-negative-fixnum)) - (setq result highest))) + ;; We set a lower bound to how long we accept that the + ;; readable portion of the page is going to be. + (when (> (length (split-string (dom-texts highest))) 100) + (setq result highest)))) result)) (defvar eww-mode-map @@ -923,8 +957,9 @@ 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))) - (url-retrieve url 'eww-render - (list url (point) (current-buffer) encode))))) + (let ((url-mime-accept-string eww-accept-content-types)) + (url-retrieve url 'eww-render + (list url (point) (current-buffer) encode)))))) ;; Form support. @@ -1236,14 +1271,8 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") :eww-form eww-form)) (options nil) (start (point)) - (max 0) - opelem) - (if (eq (dom-tag dom) 'optgroup) - (dolist (groupelem (dom-children dom)) - (unless (dom-attr groupelem 'disabled) - (setq opelem (append opelem (list groupelem))))) - (setq opelem (list dom))) - (dolist (elem opelem) + (max 0)) + (dolist (elem (dom-non-text-children dom)) (when (eq (dom-tag elem) 'option) (when (dom-attr elem 'selected) (nconc menu (list :value (dom-attr elem 'value)))) @@ -1472,13 +1501,17 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (defun eww-browse-with-external-browser (&optional url) "Browse the current URL with an external browser. -The browser to used is specified by the `shr-external-browser' variable." +The browser to used is specified by the +`browse-url-secondary-browser-function' variable." (interactive) - (funcall shr-external-browser (or url (plist-get eww-data :url)))) + (funcall browse-url-secondary-browser-function + (or url (plist-get eww-data :url)))) (defun eww-follow-link (&optional external mouse-event) "Browse the URL under point. -If EXTERNAL is single prefix, browse the URL using `shr-external-browser'. +If EXTERNAL is single prefix, browse the URL using +`browse-url-secondary-browser-function'. + If EXTERNAL is double prefix, browse in new buffer." (interactive (list current-prefix-arg last-nonmenu-event)) (mouse-set-point mouse-event) @@ -1489,12 +1522,14 @@ If EXTERNAL is double prefix, browse in new buffer." ((string-match "^mailto:" url) (browse-url-mail url)) ((and (consp external) (<= (car external) 4)) - (funcall shr-external-browser url)) + (funcall browse-url-secondary-browser-function url) + (shr--blink-link)) ;; This is a #target url in the same page as the current one. ((and (url-target (url-generic-parse-url url)) (eww-same-page-p url (plist-get eww-data :url))) (let ((dom (plist-get eww-data :dom))) (eww-save-history) + (plist-put eww-data :url url) (eww-display-html 'utf-8 url dom nil (current-buffer)))) (t (eww-browse-url url external))))) @@ -1515,10 +1550,12 @@ Differences in #targets are ignored." (kill-new (plist-get eww-data :url))) (defun eww-download () - "Download URL under point to `eww-download-directory'." + "Download URL to `eww-download-directory'. +Use link at point if there is one, else the current page's URL." (interactive) (access-file eww-download-directory "Download failed") - (let ((url (get-text-property (point) 'shr-url))) + (let ((url (or (get-text-property (point) 'shr-url) + (eww-current-url)))) (if (not url) (message "No URL under point") (url-retrieve url 'eww-download-callback (list url))))) @@ -1651,7 +1688,7 @@ If CHARSET is nil then use UTF-8." (defun eww-read-bookmarks () (let ((file (expand-file-name "eww-bookmarks" eww-bookmarks-directory))) (setq eww-bookmarks - (unless (zerop (or (nth 7 (file-attributes file)) 0)) + (unless (zerop (or (file-attribute-size (file-attributes file)) 0)) (with-temp-buffer (insert-file-contents file) (read (current-buffer))))))) @@ -1797,13 +1834,9 @@ If CHARSET is nil then use UTF-8." (defun eww-save-history () (plist-put eww-data :point (point)) (plist-put eww-data :text (buffer-string)) - (push eww-data eww-history) - (setq eww-data (list :title "")) - ;; Don't let the history grow infinitely. We store quite a lot of - ;; data per page. - (when-let* ((tail (and eww-history-limit - (nthcdr eww-history-limit eww-history)))) - (setcdr tail nil))) + (let ((history-delete-duplicates nil)) + (add-to-history 'eww-history eww-data eww-history-limit t)) + (setq eww-data (list :title ""))) (defvar eww-current-buffer) diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index 0dcffbb9b14..61480f35877 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -36,6 +36,10 @@ ;;; Code: (require 'cl-lib) +(require 'puny) + +(declare-function network-stream-certificate "network-stream" + (host service parameters)) (defgroup gnutls nil "Emacs interface to the GnuTLS library." @@ -69,9 +73,9 @@ If the value is a list, it should have the form ((HOST-REGEX FLAGS...) (HOST-REGEX FLAGS...) ...) where each HOST-REGEX is a regular expression to be matched -against the hostname, and FLAGS is either t or a list of -one or more verification flags. The supported flags and the -corresponding conditions to be tested are: +against the hostname, on a first-match basis, and FLAGS is either +t or a list of one or more verification flags. The supported +flags and the corresponding conditions to be tested are: :trustfiles -- certificate must be issued by a trusted authority. :hostname -- hostname must match presented certificate's host name. @@ -137,7 +141,7 @@ node `(emacs) Network Security'." (integer :tag "Number of bits" 512)) :group 'gnutls) -(defun open-gnutls-stream (name buffer host service &optional nowait) +(defun open-gnutls-stream (name buffer host service &optional parameters) "Open a SSL/TLS connection for a service to a host. Returns a subprocess-object to represent the connection. Input and output work as for subprocesses; `delete-process' closes it. @@ -148,12 +152,15 @@ BUFFER is the buffer (or `buffer-name') to associate with the process. a filter function to handle the output. BUFFER may be also nil, meaning that this process is not associated with any buffer -Third arg is name of the host to connect to, or its IP address. -Fourth arg SERVICE is name of the service desired, or an integer +Third arg HOST is the name of the host to connect to, or its IP address. +Fourth arg SERVICE is the name of the service desired, or an integer specifying a port number to connect to. -Fifth arg NOWAIT (which is optional) means that the socket should -be opened asynchronously. The connection process will be -returned to the caller before TLS negotiation has happened. +Fifth arg PARAMETERS is an optional list of keyword/value pairs. +Only :client-certificate and :nowait keywords are recognized, and +have the same meaning as for `open-network-stream'. +For historical reasons PARAMETERS can also be a symbol, which is +interpreted the same as passing a list containing :nowait and the +value of that symbol. Usage example: @@ -167,20 +174,34 @@ This is a very simple wrapper around `gnutls-negotiate'. See its documentation for the specific parameters you can use to open a GnuTLS connection, including specifying the credential type, trust and key files, and priority string." - (let ((process (open-network-stream - name buffer host service - :nowait nowait - :tls-parameters - (and nowait - (cons 'gnutls-x509pki - (gnutls-boot-parameters - :type 'gnutls-x509pki - :hostname host)))))) + (let* ((parameters + (cond ((symbolp parameters) + (list :nowait parameters)) + ((not (cl-evenp (length parameters))) + (error "Malformed keyword list")) + ((consp parameters) + parameters) + (t + (error "Unknown parameter type")))) + (cert (network-stream-certificate host service parameters)) + (keylist (and cert (list cert))) + (nowait (plist-get parameters :nowait)) + (process (open-network-stream + name buffer host service + :nowait nowait + :tls-parameters + (and nowait + (cons 'gnutls-x509pki + (gnutls-boot-parameters + :type 'gnutls-x509pki + :keylist keylist + :hostname (puny-encode-domain host))))))) (if nowait process (gnutls-negotiate :process process :type 'gnutls-x509pki - :hostname host)))) + :keylist keylist + :hostname (puny-encode-domain host))))) (define-error 'gnutls-error "GnuTLS error") @@ -303,13 +324,9 @@ defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT." t) ;; if a list, look for hostname matches ((listp gnutls-verify-error) - (apply 'append - (mapcar - (lambda (check) - (when (string-match (nth 0 check) - hostname) - (nth 1 check))) - gnutls-verify-error))) + (cadr (cl-find-if #'(lambda (x) + (string-match (car x) hostname)) + gnutls-verify-error))) ;; else it's nil (t nil)))) (min-prime-bits (or min-prime-bits gnutls-min-prime-bits))) diff --git a/lisp/net/goto-addr.el b/lisp/net/goto-addr.el index 45627d9b103..40a067e6251 100644 --- a/lisp/net/goto-addr.el +++ b/lisp/net/goto-addr.el @@ -59,19 +59,10 @@ ;;; Code: +(require 'seq) (require 'thingatpt) (autoload 'browse-url-url-at-point "browse-url") -;; XEmacs needs the following definitions. -(unless (fboundp 'overlays-in) - (require 'overlay)) -(unless (fboundp 'line-beginning-position) - (defalias 'line-beginning-position 'point-at-bol)) -(unless (fboundp 'line-end-position) - (defalias 'line-end-position 'point-at-eol)) -(unless (fboundp 'match-string-no-properties) - (defalias 'match-string-no-properties 'match-string)) - (defgroup goto-address nil "Click to browse URL or to send to e-mail address." :group 'mouse @@ -98,32 +89,40 @@ A value of t means there is no limit--fontify regardless of the size." (defvar goto-address-mail-regexp ;; Actually pretty much any char could appear in the username part. -stef - "[-a-zA-Z0-9=._+]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+" + "[-a-zA-Z0-9=._+]+@\\([-a-zA-Z0-9_]+\\.\\)+[a-zA-Z0-9]+" "A regular expression probably matching an e-mail address.") +(defvar goto-address-uri-schemes-ignored + ;; By default we exclude `mailto:' (email addresses are matched + ;; by `goto-address-mail-regexp') and also `data:', as it is not + ;; terribly useful to follow those URIs, and leaving them causes + ;; `use Data::Dumper;' to be fontified oddly in Perl files. + '("mailto:" "data:") + "List of URI schemes to exclude from `goto-address-uri-schemes'. + +Customisations to this variable made after goto-addr is loaded +will have no effect.") + +(defvar goto-address-uri-schemes + ;; We use `thing-at-point-uri-schemes', with a few exclusions, + ;; as listed in `goto-address-uri-schemes-ignored'. + (seq-reduce (lambda (accum elt) (delete elt accum)) + goto-address-uri-schemes-ignored + (copy-sequence thing-at-point-uri-schemes)) + "List of URI schemes matched by `goto-address-url-regexp'. + +Customisations to this variable made after goto-addr is loaded +will have no effect.") + (defvar goto-address-url-regexp - (concat - "\\<\\(" - (mapconcat 'identity - (delete "mailto:" - ;; Remove `data:', as it's not terribly useful to follow - ;; those. Leaving them causes `use Data::Dumper;' to be - ;; fontified oddly in Perl files. - (delete "data:" - (copy-sequence thing-at-point-uri-schemes))) - "\\|") - "\\)" - thing-at-point-url-path-regexp) - ;; (concat "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|" - ;; "telnet\\|wais\\):\\(//[-a-zA-Z0-9_.]+:" - ;; "[0-9]*\\)?[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*" - ;; "[-a-zA-Z0-9_=#$@~`%&*+|\\/]") + (concat "\\<" + (regexp-opt goto-address-uri-schemes t) + thing-at-point-url-path-regexp) "A regular expression probably matching a URL.") (defvar goto-address-highlight-keymap (let ((m (make-sparse-keymap))) - (define-key m (if (featurep 'xemacs) (kbd "<button2>") (kbd "<mouse-2>")) - 'goto-address-at-point) + (define-key m (kbd "<mouse-2>") 'goto-address-at-point) (define-key m (kbd "C-c RET") 'goto-address-at-point) m) "Keymap to hold goto-addr's mouse key defs under highlighted URLs.") @@ -221,10 +220,6 @@ and `goto-address-fontify-p'." ;; snarfed from browse-url.el ;;;###autoload -(define-obsolete-function-alias - 'goto-address-at-mouse 'goto-address-at-point "22.1") - -;;;###autoload (defun goto-address-at-point (&optional event) "Send to the e-mail address or load the URL at point. Send mail to address at point. See documentation for @@ -250,7 +245,7 @@ there, then load the URL at or before point." "Find e-mail address around or before point. Then search backwards to beginning of line for the start of an e-mail address. If no e-mail address found, return nil." - (re-search-backward "[^-_A-z0-9.@]" (line-beginning-position) 'lim) + (re-search-backward "[^-_A-Za-z0-9.@]" (line-beginning-position) 'lim) (if (or (looking-at goto-address-mail-regexp) ; already at start (and (re-search-forward goto-address-mail-regexp (line-end-position) 'lim) @@ -274,10 +269,7 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and ;;;###autoload (define-minor-mode goto-address-mode - "Minor mode to buttonize URLs and e-mail addresses in the current buffer. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "Minor mode to buttonize URLs and e-mail addresses in the current buffer." nil "" nil diff --git a/lisp/net/hmac-def.el b/lisp/net/hmac-def.el index c471f691dc3..44db0bbbb24 100644 --- a/lisp/net/hmac-def.el +++ b/lisp/net/hmac-def.el @@ -73,7 +73,7 @@ If BIT is non-nil, truncate output to specified bits." ,(if (and bit (< (/ bit 8) L)) `(substring key-xor-opad 0 ,(/ bit 8)) ;; return a copy of `key-xor-opad'. - `(concat key-xor-opad))) + '(concat key-xor-opad))) ;; cleanup. (fillarray key-xor-ipad 0) (fillarray key-xor-opad 0))))) diff --git a/lisp/net/imap.el b/lisp/net/imap.el index dedf5f794a4..9f43c57ffd3 100644 --- a/lisp/net/imap.el +++ b/lisp/net/imap.el @@ -1,4 +1,4 @@ -;;; imap.el --- imap library +;;; imap.el --- imap library -*- lexical-binding:t -*- ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. @@ -135,20 +135,16 @@ ;;; Code: -(eval-when-compile (require 'cl)) -(eval-and-compile - ;; For Emacs <22.2 and XEmacs. - (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r))) - (autoload 'sasl-find-mechanism "sasl") - (autoload 'digest-md5-parse-digest-challenge "digest-md5") - (autoload 'digest-md5-digest-response "digest-md5") - (autoload 'digest-md5-digest-uri "digest-md5") - (autoload 'digest-md5-challenge "digest-md5") - (autoload 'rfc2104-hash "rfc2104") - (autoload 'utf7-encode "utf7") - (autoload 'utf7-decode "utf7") - (autoload 'format-spec "format-spec") - (autoload 'format-spec-make "format-spec")) +(eval-when-compile (require 'cl-lib)) +(require 'format-spec) +(require 'utf7) +(require 'rfc2104) +;; Hmm... digest-md5 is not part of Emacs. +;; FIXME: Should/can we use sasl-digest.el instead? +(declare-function digest-md5-parse-digest-challenge "ext:digest-md5") +(declare-function digest-md5-digest-response "ext:digest-md5") +(declare-function digest-md5-digest-uri "ext:digest-md5") +(declare-function digest-md5-challenge "ext:digest-md5") ;; User variables. @@ -1700,18 +1696,6 @@ MAILBOX specifies a mailbox on the server in BUFFER." (concat "UID STORE " articles " +FLAGS" (if silent ".SILENT") " (" flags ")")))))) -;; Cf. http://thread.gmane.org/gmane.emacs.gnus.general/65317/focus=65343 -;; Signal an error if we'd get an integer overflow. -;; -;; FIXME: Identify relevant calls to `string-to-number' and replace them with -;; `imap-string-to-integer'. -(defun imap-string-to-integer (string &optional base) - (let ((number (string-to-number string base))) - (if (> number most-positive-fixnum) - (error - (format "String %s cannot be converted to a Lisp integer" number)) - number))) - (defun imap-fetch-safe (uids props &optional receive nouidfetch buffer) "Like `imap-fetch', but DTRT with Exchange 2007 bug. However, UIDS here is a cons, where the car is the canonical form @@ -1900,9 +1884,7 @@ on failure." (setq cmdstr nil) (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) (setq command nil) ;; abort command if no cont-req - (let ((process imap-process) - (stream imap-stream) - (eol imap-client-eol)) + (let ((process imap-process)) (with-current-buffer cmd (imap-log cmd) (process-send-region process (point-min) @@ -1936,18 +1918,14 @@ on failure." (unless (< len 10) (setq imap-have-messaged t) (message "imap read: %dk" len)) - (accept-process-output imap-process - (truncate imap-read-timeout) - (truncate (* (- imap-read-timeout - (truncate imap-read-timeout)) - 1000))))) + (accept-process-output imap-process imap-read-timeout))) ;; A process can die _before_ we have processed everything it ;; has to say. Moreover, this can happen in between the call to ;; accept-process-output and the call to process-status in an ;; iteration of the loop above. (when (and (null imap-continuation) (< imap-reached-tag tag)) - (accept-process-output imap-process 0 0)) + (accept-process-output imap-process 0)) (when imap-have-messaged (message "")) (and (memq (process-status imap-process) '(open run)) @@ -1956,7 +1934,7 @@ on failure." 'INCOMPLETE 'OK)))))) -(defun imap-sentinel (process string) +(defun imap-sentinel (process _string) (delete-process process)) (defun imap-find-next-line () @@ -2145,7 +2123,7 @@ Return nil if no complete line has arrived." (imap-forward) (nreverse addresses))) ;; With assert, the code might not be eval'd. - ;; (assert (imap-parse-nil) t "In imap-parse-address-list") + ;; (cl-assert (imap-parse-nil) t "In imap-parse-address-list") (imap-parse-nil))) ;; mailbox = "INBOX" / astring @@ -2218,72 +2196,72 @@ Return nil if no complete line has arrived." (defun imap-parse-response () "Parse an IMAP command response." (let (token) - (case (setq token (read (current-buffer))) - (+ (setq imap-continuation - (or (buffer-substring (min (point-max) (1+ (point))) - (point-max)) - t))) - (* (case (prog1 (setq token (read (current-buffer))) - (imap-forward)) - (OK (imap-parse-resp-text)) - (NO (imap-parse-resp-text)) - (BAD (imap-parse-resp-text)) - (BYE (imap-parse-resp-text)) - (FLAGS (imap-mailbox-put 'flags (imap-parse-flag-list))) - (LIST (imap-parse-data-list 'list)) - (LSUB (imap-parse-data-list 'lsub)) - (SEARCH (imap-mailbox-put - 'search - (read (concat "(" (buffer-substring (point) (point-max)) ")")))) - (STATUS (imap-parse-status)) - (CAPABILITY (setq imap-capability + (pcase (setq token (read (current-buffer))) + ('+ (setq imap-continuation + (or (buffer-substring (min (point-max) (1+ (point))) + (point-max)) + t))) + ('* (pcase (prog1 (setq token (read (current-buffer))) + (imap-forward)) + ('OK (imap-parse-resp-text)) + ('NO (imap-parse-resp-text)) + ('BAD (imap-parse-resp-text)) + ('BYE (imap-parse-resp-text)) + ('FLAGS (imap-mailbox-put 'flags (imap-parse-flag-list))) + ('LIST (imap-parse-data-list 'list)) + ('LSUB (imap-parse-data-list 'lsub)) + ('SEARCH (imap-mailbox-put + 'search + (read (concat "(" (buffer-substring (point) (point-max)) ")")))) + ('STATUS (imap-parse-status)) + ('CAPABILITY (setq imap-capability (read (concat "(" (upcase (buffer-substring (point) (point-max))) ")")))) - (ID (setq imap-id (read (buffer-substring (point) - (point-max))))) - (ACL (imap-parse-acl)) - (t (case (prog1 (read (current-buffer)) - (imap-forward)) - (EXISTS (imap-mailbox-put 'exists token)) - (RECENT (imap-mailbox-put 'recent token)) - (EXPUNGE t) - (FETCH (imap-parse-fetch token)) - (t (message "Garbage: %s" (buffer-string))))))) - (t (let (status) + ('ID (setq imap-id (read (buffer-substring (point) + (point-max))))) + ('ACL (imap-parse-acl)) + (_ (pcase (prog1 (read (current-buffer)) + (imap-forward)) + ('EXISTS (imap-mailbox-put 'exists token)) + ('RECENT (imap-mailbox-put 'recent token)) + ('EXPUNGE t) + ('FETCH (imap-parse-fetch)) + (_ (message "Garbage: %s" (buffer-string))))))) + (_ (let (status) (if (not (integerp token)) (message "Garbage: %s" (buffer-string)) - (case (prog1 (setq status (read (current-buffer))) - (imap-forward)) - (OK (progn - (setq imap-reached-tag (max imap-reached-tag token)) - (imap-parse-resp-text))) - (NO (progn - (setq imap-reached-tag (max imap-reached-tag token)) - (save-excursion - (imap-parse-resp-text)) - (let (code text) - (when (eq (char-after) ?\[) - (setq code (buffer-substring (point) - (search-forward "]"))) - (imap-forward)) - (setq text (buffer-substring (point) (point-max))) - (push (list token status code text) - imap-failed-tags)))) - (BAD (progn - (setq imap-reached-tag (max imap-reached-tag token)) - (save-excursion - (imap-parse-resp-text)) - (let (code text) - (when (eq (char-after) ?\[) - (setq code (buffer-substring (point) - (search-forward "]"))) - (imap-forward)) - (setq text (buffer-substring (point) (point-max))) - (push (list token status code text) imap-failed-tags) - (error "Internal error, tag %s status %s code %s text %s" - token status code text)))) - (t (message "Garbage: %s" (buffer-string)))) + (pcase (prog1 (setq status (read (current-buffer))) + (imap-forward)) + ('OK (progn + (setq imap-reached-tag (max imap-reached-tag token)) + (imap-parse-resp-text))) + ('NO (progn + (setq imap-reached-tag (max imap-reached-tag token)) + (save-excursion + (imap-parse-resp-text)) + (let (code text) + (when (eq (char-after) ?\[) + (setq code (buffer-substring (point) + (search-forward "]"))) + (imap-forward)) + (setq text (buffer-substring (point) (point-max))) + (push (list token status code text) + imap-failed-tags)))) + ('BAD (progn + (setq imap-reached-tag (max imap-reached-tag token)) + (save-excursion + (imap-parse-resp-text)) + (let (code text) + (when (eq (char-after) ?\[) + (setq code (buffer-substring (point) + (search-forward "]"))) + (imap-forward)) + (setq text (buffer-substring (point) (point-max))) + (push (list token status code text) imap-failed-tags) + (error "Internal error, tag %s status %s code %s text %s" + token status code text)))) + (_ (message "Garbage: %s" (buffer-string)))) (when (assq token imap-callbacks) (funcall (cdr (assq token imap-callbacks)) token status) (setq imap-callbacks @@ -2459,7 +2437,7 @@ Return nil if no complete line has arrived." (search-forward "]" nil t)) section))) -(defun imap-parse-fetch (response) +(defun imap-parse-fetch () (when (eq (char-after) ?\() (let (uid flags envelope internaldate rfc822 rfc822header rfc822text rfc822size body bodydetail bodystructure flags-empty) @@ -2593,7 +2571,7 @@ Return nil if no complete line has arrived." (defun imap-parse-flag-list () (let (flag-list start) - (assert (eq (char-after) ?\() nil "In imap-parse-flag-list 1") + (cl-assert (eq (char-after) ?\() nil "In imap-parse-flag-list 1") (while (and (not (eq (char-after) ?\))) (setq start (progn (imap-forward) @@ -2602,7 +2580,7 @@ Return nil if no complete line has arrived." (point))) (> (skip-chars-forward "^ )" (point-at-eol)) 0)) (push (buffer-substring start (point)) flag-list)) - (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list 2") + (cl-assert (eq (char-after) ?\)) nil "In imap-parse-flag-list 2") (imap-forward) (nreverse flag-list))) @@ -2687,7 +2665,7 @@ Return nil if no complete line has arrived." (while (eq (char-after) ?\ ) (imap-forward) (push (imap-parse-body-extension) b-e)) - (assert (eq (char-after) ?\)) nil "In imap-parse-body-extension") + (cl-assert (eq (char-after) ?\)) nil "In imap-parse-body-extension") (imap-forward) (nreverse b-e)) (or (imap-parse-number) @@ -2716,7 +2694,7 @@ Return nil if no complete line has arrived." (push (imap-parse-string-list) dsp) (imap-forward)) ;; With assert, the code might not be eval'd. - ;; (assert (imap-parse-nil) t "In imap-parse-body-ext") + ;; (cl-assert (imap-parse-nil) t "In imap-parse-body-ext") (imap-parse-nil)) (push (nreverse dsp) ext)) (when (eq (char-after) ?\ ) ;; body-fld-lang @@ -2813,7 +2791,7 @@ Return nil if no complete line has arrived." (push (and (imap-parse-nil) nil) body)) (setq body (append (imap-parse-body-ext) body))) ;; body-ext-... - (assert (eq (char-after) ?\)) nil "In imap-parse-body") + (cl-assert (eq (char-after) ?\)) nil "In imap-parse-body") (imap-forward) (nreverse body)) @@ -2879,7 +2857,7 @@ Return nil if no complete line has arrived." (push (imap-parse-nstring) body) ;; body-fld-md5 (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part.. - (assert (eq (char-after) ?\)) nil "In imap-parse-body 2") + (cl-assert (eq (char-after) ?\)) nil "In imap-parse-body 2") (imap-forward) (nreverse body))))) diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el index 6e242d77d41..75fc7d62211 100644 --- a/lisp/net/ldap.el +++ b/lisp/net/ldap.el @@ -646,13 +646,9 @@ an alist of attribute/value pairs." (not (equal "" sizelimit))) (setq arglist (nconc arglist (list (format "-z%s" sizelimit))))) (if passwd - ;; Work around Bug#33154, see also Bug#33050. Leaving - ;; process-connection-type at its default (typically t) - ;; would probably be fine too, however this is the minimal - ;; change on the release branch that fixes ldap.el on Darwin - ;; and leaves other operating systems unchanged. - (let* ((process-connection-type (eq system-type 'darwin)) - (proc-args (append arglist ldap-ldapsearch-args + ;; Leave process-connection-type at its default value. See + ;; discussion in Bug#33050. + (let* ((proc-args (append arglist ldap-ldapsearch-args filter)) (proc (apply #'start-process "ldapsearch" buf ldap-ldapsearch-prog diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el index 78400e1dbba..eb4312ef3b5 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -36,6 +36,14 @@ :version "21.1" :group 'mime) +(defcustom mailcap-prefer-mailcap-viewers t + "If non-nil, prefer viewers specified in ~/.mailcap. +If nil, the most specific viewer will be chosen, even if there is +a general override in ~/.mailcap. For instance, if /etc/mailcap +has an entry for \"image/gif\", that one will be chosen even if +you have an entry for \"image/*\" in your ~/.mailcap file." + :type 'boolean) + (defvar mailcap-parse-args-syntax-table (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) (modify-syntax-entry ?' "\"" table) @@ -419,20 +427,32 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus ((memq system-type mailcap-poor-system-types) (setq path '("~/.mailcap" "~/mail.cap" "~/etc/mail.cap"))) (t (setq path - ;; This is per RFC 1524, specifically - ;; with /usr before /usr/local. - '("~/.mailcap" "/etc/mailcap" "/usr/etc/mailcap" - "/usr/local/etc/mailcap")))) - (dolist (fname (reverse - (if (stringp path) - (split-string path path-separator t) - path))) - (when (and (file-readable-p fname) (file-regular-p fname)) - (mailcap-parse-mailcap fname))) + ;; This is per RFC 1524, specifically with /usr before + ;; /usr/local. + '("~/.mailcap" + ("/etc/mailcap" 'after) + ("/usr/etc/mailcap" 'after) + ("/usr/local/etc/mailcap" 'after))))) + ;; We read the entries from ~/.mailcap before the built-in values, + ;; but place the rest of then afterwards as fallback values. + (dolist (spec (reverse + (if (stringp path) + (split-string path path-separator t) + path))) + (let ((afterp (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 afterp)))) (setq mailcap-parsed-p t))) -(defun mailcap-parse-mailcap (fname) - "Parse out the mailcap file specified by FNAME." +(defun mailcap-parse-mailcap (fname &optional after) + "Parse out the mailcap file specified by FNAME. +If AFTER, place the entries from the file after the ones that are +already there." (let (major ; The major mime type (image/audio/etc) minor ; The minor mime type (gif, basic, etc) save-pos ; Misc saved positions used in parsing @@ -502,7 +522,7 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus "*" minor)))) (mailcap-parse-mailcap-extras save-pos (point)))) (mailcap-mailcap-entry-passes-test info) - (mailcap-add-mailcap-entry major minor info)) + (mailcap-add-mailcap-entry major minor info after)) (beginning-of-line))))) (defun mailcap-parse-mailcap-extras (st nd) @@ -685,7 +705,7 @@ to supply to the test." (push (list otest result) mailcap-viewer-test-cache) result)))) -(defun mailcap-add-mailcap-entry (major minor info) +(defun mailcap-add-mailcap-entry (major minor info &optional after) (let ((old-major (assoc major mailcap-mime-data))) (if (null old-major) ; New major area (push (cons major (list (cons minor info))) mailcap-mime-data) @@ -693,15 +713,23 @@ to supply to the test." (cond ((or (null cur-minor) ; New minor area, or (assq 'test info)) ; Has a test, insert at beginning - (setcdr old-major (cons (cons minor info) (cdr old-major)))) + (setcdr old-major + (if after ; Or after, if specified. + (nconc (cdr old-major) + (list (cons minor info))) + (cons (cons minor info) (cdr old-major))))) ((and (not (assq 'test info)) ; No test info, replace completely (not (assq 'test cur-minor)) (equal (assq 'viewer info) ; Keep alternative viewer (assq 'viewer cur-minor))) - (setcdr cur-minor info)) + (unless after + (setcdr cur-minor info))) (t - (setcdr old-major (cons (cons minor info) (cdr old-major)))))) - ))) + (setcdr old-major + (if after + (nconc (cdr old-major) (list (cons minor info))) + (setcdr old-major + (cons (cons minor info) (cdr old-major))))))))))) (defun mailcap-add (type viewer &optional test) "Add VIEWER as a handler for TYPE. @@ -784,18 +812,23 @@ If NO-DECODE is non-nil, don't decode STRING." (setq passed (list viewer)) ;; None found, so heuristically select some applicable viewer ;; from `mailcap-mime-data'. + (mailcap-parse-mailcaps) (setq major (split-string (car ctl) "/")) (setq minor (cadr major) major (car major)) (when (setq major-info (cdr (assoc major mailcap-mime-data))) (when (setq viewers (mailcap-possible-viewers major-info minor)) - (setq info (mapcar (lambda (a) (cons (symbol-name (car a)) - (cdr a))) + (setq info (mapcar (lambda (a) + (cons (symbol-name (car a)) (cdr a))) (cdr ctl))) (dolist (entry viewers) (when (mailcap-viewer-passes-test entry info) (push entry passed))) - (setq passed (sort passed 'mailcap-viewer-lessp)) + ;; The data is in "logical" order; entries from ~/.mailcap + ;; are first, so we don't need to do any sorting if the + ;; user wants ~/.mailcap to be preferred. + (unless mailcap-prefer-mailcap-viewers + (setq passed (sort passed 'mailcap-viewer-lessp))) (setq viewer (car passed)))) (when (and (stringp (cdr (assq 'viewer viewer))) passed) @@ -1006,6 +1039,14 @@ If FORCE, re-parse even if already parsed." (setq extn (concat "." extn))) (cdr (assoc (downcase extn) mailcap-mime-extensions))) +(defun mailcap-file-name-to-mime-type (file-name) + "Return the MIME content type based on the FILE-NAME's extension. +For instance, \"foo.png\" will result in \"image/png\"." + (mailcap-extension-to-mime + (if (string-match "\\(\\.[^.]+\\)\\'" file-name) + (match-string 1 file-name) + ""))) + (defun mailcap-mime-types () "Return a list of MIME media types." (mailcap-parse-mimetypes) diff --git a/lisp/net/mairix.el b/lisp/net/mairix.el index 07415667e1b..0c699c976ce 100644 --- a/lisp/net/mairix.el +++ b/lisp/net/mairix.el @@ -266,9 +266,7 @@ Currently there are `threads' and `flags'.") ;;; Gnus -;; For gnus-buffer-exists-p, although it seems that could be replaced by: -;; (and buffer (get-buffer buffer)) -(eval-when-compile (require 'gnus-util)) +(eval-when-compile (require 'gnus-util)) ; For `gnus-buffer-live-p'. (defvar gnus-article-buffer) (declare-function gnus-group-read-ephemeral-group "gnus-group" (group method &optional activate quit-config @@ -296,7 +294,7 @@ Currently there are `threads' and `flags'.") (unless (and (fboundp 'gnus-alive-p) (gnus-alive-p)) (error "Gnus is not running")) - (unless (gnus-buffer-exists-p gnus-article-buffer) + (unless (gnus-buffer-live-p gnus-article-buffer) (error "No article buffer available")) (with-current-buffer gnus-article-buffer ;; gnus-art requires gnus-sum and message. diff --git a/lisp/net/net-utils.el b/lisp/net/net-utils.el index fc39b91529a..dcc7e01b6b4 100644 --- a/lisp/net/net-utils.el +++ b/lisp/net/net-utils.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. -;; Author: Peter Breton <pbreton@cs.umb.edu> +;; Author: Peter Breton <pbreton@cs.umb.edu> ;; Created: Sun Mar 16 1997 ;; Keywords: network comm @@ -86,8 +86,6 @@ These options can be used to limit how many ICMP packets are emitted." :group 'net-utils :type '(repeat string)) -(define-obsolete-variable-alias 'ipconfig-program 'ifconfig-program "22.2") - (defcustom ifconfig-program (cond ((eq system-type 'windows-nt) "ipconfig") ((executable-find "ifconfig") "ifconfig") @@ -99,9 +97,6 @@ These options can be used to limit how many ICMP packets are emitted." :group 'net-utils :type 'string) -(define-obsolete-variable-alias 'ipconfig-program-options - 'ifconfig-program-options "22.2") - (defcustom ifconfig-program-options (cond ((string-match "ipconfig\\'" ifconfig-program) '("/all")) ((string-match "ifconfig\\'" ifconfig-program) '("-a")) diff --git a/lisp/net/netrc.el b/lisp/net/netrc.el index e7309850266..93152f4f2c4 100644 --- a/lisp/net/netrc.el +++ b/lisp/net/netrc.el @@ -63,12 +63,14 @@ "port")) alist elem result pair) (if (and netrc-cache - (equal (car netrc-cache) (nth 5 (file-attributes file)))) + (equal (car netrc-cache) (file-attribute-modification-time + (file-attributes file)))) (insert (base64-decode-string (rot13-string (cdr netrc-cache)))) (insert-file-contents file) (when (string-match "\\.gpg\\'" file) ;; Store the contents of the file heavily encrypted in memory. - (setq netrc-cache (cons (nth 5 (file-attributes file)) + (setq netrc-cache (cons (file-attribute-modification-time + (file-attributes file)) (rot13-string (base64-encode-string (buffer-string))))))) diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index 1d247812d9c..2b3292b71ba 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -42,14 +42,21 @@ ;;; Code: -(require 'tls) -(require 'starttls) (require 'auth-source) (require 'nsm) (require 'puny) +(declare-function starttls-available-p "starttls" ()) +(declare-function starttls-negotiate "starttls" (process)) +(declare-function starttls-open-stream "starttls" (name buffer host port)) + (autoload 'gnutls-negotiate "gnutls") (autoload 'open-gnutls-stream "gnutls") +(defvar starttls-extra-arguments) +(defvar starttls-extra-args) +(defvar starttls-use-gnutls) +(defvar starttls-gnutls-program) +(defvar starttls-program) ;;;###autoload (defun open-network-stream (name buffer host service &rest parameters) @@ -190,7 +197,7 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (car result)))))) (defun network-stream-certificate (host service parameters) - (let ((spec (plist-get :client-certificate parameters))) + (let ((spec (plist-get parameters :client-certificate))) (cond ((listp spec) ;; Either nil or a list with a key/certificate pair. @@ -255,7 +262,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (or (gnutls-available-p) (and (or require-tls (plist-get parameters :use-starttls-if-possible)) - (starttls-available-p)))) + (require 'starttls) + (starttls-available-p)))) (not (eq (plist-get parameters :type) 'plain))) ;; If using external STARTTLS, drop this connection and start ;; anew with `starttls-open-stream'. @@ -295,7 +303,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (if (gnutls-available-p) (let ((cert (network-stream-certificate host service parameters))) (condition-case nil - (gnutls-negotiate :process stream :hostname host + (gnutls-negotiate :process stream + :hostname (puny-encode-domain host) :keylist (and cert (list cert))) ;; If we get a gnutls-specific error (for instance if ;; the certificate the server gives us is completely @@ -335,7 +344,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." ;; See `starttls-available-p'. If this predicate ;; changes to allow running under Windows, the error ;; message below should be amended. - (if (memq system-type '(windows-nt ms-dos)) + (if (or (memq system-type '(windows-nt ms-dos)) + (not (featurep 'starttls))) (concat "Emacs does not support TLS") (concat "Emacs does not support TLS, and no external `" (if starttls-use-gnutls @@ -366,19 +376,22 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (goto-char start) (while (and (memq (process-status stream) '(open run)) (not (re-search-forward end-of-command nil t))) - (accept-process-output stream 0 50) + (accept-process-output stream 0.05) (goto-char start)) ;; Return the data we got back, or nil if the process died. (unless (= start (point)) (buffer-substring start (point))))))) +(declare-function open-tls-stream "tls" (name buffer host port)) + (defun network-stream-open-tls (name buffer host service parameters) (with-current-buffer buffer (let* ((start (point-max)) (stream (if (gnutls-available-p) (open-gnutls-stream name buffer host service - (plist-get parameters :nowait)) + parameters) + (require 'tls) (open-tls-stream name buffer host service))) (eoc (plist-get parameters :end-of-command))) (if (plist-get parameters :nowait) @@ -405,6 +418,9 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (network-stream-command stream capability-command eo-capa) 'tls))))))) +(declare-function format-spec "format-spec" (format spec)) +(declare-function format-spec-make "format-spec" (&rest pairs)) + (defun network-stream-open-shell (name buffer host service parameters) (require 'format-spec) (let* ((capability-command (plist-get parameters :capability-command)) diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index 96503bae18b..e356a0ece55 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -1,4 +1,4 @@ -;;; newst-backend.el --- Retrieval backend for newsticker. +;;; newst-backend.el --- Retrieval backend for newsticker -*- lexical-binding:t -*- ;; Copyright (C) 2003-2019 Free Software Foundation, Inc. @@ -170,7 +170,7 @@ These were mostly extracted from the Radio Community Server at http://subhonker6.userland.com/rcsPublic/rssHotlist. You may add other entries in `newsticker-url-list'." - :type `(set ,@(mapcar `newsticker--splicer + :type `(set ,@(mapcar #'newsticker--splicer newsticker--raw-url-list-defaults)) :set 'newsticker--set-customvar-retrieval :group 'newsticker-retrieval) @@ -435,40 +435,6 @@ buffers *newsticker-wget-<feed>* will not be closed." :group 'newsticker-miscellaneous) ;; ====================================================================== -;;; Compatibility section, XEmacs, Emacs -;; ====================================================================== - -;; FIXME It is bad practice to define compat functions with such generic names. - -(unless (fboundp 'match-string-no-properties) - (defalias 'match-string-no-properties 'match-string)) - -(when (featurep 'xemacs) - (unless (fboundp 'replace-regexp-in-string) - (defun replace-regexp-in-string (re rp st) - (save-match-data ;; apparently XEmacs needs save-match-data - (replace-in-string st re rp))))) - -;; copied from subr.el -(unless (fboundp 'add-to-invisibility-spec) - (defun add-to-invisibility-spec (arg) - "Add elements to `buffer-invisibility-spec'. -See documentation for `buffer-invisibility-spec' for the kind of elements -that can be added." - (if (eq buffer-invisibility-spec t) - (setq buffer-invisibility-spec (list t))) - (setq buffer-invisibility-spec - (cons arg buffer-invisibility-spec)))) - -;; copied from subr.el -(unless (fboundp 'remove-from-invisibility-spec) - (defun remove-from-invisibility-spec (arg) - "Remove elements from `buffer-invisibility-spec'." - (if (consp buffer-invisibility-spec) - (setq buffer-invisibility-spec - (delete arg buffer-invisibility-spec))))) - -;; ====================================================================== ;;; Internal variables ;; ====================================================================== (defvar newsticker--buffer-uptodate-p nil @@ -591,11 +557,6 @@ name/timer pair to `newsticker--retrieval-timer-list'." ;; do not repeat retrieval if interval not positive (if (<= interval 0) (setq interval nil)) - ;; Suddenly XEmacs doesn't like start-time 0 - (if (or (not start-time) - (and (numberp start-time) (= start-time 0))) - (setq start-time 1)) - ;; (message "start-time %s" start-time) (setq timer (run-at-time start-time interval 'newsticker-get-news feed-name)) (if interval @@ -603,7 +564,7 @@ name/timer pair to `newsticker--retrieval-timer-list'." (cons feed-name timer)))))) ;;;###autoload -(defun newsticker-start (&optional do-not-complain-if-running) +(defun newsticker-start (&optional _do-not-complain-if-running) "Start the newsticker. Start the timers for display and retrieval. If the newsticker, i.e. the timers, are running already a warning message is printed unless @@ -639,9 +600,8 @@ if newsticker has been running." (when (fboundp 'newsticker-stop-ticker) ; silence compiler warnings (newsticker-stop-ticker)) (when (newsticker-running-p) - (mapc (lambda (name-and-timer) - (newsticker--stop-feed (car name-and-timer))) - newsticker--retrieval-timer-list) + (dolist (name-and-timer newsticker--retrieval-timer-list) + (newsticker--stop-feed (car name-and-timer))) (setq newsticker--retrieval-timer-list nil) (run-hooks 'newsticker-stop-hook) (message "Newsticker stopped!"))) @@ -651,9 +611,8 @@ if newsticker has been running." This does NOT start the retrieval timers." (interactive) ;; launch retrieval of news - (mapc (lambda (item) - (newsticker-get-news (car item))) - (append newsticker-url-list-defaults newsticker-url-list))) + (dolist (item (append newsticker-url-list-defaults newsticker-url-list)) + (newsticker-get-news (car item)))) (defun newsticker-save-item (feed item) "Save FEED ITEM." @@ -709,7 +668,7 @@ See `newsticker-get-news'." (let ((buffername (concat " *newsticker-funcall-" feed-name "*"))) (with-current-buffer (get-buffer-create buffername) (erase-buffer) - (insert (string-to-multibyte (funcall function feed-name))) + (newsticker--insert-bytes (funcall function feed-name)) (newsticker--sentinel-work nil t feed-name function (current-buffer))))) @@ -730,10 +689,10 @@ STATUS is the return status as delivered by `url-retrieve', and FEED-NAME is the name of the feed that the news were retrieved from." (let ((buf (get-buffer-create (concat " *newsticker-url-" feed-name "*"))) - (result (string-to-multibyte (buffer-string)))) + (result (buffer-string))) (set-buffer buf) (erase-buffer) - (insert result) + (newsticker--insert-bytes result) ;; remove MIME header (goto-char (point-min)) (search-forward "\n\n" nil t) @@ -876,11 +835,12 @@ Argument BUFFER is the buffer of the retrieval process." (decode-coding-region (point-min) (point-max) coding-system)) (condition-case errordata - ;; The xml parser might fail or the xml might be - ;; bugged + ;; The xml parser might fail or the xml might be bugged. (if (fboundp 'libxml-parse-xml-region) - (list (libxml-parse-xml-region (point-min) (point-max) - nil t)) + (progn + (xml-remove-comments (point-min) (point-max)) + (list (libxml-parse-xml-region (point-min) (point-max) + nil))) (xml-parse-region (point-min) (point-max))) (error (message "Could not parse %s: %s" (buffer-name) (cadr errordata)) @@ -1255,9 +1215,6 @@ For the RSS 0.91 specification see URL `http://backend.userland.com/rss091' or URL `http://my.netscape.com/publish/formats/rss-spec-0.91.html'." (newsticker--debug-msg "Parsing RSS 0.91 feed %s" name) (let* ((channelnode (car (xml-get-children topnode 'channel))) - (pub-date (newsticker--decode-rfc822-date - (car (xml-node-children - (car (xml-get-children channelnode 'pubDate)))))) is-new-feed has-new-items) (setq is-new-feed (newsticker--parse-generic-feed name time @@ -1293,7 +1250,7 @@ or URL `http://my.netscape.com/publish/formats/rss-spec-0.91.html'." (car (xml-node-children (car (xml-get-children node 'pubDate)))))) ;; guid-fn - (lambda (node) + (lambda (_node) nil) ;; extra-fn (lambda (node) @@ -1308,9 +1265,6 @@ same as in `newsticker--parse-atom-1.0'. For the RSS 0.92 specification see URL `http://backend.userland.com/rss092'." (newsticker--debug-msg "Parsing RSS 0.92 feed %s" name) (let* ((channelnode (car (xml-get-children topnode 'channel))) - (pub-date (newsticker--decode-rfc822-date - (car (xml-node-children - (car (xml-get-children channelnode 'pubDate)))))) is-new-feed has-new-items) (setq is-new-feed (newsticker--parse-generic-feed name time @@ -1346,7 +1300,7 @@ For the RSS 0.92 specification see URL `http://backend.userland.com/rss092'." (car (xml-node-children (car (xml-get-children node 'pubDate)))))) ;; guid-fn - (lambda (node) + (lambda (_node) nil) ;; extra-fn (lambda (node) @@ -1405,7 +1359,7 @@ For the RSS 1.0 specification see URL `http://web.resource.org/rss/1.0/spec'." (car (xml-node-children (car (xml-get-children node 'date))))))) ;; guid-fn - (lambda (node) + (lambda (_node) nil) ;; extra-fn (lambda (node) @@ -1486,7 +1440,6 @@ The arguments TITLE, DESC, LINK, and EXTRA-ELEMENTS give the feed's title, description, link, and extra elements resp." (let ((title (or title "[untitled]")) (link (or link "")) - (old-item nil) (position 0) (something-was-added nil)) ;; decode numeric entities @@ -1522,89 +1475,89 @@ The arguments TITLE-FN, DESC-FN, LINK-FN, TIME-FN, GUID-FN, and EXTRA-FN give functions for extracting title, description, link, time, guid, and extra-elements resp. They are called with one argument, which is one of the items in ITEMLIST." - (let (title desc link - (old-item nil) - (position 0) + (let ((position 0) (something-was-added nil)) ;; gather all items for this feed - (mapc (lambda (node) - (setq position (1+ position)) - (setq title (or (funcall title-fn node) "[untitled]")) - (setq desc (funcall desc-fn node)) - (setq link (or (funcall link-fn node) "")) - (setq time (or (funcall time-fn node) time)) - ;; It happened that the title or description - ;; contained evil HTML code that confused the - ;; xml parser. Therefore: - (unless (stringp title) - (setq title (prin1-to-string title))) - (unless (or (stringp desc) (not desc)) - (setq desc (prin1-to-string desc))) - ;; ignore items with empty title AND empty desc - (when (or (> (length title) 0) - (> (length desc) 0)) - ;; decode numeric entities - (setq title (xml-substitute-numeric-entities title)) - (when desc - (setq desc (xml-substitute-numeric-entities desc))) - (setq link (xml-substitute-numeric-entities link)) - ;; remove whitespace from title, desc, and link - (setq title (newsticker--remove-whitespace title)) - (setq desc (newsticker--remove-whitespace desc)) - (setq link (newsticker--remove-whitespace link)) - ;; add data to cache - ;; do we have this item already? - (let* ((guid (funcall guid-fn node))) - ;;(message "guid=%s" guid) - (setq old-item - (newsticker--cache-contains newsticker--cache - (intern name) title - desc link nil guid))) - ;; add this item, or mark it as old, or do nothing - (let ((age1 'new) - (age2 'old) - (item-new-p nil)) - (if old-item - (let ((prev-age (newsticker--age old-item))) - (unless newsticker-automatically-mark-items-as-old - ;; Some feeds deliver items multiply, the - ;; first time we find an 'obsolete-old one in - ;; the cache, the following times we find an - ;; 'old one - (if (memq prev-age '(obsolete-old old)) - (setq age2 'old) - (setq age2 'new))) - (if (eq prev-age 'immortal) - (setq age2 'immortal)) - (setq time (newsticker--time old-item))) - ;; item was not there - (setq item-new-p t) - (setq something-was-added t)) - (let ((extra-elements-with-guid (funcall extra-fn node))) - (unless (assoc 'guid extra-elements-with-guid) - (setq extra-elements-with-guid - (cons `(guid nil ,(funcall guid-fn node)) - extra-elements-with-guid))) - (setq newsticker--cache - (newsticker--cache-add - newsticker--cache (intern name) title desc link - time age1 position extra-elements-with-guid - time age2))) - (when item-new-p - (let ((item (newsticker--cache-contains - newsticker--cache (intern name) title - desc link nil))) - (if newsticker-auto-mark-filter-list - (newsticker--run-auto-mark-filter name item)) - (run-hook-with-args - 'newsticker-new-item-functions name item)))))) - itemlist) + (dolist (node itemlist) + (setq position (1+ position)) + (let ((title (or (funcall title-fn node) "[untitled]")) + (desc (funcall desc-fn node)) + (link (or (funcall link-fn node) ""))) + (setq time (or (funcall time-fn node) time)) + ;; It happened that the title or description + ;; contained evil HTML code that confused the + ;; xml parser. Therefore: + (unless (stringp title) + (setq title (prin1-to-string title))) + (unless (or (stringp desc) (not desc)) + (setq desc (prin1-to-string desc))) + ;; ignore items with empty title AND empty desc + (when (or (> (length title) 0) + (> (length desc) 0)) + ;; decode numeric entities + (setq title (xml-substitute-numeric-entities title)) + (when desc + (setq desc (xml-substitute-numeric-entities desc))) + (setq link (xml-substitute-numeric-entities link)) + ;; remove whitespace from title, desc, and link + (setq title (newsticker--remove-whitespace title)) + (setq desc (newsticker--remove-whitespace desc)) + (setq link (newsticker--remove-whitespace link)) + ;; add data to cache + ;; do we have this item already? + (let ((old-item + (let* ((guid (funcall guid-fn node))) + ;;(message "guid=%s" guid) + (newsticker--cache-contains newsticker--cache + (intern name) title + desc link nil guid))) + (age1 'new) + (age2 'old) + (item-new-p nil)) + ;; Add this item, or mark it as old, or do nothing + (if old-item + (let ((prev-age (newsticker--age old-item))) + (unless newsticker-automatically-mark-items-as-old + ;; Some feeds deliver items multiply, the + ;; first time we find an 'obsolete-old one in + ;; the cache, the following times we find an + ;; 'old one + (if (memq prev-age '(obsolete-old old)) + (setq age2 'old) + (setq age2 'new))) + (if (eq prev-age 'immortal) + (setq age2 'immortal)) + (setq time (newsticker--time old-item))) + ;; item was not there + (setq item-new-p t) + (setq something-was-added t)) + (let ((extra-elements-with-guid (funcall extra-fn node))) + (unless (assoc 'guid extra-elements-with-guid) + (setq extra-elements-with-guid + (cons `(guid nil ,(funcall guid-fn node)) + extra-elements-with-guid))) + (setq newsticker--cache + (newsticker--cache-add + newsticker--cache (intern name) title desc link + time age1 position extra-elements-with-guid + time age2))) + (when item-new-p + (let ((item (newsticker--cache-contains + newsticker--cache (intern name) title + desc link nil))) + (if newsticker-auto-mark-filter-list + (newsticker--run-auto-mark-filter name item)) + (run-hook-with-args + 'newsticker-new-item-functions name item))))))) something-was-added)) ;; ====================================================================== ;;; Misc ;; ====================================================================== +(defun newsticker--insert-bytes (bytes) + (insert (decode-coding-string bytes 'binary))) + (defun newsticker--remove-whitespace (string) "Remove leading and trailing whitespace from STRING." ;; we must have ...+ but not ...* in the regexps otherwise xemacs loops @@ -1759,12 +1712,11 @@ Sat, 07 Sep 2002 00:00:01 GMT (setq minute (+ minute offset-minute))))) (condition-case error-data (let ((i 1)) - (mapc (lambda (m) - (if (string= month-name m) - (setq month i)) - (setq i (1+ i))) - '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" - "Sep" "Oct" "Nov" "Dec")) + (dolist (m '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" + "Sep" "Oct" "Nov" "Dec")) + (if (string= month-name m) + (setq month i)) + (setq i (1+ i))) (encode-time second minute hour day month year t)) (error (message "Cannot decode \"%s\": %s %s" rfc822-string @@ -1775,22 +1727,19 @@ Sat, 07 Sep 2002 00:00:01 GMT (defun newsticker--lists-intersect-p (list1 list2) "Return t if LIST1 and LIST2 share elements." (let ((result nil)) - (mapc (lambda (elt) - (if (memq elt list2) - (setq result t))) - list1) + (dolist (elt list1) + (if (memq elt list2) + (setq result t))) result)) (defun newsticker--update-process-ids () "Update list of ids of active newsticker processes. Checks list of active processes against list of newsticker processes." - (let ((active-procs (process-list)) - (new-list nil)) - (mapc (lambda (proc) - (let ((id (process-id proc))) - (if (memq id newsticker--process-ids) - (setq new-list (cons id new-list))))) - active-procs) + (let ((new-list nil)) + (dolist (proc (process-list)) + (let ((id (process-id proc))) + (if (memq id newsticker--process-ids) + (setq new-list (cons id new-list))))) (setq newsticker--process-ids new-list)) (force-mode-line-update)) @@ -1811,9 +1760,10 @@ If the file does no exist or if it is older than 24 hours download it from URL first." (let ((image-name (concat directory feed-name))) (if (and (file-exists-p image-name) - (time-less-p (current-time) - (time-add (nth 5 (file-attributes image-name)) - (seconds-to-time 86400)))) + (time-less-p nil + (time-add (file-attribute-modification-time + (file-attributes image-name)) + 86400))) (newsticker--debug-msg "%s: Getting image for %s skipped" (format-time-string "%A, %H:%M") feed-name) @@ -1853,7 +1803,7 @@ Save image as FILENAME in DIRECTORY, download it from URL." (process-put proc 'nt-feed-name feed-name) (process-put proc 'nt-filename filename))))) -(defun newsticker--image-sentinel (process event) +(defun newsticker--image-sentinel (process _event) "Sentinel for image-retrieving PROCESS caused by EVENT." (let* ((p-status (process-status process)) (exit-status (process-exit-status process)) @@ -1914,21 +1864,21 @@ from. The image is saved in DIRECTORY as FILENAME." (let ((do-save (or (not status) - (let ((status-type (car status)) - (status-details (cdr status))) - (cond ((eq status-type :redirect) - ;; don't care about redirects - t) - ((eq status-type :error) - ;; silently ignore errors - nil)))))) + ;; (let ((status-type (car status))) + ;; (cond ((eq status-type :redirect) + ;; ;; don't care about redirects + ;; t) + ;; ((eq status-type :error) + ;; ;; silently ignore errors + ;; nil))) + (eq (car status) :redirect)))) (when do-save (let ((buf (get-buffer-create (concat " *newsticker-url-image-" feed-name "-" directory "*"))) - (result (string-to-multibyte (buffer-string)))) + (result (buffer-string))) (set-buffer buf) (erase-buffer) - (insert result) + (newsticker--insert-bytes result) ;; remove MIME header (goto-char (point-min)) (search-forward "\n\n") @@ -2006,9 +1956,8 @@ older than TIME." (mapc (lambda (item) (when (eq (newsticker--age item) old-age) - (let ((exp-time (time-add (newsticker--time item) - (seconds-to-time time)))) - (when (time-less-p exp-time (current-time)) + (let ((exp-time (time-add (newsticker--time item) time))) + (when (time-less-p exp-time nil) (newsticker--debug-msg "Item `%s' from %s has expired on %s" (newsticker--title item) @@ -2020,7 +1969,7 @@ older than TIME." data) data) -(defun newsticker--cache-contains (data feed title desc link age +(defun newsticker--cache-contains (data feed title desc link _age &optional guid) "Check DATA whether FEED contains an item with the given properties. This function returns the contained item or nil if it is not @@ -2182,22 +2131,8 @@ well." (throw 'result nil)) ((eq age2 'obsolete) (throw 'result t))))) - (let* ((time1 (newsticker--time item1)) - (time2 (newsticker--time item2))) - (cond ((< (nth 0 time1) (nth 0 time2)) - nil) - ((> (nth 0 time1) (nth 0 time2)) - t) - ((< (nth 1 time1) (nth 1 time2)) - nil) - ((> (nth 1 time1) (nth 1 time2)) - t) - ((< (or (nth 2 time1) 0) (or (nth 2 time2) 0)) - nil) - ((> (or (nth 2 time1) 0) (or (nth 2 time2) 0)) - t) - (t - nil))))) + (time-less-p (newsticker--time item2) + (newsticker--time item1)))) (defun newsticker--cache-item-compare-by-title (item1 item2) "Compare ITEM1 and ITEM2 by comparing their titles." @@ -2293,9 +2228,8 @@ FEED is a symbol!" (newsticker--cache-read-version1)) (when (y-or-n-p (format "Delete old newsticker cache file? ")) (delete-file newsticker-cache-filename))) - (mapc (lambda (f) - (newsticker--cache-read-feed (car f))) - (append newsticker-url-list-defaults newsticker-url-list)))) + (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." @@ -2362,14 +2296,13 @@ Export subscriptions to a buffer in OPML Format." " <ownerName>" (user-full-name) "</ownerName>\n" " </head>\n" " <body>\n")) - (mapc (lambda (sub) - (insert " <outline text=\"") - (insert (newsticker--title sub)) - (insert "\" xmlUrl=\"") - (insert (xml-escape-string (let ((url (cadr sub))) - (if (stringp url) url (prin1-to-string url))))) - (insert "\"/>\n")) - (append newsticker-url-list newsticker-url-list-defaults)) + (dolist (sub (append newsticker-url-list newsticker-url-list-defaults)) + (insert " <outline text=\"") + (insert (newsticker--title sub)) + (insert "\" xmlUrl=\"") + (insert (xml-escape-string (let ((url (cadr sub))) + (if (stringp url) url (prin1-to-string url))))) + (insert "\"/>\n")) (insert " </body>\n</opml>\n")) (pop-to-buffer "*OPML Export*") (when (fboundp 'sgml-mode) @@ -2409,28 +2342,26 @@ removed." This function checks the variable `newsticker-auto-mark-filter-list' for an entry that matches FEED and ITEM." (let ((case-fold-search t)) - (mapc (lambda (filter) - (let ((filter-feed (car filter)) - (pattern-list (cadr filter))) - (when (string-match filter-feed feed) - (newsticker--do-run-auto-mark-filter item pattern-list)))) - newsticker-auto-mark-filter-list))) + (dolist (filter newsticker-auto-mark-filter-list) + (let ((filter-feed (car filter)) + (pattern-list (cadr filter))) + (when (string-match filter-feed feed) + (newsticker--do-run-auto-mark-filter item pattern-list)))))) (defun newsticker--do-run-auto-mark-filter (item list) "Actually compare ITEM against the pattern-LIST. LIST must be an element of `newsticker-auto-mark-filter-list'." - (mapc (lambda (pattern) - (let ((place (nth 1 pattern)) - (regexp (nth 2 pattern)) - (title (newsticker--title item)) - (desc (newsticker--desc item))) - (when (or (eq place 'title) (eq place 'all)) - (when (and title (string-match regexp title)) - (newsticker--process-auto-mark-filter-match item pattern))) - (when (or (eq place 'description) (eq place 'all)) - (when (and desc (string-match regexp desc)) - (newsticker--process-auto-mark-filter-match item pattern))))) - list)) + (dolist (pattern list) + (let ((place (nth 1 pattern)) + (regexp (nth 2 pattern)) + (title (newsticker--title item)) + (desc (newsticker--desc item))) + (when (or (eq place 'title) (eq place 'all)) + (when (and title (string-match regexp title)) + (newsticker--process-auto-mark-filter-match item pattern))) + (when (or (eq place 'description) (eq place 'all)) + (when (and desc (string-match regexp desc)) + (newsticker--process-auto-mark-filter-match item pattern)))))) (defun newsticker--process-auto-mark-filter-match (item pattern) "Process ITEM that matches an auto-mark-filter PATTERN." @@ -2503,7 +2434,7 @@ This function is suited for adding it to `newsticker-new-item-functions'." ;; ====================================================================== ;;; Retrieve samples ;; ====================================================================== -(defun newsticker-retrieve-random-message (feed-name) +(defun newsticker-retrieve-random-message (_feed-name) "Return an artificial RSS string under the name FEED-NAME." (concat "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?><rss version=\"0.91\">" "<channel>" diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el index 569383b4a28..4f5c729dd00 100644 --- a/lisp/net/newst-plainview.el +++ b/lisp/net/newst-plainview.el @@ -562,7 +562,6 @@ This does NOT start the retrieval timers." (newsticker--debug-msg "Getting news for %s" (symbol-name feed)) (newsticker-get-news (symbol-name feed))))) -(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) (declare-function w3m-toggle-inline-image "ext:w3m" (&optional force no-cache)) (defun newsticker-w3m-show-inline-images () diff --git a/lisp/net/newst-treeview.el b/lisp/net/newst-treeview.el index 3af2c423be9..ece728a8358 100644 --- a/lisp/net/newst-treeview.el +++ b/lisp/net/newst-treeview.el @@ -36,6 +36,7 @@ ;; ====================================================================== ;;; Code: +(require 'cl-lib) (require 'newst-reader) (require 'widget) (require 'tree-widget) @@ -258,7 +259,6 @@ their id stays constant." ;; ====================================================================== -(unless (fboundp 'declare-function) (defmacro declare-function (&rest _))) (declare-function w3m-toggle-inline-images "ext:w3m" (&optional force no-cache)) (defvar w3m-fill-column) (defvar w3-maximum-line-length) diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index 13e6b08e2fc..dbfa2101f0c 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -26,6 +26,7 @@ (require 'cl-lib) (require 'rmc) ; read-multiple-choice +(eval-when-compile (require 'subr-x)) (defvar nsm-permanent-host-settings nil) (defvar nsm-temporary-host-settings nil) @@ -118,12 +119,10 @@ unencrypted." process)))))) (defun nsm-check-tls-connection (process host port status settings) - (let ((process (nsm-check-certificate process host port status settings))) - (if (and process - (>= (nsm-level network-security-level) (nsm-level 'high))) - ;; Do further protocol-level checks if the security is high. - (nsm-check-protocol process host port status settings) - process))) + (when-let ((process + (nsm-check-certificate process host port status settings))) + ;; Do further protocol-level checks. + (nsm-check-protocol process host port status settings))) (declare-function gnutls-peer-status-warning-describe "gnutls.c" (status-symbol)) @@ -150,11 +149,6 @@ unencrypted." (not (nsm-new-fingerprint-ok-p host port status))) (delete-process process) nil) - ((>= (nsm-level network-security-level) (nsm-level 'high)) - ;; Save the host fingerprint so that we can check it the - ;; next time we connect. - (nsm-save-host host port status 'fingerprint 'always) - process) (t process))) @@ -182,57 +176,104 @@ unencrypted." nil) process)))))) +(defvar network-security-protocol-checks + '((diffie-hellman-prime-bits medium 1024) + (rc4 medium) + (signature-sha1 medium) + (intermediate-sha1 medium) + (3des high) + (ssl medium)) + "This variable specifies what TLS connection checks to perform. +It's an alist where the first element is the name of the check, +the second is the security level where the check kicks in, and the +optional third element is a parameter supplied to the check. + +An element like `(rc4 medium)' will result in the function +`nsm-protocol-check--rc4' being called with the parameters +HOST PORT STATUS OPTIONAL-PARAMETER.") + (defun nsm-check-protocol (process host port status settings) - (let ((prime-bits (plist-get status :diffie-hellman-prime-bits)) - (signature-algorithm - (plist-get (plist-get status :certificate) :signature-algorithm)) - (encryption (format "%s-%s-%s" - (plist-get status :key-exchange) - (plist-get status :cipher) - (plist-get status :mac))) - (protocol (plist-get status :protocol))) - (cond - ((and prime-bits - (< prime-bits 1024) - (not (memq :diffie-hellman-prime-bits - (plist-get settings :conditions))) - (not - (nsm-query - host port status :diffie-hellman-prime-bits - "The Diffie-Hellman prime bits (%s) used for this connection to %s:%s is less than what is considered safe (%s)." - prime-bits host port 1024))) - (delete-process process) - nil) - ((and (string-match "\\bRC4\\b" encryption) - (not (memq :rc4 (plist-get settings :conditions))) - (not - (nsm-query - host port status :rc4 - "The connection to %s:%s uses the RC4 algorithm (%s), which is believed to be unsafe." - host port encryption))) - (delete-process process) - nil) - ((and (string-match "\\bSHA1\\b" signature-algorithm) - (not (memq :signature-sha1 (plist-get settings :conditions))) - (not - (nsm-query - host port status :signature-sha1 - "The certificate used to verify the connection to %s:%s uses the SHA1 algorithm (%s), which is believed to be unsafe." - host port signature-algorithm))) - (delete-process process) - nil) - ((and protocol - (string-match "SSL" protocol) - (not (memq :ssl (plist-get settings :conditions))) - (not - (nsm-query - host port status :ssl - "The connection to %s:%s uses the %s protocol, which is believed to be unsafe." - host port protocol))) - (delete-process process) - nil) - (t - process)))) + (cl-loop for check in network-security-protocol-checks + for type = (intern (format ":%s" (car check)) obarray) + while process + ;; Skip the check if the user has already said that this + ;; host is OK for this type of "error". + when (and (not (memq type (plist-get settings :conditions))) + (>= (nsm-level network-security-level) + (nsm-level (cadr check)))) + do (let ((result + (funcall (intern (format "nsm-protocol-check--%s" + (car check)) + obarray) + host port status (nth 2 check)))) + (unless result + (delete-process process) + (setq process nil)))) + ;; If a test failed we return nil, otherwise the process object. + process) + +(defun nsm--encryption (status) + (format "%s-%s-%s" + (plist-get status :key-exchange) + (plist-get status :cipher) + (plist-get status :mac))) + +(defun nsm-protocol-check--diffie-hellman-prime-bits (host port status bits) + (let ((prime-bits (plist-get status :diffie-hellman-prime-bits))) + (or (not prime-bits) + (>= prime-bits bits) + (nsm-query + host port status :diffie-hellman-prime-bits + "The Diffie-Hellman prime bits (%s) used for this connection to %s:%s is less than what is considered safe (%s)." + prime-bits host port bits)))) + +(defun nsm-protocol-check--3des (host port status _) + (or (not (string-match "\\b3DES\\b" (plist-get status :cipher))) + (nsm-query + host port status :rc4 + "The connection to %s:%s uses the 3DES cipher (%s), which is believed to be unsafe." + host port (plist-get status :cipher)))) + +(defun nsm-protocol-check--rc4 (host port status _) + (or (not (string-match "\\bRC4\\b" (nsm--encryption status))) + (nsm-query + host port status :rc4 + "The connection to %s:%s uses the RC4 algorithm (%s), which is believed to be unsafe." + host port (nsm--encryption status)))) + +(defun nsm-protocol-check--signature-sha1 (host port status _) + (let ((signature-algorithm + (plist-get (plist-get status :certificate) :signature-algorithm))) + (or (not (string-match "\\bSHA1\\b" signature-algorithm)) + (nsm-query + host port status :signature-sha1 + "The certificate used to verify the connection to %s:%s uses the SHA1 algorithm (%s), which is believed to be unsafe." + host port signature-algorithm)))) + +(defun nsm-protocol-check--intermediate-sha1 (host port status _) + ;; Skip the first certificate, because that's the host certificate. + (cl-loop for certificate in (cdr (plist-get status :certificates)) + for algo = (plist-get certificate :signature-algorithm) + ;; Don't check root certificates -- SHA1 isn't dangerous + ;; there. + when (and (not (equal (plist-get certificate :issuer) + (plist-get certificate :subject))) + (string-match "\\bSHA1\\b" algo) + (not (nsm-query + host port status :intermediate-sha1 + "An intermediate certificate used to verify the connection to %s:%s uses the SHA1 algorithm (%s), which is believed to be unsafe." + host port algo))) + do (cl-return nil) + finally (cl-return t))) + +(defun nsm-protocol-check--ssl (host port status _) + (let ((protocol (plist-get status :protocol))) + (or (not protocol) + (not (string-match "SSL" protocol)) + (nsm-query + host port status :ssl + "The connection to %s:%s uses the %s protocol, which is believed to be unsafe." + host port protocol)))) (defun nsm-fingerprint (status) (plist-get (plist-get status :certificate) :public-key-id)) diff --git a/lisp/net/ntlm.el b/lisp/net/ntlm.el index d3899e45eae..88c561910cb 100644 --- a/lisp/net/ntlm.el +++ b/lisp/net/ntlm.el @@ -1,4 +1,4 @@ -;;; ntlm.el --- NTLM (NT LanManager) authentication support +;;; ntlm.el --- NTLM (NT LanManager) authentication support -*- lexical-binding:t -*- ;; Copyright (C) 2001, 2007-2019 Free Software Foundation, Inc. @@ -106,7 +106,7 @@ is not given." (request-flags (concat (make-string 1 7) (make-string 1 130) (make-string 1 8) (make-string 1 0))) ;0x07 0x82 0x08 0x00 - lu ld off-d off-u) + ) (when (and user (string-match "@" user)) (unless domain (setq domain (substring user (1+ (match-beginning 0))))) @@ -115,10 +115,10 @@ is not given." ;; set "negotiate domain supplied" bit (aset request-flags 1 (logior (aref request-flags 1) ?\x10))) ;; set fields offsets within the request struct - (setq lu (length user)) - (setq ld (length domain)) - (setq off-u 32) ;offset to the string 'user - (setq off-d (+ 32 lu)) ;offset to the string 'domain + (let* ((lu (length user)) + (ld (length domain)) + (off-u 32) ;offset to the string 'user + (off-d (+ 32 lu))) ;offset to the string 'domain ;; pack the request struct in a string (concat request-ident ;8 bytes request-msgType ;4 bytes @@ -131,39 +131,34 @@ is not given." (md4-pack-int32 (cons 0 off-d)) ;domain field, offset field user ;buffer field domain ;buffer field - ))) - -(eval-when-compile - (defmacro ntlm-string-as-unibyte (string) - (if (fboundp 'string-as-unibyte) - `(string-as-unibyte ,string) - string))) + )))) (defun ntlm-compute-timestamp () "Compute an NTLMv2 timestamp. Return a unibyte string representing the number of tenths of a microsecond since January 1, 1601 as a 64-bit little-endian signed integer." + ;; FIXME: This can likely be significantly simplified using the new + ;; bignums support! (let* ((s-to-tenths-of-us "mul(add(lsh($1,16),$2),10000000)") (us-to-tenths-of-us "mul($3,10)") (ps-to-tenths-of-us "idiv($4,100000)") (tenths-of-us-since-jan-1-1601 - (apply 'calc-eval (concat "add(add(add(" + (apply #'calc-eval (concat "add(add(add(" s-to-tenths-of-us "," us-to-tenths-of-us ")," ps-to-tenths-of-us ")," ;; tenths of microseconds between ;; 1601-01-01 and 1970-01-01 "116444736000000000)") - ;; add trailing zeros to support old current-time formats - 'rawnum (append (current-time) '(0 0)))) + 'rawnum (encode-time nil 'list))) result-bytes) - (dotimes (byte 8) + (dotimes (_byte 8) (push (calc-eval "and($1,16#FF)" 'rawnum tenths-of-us-since-jan-1-1601) result-bytes) (setq tenths-of-us-since-jan-1-1601 (calc-eval "rsh($1,8,64)" 'rawnum tenths-of-us-since-jan-1-1601))) - (apply 'unibyte-string (nreverse result-bytes)))) + (apply #'unibyte-string (nreverse result-bytes)))) (defun ntlm-generate-nonce () "Generate a random nonce, not to be used more than once. @@ -178,7 +173,13 @@ the NTLM based server for the user USER and the password hash list PASSWORD-HASHES. NTLM uses two hash values which are represented by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of (list (ntlm-smb-passwd-hash password) (ntlm-md4hash password))" - (let* ((rchallenge (ntlm-string-as-unibyte challenge)) + (let* ((rchallenge (if (multibyte-string-p challenge) + (progn + ;; FIXME: Maybe it would be better to + ;; signal an error. + (message "Incorrect challenge string type in ntlm-build-auth-response") + (encode-coding-string challenge 'binary)) + challenge)) ;; get fields within challenge struct ;;(ident (substring rchallenge 0 8)) ;ident, 8 bytes ;;(msgType (substring rchallenge 8 12)) ;msgType, 4 bytes @@ -189,20 +190,16 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of ;0x07 0x82 0x08 0x00 (flags (substring rchallenge 20 24)) ;flags, 4 bytes (challengeData (substring rchallenge 24 32)) ;challengeData, 8 bytes - uDomain-len uDomain-offs - ;; response struct and its fields + ;; Extract domain string from challenge string. + ;;(uDomain-len (md4-unpack-int16 (substring uDomain 0 2))) + (uDomain-offs (md4-unpack-int32 (substring uDomain 4 8))) + ;; Response struct and its fields. lmRespData ;lmRespData, 24 bytes ntRespData ;ntRespData, variable length - domain ;ascii domain string - workstation ;ascii workstation string - ll ln lu ld lw off-lm off-nt off-u off-d off-w) - ;; extract domain string from challenge string - (setq uDomain-len (md4-unpack-int16 (substring uDomain 0 2))) - (setq uDomain-offs (md4-unpack-int32 (substring uDomain 4 8))) - ;; match Mozilla behavior, which is to send an empty domain string - (setq domain "") - ;; match Mozilla behavior, which is to send "WORKSTATION" - (setq workstation "WORKSTATION") + ;; Match Mozilla behavior, which is to send an empty domain string + (domain "") ;ascii domain string + ;; Match Mozilla behavior, which is to send "WORKSTATION". + (workstation "WORKSTATION")) ;ascii workstation string ;; overwrite domain in case user is given in <user>@<domain> format (when (string-match "@" user) (setq domain (substring user (1+ (match-beginning 0)))) @@ -261,13 +258,11 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of ;; so just treat it the same as levels 0 and 1 ;; check if "negotiate NTLM2 key" flag is set in type 2 message (if (not (zerop (logand (aref flags 2) 8))) - (let (randomString - sessionHash) - ;; generate NTLM2 session response data - (setq randomString (ntlm-generate-nonce)) - (setq sessionHash (secure-hash 'md5 + ;; generate NTLM2 session response data + (let* ((randomString (ntlm-generate-nonce)) + (sessionHash (secure-hash 'md5 (concat challengeData randomString) - nil nil t)) + nil nil t))) (setq sessionHash (substring sessionHash 0 8)) (setq lmRespData (concat randomString (make-string 16 0))) (setq ntRespData (ntlm-smb-owf-encrypt @@ -279,16 +274,16 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of (ntlm-smb-owf-encrypt (cadr password-hashes) challengeData)))) ;; get offsets to fields to pack the response struct in a string - (setq ll (length lmRespData)) - (setq ln (length ntRespData)) - (setq lu (length user)) - (setq ld (length domain)) - (setq lw (length workstation)) - (setq off-u 64) ;offset to string 'uUser - (setq off-d (+ off-u (* 2 lu))) ;offset to string 'uDomain - (setq off-w (+ off-d (* 2 ld))) ;offset to string 'uWks - (setq off-lm (+ off-w (* 2 lw))) ;offset to string 'lmResponse - (setq off-nt (+ off-lm ll)) ;offset to string 'ntResponse + (let* ((ll (length lmRespData)) + (ln (length ntRespData)) + (lu (length user)) + (ld (length domain)) + (lw (length workstation)) + (off-u 64) ;offset to string 'uUser + (off-d (+ off-u (* 2 lu))) ;offset to string 'uDomain + (off-w (+ off-d (* 2 ld))) ;offset to string 'uWks + (off-lm (+ off-w (* 2 lw))) ;offset to string 'lmResponse + (off-nt (+ off-lm ll))) ;offset to string 'ntResponse ;; pack the response struct in a string (concat "NTLMSSP\0" ;response ident field, 8 bytes (md4-pack-int32 '(0 . 3)) ;response msgType field, 4 bytes @@ -342,7 +337,7 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of (ntlm-ascii2unicode workstation lw) ;Unicode workstation, 2*lw bytes lmRespData ;lmResponse, 24 bytes ntRespData ;ntResponse, ln bytes - ))) + )))) (defun ntlm-get-password-hashes (password) "Return a pair of SMB hash and NT MD4 hash of the given password PASSWORD." @@ -352,7 +347,10 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of (defun ntlm-ascii2unicode (str len) "Convert an ASCII string into a NT Unicode string, which is little-endian utf16." - (let ((utf (make-string (* 2 len) 0)) (i 0) val) + ;; FIXME: Can't we use encode-coding-string with a `utf-16le' coding system? + (let ((utf (make-string (* 2 len) 0)) + (i 0) + val) (while (and (< i len) (not (zerop (setq val (aref str i))))) (aset utf (* 2 i) val) @@ -381,9 +379,9 @@ string PASSWD. PASSWD is truncated to 14 bytes if longer." "Return the response string of 24 bytes long for the given password string PASSWD based on the DES encryption. PASSWD is of at most 14 bytes long and the challenge string C8 of 8 bytes long." - (let ((len (min (length passwd) 16)) p22) - (setq p22 (concat (substring passwd 0 len) ;fill top 16 bytes with passwd - (make-string (- 22 len) 0))) + (let* ((len (min (length passwd) 16)) + (p22 (concat (substring passwd 0 len) ;Fill top 16 bytes with passwd. + (make-string (- 22 len) 0)))) (ntlm-smb-des-e-p24 p22 c8))) (defun ntlm-smb-des-e-p24 (p22 c8) @@ -405,53 +403,53 @@ string C8." "Return the hash string of length 8 for a string IN of length 8 and a string KEY of length 8. FORW is t or nil." (let ((out (make-string 8 0)) - outb ;string of length 64 (inb (make-string 64 0)) (keyb (make-string 64 0)) (key2 (ntlm-smb-str-to-key key)) - (i 0) aa) + (i 0)) (while (< i 64) - (unless (zerop (logand (aref in (/ i 8)) (lsh 1 (- 7 (% i 8))))) + (unless (zerop (logand (aref in (/ i 8)) (ash 1 (- 7 (% i 8))))) (aset inb i 1)) - (unless (zerop (logand (aref key2 (/ i 8)) (lsh 1 (- 7 (% i 8))))) + (unless (zerop (logand (aref key2 (/ i 8)) (ash 1 (- 7 (% i 8))))) (aset keyb i 1)) (setq i (1+ i))) - (setq outb (ntlm-smb-dohash inb keyb forw)) - (setq i 0) - (while (< i 64) - (unless (zerop (aref outb i)) - (setq aa (aref out (/ i 8))) - (aset out (/ i 8) - (logior aa (lsh 1 (- 7 (% i 8)))))) - (setq i (1+ i))) - out)) + (let ((outb (ntlm-smb-dohash inb keyb forw)) + aa) + (setq i 0) + (while (< i 64) + (unless (zerop (aref outb i)) + (setq aa (aref out (/ i 8))) + (aset out (/ i 8) + (logior aa (ash 1 (- 7 (% i 8)))))) + (setq i (1+ i))) + out))) (defun ntlm-smb-str-to-key (str) "Return a string of length 8 for the given string STR of length 7." (let ((key (make-string 8 0)) (i 7)) - (aset key 0 (lsh (aref str 0) -1)) + (aset key 0 (ash (aref str 0) -1)) (aset key 1 (logior - (lsh (logand (aref str 0) 1) 6) - (lsh (aref str 1) -2))) + (ash (logand (aref str 0) 1) 6) + (ash (aref str 1) -2))) (aset key 2 (logior - (lsh (logand (aref str 1) 3) 5) - (lsh (aref str 2) -3))) + (ash (logand (aref str 1) 3) 5) + (ash (aref str 2) -3))) (aset key 3 (logior - (lsh (logand (aref str 2) 7) 4) - (lsh (aref str 3) -4))) + (ash (logand (aref str 2) 7) 4) + (ash (aref str 3) -4))) (aset key 4 (logior - (lsh (logand (aref str 3) 15) 3) - (lsh (aref str 4) -5))) + (ash (logand (aref str 3) 15) 3) + (ash (aref str 4) -5))) (aset key 5 (logior - (lsh (logand (aref str 4) 31) 2) - (lsh (aref str 5) -6))) + (ash (logand (aref str 4) 31) 2) + (ash (aref str 5) -6))) (aset key 6 (logior - (lsh (logand (aref str 5) 63) 1) - (lsh (aref str 6) -7))) + (ash (logand (aref str 5) 63) 1) + (ash (aref str 6) -7))) (aset key 7 (logand (aref str 6) 127)) (while (>= i 0) - (aset key i (lsh (aref key i) 1)) + (aset key i (ash (aref key i) 1)) (setq i (1- i))) key)) @@ -571,27 +569,22 @@ length of STR is LEN." "Return the hash value for a string IN and a string KEY. Length of IN and KEY are 64. FORW non-nil means forward, nil means backward." - (let (pk1 ;string of length 56 - c ;string of length 28 - d ;string of length 28 - cd ;string of length 56 - (ki (make-vector 16 0)) ;vector of string of length 48 - pd1 ;string of length 64 - l ;string of length 32 - r ;string of length 32 - rl ;string of length 64 - (i 0) (j 0) (k 0)) - (setq pk1 (ntlm-string-permute key ntlm-smb-perm1 56)) - (setq c (substring pk1 0 28)) - (setq d (substring pk1 28 56)) - - (setq i 0) - (while (< i 16) + (let* ((pk1 (ntlm-string-permute key ntlm-smb-perm1 56)) ;string of length 56 + (c (substring pk1 0 28)) ;string of length 28 + (d (substring pk1 28 56)) ;string of length 28 + cd ;string of length 56 + (ki (make-vector 16 0)) ;vector of string of length 48 + pd1 ;string of length 64 + l ;string of length 32 + r ;string of length 32 + rl ;string of length 64 + (i 0) (j 0) (k 0)) + + (dotimes (i 16) (setq c (ntlm-string-lshift c (aref ntlm-smb-sc i) 28)) (setq d (ntlm-string-lshift d (aref ntlm-smb-sc i) 28)) (setq cd (concat (substring c 0 28) (substring d 0 28))) - (aset ki i (ntlm-string-permute cd ntlm-smb-perm2 48)) - (setq i (1+ i))) + (aset ki i (ntlm-string-permute cd ntlm-smb-perm2 48))) (setq pd1 (ntlm-string-permute in ntlm-smb-perm3 64)) @@ -619,16 +612,16 @@ backward." (setq j 0) (while (< j 8) (setq bj (aref b j)) - (setq m (logior (lsh (aref bj 0) 1) (aref bj 5))) - (setq n (logior (lsh (aref bj 1) 3) - (lsh (aref bj 2) 2) - (lsh (aref bj 3) 1) + (setq m (logior (ash (aref bj 0) 1) (aref bj 5))) + (setq n (logior (ash (aref bj 1) 3) + (ash (aref bj 2) 2) + (ash (aref bj 3) 1) (aref bj 4))) (setq k 0) (setq sbox-jmn (aref (aref (aref ntlm-smb-sbox j) m) n)) (while (< k 4) (aset bj k - (if (zerop (logand sbox-jmn (lsh 1 (- 3 k)))) + (if (zerop (logand sbox-jmn (ash 1 (- 3 k)))) 0 1)) (setq k (1+ k))) (setq j (1+ j))) @@ -650,16 +643,12 @@ backward." (defun ntlm-md4hash (passwd) "Return the 16 bytes MD4 hash of a string PASSWD after converting it into a Unicode string. PASSWD is truncated to 128 bytes if longer." - (let (len wpwd) - ;; Password cannot be longer than 128 characters - (setq len (length passwd)) - (if (> len 128) - (setq len 128)) - ;; Password must be converted to NT Unicode - (setq wpwd (ntlm-ascii2unicode passwd len)) - ;; Calculate length in bytes - (setq len (* len 2)) - (md4 wpwd len))) + (let* ((len (min (length passwd) 128)) ;Pwd can't be > than 128 characters. + ;; Password must be converted to NT Unicode. + (wpwd (ntlm-ascii2unicode passwd len))) + (md4 wpwd + ;; Calculate length in bytes. + (* len 2)))) (provide 'ntlm) diff --git a/lisp/net/pop3.el b/lisp/net/pop3.el index f73607081c5..ddb4139610e 100644 --- a/lisp/net/pop3.el +++ b/lisp/net/pop3.el @@ -1,4 +1,4 @@ -;;; pop3.el --- Post Office Protocol (RFC 1460) interface +;;; pop3.el --- Post Office Protocol (RFC 1460) interface -*- lexical-binding:t -*- ;; Copyright (C) 1996-2019 Free Software Foundation, Inc. @@ -32,7 +32,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'mail-utils) (defvar parse-time-months) @@ -165,12 +165,7 @@ Used for APOP authentication.") "How long pop3 should wait between checking for the end of output. Shorter values mean quicker response, but are more CPU intensive.") (defun pop3-accept-process-output (process) - (accept-process-output - process - (truncate pop3-read-timeout) - (truncate (* (- pop3-read-timeout - (truncate pop3-read-timeout)) - 1000)))))) + (accept-process-output process pop3-read-timeout)))) (defvar pop3-uidl) ;; List of UIDLs of existing messages at present in the server: @@ -185,8 +180,8 @@ Shorter values mean quicker response, but are more CPU intensive.") ;; ("SERVER_B" ("USER_B1" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...) ;; ("USER_B2" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...) ;; ...)) -;; Where TIMESTAMP is the most significant two digits of an Emacs time, -;; i.e. the return value of `current-time'. +;; Where TIMESTAMP is an Emacs time value (HI LO) representing the +;; number of seconds (+ (ash HI 16) LO). ;;;###autoload (defun pop3-movemail (file) @@ -237,8 +232,8 @@ Use streaming commands." (setq start-point (pop3-wait-for-messages process pop3-stream-length total-size start-point)) - (incf waited-for pop3-stream-length)) - (incf i)) + (cl-incf waited-for pop3-stream-length)) + (cl-incf i)) (pop3-wait-for-messages process (- count waited-for) total-size start-point))) @@ -249,7 +244,7 @@ Use streaming commands." (or (not total-size) (re-search-forward "^\\.\r?\n" nil t))) (re-search-forward "^-ERR " nil t)) - (decf count) + (cl-decf count) (setq start-point (point))) (unless (memq (process-status process) '(open run)) (error "pop3 process died")) @@ -269,7 +264,6 @@ Use streaming commands." (defun pop3-write-to-file (file messages) (let ((pop-buffer (current-buffer)) - (start (point-min)) beg end temp-buffer) (with-temp-buffer @@ -280,7 +274,6 @@ Use streaming commands." (forward-line 1) (setq beg (point)) (when (re-search-forward "^\\.\r?\n" nil t) - (setq start (point)) (forward-line -1) (setq end (point))) (with-current-buffer temp-buffer @@ -369,7 +362,7 @@ Use streaming commands." (while (> i 0) (unless (member (nth (1- i) pop3-uidl) saved) (push i messages)) - (decf i))) + (cl-decf i))) (when messages (setq list (pop3-list process) size 0) @@ -387,7 +380,9 @@ Use streaming commands." (defun pop3-uidl-dele (process) "Delete messages according to `pop3-leave-mail-on-server'. Return non-nil if it is necessary to update the local UIDL file." - (let* ((ctime (current-time)) + (let* ((ctime (encode-time nil 'list)) + (age-limit (and (numberp pop3-leave-mail-on-server) + (* 86400 pop3-leave-mail-on-server))) (srvr (assoc pop3-mailhost pop3-uidl-saved)) (saved (assoc pop3-maildrop (cdr srvr))) i uidl mod new tstamp dele) @@ -399,22 +394,18 @@ Return non-nil if it is necessary to update the local UIDL file." (unless (member (setq uidl (nth i pop3-uidl)) (cdr saved)) (push ctime new) (push uidl new)) - (decf i))) + (cl-decf i))) (pop3-uidl (setq new (mapcan (lambda (elt) (list elt ctime)) pop3-uidl)))) (when new (setq mod t)) ;; List expirable messages and delete them from the data to be saved. - (setq ctime (when (numberp pop3-leave-mail-on-server) - (/ (+ (* (car ctime) 65536.0) (cadr ctime)) 86400)) - i (1- (length saved))) + (setq i (1- (length saved))) (while (> i 0) (if (member (setq uidl (nth (1- i) saved)) pop3-uidl) (progn (setq tstamp (nth i saved)) - (if (and ctime - (> (- ctime (/ (+ (* (car tstamp) 65536.0) (cadr tstamp)) - 86400)) - pop3-leave-mail-on-server)) + (if (and age-limit + (time-less-p age-limit (time-subtract ctime tstamp))) ;; Mails to delete. (progn (setq mod t) @@ -424,7 +415,7 @@ Return non-nil if it is necessary to update the local UIDL file." (push uidl new))) ;; Mails having been deleted in the server. (setq mod t)) - (decf i 2)) + (cl-decf i 2)) (cond (saved (setcdr saved new)) (srvr @@ -440,7 +431,7 @@ Return non-nil if it is necessary to update the local UIDL file." (while (> i 0) (when (member (nth (1- i) pop3-uidl) dele) (push i uidl)) - (decf i)) + (cl-decf i)) (when uidl (pop3-send-streaming-command process "DELE" uidl nil))) mod)) @@ -594,7 +585,7 @@ Return the response string if optional second argument is non-nil." (goto-char pop3-read-point) (if (looking-at "-ERR") (error "%s" (buffer-substring (point) (- match-end 2))) - (if (not (looking-at "+OK")) + (if (not (looking-at "\\+OK")) (progn (setq pop3-read-point match-end) nil) (setq pop3-read-point match-end) (if return @@ -620,16 +611,14 @@ Return the response string if optional second argument is non-nil." If NOW, use that time instead." (require 'parse-time) (let* ((now (or now (current-time))) - (zone (nth 8 (decode-time now))) - (sign "+")) + (zone (decoded-time-zone (decode-time now)))) (when (< zone 0) - (setq sign "-") (setq zone (- zone))) (concat (format-time-string "%d" now) ;; The month name of the %b spec is locale-specific. Pfff. (format " %s " - (capitalize (car (rassoc (nth 4 (decode-time now)) + (capitalize (car (rassoc (decoded-time-month (decode-time now)) parse-time-months)))) (format-time-string "%Y %H:%M:%S %z" now)))) @@ -695,14 +684,14 @@ If NOW, use that time instead." "Send USER information to POP3 server." (pop3-send-command process (format "USER %s" user)) (let ((response (pop3-read-response process t))) - (if (not (and response (string-match "+OK" response))) + (if (not (and response (string-match "\\+OK" response))) (error "USER %s not valid" user)))) (defun pop3-pass (process) "Send authentication information to the server." (pop3-send-command process (format "PASS %s" pop3-password)) (let ((response (pop3-read-response process t))) - (if (not (and response (string-match "+OK" response))) + (if (not (and response (string-match "\\+OK" response))) (pop3-quit process)))) (defun pop3-apop (process user) @@ -715,7 +704,7 @@ If NOW, use that time instead." (let ((hash (md5 (concat pop3-timestamp pass) nil nil 'binary))) (pop3-send-command process (format "APOP %s %s" user hash)) (let ((response (pop3-read-response process t))) - (if (not (and response (string-match "+OK" response))) + (if (not (and response (string-match "\\+OK" response))) (pop3-quit process))))) )) @@ -785,7 +774,7 @@ Otherwise, return the size of the message-id MSG" (pop3-send-command process (format "DELE %s" msg)) (pop3-read-response process)) -(defun pop3-noop (process msg) +(defun pop3-noop (process _msg) "No-operation." (pop3-send-command process "NOOP") (pop3-read-response process)) diff --git a/lisp/net/puny.el b/lisp/net/puny.el index bb1ef290f64..23c7af80619 100644 --- a/lisp/net/puny.el +++ b/lisp/net/puny.el @@ -27,6 +27,7 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) (require 'seq) (defun puny-encode-domain (domain) diff --git a/lisp/net/quickurl.el b/lisp/net/quickurl.el index db1ff0d3ae9..91e980e4f15 100644 --- a/lisp/net/quickurl.el +++ b/lisp/net/quickurl.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. ;; Author: Dave Pearson <davep@davep.org> -;; Maintainer: Dave Pearson <davep@davep.org> ;; Created: 1999-05-28 ;; Keywords: hypermedia @@ -155,7 +154,7 @@ could be used here." (defconst quickurl-reread-hook-postfix " ;; Local Variables: -;; eval: (progn (require 'quickurl) (add-hook 'local-write-file-hooks (lambda () (quickurl-read) nil))) +;; eval: (progn (require 'quickurl) (add-hook 'write-file-functions (lambda () (quickurl-read) nil) nil t)) ;; End: " "Example `quickurl-postfix' text that adds a local variable to the @@ -504,15 +503,15 @@ TYPE dictates what will be inserted, options are: (with-current-buffer quickurl-list-last-buffer (insert (pcase type - (`url (funcall quickurl-format-function url)) - (`naked-url (quickurl-url-url url)) - (`with-lookup (format "%s <URL:%s>" + ('url (funcall quickurl-format-function url)) + ('naked-url (quickurl-url-url url)) + ('with-lookup (format "%s <URL:%s>" (quickurl-url-keyword url) (quickurl-url-url url))) - (`with-desc (format "%S <URL:%s>" + ('with-desc (format "%S <URL:%s>" (quickurl-url-description url) (quickurl-url-url url))) - (`lookup (quickurl-url-keyword url))))) + ('lookup (quickurl-url-keyword url))))) (error "No URL details on that line")) url)) diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index de524d9ef10..5722582ab6c 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -39,13 +39,14 @@ ;; Open a new irc connection with: ;; M-x irc RET -;;; Todo: - ;;; Code: (require 'cl-lib) (require 'ring) (require 'time-date) +(eval-when-compile (require 'subr-x)) + +(defconst rcirc-id-string (concat "rcirc on GNU Emacs " emacs-version)) (defgroup rcirc nil "Simple IRC client." @@ -119,35 +120,39 @@ display purposes. If absent, the real server name will be displayed instead." (:channels (repeat string)) (:encryption (choice (const tls) (const plain))) - (:server-alias string)))) - :group 'rcirc) + (:server-alias string))))) (defcustom rcirc-default-port 6667 "The default port to connect to." - :type 'integer - :group 'rcirc) + :type 'integer) (defcustom rcirc-default-nick (user-login-name) "Your nick." - :type 'string - :group 'rcirc) + :type 'string) (defcustom rcirc-default-user-name "user" "Your user name sent to the server when connecting." :version "24.1" ; changed default - :type 'string - :group 'rcirc) + :type 'string) (defcustom rcirc-default-full-name "unknown" "The full name sent to the server when connecting." :version "24.1" ; changed default - :type 'string - :group 'rcirc) + :type 'string) + +(defcustom rcirc-default-part-reason rcirc-id-string + "The default reason to send when parting from a channel. +Used when no reason is explicitly given." + :type 'string) + +(defcustom rcirc-default-quit-reason rcirc-id-string + "The default reason to send when quitting a server. +Used when no reason is explicitly given." + :type 'string) (defcustom rcirc-fill-flag t "Non-nil means line-wrap messages printed in channel buffers." - :type 'boolean - :group 'rcirc) + :type 'boolean) (defcustom rcirc-fill-column nil "Column beyond which automatic line-wrapping should happen. @@ -157,16 +162,21 @@ call it to compute the number of columns." :risky t ; can get funcalled :type '(choice (const :tag "Value of `fill-column'" nil) (integer :tag "Number of columns") - (function :tag "Function returning the number of columns")) - :group 'rcirc) + (function :tag "Function returning the number of columns"))) (defcustom rcirc-fill-prefix nil "Text to insert before filled lines. If nil, calculate the prefix dynamically to line up text underneath each nick." :type '(choice (const :tag "Dynamic" nil) - (string :tag "Prefix text")) - :group 'rcirc) + (string :tag "Prefix text"))) + +(defcustom rcirc-url-max-length nil + "Maximum number of characters in displayed URLs. +If nil, no maximum is applied." + :version "27.1" + :type '(choice (const :tag "No maximum" nil) + (integer :tag "Number of characters"))) (defvar rcirc-ignore-buffer-activity-flag nil "If non-nil, ignore activity in this buffer.") @@ -179,16 +189,12 @@ underneath each nick." (defcustom rcirc-omit-responses '("JOIN" "PART" "QUIT" "NICK") "Responses which will be hidden when `rcirc-omit-mode' is enabled." - :type '(repeat string) - :group 'rcirc) + :type '(repeat string)) (defvar rcirc-prompt-start-marker nil) (define-minor-mode rcirc-omit-mode "Toggle the hiding of \"uninteresting\" lines. -With a prefix argument ARG, enable Rcirc-Omit mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Uninteresting lines are those whose responses are listed in `rcirc-omit-responses'." @@ -206,32 +212,27 @@ Uninteresting lines are those whose responses are listed in (defcustom rcirc-time-format "%H:%M " "Describes how timestamps are printed. Used as the first arg to `format-time-string'." - :type 'string - :group 'rcirc) + :type 'string) (defcustom rcirc-input-ring-size 1024 "Size of input history ring." - :type 'integer - :group 'rcirc) + :type 'integer) (defcustom rcirc-read-only-flag t "Non-nil means make text in IRC buffers read-only." - :type 'boolean - :group 'rcirc) + :type 'boolean) (defcustom rcirc-buffer-maximum-lines nil "The maximum size in lines for rcirc buffers. Channel buffers are truncated from the top to be no greater than this number. If zero or nil, no truncating is done." :type '(choice (const :tag "No truncation" nil) - (integer :tag "Number of lines")) - :group 'rcirc) + (integer :tag "Number of lines"))) (defcustom rcirc-scroll-show-maximum-output t "If non-nil, scroll buffer to keep the point at the bottom of the window." - :type 'boolean - :group 'rcirc) + :type 'boolean) (defcustom rcirc-authinfo nil "List of authentication passwords. @@ -270,21 +271,18 @@ Examples: (list :tag "QuakeNet" (const quakenet) (string :tag "Account") - (string :tag "Password")))) - :group 'rcirc) + (string :tag "Password"))))) (defcustom rcirc-auto-authenticate-flag t "Non-nil means automatically send authentication string to server. See also `rcirc-authinfo'." - :type 'boolean - :group 'rcirc) + :type 'boolean) (defcustom rcirc-authenticate-before-join t "Non-nil means authenticate to services before joining channels. Currently only works with NickServ on some networks." :version "24.1" - :type 'boolean - :group 'rcirc) + :type 'boolean) (defcustom rcirc-prompt "> " "Prompt string to use in IRC buffers. @@ -298,19 +296,16 @@ Setting this alone will not affect the prompt; use either M-x customize or also call `rcirc-update-prompt'." :type 'string :set 'rcirc-set-changed - :initialize 'custom-initialize-default - :group 'rcirc) + :initialize 'custom-initialize-default) (defcustom rcirc-keywords nil "List of keywords to highlight in message text." - :type '(repeat string) - :group 'rcirc) + :type '(repeat string)) (defcustom rcirc-ignore-list () "List of ignored nicks. Use /ignore to list them, use /ignore NICK to add or remove a nick." - :type '(repeat string) - :group 'rcirc) + :type '(repeat string)) (defvar rcirc-ignore-list-automatic () "List of ignored nicks added to `rcirc-ignore-list' because of renaming. @@ -321,42 +316,36 @@ parts.") (defcustom rcirc-bright-nicks nil "List of nicks to be emphasized. See `rcirc-bright-nick' face." - :type '(repeat string) - :group 'rcirc) + :type '(repeat string)) (defcustom rcirc-dim-nicks nil "List of nicks to be deemphasized. See `rcirc-dim-nick' face." - :type '(repeat string) - :group 'rcirc) + :type '(repeat string)) (define-obsolete-variable-alias 'rcirc-print-hooks 'rcirc-print-functions "24.3") (defcustom rcirc-print-functions nil "Hook run after text is printed. Called with 5 arguments, PROCESS, SENDER, RESPONSE, TARGET and TEXT." - :type 'hook - :group 'rcirc) + :type 'hook) (defvar rcirc-authenticated-hook nil "Hook run after successfully authenticated.") (defcustom rcirc-always-use-server-buffer-flag nil "Non-nil means messages without a channel target will go to the server buffer." - :type 'boolean - :group 'rcirc) + :type 'boolean) (defcustom rcirc-decode-coding-system 'utf-8 "Coding system used to decode incoming irc messages. Set to `undecided' if you want the encoding of the incoming messages autodetected." - :type 'coding-system - :group 'rcirc) + :type 'coding-system) (defcustom rcirc-encode-coding-system 'utf-8 "Coding system used to encode outgoing irc messages." - :type 'coding-system - :group 'rcirc) + :type 'coding-system) (defcustom rcirc-coding-system-alist nil "Alist to decide a coding system to use for a channel I/O operation. @@ -375,13 +364,11 @@ and the cdr part is used for encoding." (string :tag "Server Regexp"))) :value-type (choice coding-system (cons (coding-system :tag "Decode") - (coding-system :tag "Encode")))) - :group 'rcirc) + (coding-system :tag "Encode"))))) (defcustom rcirc-multiline-major-mode 'fundamental-mode "Major-mode function to use in multiline edit buffers." - :type 'function - :group 'rcirc) + :type 'function) (defcustom rcirc-nick-completion-format "%s: " "Format string to use in nick completions. @@ -390,16 +377,14 @@ The format string is only used when completing at the beginning of a line. The string is passed as the first argument to `format' with the nickname as the second argument." :version "24.1" - :type 'string - :group 'rcirc) + :type 'string) (defcustom rcirc-kill-channel-buffers nil "When non-nil, kill channel buffers when the server buffer is killed. Only the channel buffers associated with the server in question will be killed." :version "24.3" - :type 'boolean - :group 'rcirc) + :type 'boolean) (defvar rcirc-nick nil) @@ -441,7 +426,6 @@ will be killed." (defvar rcirc-timeout-seconds 600 "Kill connection after this many seconds if there is no activity.") -(defconst rcirc-id-string (concat "rcirc on GNU Emacs " emacs-version)) (defvar rcirc-startup-channels nil) @@ -637,13 +621,12 @@ If ARG is non-nil, instead prompt for connection parameters." (defun rcirc-prompt-for-encryption (server-plist) "Prompt the user for the encryption method to use. SERVER-PLIST is the property list for the server." - (let ((msg "Encryption (default %s): ") - (choices '("plain" "tls")) + (let ((choices '("plain" "tls")) (default (or (plist-get server-plist :encryption) - 'plain))) + "plain"))) (intern - (completing-read (format msg default) - choices nil t nil nil (symbol-name default))))) + (completing-read (format "Encryption (default %s): " default) + choices nil t nil nil default)))) (defun rcirc-keepalive () "Send keep alive pings to active rcirc processes. @@ -665,24 +648,33 @@ last ping." (defun rcirc-handler-ctcp-KEEPALIVE (process _target _sender message) (with-rcirc-process-buffer process - (setq header-line-format (format "%f" (- (float-time) - (string-to-number message)))))) + (setq header-line-format + (format "%f" (float-time + (time-since (string-to-number message))))))) (defvar rcirc-debug-buffer "*rcirc debug*") (defvar rcirc-debug-flag nil "If non-nil, write information to `rcirc-debug-buffer'.") (defun rcirc-debug (process text) "Add an entry to the debug log including PROCESS and TEXT. -Debug text is written to `rcirc-debug-buffer' if `rcirc-debug-flag' -is non-nil." +Debug text is appended to `rcirc-debug-buffer' if `rcirc-debug-flag' +is non-nil. + +For convenience, the read-only state of the debug buffer is ignored. +When the point is at the end of the visible portion of the buffer, it +is moved to after the text inserted. Otherwise the point is not moved." (when rcirc-debug-flag (with-current-buffer (get-buffer-create rcirc-debug-buffer) - (goto-char (point-max)) - (insert (concat - "[" - (format-time-string "%Y-%m-%dT%T ") (process-name process) - "] " - text))))) + (let ((old (point-marker))) + (set-marker-insertion-type old t) + (goto-char (point-max)) + (let ((inhibit-read-only t)) + (terpri (current-buffer) t) + (insert "[" + (format-time-string "%FT%T ") (process-name process) + "] " + text)) + (goto-char old))))) (define-obsolete-variable-alias 'rcirc-sentinel-hooks 'rcirc-sentinel-functions "24.3") @@ -694,8 +686,7 @@ Functions are called with PROCESS and SENTINEL arguments.") "The minimum interval in seconds between reconnect attempts. When 0, do not auto-reconnect." :version "25.1" - :type 'integer - :group 'rcirc) + :type 'integer) (defvar rcirc-last-connect-time nil "The last time the buffer was connected.") @@ -718,8 +709,8 @@ When 0, do not auto-reconnect." (< 0 rcirc-reconnect-delay)) (let ((now (current-time))) (when (or (null rcirc-last-connect-time) - (< rcirc-reconnect-delay - (float-time (time-subtract now rcirc-last-connect-time)))) + (time-less-p rcirc-reconnect-delay + (time-subtract now rcirc-last-connect-time))) (setq rcirc-last-connect-time now) (rcirc-cmd-reconnect nil)))) (run-hook-with-args 'rcirc-sentinel-functions process sentinel)))) @@ -784,22 +775,33 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.") (rcirc-process-server-response-1 process text))) (defun rcirc-process-server-response-1 (process text) - (if (string-match "^\\(:\\([^ ]+\\) \\)?\\([^ ]+\\) \\(.+\\)$" text) + ;; See https://tools.ietf.org/html/rfc2812#section-2.3.1. We're a + ;; bit more accepting than the RFC: We allow any non-space + ;; characters in the command name, multiple spaces between + ;; arguments, and allow the last argument to omit the leading ":", + ;; even if there are less than 15 arguments. + (if (string-match "^\\(:\\([^ ]+\\) \\)?\\([^ ]+\\)" text) (let* ((user (match-string 2 text)) (sender (rcirc-user-nick user)) (cmd (match-string 3 text)) - (args (match-string 4 text)) + (cmd-end (match-end 3)) + (args nil) (handler (intern-soft (concat "rcirc-handler-" cmd)))) - (string-match "^\\([^:]*\\):?\\(.+\\)?$" args) - (let* ((args1 (match-string 1 args)) - (args2 (match-string 2 args)) - (args (delq nil (append (split-string args1 " " t) - (list args2))))) + (cl-loop with i = cmd-end + repeat 14 + while (eql i (string-match " +\\([^: ][^ ]*\\)" text i)) + do (progn (push (match-string 1 text) args) + (setq i (match-end 0))) + finally + (progn (if (eql i (string-match " +:?" text i)) + (push (substring text (match-end 0)) args) + (cl-assert (= i (length text)))) + (cl-callf nreverse args))) (if (not (fboundp handler)) (rcirc-handler-generic process cmd sender args text) (funcall handler process sender args text)) (run-hook-with-args 'rcirc-receive-message-functions - process cmd sender args text))) + process cmd sender args text)) (message "UNHANDLED: %s" text))) (defvar rcirc-responses-no-activity '("305" "306") @@ -1162,14 +1164,12 @@ If ALL is non-nil, update prompts in all IRC buffers." (defcustom rcirc-log-directory "~/.emacs.d/rcirc-log" "Directory to keep IRC logfiles." - :type 'directory - :group 'rcirc) + :type 'directory) (defcustom rcirc-log-flag nil "Non-nil means log IRC activity to disk. Logfiles are kept in `rcirc-log-directory'." - :type 'boolean - :group 'rcirc) + :type 'boolean) (defun rcirc-kill-buffer-hook () "Part the channel when killing an rcirc buffer. @@ -1182,6 +1182,8 @@ with it." rcirc-log-directory) (rcirc-log-write)) (rcirc-clean-up-buffer "Killed buffer") + (when-let ((process (get-buffer-process (current-buffer)))) + (delete-process process)) (when (and rcirc-buffer-alist ;; it's a server buffer rcirc-kill-channel-buffers) (dolist (channel rcirc-buffer-alist) @@ -1353,15 +1355,11 @@ Create the buffer if it doesn't exist." "Keymap for multiline mode in rcirc.") (define-minor-mode rcirc-multiline-minor-mode - "Minor mode for editing multiple lines in rcirc. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "Minor mode for editing multiple lines in rcirc." :init-value nil :lighter " rcirc-mline" :keymap rcirc-multiline-minor-mode-map :global nil - :group 'rcirc (setq fill-column rcirc-max-message-length)) (defun rcirc-multiline-minor-submit () @@ -1423,8 +1421,7 @@ the of the following escape sequences replaced by the described values: %% A literal `%' character" :type '(alist :key-type (choice (string :tag "Type") (const :tag "Default" t)) - :value-type string) - :group 'rcirc) + :value-type string)) (defun rcirc-format-response-string (process sender response target text) "Return a nicely-formatted response string, incorporating TEXT @@ -1506,12 +1503,10 @@ is found by looking up RESPONSE in `rcirc-response-formats'." (defcustom rcirc-omit-threshold 100 "Number of lines since last activity from a nick before `rcirc-omit-responses' are omitted." - :type 'integer - :group 'rcirc) + :type 'integer) (defcustom rcirc-log-process-buffers nil "Non-nil if rcirc process buffers should be logged to disk." - :group 'rcirc :type 'boolean :version "24.1") @@ -1704,7 +1699,6 @@ is put into `rcirc-log-directory'. The filename is then cleaned using `convert-standard-filename' to guarantee valid filenames for the current OS." - :group 'rcirc :type 'function) (defun rcirc-log (process sender response target text) @@ -1867,15 +1861,11 @@ This function does not alter the INPUT string." ;;;###autoload (define-minor-mode rcirc-track-minor-mode - "Global minor mode for tracking activity in rcirc buffers. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "Global minor mode for tracking activity in rcirc buffers." :init-value nil :lighter "" :keymap rcirc-track-minor-mode-map :global t - :group 'rcirc (or global-mode-string (setq global-mode-string '(""))) ;; toggle the mode-line channel indicator (if rcirc-track-minor-mode @@ -2065,9 +2055,7 @@ activity. Only run if the buffer is not visible and (defvar rcirc-visible-buffers nil) (defun rcirc-window-configuration-change () (unless (minibuffer-window-active-p (minibuffer-window)) - ;; delay this until command has finished to make sure window is - ;; actually visible before clearing activity - (add-hook 'post-command-hook 'rcirc-window-configuration-change-1))) + (rcirc-window-configuration-change-1))) (defun rcirc-window-configuration-change-1 () ;; clear activity and overlay arrows @@ -2091,9 +2079,7 @@ activity. Only run if the buffer is not visible and rcirc-activity))) ;; update the mode-line string (unless (equal old-activity rcirc-activity) - (rcirc-update-activity-string))) - - (remove-hook 'post-command-hook 'rcirc-window-configuration-change-1)) + (rcirc-update-activity-string)))) ;;; buffer name abbreviation @@ -2223,12 +2209,21 @@ CHANNELS is a comma- or space-separated string of channel names." (read-string "Channel: ")))) (rcirc-send-string process (concat "INVITE " nick-channel))) -;; TODO: /part #channel reason, or consider removing #channel altogether (defun-rcirc-command part (channel) - "Part CHANNEL." + "Part CHANNEL. +CHANNEL should be a string of the form \"#CHANNEL-NAME REASON\". +If omitted, CHANNEL-NAME defaults to TARGET, and REASON defaults +to `rcirc-default-part-reason'." (interactive "sPart channel: ") - (let ((channel (if (> (length channel) 0) channel target))) - (rcirc-send-string process (concat "PART " channel " :" rcirc-id-string)))) + (let ((channel (if (> (length channel) 0) channel target)) + (msg rcirc-default-part-reason)) + (when (string-match "\\`\\([&#+!]\\S-+\\)?\\s-*\\(.+\\)?\\'" channel) + (when (match-beginning 2) + (setq msg (match-string 2 channel))) + (setq channel (if (match-beginning 1) + (match-string 1 channel) + target))) + (rcirc-send-string process (concat "PART " channel " :" msg)))) (defun-rcirc-command quit (reason) "Send a quit message to server with REASON." @@ -2236,7 +2231,7 @@ CHANNELS is a comma- or space-separated string of channel names." (rcirc-send-string process (concat "QUIT :" (if (not (zerop (length reason))) reason - rcirc-id-string)))) + rcirc-default-quit-reason)))) (defun-rcirc-command reconnect (_) "Reconnect to current server." @@ -2494,24 +2489,26 @@ If ARG is given, opens the URL in a new browser window." (rcirc-record-activity (current-buffer) 'nick))))) (defun rcirc-markup-urls (_sender _response) - (while (and rcirc-url-regexp ;; nil means disable URL catching + (while (and rcirc-url-regexp ; nil means disable URL catching. (re-search-forward rcirc-url-regexp nil t)) (let* ((start (match-beginning 0)) - (end (match-end 0)) - (url (match-string-no-properties 0)) - (link-text (buffer-substring-no-properties start end))) + (url (buffer-substring-no-properties start (point)))) + (when rcirc-url-max-length + ;; Replace match with truncated URL. + (delete-region start (point)) + (insert (url-truncate-url-for-viewing url rcirc-url-max-length))) ;; Add a button for the URL. Note that we use `make-text-button', ;; rather than `make-button', as text-buttons are much faster in ;; large buffers. - (make-text-button start end + (make-text-button start (point) 'face 'rcirc-url 'follow-link t 'rcirc-url url 'action (lambda (button) (browse-url (button-get button 'rcirc-url)))) - ;; record the url if it is not already the latest stored url - (when (not (string= link-text (caar rcirc-urls))) - (push (cons link-text start) rcirc-urls))))) + ;; Record the URL if it is not already the latest stored URL. + (unless (string= url (caar rcirc-urls)) + (push (cons url start) rcirc-urls))))) (defun rcirc-markup-keywords (sender response) (when (and (string= response "PRIVMSG") @@ -2561,16 +2558,15 @@ If ARG is given, opens the URL in a new browser window." (setq rcirc-server-name sender) (setq rcirc-nick (car args)) (rcirc-update-prompt) - (if rcirc-auto-authenticate-flag - (if (and rcirc-authenticate-before-join - ;; We have to ensure that there's an authentication - ;; entry for that server. Else, - ;; rcirc-authenticated-hook won't be triggered, and - ;; autojoin won't happen at all. - (let (auth-required) - (dolist (s rcirc-authinfo auth-required) - (when (string-match (car s) rcirc-server-name) - (setq auth-required t))))) + (if (and rcirc-auto-authenticate-flag + ;; We have to ensure that there's an authentication + ;; entry for that server. Otherwise, + ;; there's no point in calling authenticate. + (let (auth-required) + (dolist (s rcirc-authinfo auth-required) + (when (string-match (car s) rcirc-server) + (setq auth-required t))))) + (if rcirc-authenticate-before-join (progn (add-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t t) (rcirc-authenticate)) @@ -2796,11 +2792,8 @@ the only argument." "RPL_WHOISIDLE" (let* ((nick (nth 1 args)) (idle-secs (string-to-number (nth 2 args))) - (idle-string - (if (< idle-secs most-positive-fixnum) - (format-seconds "%yy %dd %hh %mm %z%ss" idle-secs) - "a very long time")) - (signon-time (seconds-to-time (string-to-number (nth 3 args)))) + (idle-string (format-seconds "%yy %dd %hh %mm %z%ss" idle-secs)) + (signon-time (string-to-number (nth 3 args))) (signon-string (format-time-string "%c" signon-time)) (message (format "%s idle for %s, signed on %s" nick idle-string signon-string))) @@ -2821,8 +2814,7 @@ Not in rfc1459.txt" (with-current-buffer buffer (let ((setter (nth 2 args)) (time (current-time-string - (seconds-to-time - (string-to-number (cl-cadddr args)))))) + (string-to-number (cl-cadddr args))))) (rcirc-print process sender "TOPIC" (cadr args) (format "%s (%s on %s)" rcirc-topic setter time)))))) @@ -2969,8 +2961,7 @@ Passwords are stored in `rcirc-authinfo' (which see)." (((class color) (min-colors 16) (background dark)) :foreground "LightSkyBlue") (((class color) (min-colors 8)) :foreground "blue" :weight bold) (t :inverse-video t :weight bold)) - "Rcirc face for my messages." - :group 'rcirc-faces) + "Rcirc face for my messages.") (defface rcirc-other-nick ; font-lock-variable-name-face '((((class grayscale) (background light)) @@ -2983,8 +2974,7 @@ Passwords are stored in `rcirc-authinfo' (which see)." (((class color) (min-colors 16) (background dark)) :foreground "LightGoldenrod") (((class color) (min-colors 8)) :foreground "yellow" :weight light) (t :weight bold :slant italic)) - "Rcirc face for other users' messages." - :group 'rcirc-faces) + "Rcirc face for other users' messages.") (defface rcirc-bright-nick '((((class grayscale) (background light)) @@ -2997,13 +2987,11 @@ Passwords are stored in `rcirc-authinfo' (which see)." (((class color) (min-colors 16) (background dark)) :foreground "Aquamarine") (((class color) (min-colors 8)) :foreground "magenta") (t :weight bold :underline t)) - "Rcirc face for nicks matched by `rcirc-bright-nicks'." - :group 'rcirc-faces) + "Rcirc face for nicks matched by `rcirc-bright-nicks'.") (defface rcirc-dim-nick '((t :inherit default)) - "Rcirc face for nicks in `rcirc-dim-nicks'." - :group 'rcirc-faces) + "Rcirc face for nicks in `rcirc-dim-nicks'.") (defface rcirc-server ; font-lock-comment-face '((((class grayscale) (background light)) @@ -3021,8 +3009,7 @@ Passwords are stored in `rcirc-authinfo' (which see)." (((class color) (min-colors 8) (background light))) (((class color) (min-colors 8) (background dark))) (t :weight bold :slant italic)) - "Rcirc face for server messages." - :group 'rcirc-faces) + "Rcirc face for server messages.") (defface rcirc-server-prefix ; font-lock-comment-delimiter-face '((default :inherit rcirc-server) @@ -3032,13 +3019,11 @@ Passwords are stored in `rcirc-authinfo' (which see)." :foreground "red") (((class color) (min-colors 8) (background dark)) :foreground "red1")) - "Rcirc face for server prefixes." - :group 'rcirc-faces) + "Rcirc face for server prefixes.") (defface rcirc-timestamp '((t :inherit default)) - "Rcirc face for timestamps." - :group 'rcirc-faces) + "Rcirc face for timestamps.") (defface rcirc-nick-in-message ; font-lock-keyword-face '((((class grayscale) (background light)) :foreground "LightGray" :weight bold) @@ -3049,37 +3034,30 @@ Passwords are stored in `rcirc-authinfo' (which see)." (((class color) (min-colors 16) (background dark)) :foreground "Cyan") (((class color) (min-colors 8)) :foreground "cyan" :weight bold) (t :weight bold)) - "Rcirc face for instances of your nick within messages." - :group 'rcirc-faces) + "Rcirc face for instances of your nick within messages.") (defface rcirc-nick-in-message-full-line '((t :weight bold)) - "Rcirc face for emphasizing the entire message when your nick is mentioned." - :group 'rcirc-faces) + "Rcirc face for emphasizing the entire message when your nick is mentioned.") (defface rcirc-prompt ; comint-highlight-prompt '((((min-colors 88) (background dark)) :foreground "cyan1") (((background dark)) :foreground "cyan") (t :foreground "dark blue")) - "Rcirc face for prompts." - :group 'rcirc-faces) + "Rcirc face for prompts.") (defface rcirc-track-nick '((((type tty)) :inherit default) (t :inverse-video t)) - "Rcirc face used in the mode-line when your nick is mentioned." - :group 'rcirc-faces) + "Rcirc face used in the mode-line when your nick is mentioned.") (defface rcirc-track-keyword '((t :weight bold)) - "Rcirc face used in the mode-line when keywords are mentioned." - :group 'rcirc-faces) + "Rcirc face used in the mode-line when keywords are mentioned.") (defface rcirc-url '((t :weight bold)) - "Rcirc face used to highlight urls." - :group 'rcirc-faces) + "Rcirc face used to highlight urls.") (defface rcirc-keyword '((t :inherit highlight)) - "Rcirc face used to highlight keywords." - :group 'rcirc-faces) + "Rcirc face used to highlight keywords.") ;; When using M-x flyspell-mode, only check words after the prompt diff --git a/lisp/net/rfc2104.el b/lisp/net/rfc2104.el index 3b000399b99..5de8401d5b6 100644 --- a/lisp/net/rfc2104.el +++ b/lisp/net/rfc2104.el @@ -1,4 +1,4 @@ -;;; rfc2104.el --- RFC2104 Hashed Message Authentication Codes +;;; rfc2104.el --- RFC2104 Hashed Message Authentication Codes -*- lexical-binding:t -*- ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. @@ -55,7 +55,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; Magic character for inner HMAC round. 0x36 == 54 == '6' (defconst rfc2104-ipad ?\x36) @@ -84,14 +84,6 @@ (setq ls (cdr ls))) v)) -(eval-when-compile - (defmacro rfc2104-string-make-unibyte (string) - "Return the unibyte equivalent of STRING. -In XEmacs return just STRING." - (if (featurep 'xemacs) - string - `(string-make-unibyte ,string)))) - (defun rfc2104-hash (hash block-length hash-length key text) (let* (;; if key is longer than B, reset it to HASH(key) (key (if (> (length key) block-length) @@ -101,23 +93,22 @@ In XEmacs return just STRING." (opad (make-string (+ block-length hash-length) rfc2104-opad)) c partial) ;; Prefix *pad with key, appropriately XORed. - (do ((i 0 (1+ i))) + (cl-do ((i 0 (1+ i))) ((= len i)) (setq c (aref key i)) (aset ipad i (logxor rfc2104-ipad c)) (aset opad i (logxor rfc2104-opad c))) ;; Perform inner hash. - (setq partial (rfc2104-string-make-unibyte - (funcall hash (concat ipad text)))) + (setq partial (funcall hash (concat ipad text))) ;; Pack latter part of opad. - (do ((r 0 (+ 2 r)) - (w block-length (1+ w))) + (cl-do ((r 0 (+ 2 r)) + (w block-length (1+ w))) ((= (* 2 hash-length) r)) (aset opad w (+ (* 16 (aref rfc2104-nybbles (aref partial r))) ( aref rfc2104-nybbles (aref partial (1+ r)))))) ;; Perform outer hash. - (rfc2104-string-make-unibyte (funcall hash opad)))) + (funcall hash opad))) (provide 'rfc2104) diff --git a/lisp/net/rlogin.el b/lisp/net/rlogin.el index f73638699d4..9da35488361 100644 --- a/lisp/net/rlogin.el +++ b/lisp/net/rlogin.el @@ -1,10 +1,9 @@ -;;; rlogin.el --- remote login interface +;;; rlogin.el --- remote login interface -*- lexical-binding:t -*- ;; Copyright (C) 1992-1995, 1997-1998, 2001-2019 Free Software ;; Foundation, Inc. -;; Author: Noah Friedman -;; Maintainer: Noah Friedman <friedman@splode.com> +;; Author: Noah Friedman <friedman@splode.com> ;; Keywords: unix, comm ;; This file is part of GNU Emacs. @@ -30,9 +29,9 @@ ;; tracking and the sending of some special characters. ;; If you wish for rlogin mode to prompt you in the minibuffer for -;; passwords when a password prompt appears, just enter m-x send-invisible -;; and type in your line, or add `comint-watch-for-password-prompt' to -;; `comint-output-filter-functions'. +;; passwords when a password prompt appears, just enter +;; M-x comint-send-invisible and type in your line (or tweak +;; `comint-password-prompt-regexp' to match your password prompt). ;;; Code: diff --git a/lisp/net/sasl-cram.el b/lisp/net/sasl-cram.el index a4d80c92e53..cbca829b035 100644 --- a/lisp/net/sasl-cram.el +++ b/lisp/net/sasl-cram.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2000, 2007-2019 Free Software Foundation, Inc. -;; Author: Daiki Ueno <ueno@unixuser.org> +;; Author: Daiki Ueno <ueno@gnu.org> ;; Kenichi OKADA <okada@opaopa.org> ;; Keywords: SASL, CRAM-MD5 ;; Package: sasl diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el index e67a5a915fa..bd0351644a8 100644 --- a/lisp/net/sasl.el +++ b/lisp/net/sasl.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2000, 2007-2019 Free Software Foundation, Inc. -;; Author: Daiki Ueno <ueno@unixuser.org> +;; Author: Daiki Ueno <ueno@gnu.org> ;; Keywords: SASL ;; This file is part of GNU Emacs. @@ -183,7 +183,7 @@ It contain at least 64 bits of entropy." ;; Don't use microseconds from (current-time), 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- (lsh 1 20))))) + (% (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))) @@ -191,10 +191,10 @@ It contain at least 64 bits of entropy." (concat (sasl-unique-id-number-base36 (+ (car tm) - (lsh (% sasl-unique-id-char 25) 16)) 4) + (ash (% sasl-unique-id-char 25) 16)) 4) (sasl-unique-id-number-base36 (+ (nth 1 tm) - (lsh (/ sasl-unique-id-char 25) 16)) 4)))) + (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 e8d2091296a..5d294ce2c51 100644 --- a/lisp/net/secrets.el +++ b/lisp/net/secrets.el @@ -158,7 +158,7 @@ (defvar secrets-enabled nil "Whether there is a daemon offering the Secret Service API.") -(defvar secrets-debug t +(defvar secrets-debug nil "Write debug messages") (defconst secrets-service "org.freedesktop.secrets" @@ -331,9 +331,7 @@ It returns t if not." ;; Properties. `(:array (:dict-entry ,(concat secrets-interface-item ".Label") - (:variant "dummy")) - (:dict-entry ,(concat secrets-interface-item ".Type") - (:variant ,secrets-interface-item-type-generic))) + (:variant " "))) ;; Secret. `(:struct :object-path ,path (:array :signature "y") @@ -539,6 +537,18 @@ For the time being, only the alias \"default\" is supported." secrets-interface-service "SetAlias" alias :object-path secrets-empty-path)) +(defun secrets-lock-collection (collection) + "Lock collection labeled COLLECTION. +If successful, return the object path of the collection." + (let ((collection-path (secrets-collection-path collection))) + (unless (secrets-empty-path collection-path) + (secrets-prompt + (cadr + (dbus-call-method + :session secrets-service secrets-path secrets-interface-service + "Lock" `(:array :object-path ,collection-path))))) + collection-path)) + (defun secrets-unlock-collection (collection) "Unlock collection labeled COLLECTION. If successful, return the object path of the collection." @@ -565,7 +575,6 @@ If successful, return the object path of the collection." (defun secrets-get-items (collection-path) "Return the object paths of all available items in COLLECTION-PATH." (unless (secrets-empty-path collection-path) - (secrets-open-session) (dbus-get-property :session secrets-service collection-path secrets-interface-collection "Items"))) @@ -593,16 +602,16 @@ If successful, return the object path of the collection." (secrets-get-item-property item-path "Label")) (secrets-get-items collection-path))))) -(defun secrets-search-items (collection &rest attributes) +(defun secrets-search-item-paths (collection &rest attributes) "Search items in COLLECTION with ATTRIBUTES. ATTRIBUTES are key-value pairs. The keys are keyword symbols, starting with a colon. Example: - (secrets-search-items \"Tramp collection\" :user \"joe\") + (secrets-search-item-paths \"Tramp collection\" :user \"joe\") -The object labels of the found items are returned as list." +The object paths of the found items are returned as list." (let ((collection-path (secrets-unlock-collection collection)) - result props) + props) (unless (secrets-empty-path collection-path) ;; Create attributes list. (while (consp (cdr attributes)) @@ -617,84 +626,109 @@ The object labels of the found items are returned as list." ,(cadr attributes)))) attributes (cddr attributes))) ;; Search. The result is a list of object paths. - (setq result - (dbus-call-method - :session secrets-service collection-path - secrets-interface-collection "SearchItems" - (if props - (cons :array props) - '(:array :signature "{ss}")))) - ;; Return the found items. - (mapcar - (lambda (item-path) (secrets-get-item-property item-path "Label")) - result)))) + (dbus-call-method + :session secrets-service collection-path + secrets-interface-collection "SearchItems" + (if props + (cons :array props) + '(:array :signature "{ss}")))))) + +(defun secrets-search-items (collection &rest attributes) + "Search items in COLLECTION with ATTRIBUTES. +ATTRIBUTES are key-value pairs. The keys are keyword symbols, +starting with a colon. Example: + + (secrets-search-items \"Tramp collection\" :user \"joe\") + +The object labels of the found items are returned as list." + (mapcar + (lambda (item-path) (secrets-get-item-property item-path "Label")) + (apply 'secrets-search-item-paths collection attributes))) (defun secrets-create-item (collection item password &rest attributes) "Create a new item in COLLECTION with label ITEM and password PASSWORD. +The label ITEM does not have to be unique in COLLECTION. ATTRIBUTES are key-value pairs set for the created item. The keys are keyword symbols, starting with a colon. Example: (secrets-create-item \"Tramp collection\" \"item\" \"geheim\" :method \"sudo\" :user \"joe\" :host \"remote-host\") +The key `:xdg:schema' determines the scope of the item to be +generated, i.e. for which applications the item is intended for. +This is just a string like \"org.freedesktop.NetworkManager.Mobile\" +or \"org.gnome.OnlineAccounts\", the other required keys are +determined by this. If no `:xdg:schema' is given, +\"org.freedesktop.Secret.Generic\" is used by default. + The object path of the created item is returned." - (unless (member item (secrets-list-items collection)) - (let ((collection-path (secrets-unlock-collection collection)) - result props) - (unless (secrets-empty-path collection-path) - ;; Create attributes list. - (while (consp (cdr attributes)) - (unless (keywordp (car attributes)) - (error 'wrong-type-argument (car attributes))) - (unless (stringp (cadr attributes)) - (error 'wrong-type-argument (cadr attributes))) - (setq props (append - props - `((:dict-entry - ,(substring (symbol-name (car attributes)) 1) - ,(cadr attributes)))) - attributes (cddr attributes))) - ;; Create the item. - (setq result - (dbus-call-method - :session secrets-service collection-path - secrets-interface-collection "CreateItem" - ;; Properties. - (append - `(:array - (:dict-entry ,(concat secrets-interface-item ".Label") - (:variant ,item)) - (:dict-entry ,(concat secrets-interface-item ".Type") - (:variant ,secrets-interface-item-type-generic))) - (when props - `((: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) - ;; Do not replace. Replace does not seem to work. - nil)) - (secrets-prompt (cadr result)) - ;; Return the object path. - (car result))))) + (let ((collection-path (secrets-unlock-collection collection)) + result props) + (unless (secrets-empty-path collection-path) + ;; Set default type if needed. + (unless (member :xdg:schema attributes) + (setq attributes + (append + attributes `(:xdg:schema ,secrets-interface-item-type-generic)))) + ;; Create attributes list. + (while (consp (cdr attributes)) + (unless (keywordp (car attributes)) + (error 'wrong-type-argument (car attributes))) + (unless (stringp (cadr attributes)) + (error 'wrong-type-argument (cadr attributes))) + (setq props (append + props + `((:dict-entry + ,(substring (symbol-name (car attributes)) 1) + ,(cadr attributes)))) + attributes (cddr attributes))) + ;; Create the item. + (setq result + (dbus-call-method + :session secrets-service collection-path + secrets-interface-collection "CreateItem" + ;; Properties. + (append + `(:array + (:dict-entry ,(concat secrets-interface-item ".Label") + (:variant ,item))) + (when props + `((: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) + ;; Do not replace. Replace does not seem to work. + nil)) + (secrets-prompt (cadr result)) + ;; Return the object path. + (car result)))) (defun secrets-item-path (collection item) "Return the object path of item labeled ITEM in COLLECTION. -If there is no such item, return nil." +If there are several items labeled ITEM, it is undefined which +one is returned. If there is no such item, return nil. + +ITEM can also be an object path, which is returned if contained in COLLECTION." (let ((collection-path (secrets-unlock-collection collection))) - (catch 'item-found - (dolist (item-path (secrets-get-items collection-path)) - (when (string-equal item (secrets-get-item-property item-path "Label")) - (throw 'item-found item-path)))))) + (or (and (member item (secrets-get-items collection-path)) item) + (catch 'item-found + (dolist (item-path (secrets-get-items collection-path)) + (when (string-equal + item (secrets-get-item-property item-path "Label")) + (throw 'item-found item-path))))))) (defun secrets-get-secret (collection item) "Return the secret of item labeled ITEM in COLLECTION. -If there is no such item, return nil." +If there are several items labeled ITEM, it is undefined which +one is returned. If there is no such item, return nil. + +ITEM can also be an object path, which is used if contained in COLLECTION." (let ((item-path (secrets-item-path collection item))) (unless (secrets-empty-path item-path) (dbus-byte-array-to-string @@ -705,8 +739,11 @@ If there is no such item, return nil." (defun secrets-get-attributes (collection item) "Return the lookup attributes of item labeled ITEM in COLLECTION. -If there is no such item, or the item has no attributes, return nil." - (unless (stringp collection) (setq collection "default")) +If there are several items labeled ITEM, it is undefined which +one is returned. If there is no such item, or the item has no +attributes, return nil. + +ITEM can also be an object path, which is used if contained in COLLECTION." (let ((item-path (secrets-item-path collection item))) (unless (secrets-empty-path item-path) (mapcar @@ -718,11 +755,19 @@ If there is no such item, or the item has no attributes, return nil." (defun secrets-get-attribute (collection item attribute) "Return the value of ATTRIBUTE of item labeled ITEM in COLLECTION. -If there is no such item, or the item doesn't own this attribute, return nil." +If there are several items labeled ITEM, it is undefined which +one is returned. If there is no such item, or the item doesn't +own this attribute, return nil. + +ITEM can also be an object path, which is used if contained in COLLECTION." (cdr (assoc attribute (secrets-get-attributes collection item)))) (defun secrets-delete-item (collection item) - "Delete ITEM in COLLECTION." + "Delete item labeled ITEM in COLLECTION. +If there are several items labeled ITEM, it is undefined which +one is deleted. + +ITEM can also be an object path, which is used if contained in COLLECTION." (let ((item-path (secrets-item-path collection item))) (unless (secrets-empty-path item-path) (secrets-prompt @@ -872,6 +917,8 @@ to their attributes." (when (dbus-ping :session secrets-service 100) + (secrets-open-session) + ;; We must reset all variables, when there is a new instance of the ;; "org.freedesktop.secrets" service. (dbus-register-signal diff --git a/lisp/net/shr-color.el b/lisp/net/shr-color.el index fcc307b929c..af0b99c76f4 100644 --- a/lisp/net/shr-color.el +++ b/lisp/net/shr-color.el @@ -1,4 +1,4 @@ -;;; shr-color.el --- Simple HTML Renderer color management +;;; shr-color.el --- Simple HTML Renderer color management -*- lexical-binding:t -*- ;; Copyright (C) 2010-2019 Free Software Foundation, Inc. @@ -27,7 +27,7 @@ ;;; Code: (require 'color) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup shr-color nil "Simple HTML Renderer colors" @@ -210,8 +210,8 @@ This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"." (defun shr-color-hue-to-rgb (x y h) "Convert X Y H to RGB value." - (when (< h 0) (incf h)) - (when (> h 1) (decf h)) + (when (< h 0) (cl-incf h)) + (when (> h 1) (cl-decf h)) (cond ((< h (/ 6.0)) (+ x (* (- y x) h 6))) ((< h 0.5) y) ((< h (/ 2.0 3.0)) (+ x (* (- y x) (- (/ 2.0 3.0) h) 6))) @@ -235,7 +235,7 @@ Like rgb() or hsl()." (cond ;; Hexadecimal color: #abc or #aabbcc ((string-match - "\\(#[0-9a-fA-F]\\{3\\}[0-9a-fA-F]\\{3\\}?\\)" + "\\(#[[:xdigit:]]\\{3\\}[[:xdigit:]]\\{3\\}?\\)" color) (match-string 1 color)) ;; rgb() or rgba() colors @@ -259,8 +259,7 @@ Like rgb() or hsl()." (let ((h (/ (string-to-number (match-string-no-properties 1 color)) 360.0)) (s (/ (string-to-number (match-string-no-properties 2 color)) 100.0)) (l (/ (string-to-number (match-string-no-properties 3 color)) 100.0))) - (destructuring-bind (r g b) - (shr-color-hsl-to-rgb-fractions h s l) + (pcase-let ((`(,r ,g ,b) (shr-color-hsl-to-rgb-fractions h s l))) (color-rgb-to-hex r g b 2)))) ;; Color names ((cdr (assoc-string color shr-color-html-colors-alist t))) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 4e584e131fa..fbd1a9b7661 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -30,7 +30,7 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) (eval-when-compile (require 'url)) ;For url-filename's setf handler. (require 'browse-url) (eval-when-compile (require 'subr-x)) @@ -38,6 +38,8 @@ (require 'seq) (require 'svg) (require 'image) +(require 'puny) +(require 'text-property-search) (defgroup shr nil "Simple HTML Renderer" @@ -51,46 +53,44 @@ width and height of the window. If they are larger than this, and Emacs supports it, then the images will be rescaled down to fit these criteria." :version "24.1" - :group 'shr :type 'float) (defcustom shr-blocked-images nil "Images that have URLs matching this regexp will be blocked." :version "24.1" - :group 'shr :type '(choice (const nil) regexp)) (defcustom shr-use-fonts t "If non-nil, use proportional fonts for text." :version "25.1" - :group 'shr + :type 'boolean) + +(defcustom shr-discard-aria-hidden nil + "If non-nil, don't render tags with `aria-hidden=\"true\"'. +This attribute is meant to tell screen readers to ignore a tag." + :version "27.1" :type 'boolean) (defcustom shr-use-colors t "If non-nil, respect color specifications in the HTML." :version "26.1" - :group 'shr :type 'boolean) (defcustom shr-table-horizontal-line nil "Character used to draw horizontal table lines. If nil, don't draw horizontal table lines." - :group 'shr :type '(choice (const nil) character)) (defcustom shr-table-vertical-line ?\s "Character used to draw vertical table lines." - :group 'shr :type 'character) (defcustom shr-table-corner ?\s "Character used to draw table corners." - :group 'shr :type 'character) (defcustom shr-hr-line ?- "Character used to draw hr lines." - :group 'shr :type 'character) (defcustom shr-width nil @@ -101,8 +101,7 @@ If `shr-use-fonts' is set, the mean character width is used to compute the pixel width, which is used instead." :version "25.1" :type '(choice (integer :tag "Fixed width in characters") - (const :tag "Use the width of the window" nil)) - :group 'shr) + (const :tag "Use the width of the window" nil))) (defcustom shr-bullet "* " "Bullet used for unordered lists. @@ -110,19 +109,14 @@ Alternative suggestions are: - \" \" - \" \"" :version "24.4" - :type 'string - :group 'shr) + :type 'string) -(defcustom shr-external-browser 'browse-url-default-browser - "Function used to launch an external browser." - :version "24.4" - :group 'shr - :type 'function) +(define-obsolete-variable-alias 'shr-external-browser + 'browse-url-secondary-browser-function "27.1") (defcustom shr-image-animate t "Non nil means that images that can be animated will be." :version "24.4" - :group 'shr :type 'boolean) (defvar shr-content-function nil @@ -133,14 +127,26 @@ cid: URL as the argument.") (defvar shr-put-image-function 'shr-put-image "Function called to put image and alt string.") -(defface shr-strike-through '((t (:strike-through t))) - "Font for <s> elements." - :group 'shr) +(defface shr-strike-through '((t :strike-through t)) + "Face for <s> elements." + :version "24.1") (defface shr-link - '((t (:inherit link))) - "Font for link elements." - :group 'shr) + '((t :inherit link)) + "Face for link elements." + :version "24.1") + +(defface shr-selected-link + '((t :inherit shr-link :background "red")) + "Temporary face for externally visited link elements. +When a link is visited with an external browser, the link +temporarily blinks with this face." + :version "27.1") + +(defface shr-abbreviation + '((t :inherit underline :underline (:style wave))) + "Face for <abbr> elements." + :version "27.1") (defvar shr-inhibit-images nil "If non-nil, inhibit loading images.") @@ -267,7 +273,9 @@ DOM should be a parse tree as generated by (if (and (null shr-width) (not (shr--have-one-fringe-p))) (* (frame-char-width) 2) - 0))))) + 0) + 1)))) + (max-specpdl-size max-specpdl-size) bidi-display-reordering) ;; If the window was hscrolled for some reason, shr-fill-lines ;; below will misbehave, because it silently assumes that it @@ -344,52 +352,45 @@ If the URL is already at the front of the kill ring act like (shr-probe-and-copy-url url) (shr-copy-url url))) +(defun shr--current-link-region () + (let ((current (get-text-property (point) 'shr-url)) + start) + (save-excursion + ;; Go to the beginning. + (while (and (not (bobp)) + (equal (get-text-property (point) 'shr-url) current)) + (forward-char -1)) + (unless (equal (get-text-property (point) 'shr-url) current) + (forward-char 1)) + (setq start (point)) + ;; Go to the end. + (while (and (not (eobp)) + (equal (get-text-property (point) 'shr-url) current)) + (forward-char 1)) + (list start (point))))) + +(defun shr--blink-link () + (let* ((region (shr--current-link-region)) + (overlay (make-overlay (car region) (cadr region)))) + (overlay-put overlay 'face 'shr-selected-link) + (run-at-time 1 nil (lambda () + (delete-overlay overlay))))) + (defun shr-next-link () "Skip to the next link." (interactive) - (let ((current (get-text-property (point) 'shr-url)) - (start (point)) - skip) - (while (and (not (eobp)) - (equal (get-text-property (point) 'shr-url) current)) - (forward-char 1)) - (cond - ((and (not (eobp)) - (get-text-property (point) 'shr-url)) - ;; The next link is adjacent. - (message "%s" (get-text-property (point) 'help-echo))) - ((or (eobp) - (not (setq skip (text-property-not-all (point) (point-max) - 'shr-url nil)))) - (goto-char start) - (message "No next link")) - (t - (goto-char skip) - (message "%s" (get-text-property (point) 'help-echo)))))) + (let ((match (text-property-search-forward 'shr-url nil nil t))) + (if (not match) + (message "No next link") + (goto-char (prop-match-beginning match)) + (message "%s" (get-text-property (point) 'help-echo))))) (defun shr-previous-link () "Skip to the previous link." (interactive) - (let ((start (point)) - (found nil)) - ;; Skip past the current link. - (while (and (not (bobp)) - (get-text-property (point) 'help-echo)) - (forward-char -1)) - ;; Find the previous link. - (while (and (not (bobp)) - (not (setq found (get-text-property (point) 'help-echo)))) - (forward-char -1)) - (if (not found) - (progn - (message "No previous link") - (goto-char start)) - ;; Put point at the start of the link. - (while (and (not (bobp)) - (get-text-property (point) 'help-echo)) - (forward-char -1)) - (forward-char 1) - (message "%s" (get-text-property (point) 'help-echo))))) + (if (not (text-property-search-backward 'shr-url nil nil t)) + (message "No previous link") + (message "%s" (get-text-property (point) 'help-echo)))) (defun shr-show-alt-text () "Show the ALT text of the image under point." @@ -493,15 +494,20 @@ size, and full-buffer size." (shr-depth (1+ shr-depth)) (start (point))) ;; shr uses many frames per nested node. - (if (> shr-depth (/ max-specpdl-size 15)) - (setq shr-warning "Too deeply nested to render properly; consider increasing `max-specpdl-size'") + (if (and (> shr-depth (/ max-specpdl-size 15)) + (not (and (y-or-n-p "Too deeply nested to render properly; increase `max-specpdl-size'?") + (setq max-specpdl-size (* max-specpdl-size 2))))) + (setq shr-warning + "Not rendering the complete page because of too-deep nesting") (when style (if (string-match "color\\|display\\|border-collapse" style) (setq shr-stylesheet (nconc (shr-parse-style style) shr-stylesheet)) (setq style nil))) ;; If we have a display:none, then just ignore this part of the DOM. - (unless (equal (cdr (assq 'display shr-stylesheet)) "none") + (unless (or (equal (cdr (assq 'display shr-stylesheet)) "none") + (and shr-discard-aria-hidden + (equal (dom-attr dom 'aria-hidden) "true"))) ;; We don't use shr-indirect-call here, since shr-descend is ;; the central bit of shr.el, and should be as fast as ;; possible. Having one more level of indirection with its @@ -689,37 +695,49 @@ size, and full-buffer size." `,(shr-face-background face)))) (setq start (point)) (setq shr-indentation (or continuation shr-indentation)) - (shr-vertical-motion shr-internal-width) - (when (looking-at " $") - (delete-region (point) (line-end-position))) - (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))) - (= (point) start)) - ;; We had unbreakable text (for this width), so just go to - ;; the first space and carry on. - (progn - (beginning-of-line) - (skip-chars-forward " ") - (search-forward " " (line-end-position) 'move))) - ;; Success; continue. - (when (= (preceding-char) ?\s) - (delete-char -1)) - (let ((props `(face ,(get-text-property (point) 'face) - ;; Don't break the image-displayer property - ;; as it will cause `gnus-article-show-images' - ;; to show the two or more same images. - image-displayer - ,(get-text-property (point) 'image-displayer))) - (gap-start (point))) - (insert "\n") - (shr-indent) - (add-text-properties gap-start (point) props)) - (setq start (point)) + ;; If we have an indentation that's wider than the width we're + ;; trying to fill to, then just give up and don't do any filling. + (when (< shr-indentation shr-internal-width) (shr-vertical-motion shr-internal-width) (when (looking-at " $") - (delete-region (point) (line-end-position)))))) + (delete-region (point) (line-end-position))) + (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))) + (= (point) start)) + ;; We had unbreakable text (for this width), so just go to + ;; the first space and carry on. + (progn + (beginning-of-line) + (skip-chars-forward " ") + (search-forward " " (line-end-position) 'move))) + ;; Success; continue. + (when (= (preceding-char) ?\s) + (delete-char -1)) + (let ((gap-start (point))) + (insert "\n") + (shr-indent) + (when (and (> (1- gap-start) (point-min)) + ;; The link on both sides of the newline are the + ;; same... + (equal (get-text-property (point) 'shr-url) + (get-text-property (1- gap-start) 'shr-url))) + ;; ... so we join the two bits into one link logically, but + ;; not visually. This makes navigation between links work + ;; well, but avoids underscores before the link on the next + ;; line when indented. + (let* ((props (copy-sequence (text-properties-at (point)))) + (face (plist-get props 'face))) + ;; We don't want to use the faces on the indentation, because + ;; that's ugly, but we do want to use the background colour. + (when face + (setq props (plist-put props 'face (shr-face-background face)))) + (add-text-properties gap-start (point) props)))) + (setq start (point)) + (shr-vertical-motion shr-internal-width) + (when (looking-at " $") + (delete-region (point) (line-end-position))))))) (defun shr-find-fill-point (start) (let ((bp (point)) @@ -936,7 +954,7 @@ size, and full-buffer size." (defun shr-browse-url (&optional external mouse-event) "Browse the URL at point using `browse-url'. If EXTERNAL is non-nil (interactively, the prefix argument), browse -the URL using `shr-external-browser'. +the URL using `browse-url-secondary-browser-function'. If this function is invoked by a mouse click, it will browse the URL at the position of the click. Optional argument MOUSE-EVENT describes the mouse click event." @@ -950,7 +968,9 @@ the mouse click event." (browse-url-mail url)) (t (if external - (funcall shr-external-browser url) + (progn + (funcall browse-url-secondary-browser-function url) + (shr--blink-link)) (browse-url url)))))) (defun shr-save-contents (directory) @@ -1064,6 +1084,16 @@ element is the data blob and the second element is the content-type." image) (insert (or alt "")))) +(defun shr--image-type () + "Emacs image type to use when displaying images. +If Emacs has native image scaling support, that's used, but if +not, `imagemagick' is preferred if it's present." + (if (or (and (fboundp 'image-transforms-p) + (image-transforms-p)) + (not (fboundp 'imagemagick-types))) + nil + 'imagemagick)) + (defun shr-rescale-image (data content-type width height &optional max-width max-height) "Rescale DATA, if too big, to fit the current buffer. @@ -1072,8 +1102,7 @@ WIDTH and HEIGHT are the sizes given in the HTML data, if any. The size of the displayed image will not exceed MAX-WIDTH/MAX-HEIGHT. If not given, use the current window width/height instead." - (if (or (not (fboundp 'imagemagick-types)) - (not (get-buffer-window (current-buffer)))) + (if (not (get-buffer-window (current-buffer))) (create-image data nil t :ascent 100) (let* ((edges (window-inside-pixel-edges (get-buffer-window (current-buffer)))) @@ -1094,13 +1123,13 @@ width/height instead." (< (* width scaling) max-width) (< (* height scaling) max-height)) (create-image - data 'imagemagick t + data (shr--image-type) t :ascent 100 :width width :height height :format content-type) (create-image - data 'imagemagick t + data (shr--image-type) t :ascent 100 :max-width max-width :max-height max-height @@ -1178,12 +1207,26 @@ START, and END. Note that START and END should be markers." (add-text-properties start (point) (list 'shr-url url - 'help-echo (let ((iri (or (ignore-errors - (decode-coding-string - (url-unhex-string url) - 'utf-8 t)) - url))) - (if title (format "%s (%s)" iri title) iri)) + 'button t + 'category 'shr ; For button.el button buffers. + 'help-echo (let ((parsed (url-generic-parse-url + (or (ignore-errors + (decode-coding-string + (url-unhex-string url) + 'utf-8 t)) + url))) + iri) + ;; If we have an IDNA domain, then show the + ;; decoded version in the mouseover to let the + ;; user know that there's something possibly + ;; fishy. + (when (url-host parsed) + (setf (url-host parsed) + (puny-encode-domain (url-host parsed)))) + (setq iri (url-recreate-url parsed)) + (if title + (format "%s (%s)" iri title) + iri)) 'follow-link t 'mouse-face 'highlight)) ;; Don't overwrite any keymaps that are already in the buffer (i.e., @@ -1319,19 +1362,19 @@ ones, in case fg and bg are nil." (shr-generic dom) (put-text-property start (point) 'display '(raise -0.5)))) -(defun shr-tag-label (dom) - (shr-generic dom) - (shr-ensure-paragraph)) - (defun shr-tag-p (dom) (shr-ensure-paragraph) (shr-generic dom) (shr-ensure-paragraph)) (defun shr-tag-div (dom) - (shr-ensure-newline) - (shr-generic dom) - (shr-ensure-newline)) + (let ((display (cdr (assq 'display shr-stylesheet)))) + (if (or (equal display "inline") + (equal display "inline-block")) + (shr-generic dom) + (shr-ensure-newline) + (shr-generic dom) + (shr-ensure-newline)))) (defun shr-tag-s (dom) (shr-fontize-dom dom 'shr-strike-through)) @@ -1351,10 +1394,14 @@ ones, in case fg and bg are nil." (defun shr-tag-u (dom) (shr-fontize-dom dom 'underline)) -(defun shr-tag-tt (dom) +(defun shr-tag-code (dom) (let ((shr-current-font 'default)) (shr-generic dom))) +(defun shr-tag-tt (dom) + ;; The `tt' tag is deprecated in favor of `code'. + (shr-tag-code dom)) + (defun shr-tag-ins (cont) (let* ((start (point)) (color "green") @@ -1416,6 +1463,21 @@ ones, in case fg and bg are nil." (when url (shr-urlify (or shr-start start) (shr-expand-url url) title)))) +(defun shr-tag-abbr (dom) + (when-let* ((title (dom-attr dom 'title)) + (start (point))) + (shr-generic dom) + (shr-add-font start (point) 'shr-abbreviation) + (add-text-properties + start (point) + (list + 'help-echo title + 'mouse-face 'highlight)))) + +(defun shr-tag-acronym (dom) + ;; `acronym' is deprecated in favor of `abbr'. + (shr-tag-abbr dom)) + (defun shr-tag-object (dom) (unless shr-inhibit-images (let ((start (point)) @@ -1455,7 +1517,6 @@ The key element should be a regexp matched against the type of the source or url if no type is specified. The value should be a float in the range 0.0 to 1.0. Media elements with higher value are preferred." :version "24.4" - :group 'shr :type '(alist :key-type regexp :value-type float)) (defun shr--get-media-pref (elem) @@ -1528,6 +1589,10 @@ The preference is a float determined from `shr-prefer-media-type'." (when (zerop (length alt)) (setq alt "*")) (cond + ((null url) + ;; After further expansion, there turned out to be no valid + ;; src in the img after all. + ) ((or (member (dom-attr dom 'height) '("0" "1")) (member (dom-attr dom 'width) '("0" "1"))) ;; Ignore zero-sized or single-pixel images. @@ -1662,7 +1727,7 @@ The preference is a float determined from `shr-prefer-media-type'." (svg-gradient svg "background" 'linear '((0 . "#b0b0b0") (100 . "#808080"))) (svg-rectangle svg 0 0 width height :gradient "background" :stroke-width 2 :stroke-color "black") - (let ((image (svg-image svg))) + (let ((image (svg-image svg :scale 1))) (setf (image-property image :ascent) 100) image))) @@ -1710,7 +1775,14 @@ The preference is a float determined from `shr-prefer-media-type'." (defun shr-tag-ol (dom) (shr-ensure-paragraph) - (let ((shr-list-mode 1)) + (let* ((attrs (dom-attributes dom)) + (start-attr (alist-get 'start attrs)) + ;; Start at 1 if there is no start attribute + ;; or if start can't be parsed as an integer. + (start-index (condition-case _ + (cl-parse-integer start-attr) + (t 1))) + (shr-list-mode start-index)) (shr-generic dom)) (shr-ensure-paragraph)) @@ -1738,7 +1810,10 @@ The preference is a float determined from `shr-prefer-media-type'." (defun shr-mark-fill (start) ;; We may not have inserted any text to fill. - (unless (= start (point)) + (when (and (/= start (point)) + ;; Tables insert themselves with the correct indentation, + ;; so don't do anything if we're at the start of a table. + (not (get-text-property start 'shr-table-id))) (put-text-property start (1+ start) 'shr-indentation shr-indentation))) @@ -2035,7 +2110,8 @@ flags that control whether to collect or render objects." (setq max (max max (nth 2 column)))) max))) (dotimes (_ (max height 1)) - (shr-indent) + (when (bolp) + (shr-indent)) (insert shr-table-vertical-line "\n")) (dolist (column row) (when (> (nth 2 column) -1) diff --git a/lisp/net/sieve-manage.el b/lisp/net/sieve-manage.el index 2530d3a0bab..d14475a9d53 100644 --- a/lisp/net/sieve-manage.el +++ b/lisp/net/sieve-manage.el @@ -1,4 +1,4 @@ -;;; sieve-manage.el --- Implementation of the managesieve protocol in elisp +;;; sieve-manage.el --- Implementation of the managesieve protocol in elisp -*- lexical-binding:t -*- ;; Copyright (C) 2001-2019 Free Software Foundation, Inc. @@ -75,9 +75,8 @@ (require 'password-cache) (require 'password)) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'sasl) -(require 'starttls) (autoload 'sasl-find-mechanism "sasl") (autoload 'auth-source-search "auth-source") @@ -182,7 +181,7 @@ Valid states are `closed', `initial', `nonauth', and `auth'.") (generate-new-buffer (format " *sieve %s:%s*" sieve-manage-server sieve-manage-port)) - (mapc 'make-local-variable sieve-manage-local-variables) + (mapc #'make-local-variable sieve-manage-local-variables) (mm-enable-multibyte) (buffer-disable-undo) (current-buffer))) @@ -206,19 +205,19 @@ Return the buffer associated with the connection." (with-current-buffer buffer (sieve-manage-erase) (setq sieve-manage-state 'initial) - (destructuring-bind (proc . props) - (open-network-stream - "SIEVE" buffer server port - :type stream - :capability-command "CAPABILITY\r\n" - :end-of-command "^\\(OK\\|NO\\).*\n" - :success "^OK.*\n" - :return-list t - :starttls-function - (lambda (capabilities) - (when (and (not sieve-manage-ignore-starttls) - (string-match "\\bSTARTTLS\\b" capabilities)) - "STARTTLS\r\n"))) + (pcase-let ((`(,proc . ,props) + (open-network-stream + "SIEVE" buffer server port + :type stream + :capability-command "CAPABILITY\r\n" + :end-of-command "^\\(OK\\|NO\\).*\n" + :success "^OK.*\n" + :return-list t + :starttls-function + (lambda (capabilities) + (when (and (not sieve-manage-ignore-starttls) + (string-match "\\bSTARTTLS\\b" capabilities)) + "STARTTLS\r\n"))))) (setq sieve-manage-process proc) (setq sieve-manage-capability (sieve-manage-parse-capability (plist-get props :capabilities))) @@ -250,7 +249,7 @@ Return the buffer associated with the connection." ;; somehow. `(lambda (prompt) ,(copy-sequence user-password))) (step (sasl-next-step client nil)) - (tag (sieve-manage-send + (_tag (sieve-manage-send (concat "AUTHENTICATE \"" mech @@ -373,11 +372,11 @@ to work in." ;; Choose authenticator (when (and (null sieve-manage-auth) (not (eq sieve-manage-state 'auth))) - (dolist (auth sieve-manage-authenticators) + (cl-dolist (auth sieve-manage-authenticators) (when (funcall (nth 1 (assq auth sieve-manage-authenticator-alist)) buffer) (setq sieve-manage-auth auth) - (return))) + (cl-return))) (unless sieve-manage-auth (error "Couldn't figure out authenticator for server"))) (sieve-manage-erase) diff --git a/lisp/net/sieve-mode.el b/lisp/net/sieve-mode.el index 774047f3aa8..adab010257f 100644 --- a/lisp/net/sieve-mode.el +++ b/lisp/net/sieve-mode.el @@ -100,23 +100,20 @@ (defconst sieve-font-lock-keywords (eval-when-compile - (list - ;; control commands - (cons (regexp-opt '("require" "if" "else" "elsif" "stop") - 'words) - 'sieve-control-commands) - ;; action commands - (cons (regexp-opt '("fileinto" "redirect" "reject" "keep" "discard") - 'words) - 'sieve-action-commands) - ;; test commands - (cons (regexp-opt '("address" "allof" "anyof" "exists" "false" - "true" "header" "not" "size" "envelope" - "body") - 'words) - 'sieve-test-commands) - (cons "\\Sw+:\\sw+" - 'sieve-tagged-arguments)))) + `( + ;; control commands + (,(regexp-opt '("require" "if" "else" "elsif" "stop") 'words) + . 'sieve-control-commands) + ;; action commands + (,(regexp-opt '("fileinto" "redirect" "reject" "keep" "discard") 'words) + . 'sieve-action-commands) + ;; test commands + (,(regexp-opt '("address" "allof" "anyof" "exists" "false" + "true" "header" "not" "size" "envelope" + "body") + 'words) + . 'sieve-test-commands) + ("\\Sw+:\\sw+" . 'sieve-tagged-arguments)))) ;; Syntax table diff --git a/lisp/net/sieve.el b/lisp/net/sieve.el index 0e14af2cc84..3337998bedc 100644 --- a/lisp/net/sieve.el +++ b/lisp/net/sieve.el @@ -137,16 +137,15 @@ require \"fileinto\"; '("Manage Sieve" ["Edit script" sieve-edit-script t] ["Activate script" sieve-activate t] - ["Deactivate script" sieve-deactivate t])) + ["Deactivate script" sieve-deactivate t] + ["Quit and close connection" sieve-manage-quit t])) -(define-derived-mode sieve-manage-mode fundamental-mode "Sieve-manage" +(define-derived-mode sieve-manage-mode special-mode "Sieve-manage" "Mode used for sieve script management." (buffer-disable-undo (current-buffer)) (setq truncate-lines t) (easy-menu-add sieve-manage-mode-menu sieve-manage-mode-map)) -(put 'sieve-manage-mode 'mode-class 'special) - ;; Commands used in sieve-manage mode: (defun sieve-manage-quit () @@ -215,9 +214,9 @@ require \"fileinto\"; (sieve-mode) (setq sieve-buffer-script-name name) (goto-char (point-min)) - (message - (substitute-command-keys - "Press \\[sieve-upload] to upload script to server.")))) + (set-buffer-modified-p nil) + (message "Press %s to upload script to server." + (substitute-command-keys "\\[sieve-upload]")))) (defmacro sieve-change-region (&rest body) "Turns off sieve-region before executing BODY, then re-enables it after. @@ -256,8 +255,10 @@ Used to bracket operations which move point in the sieve-buffer." (if (eq last-command 'sieve-help) ;; would need minor-mode for log-edit-mode (describe-function 'sieve-mode) - (message "%s" (substitute-command-keys - "`\\[sieve-edit-script]':edit `\\[sieve-activate]':activate `\\[sieve-deactivate]':deactivate `\\[sieve-remove]':remove")))) + (message "%s" (substitute-command-keys "\ +`\\[sieve-edit-script]':edit `\\[sieve-activate]':activate \ +`\\[sieve-deactivate]':deactivate `\\[sieve-remove]':remove \ +`\\[sieve-manage-quit]':quit")))) ;; Create buffer: @@ -312,20 +313,20 @@ Used to bracket operations which move point in the sieve-buffer." (delete-region (or sieve-buffer-header-end (point-max)) (point-max)) (goto-char (point-max)) ;; get list of script names and print them - (let ((scripts (sieve-manage-listscripts sieve-manage-buffer))) - (if (null scripts) - (insert - (substitute-command-keys - (format - "No scripts on server, press \\[sieve-edit-script] on %s to create a new script.\n" - sieve-new-script))) - (insert - (substitute-command-keys - (format (concat "%d script%s on server, press \\[sieve-edit-script] on a script " - "name edits it, or\npress \\[sieve-edit-script] on %s to create " - "a new script.\n") (length scripts) - (if (eq (length scripts) 1) "" "s") - sieve-new-script)))) + (let* ((scripts (sieve-manage-listscripts sieve-manage-buffer)) + (count (length scripts)) + (keys (substitute-command-keys "\\[sieve-edit-script]"))) + (insert + (if (null scripts) + (format + "No scripts on server, press %s on %s to create a new script.\n" + keys sieve-new-script) + (format (concat (ngettext "%d script on server" + "%d scripts on server" + count) + ", press %s on a script name to edit it, or" + "\npress %s on %s to create a new script.\n") + count keys keys sieve-new-script))) (save-excursion (sieve-insert-scripts (list sieve-new-script)) (sieve-insert-scripts scripts))) @@ -345,16 +346,20 @@ Used to bracket operations which move point in the sieve-buffer." ;;;###autoload (defun sieve-upload (&optional name) (interactive) - (when (or (get-buffer sieve-buffer) (call-interactively 'sieve-manage)) - (let ((script (buffer-string)) err) + (when (or (get-buffer sieve-buffer) + (save-current-buffer (call-interactively 'sieve-manage))) + (let ((script (buffer-string)) + (script-name (file-name-sans-extension (buffer-name))) + err) (with-current-buffer (get-buffer sieve-buffer) (setq err (sieve-manage-putscript - (or name sieve-buffer-script-name (buffer-name)) + (or name sieve-buffer-script-name script-name) script sieve-manage-buffer)) - (if (sieve-manage-ok-p err) - (message (substitute-command-keys - "Sieve upload done. Use \\[sieve-manage] to manage scripts.")) - (message "Sieve upload failed: %s" (nth 2 err))))))) + (if (not (sieve-manage-ok-p err)) + (message "Sieve upload failed: %s" (nth 2 err)) + (message "Sieve upload done. Use %s to manage scripts." + (substitute-command-keys "\\[sieve-manage]")) + (set-buffer-modified-p nil)))))) ;;;###autoload (defun sieve-upload-and-bury (&optional name) diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index 64c2b9a2367..5526d624f96 100644 --- a/lisp/net/soap-client.el +++ b/lisp/net/soap-client.el @@ -5,7 +5,7 @@ ;; Author: Alexandru Harsanyi <AlexHarsanyi@gmail.com> ;; Author: Thomas Fitzsimmons <fitzsim@fitzsim.org> ;; Created: December, 2009 -;; Version: 3.1.4 +;; Version: 3.1.5 ;; Keywords: soap, web-services, comm, hypermedia ;; Package: soap-client ;; Homepage: https://github.com/alex-hhh/emacs-soap-client @@ -464,8 +464,14 @@ position. This is a specialization of `soap-encode-value' for `soap-xs-basic-type' objects." - (let ((kind (soap-xs-basic-type-kind type))) - + (let ((kind (soap-xs-basic-type-kind type)) + ;; Handle conversions of this form: + ;; (Element (AttrA . "A") (AttrB . "B") "Value here") + ;; to: + ;; <ns:Element AttrA="A" AttrB="B">Value here</ns:Element> + ;; by assuming that if this is a list, it must have attributes + ;; preceding the basic value. + (value (if (listp value) (progn (car (last value))) value))) (when (eq kind 'anyType) (cond ((stringp value) (setq kind 'string)) @@ -629,7 +635,7 @@ disallows them." (<= time-zone-minute 59)) (error "Invalid or unsupported time: %s" date-time-string)) ;; Return a value in a format similar to that returned by decode-time, and - ;; suitable for (apply 'encode-time ...). + ;; suitable for (apply #'encode-time ...). (list second minute hour day month year second-fraction datatype (if has-time-zone (* (rng-xsd-time-to-seconds @@ -685,14 +691,17 @@ This is a specialization of `soap-decode-type' for (anyType (soap-decode-any-type node)) (Array (soap-decode-array node)))))) -(defun soap-type-of (element) - "Return the type of ELEMENT." - ;; Support Emacs < 26 byte-code running in Emacs >= 26 sessions - ;; (Bug#31742). - (let ((type (type-of element))) - (if (eq type 'vector) - (aref element 0) ; For Emacs 25 and earlier. - type))) +(defalias 'soap-type-of + (if (eq 'soap-xs-basic-type (type-of (make-soap-xs-basic-type))) + ;; `type-of' in Emacs ≥ 26 already does what we need. + #'type-of + ;; For Emacs < 26, use our own function. + (lambda (element) + "Return the type of ELEMENT." + (if (vectorp element) + (aref element 0) ;Assume this vector is actually a struct! + ;; This should never happen. + (type-of element))))) ;; Register methods for `soap-xs-basic-type' (let ((tag (soap-type-of (make-soap-xs-basic-type)))) @@ -1343,14 +1352,25 @@ See also `soap-wsdl-resolve-references'." (defun soap-encode-xs-simple-type-attributes (value type) "Encode the XML attributes for VALUE according to TYPE. -The xsi:type and an optional xsi:nil attributes are added. The -attributes are inserted in the current buffer at the current -position. +The attributes are inserted in the current buffer at the current +position. If TYPE has no attributes, the xsi:type attribute and +an optional xsi:nil attribute are added. This is a specialization of `soap-encode-attributes' for `soap-xs-simple-type' objects." - (insert " xsi:type=\"" (soap-element-fq-name type) "\"") - (unless value (insert " xsi:nil=\"true\""))) + (let ((attributes (soap-get-xs-attributes type))) + (dolist (a attributes) + (let ((element-name (soap-element-name a))) + (if (soap-xs-attribute-default a) + (insert " " element-name + "=\"" (soap-xs-attribute-default a) "\"") + (dolist (value-pair value) + (when (equal element-name (symbol-name (car-safe value-pair))) + (insert " " element-name + "=\"" (cdr value-pair) "\"")))))) + (unless attributes + (insert " xsi:type=\"" (soap-element-fq-name type) "\"") + (unless value (insert " xsi:nil=\"true\""))))) (defun soap-encode-xs-simple-type (value type) "Encode the VALUE according to TYPE. @@ -1640,7 +1660,8 @@ This is a specialization of `soap-encode-value' for (array (error "Arrays of type soap-encode-xs-complex-type are handled elsewhere")) ((sequence choice all nil) - (let ((type-list (list type))) + (let ((type-list (list type)) + (type-elements '())) ;; Collect all base types (let ((base (soap-xs-complex-type-base type))) @@ -1648,60 +1669,66 @@ This is a specialization of `soap-encode-value' for (push base type-list) (setq base (soap-xs-complex-type-base base)))) + ;; Collect type elements, eliminating duplicates from the type + ;; hierarchy. (dolist (type type-list) (dolist (element (soap-xs-complex-type-elements type)) - (catch 'done - (let ((instance-count 0)) - (dolist (candidate (soap-get-candidate-elements element)) - (let ((e-name (soap-xs-element-name candidate))) - (if e-name - (let ((e-name (intern e-name))) - (dolist (v value) - (when (equal (car v) e-name) - (cl-incf instance-count) - (soap-encode-value (cdr v) candidate)))) - (if (soap-xs-complex-type-indicator type) - (let ((current-point (point))) - ;; Check if encoding happened by checking if - ;; characters were inserted in the buffer. - (soap-encode-value value candidate) - (when (not (equal current-point (point))) - (cl-incf instance-count))) + (unless (member element type-elements) + (setq type-elements (append type-elements (list element)))))) + + (dolist (element type-elements) + (catch 'done + (let ((instance-count 0)) + (dolist (candidate (soap-get-candidate-elements element)) + (let ((e-name (soap-xs-element-name candidate))) + (if e-name + (let ((e-name (intern e-name))) (dolist (v value) - (let ((current-point (point))) - (soap-encode-value v candidate) - (when (not (equal current-point (point))) - (cl-incf instance-count)))))))) - ;; Do some sanity checking - (let* ((indicator (soap-xs-complex-type-indicator type)) - (element-type (soap-xs-element-type element)) - (reference (soap-xs-element-reference element)) - (e-name (or (soap-xs-element-name element) - (and reference - (soap-xs-element-name reference))))) - (cond ((and (eq indicator 'choice) - (> instance-count 0)) - ;; This was a choice node and we encoded - ;; one instance. - (throw 'done t)) - ((and (not (eq indicator 'choice)) - (= instance-count 0) - (not (soap-xs-element-optional? element)) - (and (soap-xs-complex-type-p element-type) - (not (soap-xs-complex-type-optional-p - element-type)))) - (soap-warning - "While encoding %s: missing non-nillable slot %s" - value e-name)) - ((and (> instance-count 1) - (not (soap-xs-element-multiple? element)) - (and (soap-xs-complex-type-p element-type) - (not (soap-xs-complex-type-multiple-p - element-type)))) - (soap-warning - (concat "While encoding %s: expected single," - " found multiple elements for slot %s") - value e-name)))))))))) + (when (equal (car v) e-name) + (cl-incf instance-count) + (soap-encode-value (cdr v) candidate)))) + (if (soap-xs-complex-type-indicator type) + (let ((current-point (point))) + ;; Check if encoding happened by checking if + ;; characters were inserted in the buffer. + (soap-encode-value value candidate) + (when (not (equal current-point (point))) + (cl-incf instance-count))) + (dolist (v value) + (let ((current-point (point))) + (soap-encode-value v candidate) + (when (not (equal current-point (point))) + (cl-incf instance-count)))))))) + ;; Do some sanity checking + (let* ((indicator (soap-xs-complex-type-indicator type)) + (element-type (soap-xs-element-type element)) + (reference (soap-xs-element-reference element)) + (e-name (or (soap-xs-element-name element) + (and reference + (soap-xs-element-name reference))))) + (cond ((and (eq indicator 'choice) + (> instance-count 0)) + ;; This was a choice node and we encoded + ;; one instance. + (throw 'done t)) + ((and (not (eq indicator 'choice)) + (= instance-count 0) + (not (soap-xs-element-optional? element)) + (and (soap-xs-complex-type-p element-type) + (not (soap-xs-complex-type-optional-p + element-type)))) + (soap-warning + "While encoding %s: missing non-nillable slot %s" + value e-name)) + ((and (> instance-count 1) + (not (soap-xs-element-multiple? element)) + (and (soap-xs-complex-type-p element-type) + (not (soap-xs-complex-type-multiple-p + element-type)))) + (soap-warning + (concat "While encoding %s: expected single," + " found multiple elements for slot %s") + value e-name))))))))) (t (error "Don't know how to encode complex type: %s" (soap-xs-complex-type-indicator type))))) @@ -2334,6 +2361,14 @@ traverse an element tree." (defun soap-parse-server-response () "Error-check and parse the XML contents of the current buffer." (let ((mime-part (mm-dissect-buffer t t))) + (when (and + (equal (mm-handle-media-type mime-part) "multipart/related") + (equal (get-text-property 0 'type (mm-handle-media-type mime-part)) + "text/xml")) + (setq mime-part + (mm-make-handle + (get-text-property 0 'buffer (mm-handle-media-type mime-part)) + `(,(get-text-property 0 'type (mm-handle-media-type mime-part)))))) (unless mime-part (error "Failed to decode response from server")) (unless (equal (car (mm-handle-type mime-part)) "text/xml") @@ -2881,6 +2916,8 @@ reference multiRef parts which are external to RESPONSE-NODE." ;;;; SOAP type encoding +;; FIXME: Use `cl-defmethod' (but this requires Emacs-25). + (defun soap-encode-attributes (value type) "Encode XML attributes for VALUE according to TYPE. This is a generic function which determines the attribute encoder diff --git a/lisp/net/socks.el b/lisp/net/socks.el index c2a8b699cd5..6356707a1db 100644 --- a/lisp/net/socks.el +++ b/lisp/net/socks.el @@ -1,4 +1,4 @@ -;;; socks.el --- A Socks v5 Client for Emacs +;;; socks.el --- A Socks v5 Client for Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1996-2000, 2002, 2007-2019 Free Software Foundation, ;; Inc. @@ -32,71 +32,59 @@ ;; - Implement composition of servers. Recursively evaluate the ;; redirection rules and do SOCKS-over-HTTP and SOCKS-in-SOCKS -(eval-when-compile - (require 'wid-edit)) -(require 'custom) - -(eval-and-compile - (if (featurep 'emacs) - (defalias 'socks-split-string 'split-string) ; since at least 21.1 - (if (fboundp 'split-string) - (defalias 'socks-split-string 'split-string) - (defun socks-split-string (string &optional pattern) - "Return a list of substrings of STRING which are separated by PATTERN. -If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." - (or pattern - (setq pattern "[ \f\t\n\r\v]+")) - (let (parts (start 0)) - (while (string-match pattern string start) - (setq parts (cons (substring string start - (match-beginning 0)) parts) - start (match-end 0))) - (nreverse (cons (substring string start) parts))))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Custom widgets -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; (define-widget 'dynamic-choice 'menu-choice -;;; "A pretty simple dynamic dropdown list" -;;; :format "%[%t%]: %v" -;;; :tag "Network" -;;; :case-fold t -;;; :void '(item :format "invalid (%t)\n") -;;; :value-create 's5-widget-value-create -;;; :value-delete 'widget-children-value-delete -;;; :value-get 'widget-choice-value-get -;;; :value-inline 'widget-choice-value-inline -;;; :mouse-down-action 'widget-choice-mouse-down-action -;;; :action 'widget-choice-action -;;; :error "Make a choice" -;;; :validate 'widget-choice-validate -;;; :match 's5-dynamic-choice-match -;;; :match-inline 's5-dynamic-choice-match-inline) -;;; -;;; (defun s5-dynamic-choice-match (widget value) -;;; (let ((choices (funcall (widget-get widget :choice-function))) -;;; current found) -;;; (while (and choices (not found)) -;;; (setq current (car choices) -;;; choices (cdr choices) -;;; found (widget-apply current :match value))) -;;; found)) -;;; -;;; (defun s5-dynamic-choice-match-inline (widget value) -;;; (let ((choices (funcall (widget-get widget :choice-function))) -;;; current found) -;;; (while (and choices (not found)) -;;; (setq current (car choices) -;;; choices (cdr choices) -;;; found (widget-match-inline current value))) -;;; found)) -;;; -;;; (defun s5-widget-value-create (widget) -;;; (let ((choices (funcall (widget-get widget :choice-function))) -;;; (value (widget-get widget :value))) -;;; (if (not value) -;;; (widget-put widget :value (widget-value (car choices)))) -;;; (widget-put widget :args choices) -;;; (widget-choice-value-create widget))) +;;; Code: + +(eval-when-compile (require 'cl-lib)) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;; Custom widgets +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (eval-when-compile +;; (require 'wid-edit)) + +;; (define-widget 'dynamic-choice 'menu-choice +;; "A pretty simple dynamic dropdown list" +;; :format "%[%t%]: %v" +;; :tag "Network" +;; :case-fold t +;; :void '(item :format "invalid (%t)\n") +;; :value-create 's5-widget-value-create +;; :value-delete 'widget-children-value-delete +;; :value-get 'widget-choice-value-get +;; :value-inline 'widget-choice-value-inline +;; :mouse-down-action 'widget-choice-mouse-down-action +;; :action 'widget-choice-action +;; :error "Make a choice" +;; :validate 'widget-choice-validate +;; :match 's5-dynamic-choice-match +;; :match-inline 's5-dynamic-choice-match-inline) +;; +;; (defun s5-dynamic-choice-match (widget value) +;; (let ((choices (funcall (widget-get widget :choice-function))) +;; current found) +;; (while (and choices (not found)) +;; (setq current (car choices) +;; choices (cdr choices) +;; found (widget-apply current :match value))) +;; found)) +;; +;; (defun s5-dynamic-choice-match-inline (widget value) +;; (let ((choices (funcall (widget-get widget :choice-function))) +;; current found) +;; (while (and choices (not found)) +;; (setq current (car choices) +;; choices (cdr choices) +;; found (widget-match-inline current value))) +;; found)) +;; +;; (defun s5-widget-value-create (widget) +;; (let ((choices (funcall (widget-get widget :choice-function))) +;; (value (widget-get widget :value))) +;; (if (not value) +;; (widget-put widget :value (widget-value (car choices)))) +;; (widget-put widget :args choices) +;; (widget-choice-value-create widget))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Customization support @@ -107,70 +95,66 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." :prefix "socks-" :group 'processes) -;;; (defcustom socks-server-aliases nil -;;; "A list of server aliases for use in access control and filtering rules." -;;; :group 'socks -;;; :type '(repeat (list :format "%v" -;;; :value ("" "" 1080 5) -;;; (string :tag "Alias") -;;; (string :tag "Hostname/IP Address") -;;; (integer :tag "Port #") -;;; (choice :tag "SOCKS Version" -;;; (integer :tag "SOCKS v4" :value 4) -;;; (integer :tag "SOCKS v5" :value 5))))) -;;; -;;; (defcustom socks-network-aliases -;;; '(("Anywhere" (netmask "0.0.0.0" "0.0.0.0"))) -;;; "A list of network aliases for use in subsequent rules." -;;; :group 'socks -;;; :type '(repeat (list :format "%v" -;;; :value (netmask "" "255.255.255.0") -;;; (string :tag "Alias") -;;; (radio-button-choice -;;; :format "%v" -;;; (list :tag "IP address range" -;;; (const :format "" :value range) -;;; (string :tag "From") -;;; (string :tag "To")) -;;; (list :tag "IP address/netmask" -;;; (const :format "" :value netmask) -;;; (string :tag "IP Address") -;;; (string :tag "Netmask")) -;;; (list :tag "Domain Name" -;;; (const :format "" :value domain) -;;; (string :tag "Domain name")) -;;; (list :tag "Unique hostname/IP address" -;;; (const :format "" :value exact) -;;; (string :tag "Hostname/IP Address")))))) -;;; -;;; (defun s5-servers-filter () -;;; (if socks-server-aliases -;;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x))) s5-server-aliases) -;;; '((const :tag "No aliases defined" :value nil)))) -;;; -;;; (defun s5-network-aliases-filter () -;;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x))) -;;; socks-network-aliases)) -;;; -;;; (defcustom socks-redirection-rules -;;; nil -;;; "A list of redirection rules." -;;; :group 'socks -;;; :type '(repeat (list :format "%v" -;;; :value ("Anywhere" nil) -;;; (dynamic-choice :choice-function s5-network-aliases-filter -;;; :tag "Destination network") -;;; (radio-button-choice -;;; :tag "Connection type" -;;; (const :tag "Direct connection" :value nil) -;;; (dynamic-choice :format "%t: %[%v%]" -;;; :choice-function s5-servers-filter -;;; :tag "Proxy chain via"))))) +;; (defcustom socks-server-aliases nil +;; "A list of server aliases for use in access control and filtering rules." +;; :type '(repeat (list :format "%v" +;; :value ("" "" 1080 5) +;; (string :tag "Alias") +;; (string :tag "Hostname/IP Address") +;; (integer :tag "Port #") +;; (choice :tag "SOCKS Version" +;; (integer :tag "SOCKS v4" :value 4) +;; (integer :tag "SOCKS v5" :value 5))))) +;; +;; (defcustom socks-network-aliases +;; '(("Anywhere" (netmask "0.0.0.0" "0.0.0.0"))) +;; "A list of network aliases for use in subsequent rules." +;; :type '(repeat (list :format "%v" +;; :value (netmask "" "255.255.255.0") +;; (string :tag "Alias") +;; (radio-button-choice +;; :format "%v" +;; (list :tag "IP address range" +;; (const :format "" :value range) +;; (string :tag "From") +;; (string :tag "To")) +;; (list :tag "IP address/netmask" +;; (const :format "" :value netmask) +;; (string :tag "IP Address") +;; (string :tag "Netmask")) +;; (list :tag "Domain Name" +;; (const :format "" :value domain) +;; (string :tag "Domain name")) +;; (list :tag "Unique hostname/IP address" +;; (const :format "" :value exact) +;; (string :tag "Hostname/IP Address")))))) +;; +;; (defun s5-servers-filter () +;; (if socks-server-aliases +;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x))) s5-server-aliases) +;; '((const :tag "No aliases defined" :value nil)))) +;; +;; (defun s5-network-aliases-filter () +;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x))) +;; socks-network-aliases)) +;; +;; (defcustom socks-redirection-rules +;; nil +;; "A list of redirection rules." +;; :type '(repeat (list :format "%v" +;; :value ("Anywhere" nil) +;; (dynamic-choice :choice-function s5-network-aliases-filter +;; :tag "Destination network") +;; (radio-button-choice +;; :tag "Connection type" +;; (const :tag "Direct connection" :value nil) +;; (dynamic-choice :format "%t: %[%v%]" +;; :choice-function s5-servers-filter +;; :tag "Proxy chain via"))))) (defcustom socks-server (list "Default server" "socks" 1080 5) "" - :group 'socks :type '(list (string :format "" :value "Default server") (string :tag "Server") @@ -225,7 +209,6 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." ;; Base variables (defvar socks-timeout 5) -(defvar socks-connections (make-hash-table :size 13)) ;; Miscellaneous stuff for authentication (defvar socks-authentication-methods nil) @@ -266,40 +249,40 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (defconst socks-state-waiting 3) (defconst socks-state-connected 4) -(defmacro socks-wait-for-state-change (proc htable cur-state) - `(while (and (= (gethash 'state ,htable) ,cur-state) - (memq (process-status ,proc) '(run open))) - (accept-process-output ,proc socks-timeout))) +(defun socks-wait-for-state-change (proc cur-state) + (while (and (= (process-get proc 'socks-state) cur-state) + (memq (process-status proc) '(run open))) + (accept-process-output proc socks-timeout))) (defun socks-filter (proc string) - (let ((info (gethash proc socks-connections)) - state version desired-len) - (or info (error "socks-filter called on non-SOCKS connection %S" proc)) - (setq state (gethash 'state info)) + (let (state version desired-len) + (or (process-get proc 'socks) + (error "socks-filter called on non-SOCKS connection %S" proc)) + (setq state (process-get proc 'socks-state)) (cond ((= state socks-state-waiting-for-auth) - (puthash 'scratch (concat string (gethash 'scratch info)) info) - (setq string (gethash 'scratch info)) + (cl-callf (lambda (s) (setq string (concat string s))) + (process-get proc 'socks-scratch)) (if (< (length string) 2) nil ; We need to spin some more - (puthash 'authtype (aref string 1) info) - (puthash 'scratch (substring string 2 nil) info) - (puthash 'state socks-state-submethod-negotiation info))) + (process-put proc 'socks-authtype (aref string 1)) + (process-put proc 'socks-scratch (substring string 2 nil)) + (process-put proc 'socks-state socks-state-submethod-negotiation))) ((= state socks-state-submethod-negotiation) ) ((= state socks-state-authenticated) ) ((= state socks-state-waiting) - (puthash 'scratch (concat string (gethash 'scratch info)) info) - (setq string (gethash 'scratch info)) - (setq version (gethash 'server-protocol info)) + (cl-callf (lambda (s) (setq string (concat string s))) + (process-get proc 'socks-scratch)) + (setq version (process-get proc 'socks-server-protocol)) (cond ((equal version 'http) (if (not (string-match "\r\n\r\n" string)) nil ; Need to spin some more - (puthash 'state socks-state-connected info) - (puthash 'reply 0 info) - (puthash 'response string info))) + (process-put proc 'socks-state socks-state-connected) + (process-put proc 'socks-reply 0) + (process-put proc 'socks-response string))) ((equal version 4) (if (< (length string) 2) nil ; Can't know how much to read yet @@ -313,71 +296,58 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (let ((response (aref string 1))) (if (= response 90) (setq response 0)) - (puthash 'state socks-state-connected info) - (puthash 'reply response info) - (puthash 'response string info))))) + (process-put proc 'socks-state socks-state-connected) + (process-put proc 'socks-reply response) + (process-put proc 'socks-response string))))) ((equal version 5) (if (< (length string) 4) nil (setq desired-len (+ 6 ; Standard socks header - (cond - ((= (aref string 3) socks-address-type-v4) 4) - ((= (aref string 3) socks-address-type-v6) 16) - ((= (aref string 3) socks-address-type-name) - (if (< (length string) 5) - 255 - (+ 1 (aref string 4))))))) + (pcase (aref string 3) + ((pred (= socks-address-type-v4)) 4) + ((pred (= socks-address-type-v6)) 16) + ((pred (= socks-address-type-name)) + (if (< (length string) 5) + 255 + (+ 1 (aref string 4))))))) (if (< (length string) desired-len) nil ; Need to spin some more - (puthash 'state socks-state-connected info) - (puthash 'reply (aref string 1) info) - (puthash 'response string info)))))) - ((= state socks-state-connected) - ) - ) - ) - ) - -(declare-function socks-original-open-network-stream "socks") ; fset + (process-put proc 'socks-state socks-state-connected) + (process-put proc 'socks-reply (aref string 1)) + (process-put proc 'socks-response string)))))) + ((= state socks-state-connected))))) ;; FIXME this is a terrible idea. ;; It is not even compatible with the argument spec of open-network-stream -;; in 24.1. If this is really necessary, open-network-stream -;; could get a wrapper hook, or defer to open-network-stream-function. +;; in 24.1. (defvar socks-override-functions nil - "Whether to overwrite the `open-network-stream' function with the SOCKSified -version.") - -(require 'network-stream) + "If non-nil, overwrite `open-network-stream' function with SOCKSified version.") -(if (fboundp 'socks-original-open-network-stream) - nil ; Do nothing, we've been here already - (defalias 'socks-original-open-network-stream - (symbol-function 'open-network-stream)) - (if socks-override-functions - (defalias 'open-network-stream 'socks-open-network-stream))) +(when socks-override-functions + (advice-add 'open-network-stream :around #'socks--open-network-stream)) (defun socks-open-connection (server-info) (interactive) (save-excursion - (let ((proc (socks-original-open-network-stream "socks" - nil - (nth 1 server-info) - (nth 2 server-info))) - (info (make-hash-table :size 13)) + (let ((proc + (let ((socks-override-functions nil)) + (open-network-stream "socks" + nil + (nth 1 server-info) + (nth 2 server-info)))) (authtype nil) version) ;; Initialize process and info about the process - (set-process-filter proc 'socks-filter) + (set-process-filter proc #'socks-filter) (set-process-query-on-exit-flag proc nil) - (puthash proc info socks-connections) - (puthash 'state socks-state-waiting-for-auth info) - (puthash 'authtype socks-authentication-failure info) - (puthash 'server-protocol (nth 3 server-info) info) - (puthash 'server-name (nth 1 server-info) info) + (process-put proc 'socks t) + (process-put proc 'socks-state socks-state-waiting-for-auth) + (process-put proc 'socks-authtype socks-authentication-failure) + (process-put proc 'socks-server-protocol (nth 3 server-info)) + (process-put proc 'socks-server-name (nth 1 server-info)) (setq version (nth 3 server-info)) (cond ((equal version 'http) @@ -393,15 +363,15 @@ version.") (socks-build-auth-list))) ;; Basically just do a select() until we change states. - (socks-wait-for-state-change proc info socks-state-waiting-for-auth) - (setq authtype (gethash 'authtype info)) + (socks-wait-for-state-change proc socks-state-waiting-for-auth) + (setq authtype (process-get proc 'socks-authtype)) (cond ((= authtype socks-authentication-null) (and socks-debug (message "No authentication necessary"))) ((= authtype socks-authentication-failure) (error "No acceptable authentication methods found")) (t - (let* ((auth-type (gethash 'authtype info)) + (let* ((auth-type (process-get proc 'socks-authtype)) (auth-handler (assoc auth-type socks-authentication-methods)) (auth-func (and auth-handler (cdr (cdr auth-handler)))) (auth-desc (and auth-handler (car (cdr auth-handler))))) @@ -415,8 +385,8 @@ version.") ) ) ) - (puthash 'state socks-state-authenticated info) - (set-process-filter proc 'socks-filter))) + (process-put proc 'socks-state socks-state-authenticated) + (set-process-filter proc #'socks-filter))) proc))) (defun socks-send-command (proc command atype address port) @@ -428,12 +398,11 @@ version.") (format "%c%s" (length address) address)) (t (error "Unknown address type: %d" atype)))) - (info (gethash proc socks-connections)) request version) - (or info (error "socks-send-command called on non-SOCKS connection %S" - proc)) - (puthash 'state socks-state-waiting info) - (setq version (gethash 'server-protocol info)) + (or (process-get proc 'socks) + (error "socks-send-command called on non-SOCKS connection %S" proc)) + (process-put proc 'socks-state socks-state-waiting) + (setq version (process-get proc 'socks-server-protocol)) (cond ((equal version 'http) (setq request (format (eval-when-compile @@ -447,38 +416,36 @@ version.") (error "Unsupported address type for HTTP: %d" atype))) port))) ((equal version 4) - (setq request (string-make-unibyte - (format - "%c%c%c%c%s%s%c" - version ; version - command ; command - (lsh port -8) ; port, high byte - (- port (lsh (lsh port -8) 8)) ; port, low byte - addr ; address - (user-full-name) ; username - 0 ; terminate username - )))) + (setq request (concat + (unibyte-string + version ; version + command ; command + (ash port -8) ; port, high byte + (logand port #xff)) ; port, low byte + addr ; address + (user-full-name) ; username + "\0"))) ; terminate username ((equal version 5) - (setq request (string-make-unibyte - (format - "%c%c%c%c%s%c%c" + (setq request (concat + (unibyte-string version ; version command ; command 0 ; reserved - atype ; address type - addr ; address - (lsh port -8) ; port, high byte - (- port (lsh (lsh port -8) 8)) ; port, low byte - )))) + atype) ; address type + addr ; address + (unibyte-string + (ash port -8) ; port, high byte + (logand port #xff))))) ; port, low byte (t (error "Unknown protocol version: %d" version))) (process-send-string proc request) - (socks-wait-for-state-change proc info socks-state-waiting) + (socks-wait-for-state-change proc socks-state-waiting) (process-status proc) - (if (= (or (gethash 'reply info) 1) socks-response-success) + (if (= (or (process-get proc 'socks-reply) 1) socks-response-success) nil ; Sweet sweet success! (delete-process proc) - (error "SOCKS: %s" (nth (or (gethash 'reply info) 1) socks-errors))) + (error "SOCKS: %s" + (nth (or (process-get proc 'socks-reply) 1) socks-errors))) proc)) @@ -486,7 +453,7 @@ version.") (defvar socks-noproxy nil "List of regexps matching hosts that we should not socksify connections to") -(defun socks-find-route (host service) +(defun socks-find-route (host _service) (let ((route socks-server) (noproxy socks-noproxy)) (while noproxy @@ -540,37 +507,46 @@ version.") (if udp socks-udp-services socks-tcp-services))) (defun socks-open-network-stream (name buffer host service) - (let* ((route (socks-find-route host service)) - proc info version atype) + (let ((socks-override-functions t)) + (socks--open-network-stream + (lambda (&rest args) + (let ((socks-override-functions nil)) + (apply #'open-network-stream args))) + name buffer host service))) + +(defun socks--open-network-stream (orig-fun name buffer host service &rest params) + (let ((route (and socks-override-functions + (socks-find-route host service)))) (if (not route) - (socks-original-open-network-stream name buffer host service) - (setq proc (socks-open-connection route) - info (gethash proc socks-connections) - version (gethash 'server-protocol info)) - (cond - ((equal version 4) - (setq host (socks-nslookup-host host)) - (if (not (listp host)) - (error "Could not get IP address for: %s" host)) - (setq host (apply 'format "%c%c%c%c" host)) - (setq atype socks-address-type-v4)) - (t - (setq atype socks-address-type-name))) - (socks-send-command proc - socks-connect-command - atype - host - (if (stringp service) - (or - (socks-find-services-entry service) - (error "Unknown service: %s" service)) - service)) - (puthash 'buffer buffer info) - (puthash 'host host info) - (puthash 'service host info) - (set-process-filter proc nil) - (set-process-buffer proc (if buffer (get-buffer-create buffer))) - proc))) + (apply orig-fun name buffer host service params) + ;; FIXME: Obey `params'! + (let* ((proc (socks-open-connection route)) + (version (process-get proc 'socks-server-protocol)) + (atype + (cond + ((equal version 4) + (setq host (socks-nslookup-host host)) + (if (not (listp host)) + (error "Could not get IP address for: %s" host)) + (setq host (apply #'format "%c%c%c%c" host)) + socks-address-type-v4) + (t + socks-address-type-name)))) + (socks-send-command proc + socks-connect-command + atype + host + (if (stringp service) + (or + (socks-find-services-entry service) + (error "Unknown service: %s" service)) + service)) + (process-put proc 'socks-buffer buffer) + (process-put proc 'socks-host host) + (process-put proc 'socks-service host) + (set-process-filter proc nil) + (set-process-buffer proc (if buffer (get-buffer-create buffer))) + proc)))) ;; Authentication modules go here @@ -581,24 +557,25 @@ version.") (defconst socks-username/password-auth-version 1) (defun socks-username/password-auth-filter (proc str) - (let ((info (gethash proc socks-connections))) - (or info (error "socks-filter called on non-SOCKS connection %S" proc)) - (puthash 'scratch (concat (gethash 'scratch info) str) info) - (if (< (length (gethash 'scratch info)) 2) - nil - (puthash 'password-auth-status (aref (gethash 'scratch info) 1) info) - (puthash 'state socks-state-authenticated info)))) + (or (process-get proc 'socks) + (error "socks-filter called on non-SOCKS connection %S" proc)) + (cl-callf (lambda (s) (concat s str)) + (process-get proc 'socks-scratch)) + (if (< (length (process-get proc 'socks-scratch)) 2) + nil + (process-put proc 'socks-password-auth-status + (aref (process-get proc 'socks-scratch) 1)) + (process-put proc 'socks-state socks-state-authenticated))) (defun socks-username/password-auth (proc) - (let* ((info (gethash proc socks-connections)) - (state (gethash 'state info))) + (let ((state (process-get proc 'socks-state))) (if (not socks-password) (setq socks-password (read-passwd (format "Password for %s@%s: " socks-username - (gethash 'server-name info))))) - (puthash 'scratch "" info) - (set-process-filter proc 'socks-username/password-auth-filter) + (process-get proc 'socks-server-name))))) + (process-put proc 'socks-scratch "") + (set-process-filter proc #'socks-username/password-auth-filter) (process-send-string proc (format "%c%c%s%c%s" socks-username/password-auth-version @@ -606,33 +583,32 @@ version.") socks-username (length socks-password) socks-password)) - (socks-wait-for-state-change proc info state) - (= (gethash 'password-auth-status info) 0))) + (socks-wait-for-state-change proc state) + (= (process-get proc 'socks-password-auth-status) 0))) ;; More advanced GSS/API stuff, not yet implemented - volunteers? ;; (socks-register-authentication-method 1 "GSS/API" 'socks-gssapi-auth) -(defun socks-gssapi-auth (proc) +(defun socks-gssapi-auth (_proc) nil) ;; CHAP stuff ;; (socks-register-authentication-method 3 "CHAP" 'socks-chap-auth) -(defun socks-chap-auth (proc) +(defun socks-chap-auth (_proc) nil) ;; CRAM stuff ;; (socks-register-authentication-method 5 "CRAM" 'socks-cram-auth) -(defun socks-cram-auth (proc) +(defun socks-cram-auth (_proc) nil) (defcustom socks-nslookup-program "nslookup" - "If non-NIL then a string naming the nslookup program." - :type '(choice (const :tag "None" :value nil) string) - :group 'socks) + "If non-nil then a string naming the nslookup program." + :type '(choice (const :tag "None" :value nil) string)) (defun socks-nslookup-host (host) "Attempt to resolve the given HOSTNAME using nslookup if possible." @@ -651,8 +627,8 @@ version.") (progn (setq res (buffer-substring (match-beginning 2) (match-end 2)) - res (mapcar 'string-to-number - (socks-split-string res "\\."))))) + res (mapcar #'string-to-number + (split-string res "\\."))))) (kill-buffer (current-buffer))) res) host)) diff --git a/lisp/net/telnet.el b/lisp/net/telnet.el index cf3634f7d92..5d23ee3dce7 100644 --- a/lisp/net/telnet.el +++ b/lisp/net/telnet.el @@ -95,11 +95,22 @@ After this many passes, we stop looking for initial setup data. Should be set to the number of terminal writes telnet will make rejecting one login and prompting again for a username and password.") +(defvar telnet-connect-command nil + "Command used to start the `telnet' (or `rsh') connection.") + (defun telnet-interrupt-subjob () "Interrupt the program running through telnet on the remote host." (interactive) (process-send-string nil telnet-interrupt-string)) +(defun telnet-revert-buffer (ignore-auto noconfirm) + (if buffer-file-name + (let (revert-buffer-function) + (revert-buffer ignore-auto noconfirm)) + (if (or noconfirm + (yes-or-no-p (format "Restart connection? "))) + (apply telnet-connect-command)))) + (defun telnet-c-z () (interactive) (process-send-string nil "\C-z")) @@ -229,6 +240,7 @@ Normally input is edited in Emacs and sent a line at a time." (if port " " "") (or port "") "\n")) (telnet-mode) + (setq-local telnet-connect-command (list 'telnet host port)) (setq comint-input-sender 'telnet-simple-send) (setq telnet-count telnet-initial-count)))) @@ -240,6 +252,7 @@ It has most of the same commands as comint-mode. There is a variable `telnet-interrupt-string' which is the character sent to try to stop execution of a job on the remote host. Data is sent to the remote host when RET is typed." + (setq-local revert-buffer-function 'telnet-revert-buffer) (set (make-local-variable 'window-point-insertion-type) t) (set (make-local-variable 'comint-prompt-regexp) telnet-prompt-pattern) (set (make-local-variable 'comint-use-prompt-regexp) t)) @@ -255,6 +268,7 @@ Normally input is edited in Emacs and sent a line at a time." (switch-to-buffer (make-comint name remote-shell-program nil host)) (set-process-filter (get-process name) 'telnet-initial-filter) (telnet-mode) + (setq-local telnet-connect-command (list 'rsh host)) (setq telnet-count -16))) (provide 'telnet) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index b3aa7ca1bab..fb84aa11085 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -56,7 +56,7 @@ It is used for TCP/IP devices." ;;;###tramp-autoload (defcustom tramp-adb-prompt - "^\\(?:[[:digit:]]*|?\\)?\\(?:[[:alnum:]\e;[]*@?[[:alnum:]]*[^#\\$]*\\)?[#\\$][[:space:]]" + "^[[:digit:]]*|?[[:alnum:]\e;[]*@?[[:alnum:]]*[^#\\$]*[#\\$][[:space:]]" "Regexp used as prompt in almquist shell." :type 'string :version "24.4" @@ -68,7 +68,7 @@ It is used for TCP/IP devices." (defconst tramp-adb-ls-toolbox-regexp (concat - "^[[:space:]]*\\([-[:alpha:]]+\\)" ; \1 permissions + "^[[:space:]]*\\([-.[:alpha:]]+\\)" ; \1 permissions "\\(?:[[:space:]]+[[:digit:]]+\\)?" ; links (Android 7/toybox) "[[:space:]]*\\([^[:space:]]+\\)" ; \2 username "[[:space:]]+\\([^[:space:]]+\\)" ; \3 group @@ -78,22 +78,20 @@ It is used for TCP/IP devices." "Regexp for ls output.") ;;;###tramp-autoload -(add-to-list 'tramp-methods - `(,tramp-adb-method - (tramp-tmpdir "/data/local/tmp") - (tramp-default-port 5555))) +(tramp--with-startup + (add-to-list 'tramp-methods + `(,tramp-adb-method + (tramp-tmpdir "/data/local/tmp") + (tramp-default-port 5555))) -;;;###tramp-autoload -(add-to-list 'tramp-default-host-alist `(,tramp-adb-method nil "")) + (add-to-list 'tramp-default-host-alist `(,tramp-adb-method nil "")) -;;;###tramp-autoload -(eval-after-load 'tramp - '(tramp-set-completion-function - tramp-adb-method '((tramp-adb-parse-device-names "")))) + (tramp-set-completion-function + tramp-adb-method '((tramp-adb-parse-device-names "")))) ;;;###tramp-autoload (defconst tramp-adb-file-name-handler-alist - '((access-file . ignore) + '((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' performed by default handler. @@ -107,11 +105,12 @@ It is used for TCP/IP devices." . tramp-adb-handle-directory-files-and-attributes) (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) - (expand-file-name . tramp-adb-handle-expand-file-name) + (exec-path . tramp-adb-handle-exec-path) + (expand-file-name . tramp-handle-expand-file-name) (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . ignore) (file-attributes . tramp-adb-handle-file-attributes) - (file-directory-p . tramp-adb-handle-file-directory-p) + (file-directory-p . tramp-handle-file-directory-p) (file-equal-p . tramp-handle-file-equal-p) ;; FIXME: This is too sloppy. (file-executable-p . tramp-handle-file-exists-p) @@ -140,7 +139,6 @@ It is used for TCP/IP devices." (file-truename . tramp-adb-handle-file-truename) (file-writable-p . tramp-adb-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) - ;; `find-file-noselect' performed by default handler. ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) @@ -149,6 +147,7 @@ It is used for TCP/IP devices." (make-directory . tramp-adb-handle-make-directory) (make-directory-internal . ignore) (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-file . tramp-adb-handle-process-file) (rename-file . tramp-adb-handle-rename-file) @@ -157,10 +156,11 @@ It is used for TCP/IP devices." (set-file-selinux-context . ignore) (set-file-times . tramp-adb-handle-set-file-times) (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) - (shell-command . tramp-adb-handle-shell-command) - (start-file-process . tramp-adb-handle-start-file-process) + (shell-command . tramp-handle-shell-command) + (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-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) @@ -172,8 +172,9 @@ It is used for TCP/IP devices." ;;;###tramp-autoload (defsubst tramp-adb-file-name-p (filename) "Check if it's a filename for ADB." - (let ((v (tramp-dissect-file-name filename))) - (string= (tramp-file-name-method v) tramp-adb-method))) + (and (tramp-tramp-file-p filename) + (string= (tramp-file-name-method (tramp-dissect-file-name filename)) + tramp-adb-method))) ;;;###tramp-autoload (defun tramp-adb-file-name-handler (operation &rest args) @@ -186,72 +187,21 @@ pass to the OPERATION." (tramp-run-real-handler operation args)))) ;;;###tramp-autoload -(tramp-register-foreign-file-name-handler - 'tramp-adb-file-name-p 'tramp-adb-file-name-handler) +(tramp--with-startup + (tramp-register-foreign-file-name-handler + #'tramp-adb-file-name-p #'tramp-adb-file-name-handler)) ;;;###tramp-autoload (defun tramp-adb-parse-device-names (_ignore) "Return a list of (nil host) tuples allowed to access." - (with-timeout (10) - (with-temp-buffer - ;; `call-process' does not react on timer under MS Windows. - ;; That's why we use `start-process'. - (let ((p (start-process - tramp-adb-program (current-buffer) tramp-adb-program "devices")) - (v (make-tramp-file-name - :method tramp-adb-method :user tramp-current-user - :host tramp-current-host)) - result) - (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (process-put p 'adjust-window-size-function 'ignore) - (set-process-query-on-exit-flag p nil) - (while (process-live-p p) - (accept-process-output p 0.1)) - (accept-process-output p 0.1) - (tramp-message v 6 "\n%s" (buffer-string)) - (goto-char (point-min)) - (while (search-forward-regexp "^\\(\\S-+\\)[[:space:]]+device$" nil t) - (push (list nil (match-string 1)) result)) - - ;; Replace ":" by "#". - (mapc - (lambda (elt) - (setcar - (cdr elt) - (replace-regexp-in-string - ":" tramp-prefix-port-format (car (cdr elt))))) - result) - result)))) - -(defun tramp-adb-handle-expand-file-name (name &optional dir) - "Like `expand-file-name' for Tramp files." - ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". - (setq dir (or dir default-directory "/")) - ;; Unless NAME is absolute, concat DIR and NAME. - (unless (file-name-absolute-p name) - (setq name (concat (file-name-as-directory dir) name))) - ;; If NAME is not a Tramp file, run the real handler. - (if (not (tramp-tramp-file-p name)) - (tramp-run-real-handler 'expand-file-name (list name nil)) - ;; Dissect NAME. - (with-parsed-tramp-file-name name nil - (unless (tramp-run-real-handler 'file-name-absolute-p (list localname)) - (setq localname (concat "/" localname))) - ;; Do normal `expand-file-name' (this does "/./" and "/../"). - ;; `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 - method user domain host port - (tramp-drop-volume-letter - (tramp-run-real-handler - 'expand-file-name (list localname)))))))) - -(defun tramp-adb-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - (eq (tramp-compat-file-attribute-type - (file-attributes (file-truename filename))) - t)) + (delq nil + (mapcar + (lambda (line) + (when (string-match "^\\(\\S-+\\)[[:space:]]+device$" line) + ;; Replace ":" by "#". + `(nil ,(replace-regexp-in-string + ":" tramp-prefix-port-format (match-string 1 line))))) + (tramp-process-lines nil tramp-adb-program "devices")))) (defun tramp-adb-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." @@ -264,18 +214,19 @@ pass to the OPERATION." (goto-char (point-min)) (forward-line) (when (looking-at - (concat "[[:space:]]*[^[:space:]]+" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)")) + (eval-when-compile + (concat "[[:space:]]*[^[:space:]]+" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)"))) ;; The values are given as 1k numbers, so we must change ;; them to number of bytes. - (list (* 1024 (string-to-number (concat (match-string 1) "e0"))) + (list (* 1024 (string-to-number (match-string 1))) ;; The second value is the used size. We need the ;; free size. - (* 1024 (- (string-to-number (concat (match-string 1) "e0")) - (string-to-number (concat (match-string 2) "e0")))) - (* 1024 (string-to-number (concat (match-string 3) "e0"))))))))) + (* 1024 (- (string-to-number (match-string 1)) + (string-to-number (match-string 2)))) + (* 1024 (string-to-number (match-string 3))))))))) ;; This is derived from `tramp-sh-handle-file-truename'. Maybe the ;; code could be shared? @@ -284,10 +235,10 @@ pass to the OPERATION." ;; Preserve trailing "/". (funcall (if (string-equal (file-name-nondirectory filename) "") - 'file-name-as-directory 'identity) + #'file-name-as-directory #'identity) (with-parsed-tramp-file-name (expand-file-name filename) nil (tramp-make-tramp-file-name - method user domain host port + v (with-tramp-file-property v localname "file-truename" (let ((result nil) ; result steps in reverse order (quoted (tramp-compat-file-name-quoted-p localname))) @@ -309,19 +260,15 @@ pass to the OPERATION." (setq thisstep (pop steps)) (tramp-message v 5 "Check %s" - (mapconcat 'identity - (append '("") (reverse result) (list thisstep)) - "/")) + (string-join + (append '("") (reverse result) (list thisstep)) "/")) (setq symlink-target (tramp-compat-file-attribute-type (file-attributes (tramp-make-tramp-file-name - method user domain host port - (mapconcat 'identity - (append '("") - (reverse result) - (list thisstep)) - "/"))))) + v + (string-join + (append '("") (reverse result) (list thisstep)) "/"))))) (cond ((string= "." thisstep) (tramp-message v 5 "Ignoring step `.'")) ((string= ".." thisstep) @@ -356,9 +303,9 @@ pass to the OPERATION." ;; Combine list to form string. (setq result (if result - (mapconcat 'identity (cons "" result) "/") + (string-join (cons "" result) "/") "/")) - (when (and is-dir (or (string= "" result) + (when (and is-dir (or (string-empty-p result) (not (string= (substring result -1) "/")))) (setq result (concat result "/")))) @@ -418,9 +365,9 @@ pass to the OPERATION." ;; no way to handle numeric ids in Androids ash (if (eq id-format 'integer) 0 uid) (if (eq id-format 'integer) 0 gid) - '(0 0) ; atime + tramp-time-dont-know ; atime (date-to-time date) ; mtime - '(0 0) ; ctime + tramp-time-dont-know ; ctime size mod-string ;; fake @@ -469,18 +416,24 @@ pass to the OPERATION." (sort result (lambda (x y) (string< (car x) (car y)))))) (delq nil (mapcar (lambda (x) - (if (or (not match) (string-match match (car x))) + (if (or (not match) (string-match-p match (car x))) x)) result))))))))) (defun tramp-adb-get-ls-command (vec) - "Determine `ls' command at its arguments." + "Determine `ls' command and its arguments." (with-tramp-connection-property vec "ls" (tramp-message vec 5 "Finding a suitable `ls' command") (cond + ;; Support Android derived systems where "ls" command is provided + ;; by GNU Coreutils. Force "ls" to print one column and set + ;; time-style to imitate other "ls" flavors. + ((tramp-adb-send-command-and-check + vec "ls --time-style=long-iso /dev/null") + "ls -1 --time-style=long-iso") ;; Can't disable coloring explicitly for toybox ls command. We - ;; must force "ls" to print just one column. - ((tramp-adb-send-command-and-check vec "toybox") "env COLUMNS=1 ls") + ;; also must force "ls" to print just one column. + ((tramp-adb-send-command-and-check vec "toybox") "ls -1") ;; On CyanogenMod based system BusyBox is used and "ls" output ;; coloring is enabled by default. So we try to disable it when ;; possible. @@ -492,15 +445,15 @@ pass to the OPERATION." "Almquist shell can't handle multiple arguments. Convert (\"-al\") to (\"-a\" \"-l\"). Remove arguments like \"--dired\"." (split-string - (apply 'concat + (apply #'concat (mapcar (lambda (s) (replace-regexp-in-string - "\\(.\\)" " -\\1" (replace-regexp-in-string "^-" "" s))) + "\\(.\\)" " -\\1" (replace-regexp-in-string "^-" "" s))) ;; FIXME: Warning about removed switches (long and non-dash). (delq nil (mapcar (lambda (s) - (and (not (string-match "\\(^--\\|^[^-]\\)" s)) s)) + (and (not (string-match-p "\\(^--\\|^[^-]\\)" s)) s)) switches)))))) (defun tramp-adb-sh-fix-ls-output (&optional sort-by-time) @@ -515,7 +468,7 @@ Emacs dired can't find files." "[[:space:]]\\([[:space:]][0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9][[:space:]]\\)" nil t) (replace-match "0\\1" "\\1" nil) ;; Insert missing "/". - (when (looking-at "[0-9][0-9]:[0-9][0-9][[:space:]]+$") + (when (looking-at-p "[0-9][0-9]:[0-9][0-9][[:space:]]+$") (end-of-line) (insert "/"))) ;; Sort entries. @@ -524,10 +477,10 @@ Emacs dired can't find files." (sort lines (if sort-by-time - 'tramp-adb-ls-output-time-less-p - 'tramp-adb-ls-output-name-less-p)))) + #'tramp-adb-ls-output-time-less-p + #'tramp-adb-ls-output-name-less-p)))) (delete-region (point-min) (point-max)) - (insert " " (mapconcat 'identity sorted-lines "\n "))) + (insert " " (string-join sorted-lines "\n "))) ;; Add final newline. (goto-char (point-max)) (unless (bolp) (insert "\n")))) @@ -536,9 +489,9 @@ Emacs dired can't find files." "Sort \"ls\" output by time, descending." (let (time-a time-b) (string-match tramp-adb-ls-date-regexp a) - (setq time-a (apply 'encode-time (parse-time-string (match-string 0 a)))) + (setq time-a (apply #'encode-time (parse-time-string (match-string 0 a)))) (string-match tramp-adb-ls-date-regexp b) - (setq time-b (apply 'encode-time (parse-time-string (match-string 0 b)))) + (setq time-b (apply #'encode-time (parse-time-string (match-string 0 b)))) (time-less-p time-b time-a))) (defun tramp-adb-ls-output-name-less-p (a b) @@ -557,8 +510,8 @@ Emacs dired can't find files." (let ((par (expand-file-name ".." dir))) (unless (file-directory-p par) (make-directory par parents)))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (unless (or (tramp-adb-send-command-and-check v (format "mkdir %s" (tramp-shell-quote-argument localname))) (and parents (file-directory-p dir))) @@ -568,11 +521,11 @@ Emacs dired can't find files." "Like `delete-directory' for Tramp files." (setq directory (expand-file-name directory)) (with-parsed-tramp-file-name (file-truename directory) nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname)) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname)) (with-parsed-tramp-file-name directory nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (tramp-adb-barf-unless-okay v (format "%s %s" (if recursive "rm -r" "rmdir") @@ -583,8 +536,8 @@ Emacs dired can't find files." "Like `delete-file' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (tramp-adb-barf-unless-okay v (format "rm %s" (tramp-shell-quote-argument localname)) "Couldn't delete %s" filename))) @@ -595,28 +548,27 @@ Emacs dired can't find files." filename (with-parsed-tramp-file-name (expand-file-name directory) nil (with-tramp-file-property v localname "file-name-all-completions" - (save-match-data - (tramp-adb-send-command - v (format "%s -a %s" - (tramp-adb-get-ls-command v) - (tramp-shell-quote-argument localname))) - (mapcar - (lambda (f) - (if (file-directory-p (expand-file-name f directory)) - (file-name-as-directory f) - f)) - (with-current-buffer (tramp-get-buffer v) - (delete-dups - (append - ;; In older Android versions, "." and ".." are not - ;; included. In newer versions (toybox, since Android - ;; 6) they are. We fix this by `delete-dups'. - '("." "..") - (delq - nil - (mapcar - (lambda (l) (and (not (string-match "^[[:space:]]*$" l)) l)) - (split-string (buffer-string) "\n")))))))))))) + (tramp-adb-send-command + v (format "%s -a %s" + (tramp-adb-get-ls-command v) + (tramp-shell-quote-argument localname))) + (mapcar + (lambda (f) + (if (file-directory-p (expand-file-name f directory)) + (file-name-as-directory f) + f)) + (with-current-buffer (tramp-get-buffer v) + (delete-dups + (append + ;; In older Android versions, "." and ".." are not + ;; included. In newer versions (toybox, since Android 6) + ;; they are. We fix this by `delete-dups'. + '("." "..") + (delq + nil + (mapcar + (lambda (l) (and (not (string-match-p "^[[:space:]]*$" l)) l)) + (split-string (buffer-string) "\n"))))))))))) (defun tramp-adb-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." @@ -635,13 +587,11 @@ Emacs dired can't find files." (ignore-errors (delete-file tmpfile)) (tramp-error v 'file-error "Cannot make local copy of file `%s'" filename)) - (set-file-modes - tmpfile - (logior (or (file-modes filename) 0) (string-to-number "0400" 8)))) + (set-file-modes tmpfile (logior (or (file-modes filename) 0) #o0400))) tmpfile))) (defun tramp-adb-handle-file-writable-p (filename) - "Like `tramp-sh-handle-file-writable-p'. + "Like `file-writable-p' for Tramp files. But handle the case, if the \"test\" command is not available." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-writable-p" @@ -677,17 +627,15 @@ But handle the case, if the \"test\" command is not available." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (let* ((curbuf (current-buffer)) (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) (string-to-number "0600" 8)))) + (set-file-modes tmpfile (logior (or (file-modes tmpfile) 0) #o0600))) (tramp-run-real-handler - 'write-region (list start end tmpfile append 'no-message lockname)) + #'write-region (list start end tmpfile append 'no-message lockname)) (with-tramp-progress-reporter v 3 (format-message "Moving tmp file `%s' to `%s'" tmpfile filename) @@ -717,23 +665,35 @@ But handle the case, if the \"test\" command is not available." (defun tramp-adb-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (tramp-adb-send-command-and-check v (format "chmod %o %s" mode localname)))) (defun tramp-adb-handle-set-file-times (filename &optional time) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) - (let ((time (if (or (null time) (equal time '(0 0))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (let ((time (if (or (null time) + (tramp-compat-time-equal-p time tramp-time-doesnt-exist) + (tramp-compat-time-equal-p time tramp-time-dont-know)) (current-time) - time))) + time)) + (quoted-name (tramp-shell-quote-argument localname))) + ;; Older versions of toybox 'touch' mishandle nanoseconds and/or + ;; trailing "Z", so fall back on plain seconds if nanoseconds+Z + ;; fails. Also, fall back on old POSIX 'touch -t' if 'touch -d' + ;; (introduced in POSIX.1-2008) fails. (tramp-adb-send-command-and-check - ;; Use shell arithmetic because of Emacs integer size limit. - v (format "touch -t $(( %d * 65536 + %d )) %s" - (car time) (cadr time) - (tramp-shell-quote-argument localname)))))) + v (format (concat "touch -d %s %s 2>/dev/null || " + "touch -d %s %s 2>/dev/null || " + "touch -t %s %s") + (format-time-string "%Y-%m-%dT%H:%M:%S.%NZ" time t) + quoted-name + (format-time-string "%Y-%m-%dT%H:%M:%S" time t) + quoted-name + (format-time-string "%Y%m%d%H%M.%S" time t) + quoted-name))))) (defun tramp-adb-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -749,20 +709,21 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname))) (with-parsed-tramp-file-name (if t1 filename newname) nil + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + (with-tramp-progress-reporter v 0 (format "Copying %s to %s" filename newname) - (if (and t1 t2 (tramp-equal-remote filename newname)) - (let ((l1 (file-remote-p filename 'localname)) - (l2 (file-remote-p newname 'localname))) - (when (and (not ok-if-already-exists) - (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) + (let ((l1 (tramp-compat-file-local-name filename)) + (l2 (tramp-compat-file-local-name newname))) ;; We must also flush the cache of the directory, ;; because `file-attributes' reads the values from ;; there. - (tramp-flush-file-property v (file-name-directory l2)) - (tramp-flush-file-property v l2) + (tramp-flush-file-properties v (file-name-directory l2)) + (tramp-flush-file-properties v l2) ;; Short track. (tramp-adb-barf-unless-okay v (format @@ -796,8 +757,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; We must also flush the cache of the directory, ;; because `file-attributes' reads the values from ;; there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties + v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (when (tramp-adb-execute-adb-command v "push" (tramp-compat-file-name-unquote filename) @@ -827,23 +789,24 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname))) (with-parsed-tramp-file-name (if t1 filename newname) nil + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + (with-tramp-progress-reporter v 0 (format "Renaming %s to %s" filename newname) - (if (and t1 t2 (tramp-equal-remote filename newname) (not (file-directory-p filename))) - (let ((l1 (file-remote-p filename 'localname)) - (l2 (file-remote-p newname 'localname))) - (when (and (not ok-if-already-exists) - (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) + (let ((l1 (tramp-compat-file-local-name filename)) + (l2 (tramp-compat-file-local-name newname))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory l1)) - (tramp-flush-file-property v l1) - (tramp-flush-file-property v (file-name-directory l2)) - (tramp-flush-file-property v l2) + (tramp-flush-file-properties v (file-name-directory l1)) + (tramp-flush-file-properties v l1) + (tramp-flush-file-properties v (file-name-directory l2)) + (tramp-flush-file-properties v l2) ;; Short track. (tramp-adb-barf-unless-okay v (format @@ -867,7 +830,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (with-parsed-tramp-file-name default-directory nil (let (command input tmpinput stderr tmpstderr outbuf ret) ;; Compute command. - (setq command (mapconcat 'tramp-shell-quote-argument + (setq command (mapconcat #'tramp-shell-quote-argument (cons program args) " ")) ;; Determine input. (if (null infile) @@ -878,8 +841,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq input (with-parsed-tramp-file-name infile nil localname)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) - tmpinput (tramp-make-tramp-file-name - method user domain host port input)) + tmpinput (tramp-make-tramp-file-name v input)) (copy-file infile tmpinput t))) (when input (setq command (format "%s <%s" command input))) @@ -912,8 +874,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; 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 - method user domain host port stderr)))) + tmpstderr (tramp-make-tramp-file-name v stderr)))) ;; stderr to be discarded. ((null (cadr destination)) (setq stderr "/dev/null")))) @@ -957,167 +918,143 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when tmpinput (delete-file tmpinput)) (unless process-file-side-effects - (tramp-flush-directory-property v "")) + (tramp-flush-directory-properties v "")) ;; Return exit status. (if (equal ret -1) (keyboard-quit) ret)))) -(defun tramp-adb-handle-shell-command - (command &optional output-buffer error-buffer) - "Like `shell-command' for Tramp files." - (let* ((asynchronous (string-match "[ \t]*&[ \t]*\\'" command)) - ;; We cannot use `shell-file-name' and `shell-command-switch', - ;; they are variables of the local host. - (args (list "sh" "-c" (substring command 0 asynchronous))) - current-buffer-p - (output-buffer - (cond - ((bufferp output-buffer) output-buffer) - ((stringp output-buffer) (get-buffer-create output-buffer)) - (output-buffer - (setq current-buffer-p t) - (current-buffer)) - (t (get-buffer-create - (if asynchronous - "*Async Shell Command*" - "*Shell Command Output*"))))) - (error-buffer - (cond - ((bufferp error-buffer) error-buffer) - ((stringp error-buffer) (get-buffer-create error-buffer)))) - (buffer - (if (and (not asynchronous) error-buffer) - (with-parsed-tramp-file-name default-directory nil - (list output-buffer (tramp-make-tramp-temp-file v))) - output-buffer)) - (p (get-buffer-process output-buffer))) - - ;; Check whether there is another process running. Tramp does not - ;; support 2 (asynchronous) processes in parallel. - (when p - (if (yes-or-no-p "A command is running. Kill it? ") - (ignore-errors (kill-process p)) - (tramp-compat-user-error p "Shell command in progress"))) - - (if current-buffer-p - (progn - (barf-if-buffer-read-only) - (push-mark nil t)) - (with-current-buffer output-buffer - (setq buffer-read-only nil) - (erase-buffer))) - - (if (and (not current-buffer-p) (integerp asynchronous)) - (prog1 - ;; Run the process. - (apply 'start-file-process "*Async Shell*" buffer args) - ;; Display output. - (pop-to-buffer output-buffer) - (setq mode-line-process '(":%s")) - (shell-mode)) - - (prog1 - ;; Run the process. - (apply 'process-file (car args) nil buffer nil (cdr args)) - ;; Insert error messages if they were separated. - (when (listp buffer) - (with-current-buffer error-buffer - (insert-file-contents (cadr buffer))) - (delete-file (cadr buffer))) - (if current-buffer-p - ;; This is like exchange-point-and-mark, but doesn't - ;; activate the mark. It is cleaner to avoid activation, - ;; even though the command loop would deactivate the mark - ;; because we inserted text. - (goto-char (prog1 (mark t) - (set-marker (mark-marker) (point) - (current-buffer)))) - ;; There's some output, display it. - (when (with-current-buffer output-buffer (> (point-max) (point-min))) - (display-message-or-buffer output-buffer))))))) - ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once ;; connection has been setup. -(defun tramp-adb-handle-start-file-process (name buffer program &rest args) - "Like `start-file-process' for Tramp files." - (with-parsed-tramp-file-name default-directory nil - ;; When PROGRAM is nil, we should provide a tty. This is not - ;; possible here. - (unless (stringp program) - (tramp-error v 'file-error "PROGRAM must be a string")) - - (let* ((buffer - (if buffer - (get-buffer-create buffer) - ;; BUFFER can be nil. We use a temporary buffer. - (generate-new-buffer tramp-temp-buffer-name))) - (command - (format "cd %s; %s" - (tramp-shell-quote-argument localname) - (mapconcat 'tramp-shell-quote-argument - (cons program args) " "))) - (tramp-process-connection-type - (or (null program) tramp-process-connection-type)) - (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) - (name1 name) - (i 0) - ;; We do not want to run timers. - timer-list timer-idle-list) - - (while (get-process name1) - ;; NAME must be unique as process name. - (setq i (1+ i) - name1 (format "%s<%d>" name i))) - (setq name name1) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) - - (with-current-buffer (tramp-get-connection-buffer v) - (unwind-protect - ;; We catch this event. Otherwise, `start-process' could - ;; be called on the local host. - (save-excursion - (save-restriction - ;; Activate narrowing in order to save BUFFER - ;; contents. Clear also the modification time; - ;; otherwise we might be interrupted by - ;; `verify-visited-file-modtime'. - (let ((buffer-undo-list t) - (buffer-read-only nil) - (mark (point))) - (clear-visited-file-modtime) - (narrow-to-region (point-max) (point-max)) - ;; We call `tramp-adb-maybe-open-connection', in - ;; order to cleanup the prompt afterwards. - (tramp-adb-maybe-open-connection v) - (widen) - (delete-region mark (point)) - (narrow-to-region (point-max) (point-max)) - ;; Send the command. - (let ((tramp-adb-prompt (regexp-quote command))) - (tramp-adb-send-command v command)) - (let ((p (tramp-get-connection-process v))) - ;; Set query flag and process marker for this - ;; process. We ignore errors, because the process - ;; could have finished already. - (ignore-errors - (set-process-query-on-exit-flag p t) - (set-marker (process-mark p) (point))) - ;; Return process. - p)))) - - ;; Save exit. - (if (string-match tramp-temp-buffer-name (buffer-name)) - (ignore-errors - (set-process-buffer (tramp-get-connection-process v) nil) - (kill-buffer (current-buffer))) - (set-buffer-modified-p bmp)) - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil)))))) +(defun tramp-adb-handle-make-process (&rest args) + "Like `make-process' for Tramp files." + (when args + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let ((name (plist-get args :name)) + (buffer (plist-get args :buffer)) + (command (plist-get args :command)) + (coding (plist-get args :coding)) + (noquery (plist-get args :noquery)) + (connection-type (plist-get args :connection-type)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + (stderr (plist-get args :stderr))) + (unless (stringp name) + (signal 'wrong-type-argument (list #'stringp name))) + (unless (or (null buffer) (bufferp buffer) (stringp buffer)) + (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (consp command) + (signal 'wrong-type-argument (list #'consp command))) + (unless (or (null coding) + (and (symbolp coding) (memq coding coding-system-list)) + (and (consp coding) + (memq (car coding) coding-system-list) + (memq (cdr coding) coding-system-list))) + (signal 'wrong-type-argument (list #'symbolp coding))) + (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (signal 'wrong-type-argument (list #'symbolp connection-type))) + (unless (or (null filter) (functionp filter)) + (signal 'wrong-type-argument (list #'functionp filter))) + (unless (or (null sentinel) (functionp sentinel)) + (signal 'wrong-type-argument (list #'functionp sentinel))) + (unless (or (null stderr) (bufferp stderr) (stringp stderr)) + (signal 'wrong-type-argument (list #'stringp stderr))) + + (let* ((buffer + (if buffer + (get-buffer-create buffer) + ;; BUFFER can be nil. We use a temporary buffer. + (generate-new-buffer tramp-temp-buffer-name))) + (program (car command)) + (args (cdr command)) + (command + (format "cd %s && exec %s" + (tramp-shell-quote-argument localname) + (mapconcat #'tramp-shell-quote-argument + (cons program args) " "))) + (tramp-process-connection-type + (or (null program) tramp-process-connection-type)) + (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) + (name1 name) + (i 0)) + + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + (setq name name1) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) + + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + ;; We catch this event. Otherwise, `make-process' + ;; could be called on the local host. + (save-excursion + (save-restriction + ;; Activate narrowing in order to save BUFFER + ;; contents. Clear also the modification time; + ;; otherwise we might be interrupted by + ;; `verify-visited-file-modtime'. + (let ((buffer-undo-list t) + (inhibit-read-only t)) + (clear-visited-file-modtime) + (narrow-to-region (point-max) (point-max)) + ;; We call `tramp-adb-maybe-open-connection', in + ;; order to cleanup the prompt afterwards. + (tramp-adb-maybe-open-connection v) + (delete-region (point-min) (point-max)) + ;; Send the command. + (let* ((p (tramp-get-connection-process v))) + (tramp-adb-send-command v command nil t) ; nooutput + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + ;; Set query flag and process marker for this + ;; process. We ignore errors, because the + ;; process could have finished already. + (ignore-errors + (set-process-query-on-exit-flag p (null noquery)) + (set-marker (process-mark p) (point))) + ;; Read initial output. Remove the first line, + ;; which is the command echo. + (while + (progn + (goto-char (point-min)) + (not (re-search-forward "[\n]" nil t))) + (tramp-accept-process-output p 0)) + (delete-region (point-min) (point)) + ;; Return process. + p)))) + + ;; Save exit. + (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (ignore-errors + (set-process-buffer (tramp-get-connection-process v) nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp)) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer")))))))) + +(defun tramp-adb-handle-exec-path () + "Like `exec-path' for Tramp files." + (append + (with-parsed-tramp-file-name default-directory nil + (with-tramp-connection-property v "remote-path" + (tramp-adb-send-command v "echo \\\"$PATH\\\"") + (split-string + (with-current-buffer (tramp-get-connection-buffer v) + ;; Read the expression. + (goto-char (point-min)) + (read (current-buffer))) + ":" 'omit))) + ;; The equivalent to `exec-directory'. + `(,(tramp-compat-file-local-name default-directory)))) (defun tramp-adb-get-device (vec) "Return full host name from VEC to be used in shell execution. @@ -1126,11 +1063,11 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" ;; Sometimes this is called before there is a connection process ;; yet. In order to work with the connection cache, we flush all ;; unwanted entries first. - (tramp-flush-connection-property nil) + (tramp-flush-connection-properties nil) (with-tramp-connection-property (tramp-get-connection-process vec) "device" (let* ((host (tramp-file-name-host vec)) (port (tramp-file-name-port-or-default vec)) - (devices (mapcar 'cadr (tramp-adb-parse-device-names nil)))) + (devices (mapcar #'cadr (tramp-adb-parse-device-names nil)))) (replace-regexp-in-string tramp-prefix-port-format ":" (cond ((member host devices) host) @@ -1167,7 +1104,7 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" (prog1 (unless (zerop - (apply 'tramp-call-process vec tramp-adb-program nil t nil args)) + (apply #'tramp-call-process vec tramp-adb-program nil t nil args)) (buffer-string)) (tramp-message vec 6 "%s" (buffer-string))))) @@ -1179,24 +1116,27 @@ This happens for Android >= 4.0." ;; Connection functions -(defun tramp-adb-send-command (vec command) +(defun tramp-adb-send-command (vec command &optional neveropen nooutput) "Send the COMMAND to connection VEC." - (tramp-adb-maybe-open-connection vec) + (unless neveropen (tramp-adb-maybe-open-connection vec)) (tramp-message vec 6 "%s" command) (tramp-send-string vec command) - ;; fixme: Race condition - (tramp-adb-wait-for-output (tramp-get-connection-process vec)) - (with-current-buffer (tramp-get-connection-buffer vec) - (save-excursion - (goto-char (point-min)) - ;; We can't use stty to disable echo of command. - (delete-matching-lines (regexp-quote command)) - ;; When the local machine is W32, there are still trailing ^M. - ;; There must be a better solution by setting the correct coding - ;; system, but this requires changes in core Tramp. - (goto-char (point-min)) - (while (re-search-forward "\r+$" nil t) - (replace-match "" nil nil))))) + (unless nooutput + ;; FIXME: Race condition. + (tramp-adb-wait-for-output (tramp-get-connection-process vec)) + (with-current-buffer (tramp-get-connection-buffer vec) + (save-excursion + (goto-char (point-min)) + ;; We can't use stty to disable echo of command. stty is said + ;; to be added to toybox 0.7.6. busybox shall have it, but this + ;; isn't used any longer for Android. + (delete-matching-lines (regexp-quote command)) + ;; When the local machine is W32, there are still trailing ^M. + ;; There must be a better solution by setting the correct coding + ;; system, but this requires changes in core Tramp. + (goto-char (point-min)) + (while (re-search-forward "\r+$" nil t) + (replace-match "" nil nil)))))) (defun tramp-adb-send-command-and-check (vec command) "Run COMMAND and check its exit status. @@ -1215,51 +1155,43 @@ the exit status is not equal 0, and t otherwise." (skip-chars-forward "^ ") (prog1 (zerop (read (current-buffer))) - (let (buffer-read-only) + (let ((inhibit-read-only t)) (delete-region (match-beginning 0) (point-max)))))) (defun tramp-adb-barf-unless-okay (vec command fmt &rest args) "Run COMMAND, check exit status, throw error if exit status not okay. FMT and ARGS are passed to `error'." (unless (tramp-adb-send-command-and-check vec command) - (apply 'tramp-error vec 'file-error fmt args))) + (apply #'tramp-error vec 'file-error fmt args))) (defun tramp-adb-wait-for-output (proc &optional timeout) "Wait for output from remote command." (unless (buffer-live-p (process-buffer proc)) (delete-process proc) (tramp-error proc 'file-error "Process `%s' not available, try again" proc)) - (with-current-buffer (process-buffer proc) - (if (tramp-wait-for-regexp - proc timeout - (tramp-get-connection-property proc "prompt" tramp-adb-prompt)) - (let (buffer-read-only) - (goto-char (point-min)) - ;; ADB terminal sends "^H" sequences. - (when (re-search-forward "<\b+" (point-at-eol) t) - (forward-line 1) - (delete-region (point-min) (point))) - ;; Delete the prompt. - (goto-char (point-min)) - (when (re-search-forward - (tramp-get-connection-property proc "prompt" tramp-adb-prompt) - (point-at-eol) t) - (forward-line 1) - (delete-region (point-min) (point))) - (goto-char (point-max)) - (re-search-backward - (tramp-get-connection-property proc "prompt" tramp-adb-prompt) nil t) - (delete-region (point) (point-max))) - (if timeout + (let ((prompt (tramp-get-connection-property proc "prompt" tramp-adb-prompt))) + (with-current-buffer (process-buffer proc) + (if (tramp-wait-for-regexp proc timeout prompt) + (let ((inhibit-read-only t)) + (goto-char (point-min)) + ;; ADB terminal sends "^H" sequences. + (when (re-search-forward "<\b+" (point-at-eol) t) + (forward-line 1) + (delete-region (point-min) (point))) + ;; Delete the prompt. + (goto-char (point-min)) + (when (re-search-forward prompt (point-at-eol) t) + (forward-line 1) + (delete-region (point-min) (point))) + (goto-char (point-max)) + (re-search-backward prompt nil t) + (delete-region (point) (point-max))) + (if timeout + (tramp-error + proc 'file-error + "[[Remote prompt `%s' not found in %d secs]]" prompt timeout) (tramp-error - proc 'file-error - "[[Remote adb prompt `%s' not found in %d secs]]" - (tramp-get-connection-property proc "prompt" tramp-adb-prompt) - timeout) - (tramp-error - proc 'file-error - "[[Remote prompt `%s' not found]]" - (tramp-get-connection-property proc "prompt" tramp-adb-prompt)))))) + proc 'file-error "[[Remote prompt `%s' not found]]" prompt)))))) (defun tramp-adb-maybe-open-connection (vec) "Maybe open a connection VEC. @@ -1271,10 +1203,6 @@ connection if a previous connection has died for some reason." (user (tramp-file-name-user vec)) (device (tramp-adb-get-device vec))) - ;; Set variables for proper tracing in `tramp-adb-parse-device-names'. - (setq tramp-current-user (tramp-file-name-user vec) - tramp-current-host (tramp-file-name-host vec)) - ;; Maybe we know already that "su" is not supported. We cannot ;; use a connection property, because we have not checked yet ;; whether it is still the same device. @@ -1282,6 +1210,14 @@ connection if a previous connection has died for some reason." (tramp-error vec 'file-error "Cannot switch to user `%s'" user)) (unless (process-live-p p) + ;; During completion, don't reopen a new connection. 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. + (when (and (tramp-completion-mode-p) + (null (get-process (tramp-buffer-name vec)))) + (throw 'non-essential 'non-essential)) + (save-match-data (when (and p (processp p)) (delete-process p)) (if (zerop (length device)) @@ -1294,18 +1230,24 @@ connection if a previous connection has died for some reason." (list "shell"))) (p (let ((default-directory (tramp-compat-temporary-file-directory))) - (apply 'start-process (tramp-get-connection-name vec) buf + (apply #'start-process (tramp-get-connection-name vec) buf tramp-adb-program args))) (prompt (md5 (concat (prin1-to-string process-environment) (current-time-string))))) (tramp-message - vec 6 "%s" (mapconcat 'identity (process-command p) " ")) - ;; Wait for initial prompt. + vec 6 "%s" (string-join (process-command p) " ")) + ;; Wait for initial prompt. On some devices, it needs an + ;; initial RET, in order to get it. + (sleep-for 0.1) + (tramp-send-string vec tramp-rsh-end-of-line) (tramp-adb-wait-for-output p 30) (unless (process-live-p p) - (tramp-error vec 'file-error "Terminated!")) - (tramp-set-connection-property p "vector" vec) - (process-put p 'adjust-window-size-function 'ignore) + (tramp-error vec 'file-error "Terminated!")) + + ;; Set sentinel and query flag. Initialize variables. + (set-process-sentinel p #'tramp-process-sentinel) + (process-put p 'vector vec) + (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) ;; Change prompt. @@ -1343,28 +1285,34 @@ connection if a previous connection has died for some reason." (tramp-adb-send-command vec (format "su %s" user)) (unless (tramp-adb-send-command-and-check vec nil) (delete-process p) - (tramp-set-file-property vec "" "su-command-p" nil) + (tramp-flush-file-property vec "" "su-command-p") (tramp-error vec 'file-error "Cannot switch to user `%s'" user))) - ;; Set "remote-path" connection property. This is needed - ;; for eshell. - (tramp-adb-send-command vec "echo \\\"$PATH\\\"") - (tramp-set-connection-property - vec "remote-path" - (split-string - (with-current-buffer (tramp-get-connection-buffer vec) - ;; Read the expression. - (goto-char (point-min)) - (read (current-buffer))) - ":" 'omit)) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec) ;; Mark it as connected. (tramp-set-connection-property p "connected" t))))))) +;; Default settings for connection-local variables. +(defconst tramp-adb-connection-local-default-profile + '((shell-file-name . "/system/bin/sh") + (shell-command-switch . "-c")) + "Default connection-local variables for remote adb connections.") + +;; `connection-local-set-profile-variables' and +;; `connection-local-set-profiles' exists since Emacs 26.1. +(with-eval-after-load 'shell + (tramp-compat-funcall + 'connection-local-set-profile-variables + 'tramp-adb-connection-local-default-profile + tramp-adb-connection-local-default-profile) + (tramp-compat-funcall + 'connection-local-set-profiles + `(:application tramp :protocol ,tramp-adb-method) + 'tramp-adb-connection-local-default-profile)) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-adb 'force))) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el new file mode 100644 index 00000000000..82fd327770b --- /dev/null +++ b/lisp/net/tramp-archive.el @@ -0,0 +1,667 @@ +;;; tramp-archive.el --- Tramp archive manager -*- lexical-binding:t -*- + +;; Copyright (C) 2017-2019 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; Keywords: comm, processes +;; Package: tramp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Access functions for file archives. This is possible only on +;; machines which have installed the virtual file system for the Gnome +;; Desktop (GVFS). Internally, file archives are mounted via the GVFS +;; "archive" method. + +;; A file archive is a regular file of kind "/path/to/dir/file.EXT". +;; The extension ".EXT" identifies the type of the file archive. A +;; file inside a file archive, called archive file name, has the name +;; "/path/to/dir/file.EXT/dir/file". + +;; Most of the magic file name operations are implemented for archive +;; file names, exceptions are all operations which write into a file +;; archive, and process related operations. Therefore, functions like + +;; (copy-file "/path/to/dir/file.tar/dir/file" "/somewhere/else") + +;; work out of the box. This is also true for file name completion, +;; and for libraries like `dired' or `ediff', which accept archive +;; file names as well. + +;; File archives are identified by the file name extension ".EXT". +;; Since GVFS uses internally the library libarchive(3), all suffixes, +;; which are accepted by this library, work also for archive file +;; names. Accepted suffixes are listed in the constant +;; `tramp-archive-suffixes'. They are + +;; * ".7z" - 7-Zip archives +;; * ".apk" - Android package kits +;; * ".ar" - UNIX archiver formats +;; * ".cab", ".CAB" - Microsoft Windows cabinets +;; * ".cpio" - CPIO archives +;; * ".deb" - Debian packages +;; * ".depot" - HP-UX SD depots +;; * ".exe" - Self extracting Microsoft Windows EXE files +;; * ".iso" - ISO 9660 images +;; * ".jar" - Java archives +;; * ".lzh", ".LZH" - Microsoft Windows compressed LHA archives +;; * ".msu", ".MSU" - Microsoft Windows Update packages +;; * ".mtree" - BSD mtree format +;; * ".odb" ".odf" ".odg" ".odp" ".ods" ".odt" - OpenDocument formats +;; * ".pax" - Posix archives +;; * ".rar" - RAR archives +;; * ".rpm" - Red Hat packages +;; * ".shar" - Shell archives +;; * ".tar", ".tbz", ".tgz", ".tlz", ".txz" - (Compressed) tape archives +;; * ".warc" - Web archives +;; * ".xar" - macOS XAR archives +;; * ".xpi" - XPInstall Mozilla addons +;; * ".xps" - Open XML Paper Specification (OpenXPS) documents +;; * ".zip", ".ZIP" - ZIP archives + +;; File archives could also be compressed, identified by an additional +;; compression suffix. Valid compression suffixes are listed in the +;; constant `tramp-archive-compression-suffixes'. They are ".bz2", +;; ".gz", ".lrz", ".lz", ".lz4", ".lzma", ".lzo", ".uu", ".xz", ".Z", +;; and ".zst". A valid archive file name would be +;; "/path/to/dir/file.tar.gz/dir/file". Even several suffixes in a +;; row are possible, like "/path/to/dir/file.tar.gz.uu/dir/file". + +;; An archive file name could be a remote file name, as in +;; "/ftp:anonymous@ftp.gnu.org:/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL". +;; Since all file operations are mapped internally to GVFS operations, +;; remote file names supported by tramp-gvfs.el perform better, +;; because no local copy of the file archive must be downloaded first. +;; For example, "/sftp:user@host:..." performs better than the similar +;; "/scp:user@host:...". See the constant +;; `tramp-archive-all-gvfs-methods' for a complete list of +;; tramp-gvfs.el supported method names. + +;; If `url-handler-mode' is enabled, archives could be visited via +;; URLs, like "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL". +;; This allows complex file operations like + +;; (ediff-directories +;; "https://ftp.gnu.org/gnu/tramp/tramp-2.3.1.tar.gz/tramp-2.3.1" +;; "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/tramp-2.3.2" "") + +;; It is even possible to access file archives in file archives, as + +;; (find-file +;; "http://ftp.debian.org/debian/pool/main/c/coreutils/coreutils_8.28-1_amd64.deb/control.tar.gz/control") + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +;; Sometimes, compilation fails with "Variable binding depth exceeds +;; max-specpdl-size". +(eval-and-compile + (let ((max-specpdl-size (* 2 max-specpdl-size))) (require 'tramp-gvfs))) + +(autoload 'dired-uncache "dired") +(autoload 'url-tramp-convert-url-to-tramp "url-tramp") +(defvar url-handler-mode-hook) +(defvar url-handler-regexp) +(defvar url-tramp-protocols) + +;; We cannot check `tramp-gvfs-enabled' in loaddefs.el, because this +;; would load Tramp. So we make a cheaper check. +;;;###autoload +(defvar tramp-archive-enabled (featurep 'dbusbind) + "Non-nil when file archive support is available.") + +;; After loading tramp-gvfs.el, we know it better. +(setq tramp-archive-enabled tramp-gvfs-enabled) + +;; <https://github.com/libarchive/libarchive/wiki/LibarchiveFormats> +;; Note: "arc" and "zoo" are supported by `archive-mode', but they +;; don't work here. +;;;###autoload +(defconst tramp-archive-suffixes + ;; "cab", "lzh", "msu" and "zip" are included with lower and upper + ;; letters, because Microsoft Windows provides them often with + ;; capital letters. + '("7z" ;; 7-Zip archives. + "apk" ;; Android package kits. Not in libarchive testsuite. + "ar" ;; UNIX archiver formats. + "cab" "CAB" ;; Microsoft Windows cabinets. + "cpio" ;; CPIO archives. + "deb" ;; Debian packages. Not in libarchive testsuite. + "depot" ;; HP-UX SD depot. Not in libarchive testsuite. + "exe" ;; Self extracting Microsoft Windows EXE files. + "iso" ;; ISO 9660 images. + "jar" ;; Java archives. Not in libarchive testsuite. + "lzh" "LZH" ;; Microsoft Windows compressed LHA archives. + "msu" "MSU" ;; Microsoft Windows Update packages. Not in testsuite. + "mtree" ;; BSD mtree format. + "odb" "odf" "odg" "odp" "ods" "odt" ;; OpenDocument formats. Not in testsuite. + "pax" ;; Posix archives. + "rar" ;; RAR archives. + "rpm" ;; Red Hat packages. + "shar" ;; Shell archives. Not in libarchive testsuite. + "tar" "tbz" "tgz" "tlz" "txz" "tzst" ;; (Compressed) tape archives. + "warc" ;; Web archives. + "xar" ;; macOS XAR archives. Not in libarchive testsuite. + "xpi" ;; XPInstall Mozilla addons. Not in libarchive testsuite. + "xps" ;; Open XML Paper Specification (OpenXPS) documents. + "zip" "ZIP") ;; ZIP archives. + "List of suffixes which indicate a file archive. +It must be supported by libarchive(3).") + +;; <http://unix-memo.readthedocs.io/en/latest/vfs.html> +;; read and write: tar, cpio, pax , gzip , zip, bzip2, xz, lzip, lzma, ar, mtree, iso9660, compress. +;; read only: 7-Zip, mtree, xar, lha/lzh, rar, microsoft cab. + +;;;###autoload +(defconst tramp-archive-compression-suffixes + '("bz2" "gz" "lrz" "lz" "lz4" "lzma" "lzo" "uu" "xz" "Z" "zst") + "List of suffixes which indicate a compressed file. +It must be supported by libarchive(3).") + +;; The definition of `tramp-archive-file-name-regexp' contains calls +;; to `regexp-opt', which cannot be autoloaded while loading +;; loaddefs.el. So we use a macro, which is evaluated only when needed. +;;;###autoload +(progn (defmacro tramp-archive-autoload-file-name-regexp () + "Regular expression matching archive file names." + '(concat + "\\`" "\\(" ".+" "\\." + ;; Default suffixes ... + (regexp-opt tramp-archive-suffixes) + ;; ... with compression. + "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*" + "\\)" ;; \1 + "\\(" "/" ".*" "\\)" "\\'"))) ;; \2 + +;; In older Emacsen (prior 27.1), `tramp-archive-autoload-file-name-regexp' +;; is not autoloaded. So we cannot expect it to be known in +;; tramp-loaddefs.el. But it exists, when tramp-archive.el is loaded. +;;;###tramp-autoload +(defconst tramp-archive-file-name-regexp + (ignore-errors (tramp-archive-autoload-file-name-regexp)) + "Regular expression matching archive file names.") + +;;;###tramp-autoload +(defconst tramp-archive-method "archive" + "Method name for archives in GVFS.") + +(defconst tramp-archive-all-gvfs-methods + (cons tramp-archive-method + (let ((values (cdr (cadr (get 'tramp-gvfs-methods 'custom-type))))) + (setq values (mapcar #'last values) + values (mapcar #'car values)))) + "List of all methods `tramp-gvfs-methods' offers.") + + +;; New handlers should be added here. +;;;###tramp-autoload +(defconst tramp-archive-file-name-handler-alist + '((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. + (copy-file . tramp-archive-handle-copy-file) + (delete-directory . tramp-archive-handle-not-implemented) + (delete-file . tramp-archive-handle-not-implemented) + ;; `diff-latest-backup-file' performed by default handler. + (directory-file-name . tramp-archive-handle-directory-file-name) + (directory-files . tramp-handle-directory-files) + (directory-files-and-attributes + . tramp-handle-directory-files-and-attributes) + (dired-compress-file . tramp-archive-handle-not-implemented) + (dired-uncache . tramp-archive-handle-dired-uncache) + (exec-path . ignore) + ;; `expand-file-name' performed by default handler. + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) + (file-acl . ignore) + (file-attributes . tramp-archive-handle-file-attributes) + (file-directory-p . tramp-handle-file-directory-p) + (file-equal-p . tramp-handle-file-equal-p) + (file-executable-p . tramp-archive-handle-file-executable-p) + (file-exists-p . tramp-handle-file-exists-p) + (file-in-directory-p . tramp-handle-file-in-directory-p) + (file-local-copy . tramp-archive-handle-file-local-copy) + (file-modes . tramp-handle-file-modes) + (file-name-all-completions . tramp-archive-handle-file-name-all-completions) + ;; `file-name-as-directory' performed by default handler. + (file-name-case-insensitive-p . ignore) + (file-name-completion . tramp-handle-file-name-completion) + ;; `file-name-directory' performed by default handler. + ;; `file-name-nondirectory' performed by default handler. + ;; `file-name-sans-versions' performed by default handler. + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) + (file-notify-add-watch . ignore) + (file-notify-rm-watch . ignore) + (file-notify-valid-p . ignore) + (file-ownership-preserved-p . ignore) + (file-readable-p . tramp-archive-handle-file-readable-p) + (file-regular-p . tramp-handle-file-regular-p) + ;; `file-remote-p' performed by default handler. + (file-selinux-context . tramp-handle-file-selinux-context) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-system-info . tramp-archive-handle-file-system-info) + (file-truename . tramp-archive-handle-file-truename) + (file-writable-p . ignore) + (find-backup-file-name . ignore) + ;; `get-file-buffer' performed by default handler. + (insert-directory . tramp-archive-handle-insert-directory) + (insert-file-contents . tramp-archive-handle-insert-file-contents) + (load . tramp-archive-handle-load) + (make-auto-save-file-name . ignore) + (make-directory . tramp-archive-handle-not-implemented) + (make-directory-internal . tramp-archive-handle-not-implemented) + (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-process . ignore) + (make-symbolic-link . tramp-archive-handle-not-implemented) + (process-file . ignore) + (rename-file . tramp-archive-handle-not-implemented) + (set-file-acl . ignore) + (set-file-modes . tramp-archive-handle-not-implemented) + (set-file-selinux-context . ignore) + (set-file-times . tramp-archive-handle-not-implemented) + (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) + (shell-command . tramp-archive-handle-not-implemented) + (start-file-process . tramp-archive-handle-not-implemented) + ;; `substitute-in-file-name' performed by default handler. + (temporary-file-directory . tramp-archive-handle-temporary-file-directory) + ;; `tramp-set-file-uid-gid' performed by default handler. + (unhandled-file-name-directory . ignore) + (vc-registered . ignore) + (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (write-region . tramp-archive-handle-not-implemented)) + "Alist of handler functions for file archive method. +Operations not mentioned here will be handled by the default Emacs primitives.") + +(defsubst tramp-archive-file-name-for-operation (operation &rest args) + "Like `tramp-file-name-for-operation', but for archive file name syntax." + (cl-letf (((symbol-function #'tramp-tramp-file-p) + #'tramp-archive-file-name-p)) + (apply #'tramp-file-name-for-operation operation args))) + +(defun tramp-archive-run-real-handler (operation args) + "Invoke normal file name handler for OPERATION. +First arg specifies the OPERATION, second arg is a list of arguments to +pass to the OPERATION." + (let* ((inhibit-file-name-handlers + `(tramp-archive-file-name-handler + . + ,(and (eq inhibit-file-name-operation operation) + inhibit-file-name-handlers))) + (inhibit-file-name-operation operation)) + (apply operation args))) + +;;;###tramp-autoload +(defun tramp-archive-file-name-handler (operation &rest args) + "Invoke the file archive related OPERATION. +First arg specifies the OPERATION, second arg is a list of arguments to +pass to the OPERATION." + (if (not tramp-archive-enabled) + ;; Unregister `tramp-archive-file-name-handler'. + (progn + (tramp-register-file-name-handlers) + (tramp-archive-run-real-handler operation args)) + + (let* ((filename (apply #'tramp-archive-file-name-for-operation + operation args)) + (archive (tramp-archive-file-name-archive filename))) + + ;; `filename' could be a quoted file name. Or the file + ;; archive could be a directory, see Bug#30293. + (if (or (null archive) + (tramp-archive-run-real-handler + #'file-directory-p (list archive))) + (tramp-archive-run-real-handler operation args) + ;; Now run the handler. + (let ((tramp-methods (cons `(,tramp-archive-method) tramp-methods)) + (tramp-gvfs-methods tramp-archive-all-gvfs-methods) + ;; Set uid and gid. gvfsd-archive could do it, but it doesn't. + (tramp-unknown-id-integer (user-uid)) + (tramp-unknown-id-string (user-login-name)) + (fn (assoc operation tramp-archive-file-name-handler-alist))) + (when (eq (cdr fn) #'tramp-archive-handle-not-implemented) + (setq args (cons operation args))) + (if fn + (save-match-data (apply (cdr fn) args)) + (tramp-archive-run-real-handler operation args))))))) + +;;;###autoload +(defalias + 'tramp-archive-autoload-file-name-handler #'tramp-autoload-file-name-handler) + +;;;###autoload +(progn (defun tramp-register-archive-file-name-handler () + "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)))) + +;;;###autoload +(progn + (add-hook 'after-init-hook #'tramp-register-archive-file-name-handler) + (add-hook + 'tramp-archive-unload-hook + (lambda () + (remove-hook + 'after-init-hook #'tramp-register-archive-file-name-handler)))) + +;; In older Emacsen (prior 27.1), the autoload above does not exist. +;; So we call it again; it doesn't hurt. +(tramp-register-archive-file-name-handler) + +;; Mark `operations' the handler is responsible for. +(put 'tramp-archive-file-name-handler 'operations + (mapcar #'car tramp-archive-file-name-handler-alist)) + +;; `tramp-archive-file-name-handler' must be placed before `url-file-handler'. +(when url-handler-mode (tramp-register-file-name-handlers)) + +(with-eval-after-load 'url-handler + (add-hook 'url-handler-mode-hook #'tramp-register-file-name-handlers) + (add-hook + 'tramp-archive-unload-hook + (lambda () + (remove-hook + 'url-handler-mode-hook #'tramp-register-file-name-handlers)))) + + +;; File name conversions. + +(defun tramp-archive-file-name-p (name) + "Return t if NAME is a string with archive file name syntax." + (and (stringp name) + ;; `tramp-archive-file-name-regexp' does not suppress quoted file names. + (not (tramp-compat-file-name-quoted-p name t)) + ;; We cannot use `string-match-p', the matches are used. + (string-match tramp-archive-file-name-regexp name) + t)) + +(defun tramp-archive-file-name-archive (name) + "Return archive part of NAME." + (and (tramp-archive-file-name-p name) + (match-string 1 name))) + +(defun tramp-archive-file-name-localname (name) + "Return localname part of NAME." + (and (tramp-archive-file-name-p name) + (match-string 2 name))) + +(defvar tramp-archive-hash (make-hash-table :test 'equal) + "Hash table for archive local copies. +The hash key is the archive name. The value is a cons of the +used `tramp-file-name' structure for tramp-gvfs, and the file +name of a local copy, if any.") + +(defsubst tramp-archive-gvfs-host (archive) + "Return host name of ARCHIVE as used in GVFS for mounting" + (url-hexify-string (tramp-gvfs-url-file-name archive))) + +(defun tramp-archive-dissect-file-name (name) + "Return a `tramp-file-name' structure. +The structure consists of the `tramp-archive-method' method, the +hexified archive name as host, and the localname. The archive +name is kept in slot `hop'" + (save-match-data + (unless (tramp-archive-file-name-p name) + (tramp-user-error nil "Not an archive file name: \"%s\"" name)) + (let* ((localname (tramp-archive-file-name-localname name)) + (archive (file-truename (tramp-archive-file-name-archive name))) + (vec (make-tramp-file-name + :method tramp-archive-method :hop archive))) + + (cond + ;; The value is already in the hash table. + ((gethash archive tramp-archive-hash) + (setq vec (car (gethash archive tramp-archive-hash)))) + + ;; File archives inside file archives. + ((tramp-archive-file-name-p archive) + (let ((archive + (tramp-make-tramp-file-name + (tramp-archive-dissect-file-name archive) nil 'noarchive))) + (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive))) + (puthash archive (list vec) tramp-archive-hash)) + + ;; http://... + ((and url-handler-mode + tramp-compat-use-url-tramp-p + (string-match-p url-handler-regexp archive) + (string-match-p + "https?" (url-type (url-generic-parse-url archive)))) + (let* ((url-tramp-protocols + (cons + (url-type (url-generic-parse-url archive)) + url-tramp-protocols)) + (archive (url-tramp-convert-url-to-tramp archive))) + (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive))) + (puthash archive (list vec) tramp-archive-hash)) + + ;; GVFS supported schemes. + ((or (tramp-gvfs-file-name-p archive) + (not (file-remote-p archive))) + (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive)) + (puthash archive (list vec) tramp-archive-hash)) + + ;; Anything else. Here we call `file-local-copy', which we + ;; have avoided so far. + (t (let* ((inhibit-file-name-operation #'file-local-copy) + (inhibit-file-name-handlers + (cons #'jka-compr-handler inhibit-file-name-handlers)) + (copy (file-local-copy archive))) + (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host copy)) + (puthash archive (cons vec copy) tramp-archive-hash)))) + + ;; So far, `vec' handles just the mount point. Add `localname', + ;; which shouldn't be pushed to the hash. + (setf (tramp-file-name-localname vec) localname) + vec))) + +(defun tramp-archive-cleanup-hash () + "Remove local copies of archives, used by GVFS." + ;; Don't check for a proper method. + (let ((non-essential t)) + (maphash + (lambda (key value) + ;; Unmount local copy. + (ignore-errors + (tramp-message (car value) 3 "Unmounting %s" (or (cdr value) key)) + (tramp-gvfs-unmount (car value))) + ;; Delete local copy. + (ignore-errors (delete-file (cdr value))) + (remhash key tramp-archive-hash)) + tramp-archive-hash) + (clrhash tramp-archive-hash))) + +(add-hook 'tramp-cleanup-all-connections-hook #'tramp-archive-cleanup-hash) +(add-hook 'kill-emacs-hook #'tramp-archive-cleanup-hash) +(add-hook 'tramp-archive-unload-hook + (lambda () + (remove-hook 'tramp-cleanup-all-connections-hook + #'tramp-archive-cleanup-hash) + (remove-hook 'kill-emacs-hook + #'tramp-archive-cleanup-hash))) + +(defsubst tramp-file-name-archive (vec) + "Extract the archive file name from VEC. +VEC is expected to be a `tramp-file-name', with the method being +`tramp-archive-method', and the host being a coded URL. The +archive name is extracted from the hop part of the VEC structure." + (and (tramp-file-name-p vec) + (string-equal (tramp-file-name-method vec) tramp-archive-method) + (tramp-file-name-hop vec))) + +(defmacro with-parsed-tramp-archive-file-name (filename var &rest body) + "Parse an archive filename and make components available in the body. +This works exactly as `with-parsed-tramp-file-name' for the Tramp +file name structure returned by `tramp-archive-dissect-file-name'. +A variable `foo-archive' (or `archive') will be bound to the +archive name part of FILENAME, assuming `foo' (or nil) is the +value of VAR. OTOH, the variable `foo-hop' (or `hop') won't be +offered." + (declare (debug (form symbolp body)) + (indent 2)) + (let ((bindings + (mapcar (lambda (elem) + `(,(if var (intern (format "%s-%s" var elem)) elem) + (,(intern (format "tramp-file-name-%s" elem)) + ,(or var 'v)))) + `,(cons + 'archive + (delete 'hop (tramp-compat-tramp-file-name-slots)))))) + `(let* ((,(or var 'v) (tramp-archive-dissect-file-name ,filename)) + ,@bindings) + ;; We don't know which of those vars will be used, so we bind them all, + ;; and then add here a dummy use of all those variables, so we don't get + ;; flooded by warnings about those vars `body' didn't use. + (ignore ,@(mapcar #'car bindings)) + ,@body))) + +(defun tramp-archive-gvfs-file-name (name) + "Return FILENAME in GVFS syntax." + (tramp-make-tramp-file-name + (tramp-archive-dissect-file-name name) nil 'nohop)) + + +;; File name primitives. + +(defun tramp-archive-handle-access-file (filename string) + "Like `access-file' for Tramp files." + (access-file (tramp-archive-gvfs-file-name filename) string)) + +(defun tramp-archive-handle-copy-file + (filename newname &optional ok-if-already-exists keep-date + 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)) + (copy-file + (tramp-archive-gvfs-file-name filename) newname ok-if-already-exists + keep-date preserve-uid-gid preserve-extended-attributes)) + +(defun tramp-archive-handle-directory-file-name (directory) + "Like `directory-file-name' for file archives." + (with-parsed-tramp-archive-file-name directory nil + (if (and (not (zerop (length localname))) + (eq (aref localname (1- (length localname))) ?/) + (not (string= localname "/"))) + (substring directory 0 -1) + ;; We do not want to leave the file archive. This would require + ;; unnecessary download of http-based file archives, for + ;; example. So we return `directory'. + directory))) + +(defun tramp-archive-handle-dired-uncache (dir) + "Like `dired-uncache' for file archives." + (dired-uncache (tramp-archive-gvfs-file-name dir))) + +(defun tramp-archive-handle-file-attributes (filename &optional id-format) + "Like `file-attributes' for file archives." + (file-attributes (tramp-archive-gvfs-file-name filename) id-format)) + +(defun tramp-archive-handle-file-executable-p (filename) + "Like `file-executable-p' for file archives." + (file-executable-p (tramp-archive-gvfs-file-name filename))) + +(defun tramp-archive-handle-file-local-copy (filename) + "Like `file-local-copy' for file archives." + (file-local-copy (tramp-archive-gvfs-file-name filename))) + +(defun tramp-archive-handle-file-name-all-completions (filename directory) + "Like `file-name-all-completions' for file archives." + (file-name-all-completions filename (tramp-archive-gvfs-file-name directory))) + +(defun tramp-archive-handle-file-readable-p (filename) + "Like `file-readable-p' for file archives." + (file-readable-p (tramp-archive-gvfs-file-name filename))) + +(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))) + +(defun tramp-archive-handle-file-truename (filename) + "Like `file-truename' for file archives." + (with-parsed-tramp-archive-file-name filename nil + (let ((local (or (file-symlink-p filename) localname))) + (unless (file-name-absolute-p local) + (setq local (expand-file-name local (file-name-directory localname)))) + (concat (file-truename archive) local)))) + +(defun tramp-archive-handle-insert-directory + (filename switches &optional wildcard full-directory-p) + "Like `insert-directory' for file archives." + (insert-directory + (tramp-archive-gvfs-file-name filename) switches wildcard full-directory-p) + (goto-char (point-min)) + (while (search-forward (tramp-archive-gvfs-file-name filename) nil 'noerror) + (replace-match filename))) + +(defun tramp-archive-handle-insert-file-contents + (filename &optional visit beg end replace) + "Like `insert-file-contents' for file archives." + (let ((result + (insert-file-contents + (tramp-archive-gvfs-file-name filename) visit beg end replace))) + (prog1 + (list (expand-file-name filename) + (cadr result)) + (when visit (setq buffer-file-name filename))))) + +(defun tramp-archive-handle-load + (file &optional noerror nomessage nosuffix must-suffix) + "Like `load' for file archives." + (load + (tramp-archive-gvfs-file-name file) noerror nomessage nosuffix must-suffix)) + +(defun tramp-archive-handle-temporary-file-directory () + "Like `temporary-file-directory' for file archives." + ;; If the default directory, the file archive, is located on a + ;; 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)))) + +(defun tramp-archive-handle-not-implemented (operation &rest args) + "Generic handler for operations not implemented for file archives." + (let ((v (ignore-errors + (tramp-archive-dissect-file-name + (apply #'tramp-archive-file-name-for-operation operation args))))) + (tramp-message v 10 "%s" (cons operation args)) + (tramp-error + v 'file-error + "Operation `%s' not implemented for file archives" operation))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-archive 'force))) + +(provide 'tramp-archive) + +;;; TODO: + +;; * Check, whether we could retrieve better file attributes like uid, +;; gid, permissions. See gvfsbackendarchive.c +;; (archive_file_set_info_from_entry), where it is commented out. +;; +;; * Implement write access, when possible. +;; https://bugzilla.gnome.org/show_bug.cgi?id=589617 + +;;; tramp-archive.el ends here diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 701d2c22102..40f74957f50 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -28,7 +28,7 @@ ;; An implementation of information caching for remote files. ;; Each connection, identified by a `tramp-file-name' structure or by -;; a process, has a unique cache. We distinguish 3 kind of caches, +;; a process, has a unique cache. We distinguish 4 kind of caches, ;; depending on the key: ;; ;; - localname is NIL. This are reusable properties. Examples: @@ -49,6 +49,17 @@ ;; an open connection. Examples: "scripts" keeps shell script ;; definitions already sent to the remote shell, "last-cmd-time" is ;; the time stamp a command has been sent to the remote process. +;; +;; - The key is nil. This are temporary properties related to the +;; local machine. Examples: "parse-passwd" and "parse-group" keep +;; the results of parsing "/etc/passwd" and "/etc/group", +;; "{uid,gid}-{integer,string}" are the local uid and gid, and +;; "locale" is the used shell locale. + +;; Some properties are handled special: +;; +;; - "process-name", "process-buffer" and "first-password-request" are +;; not saved in the file `tramp-persistency-file-name'. ;;; Code: @@ -58,7 +69,7 @@ ;;; -- Cache -- ;;;###tramp-autoload -(defvar tramp-cache-data (make-hash-table :test 'equal) +(defvar tramp-cache-data (make-hash-table :test #'equal) "Hash table for remote files properties.") ;;;###tramp-autoload @@ -91,15 +102,12 @@ If it doesn't exist yet, it is created and initialized with matching entries of `tramp-connection-properties'." (or (gethash key tramp-cache-data) (let ((hash - (puthash key (make-hash-table :test 'equal) tramp-cache-data))) + (puthash key (make-hash-table :test #'equal) tramp-cache-data))) (when (tramp-file-name-p key) (dolist (elt tramp-connection-properties) - (when (string-match + (when (string-match-p (or (nth 0 elt) "") - (tramp-make-tramp-file-name - (tramp-file-name-method key) (tramp-file-name-user key) - (tramp-file-name-domain key) (tramp-file-name-host key) - (tramp-file-name-port key) nil)) + (tramp-make-tramp-file-name key 'noloc 'nohop)) (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) hash))) @@ -111,20 +119,24 @@ Returns DEFAULT if not set." (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) (setf (tramp-file-name-localname key) - (tramp-run-real-handler 'directory-file-name (list file)) + (tramp-run-real-handler #'directory-file-name (list file)) (tramp-file-name-hop key) nil) (let* ((hash (tramp-get-hash-table key)) (value (when (hash-table-p hash) (gethash property hash)))) - (if - ;; We take the value only if there is any, and + (if ;; We take the value only if there is any, and ;; `remote-file-name-inhibit-cache' indicates that it is still ;; valid. Otherwise, DEFAULT is set. (and (consp value) (or (null remote-file-name-inhibit-cache) (and (integerp remote-file-name-inhibit-cache) - (<= - (tramp-time-diff (current-time) (car value)) - remote-file-name-inhibit-cache)) + (time-less-p + ;; `current-time' can be nil once we get rid of Emacs 24. + (current-time) + (time-add + (car value) + ;; `seconds-to-time' can be removed once we get + ;; rid of Emacs 24. + (seconds-to-time remote-file-name-inhibit-cache)))) (and (consp remote-file-name-inhibit-cache) (time-less-p remote-file-name-inhibit-cache (car value))))) @@ -150,7 +162,7 @@ Returns VALUE." (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) (setf (tramp-file-name-localname key) - (tramp-run-real-handler 'directory-file-name (list file)) + (tramp-run-real-handler #'directory-file-name (list file)) (tramp-file-name-hop key) nil) (let ((hash (tramp-get-hash-table key))) ;; We put the timestamp there. @@ -167,10 +179,25 @@ Returns VALUE." value)) ;;;###tramp-autoload -(defun tramp-flush-file-property (key file) +(defun tramp-flush-file-property (key file property) + "Remove PROPERTY of FILE in the cache context of KEY." + ;; Unify localname. Remove hop from `tramp-file-name' structure. + (setq file (tramp-compat-file-name-unquote file) + key (copy-tramp-file-name key)) + (setf (tramp-file-name-localname key) + (tramp-run-real-handler #'directory-file-name (list file)) + (tramp-file-name-hop key) nil) + (remhash property (tramp-get-hash-table key)) + (tramp-message key 8 "%s %s" file property) + (when (>= tramp-verbose 10) + (let ((var (intern (concat "tramp-cache-set-count-" property)))) + (makunbound var)))) + +;;;###tramp-autoload +(defun tramp-flush-file-properties (key file) "Remove all properties of FILE in the cache context of KEY." (let* ((file (tramp-run-real-handler - 'directory-file-name (list file))) + #'directory-file-name (list file))) (truename (tramp-get-file-property key file "file-truename" nil))) ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) @@ -182,29 +209,29 @@ Returns VALUE." ;; Remove file properties of symlinks. (when (and (stringp truename) (not (string-equal file (directory-file-name truename)))) - (tramp-flush-file-property key truename)))) + (tramp-flush-file-properties key truename)))) ;;;###tramp-autoload -(defun tramp-flush-directory-property (key directory) +(defun tramp-flush-directory-properties (key directory) "Remove all properties of DIRECTORY in the cache context of KEY. Remove also properties of all files in subdirectories." (setq directory (tramp-compat-file-name-unquote directory)) (let* ((directory (tramp-run-real-handler - 'directory-file-name (list directory))) + #'directory-file-name (list directory))) (truename (tramp-get-file-property key directory "file-truename" nil))) (tramp-message key 8 "%s" directory) (maphash (lambda (key _value) (when (and (tramp-file-name-p key) (stringp (tramp-file-name-localname key)) - (string-match (regexp-quote directory) - (tramp-file-name-localname key))) + (string-match-p (regexp-quote directory) + (tramp-file-name-localname key))) (remhash key tramp-cache-data))) tramp-cache-data) ;; Remove file properties of symlinks. (when (and (stringp truename) (not (string-equal directory (directory-file-name truename)))) - (tramp-flush-directory-property key truename)))) + (tramp-flush-directory-properties key truename)))) ;; Reverting or killing a buffer should also flush file properties. ;; They could have been changed outside Tramp. In eshell, "ls" would @@ -216,26 +243,26 @@ Remove also properties of all files in subdirectories." This is suppressed for temporary buffers." (save-match-data (unless (or (null (buffer-name)) - (string-match "^\\( \\|\\*\\)" (buffer-name))) + (string-match-p "^\\( \\|\\*\\)" (buffer-name))) (let ((bfn (if (stringp (buffer-file-name)) (buffer-file-name) default-directory)) (tramp-verbose 0)) (when (tramp-tramp-file-p bfn) (with-parsed-tramp-file-name bfn nil - (tramp-flush-file-property v localname))))))) + (tramp-flush-file-properties v localname))))))) -(add-hook 'before-revert-hook 'tramp-flush-file-function) -(add-hook 'eshell-pre-command-hook 'tramp-flush-file-function) -(add-hook 'kill-buffer-hook 'tramp-flush-file-function) +(add-hook 'before-revert-hook #'tramp-flush-file-function) +(add-hook 'eshell-pre-command-hook #'tramp-flush-file-function) +(add-hook 'kill-buffer-hook #'tramp-flush-file-function) (add-hook 'tramp-cache-unload-hook (lambda () (remove-hook 'before-revert-hook - 'tramp-flush-file-function) + #'tramp-flush-file-function) (remove-hook 'eshell-pre-command-hook - 'tramp-flush-file-function) + #'tramp-flush-file-function) (remove-hook 'kill-buffer-hook - 'tramp-flush-file-function))) + #'tramp-flush-file-function))) ;;; -- Properties -- @@ -292,7 +319,24 @@ used to cache connection properties of the local machine." (not (eq (tramp-get-connection-property key property 'undef) 'undef))) ;;;###tramp-autoload -(defun tramp-flush-connection-property (key) +(defun tramp-flush-connection-property (key property) + "Remove the named PROPERTY of a connection identified by KEY. +KEY identifies the connection, it is either a process or a +`tramp-file-name' structure. A special case is nil, which is +used to cache connection properties of the local machine. +PROPERTY is set persistent when KEY is a `tramp-file-name' structure." + ;; Unify key by removing localname and hop from `tramp-file-name' + ;; structure. Work with a copy in order to avoid side effects. + (when (tramp-file-name-p key) + (setq key (copy-tramp-file-name key)) + (setf (tramp-file-name-localname key) nil + (tramp-file-name-hop key) nil)) + (remhash property (tramp-get-hash-table key)) + (setq tramp-cache-data-changed t) + (tramp-message key 7 "%s" property)) + +;;;###tramp-autoload +(defun tramp-flush-connection-properties (key) "Remove all properties identified by KEY. KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is @@ -326,7 +370,7 @@ used to cache connection properties of the local machine." (when (tramp-file-name-p key) ;; (dolist ;; (slot - ;; (mapcar 'car (cdr (cl-struct-slot-info 'tramp-file-name)))) + ;; (mapcar #'car (cdr (cl-struct-slot-info 'tramp-file-name)))) ;; (when (stringp (cl-struct-slot-value 'tramp-file-name slot key)) ;; (setf (cl-struct-slot-value 'tramp-file-name slot key) ;; (substring-no-properties @@ -385,6 +429,8 @@ used to cache connection properties of the local machine." (maphash (lambda (key value) (if (and (tramp-file-name-p key) value + (not (string-equal + (tramp-file-name-method key) tramp-archive-method)) (not (tramp-file-name-localname key)) (not (gethash "login-as" value)) (not (gethash "started" value))) @@ -412,11 +458,11 @@ used to cache connection properties of the local machine." (pp (read (format "(%s)" (tramp-cache-print cache))))))))))) (unless noninteractive - (add-hook 'kill-emacs-hook 'tramp-dump-connection-properties)) + (add-hook 'kill-emacs-hook #'tramp-dump-connection-properties)) (add-hook 'tramp-cache-unload-hook (lambda () (remove-hook 'kill-emacs-hook - 'tramp-dump-connection-properties))) + #'tramp-dump-connection-properties))) ;;;###tramp-autoload (defun tramp-parse-connection-properties (method) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 1d35aa5a019..35bb85b82d9 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -55,9 +55,9 @@ SYNTAX can be one of the symbols `default' (default), "Return a list of all Tramp connection buffers." (append (all-completions - "*tramp" (mapcar 'list (mapcar 'buffer-name (buffer-list)))) + "*tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list)))) (all-completions - "*debug tramp" (mapcar 'list (mapcar 'buffer-name (buffer-list)))))) + "*debug tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list)))))) (defun tramp-list-remote-buffers () "Return a list of all buffers with remote default-directory." @@ -69,6 +69,11 @@ SYNTAX can be one of the symbols `default' (default), (buffer-list)))) ;;;###tramp-autoload +(defvar tramp-cleanup-connection-hook nil + "List of functions to be called after Tramp connection is cleaned up. +Each function is called with the current vector as argument.") + +;;;###tramp-autoload (defun tramp-cleanup-connection (vec &optional keep-debug keep-password) "Flush all connection related objects. This includes password cache, file cache, connection cache, @@ -80,16 +85,7 @@ When called interactively, a Tramp connection has to be selected." ;; Return nil when there is no Tramp connection. (list (let ((connections - (mapcar - (lambda (x) - (tramp-make-tramp-file-name - (tramp-file-name-method x) - (tramp-file-name-user x) - (tramp-file-name-domain x) - (tramp-file-name-host x) - (tramp-file-name-port x) - (tramp-file-name-localname x))) - (tramp-list-connections))) + (mapcar #'tramp-make-tramp-file-name (tramp-list-connections))) name) (when connections @@ -108,18 +104,23 @@ When called interactively, a Tramp connection has to be selected." (unless keep-password (tramp-clear-passwd vec)) ;; Cleanup `tramp-current-connection'. Otherwise, we would be - ;; suppressed in the test suite. We use `keep-password' as - ;; indicator; it is not worth to add a new argument. - (when keep-password (setq tramp-current-connection nil)) + ;; suppressed. + (setq tramp-current-connection nil) ;; Flush file cache. - (tramp-flush-directory-property vec "") + (tramp-flush-directory-properties vec "") ;; Flush connection cache. (when (processp (tramp-get-connection-process vec)) - (tramp-flush-connection-property (tramp-get-connection-process vec)) + (tramp-flush-connection-properties (tramp-get-connection-process vec)) (delete-process (tramp-get-connection-process vec))) - (tramp-flush-connection-property vec) + (tramp-flush-connection-properties vec) + + ;; Cancel timer. + (dolist (timer timer-list) + (when (and (eq (timer--function timer) 'tramp-timeout-session) + (tramp-file-name-equal-p vec (car (timer--args timer)))) + (cancel-timer timer))) ;; Remove buffers. (dolist @@ -127,7 +128,10 @@ When called interactively, a Tramp connection has to be selected." (unless keep-debug (get-buffer (tramp-debug-buffer-name vec))) (tramp-get-connection-property vec "process-buffer" nil))) - (when (bufferp buf) (kill-buffer buf))))) + (when (bufferp buf) (kill-buffer buf))) + + ;; The end. + (run-hook-with-args 'tramp-cleanup-connection-hook vec))) ;;;###tramp-autoload (defun tramp-cleanup-this-connection () @@ -138,6 +142,10 @@ When called interactively, a Tramp connection has to be selected." (tramp-dissect-file-name default-directory 'noexpand)))) ;;;###tramp-autoload +(defvar tramp-cleanup-all-connections-hook nil + "List of functions to be called after all Tramp connections are cleaned up.") + +;;;###tramp-autoload (defun tramp-cleanup-all-connections () "Flush all Tramp internal objects. This includes password cache, file cache, connection cache, buffers." @@ -152,9 +160,28 @@ This includes password cache, file cache, connection cache, buffers." ;; Flush file and connection cache. (clrhash tramp-cache-data) + ;; Remove ad-hoc proxies. + (let ((proxies tramp-default-proxies-alist)) + (while proxies + (if (ignore-errors + (get-text-property 0 'tramp-ad-hoc (nth 2 (car proxies)))) + (setq tramp-default-proxies-alist + (delete (car proxies) tramp-default-proxies-alist) + proxies tramp-default-proxies-alist) + (setq proxies (cdr proxies))))) + (when (and tramp-default-proxies-alist tramp-save-ad-hoc-proxies) + (customize-save-variable + 'tramp-default-proxies-alist tramp-default-proxies-alist)) + + ;; Cancel timers. + (cancel-function-timers 'tramp-timeout-session) + ;; Remove buffers. (dolist (name (tramp-list-tramp-buffers)) - (when (bufferp (get-buffer name)) (kill-buffer name)))) + (when (bufferp (get-buffer name)) (kill-buffer name))) + + ;; The end. + (run-hooks 'tramp-cleanup-all-connections-hook)) ;;;###tramp-autoload (defun tramp-cleanup-all-buffers () @@ -185,36 +212,38 @@ This includes password cache, file cache, connection cache, buffers." (defun tramp-bug () "Submit a bug report to the Tramp developers." (interactive) - (catch 'dont-send - (let ((reporter-prompt-for-summary-p t)) - (reporter-submit-bug-report - tramp-bug-report-address ; to-address - (format "tramp (%s)" tramp-version) ; package name and version - (sort - (delq nil (mapcar - (lambda (x) - (and x (boundp x) (cons x 'tramp-reporter-dump-variable))) - (append - (mapcar 'intern (all-completions "tramp-" obarray 'boundp)) - ;; Non-tramp variables of interest. - '(shell-prompt-pattern - backup-by-copying - backup-by-copying-when-linked - backup-by-copying-when-mismatch - backup-by-copying-when-privileged-mismatch - backup-directory-alist - password-cache - password-cache-expiry - remote-file-name-inhibit-cache - connection-local-profile-alist - connection-local-criteria-alist - file-name-handler-alist)))) - (lambda (x y) (string< (symbol-name (car x)) (symbol-name (car y))))) - - 'tramp-load-report-modules ; pre-hook - 'tramp-append-tramp-buffers ; post-hook - (propertize - "\n" 'display "\ + (let ((reporter-prompt-for-summary-p t) + ;; In rare cases, it could contain the password. So we make it nil. + tramp-password-save-function) + (reporter-submit-bug-report + tramp-bug-report-address ; to-address + (format "tramp (%s %s/%s)" ; package name and version + tramp-version tramp-repository-branch tramp-repository-version) + (sort + (delq nil (mapcar + (lambda (x) + (and x (boundp x) (cons x 'tramp-reporter-dump-variable))) + (append + (mapcar #'intern (all-completions "tramp-" obarray #'boundp)) + ;; Non-tramp variables of interest. + '(shell-prompt-pattern + backup-by-copying + backup-by-copying-when-linked + backup-by-copying-when-mismatch + backup-by-copying-when-privileged-mismatch + backup-directory-alist + password-cache + password-cache-expiry + remote-file-name-inhibit-cache + connection-local-profile-alist + connection-local-criteria-alist + file-name-handler-alist)))) + (lambda (x y) (string< (symbol-name (car x)) (symbol-name (car y))))) + + 'tramp-load-report-modules ; pre-hook + 'tramp-append-tramp-buffers ; post-hook + (propertize + "\n" 'display "\ Enter your bug report in this message, including as much detail as you possibly can about the problem, what you did to cause it and what the local and remote machines are. @@ -237,7 +266,7 @@ contents of the *tramp/foo* buffer and the *debug tramp/foo* buffer in your bug report. --bug report follows this line-- -"))))) +")))) (defun tramp-reporter-dump-variable (varsym mailbuf) "Pretty-print the value of the variable in symbol VARSYM." @@ -250,7 +279,7 @@ buffer in your bug report. (set varsym (read (format "(%s)" (tramp-cache-print val)))) ;; There are non-7bit characters to be masked. (when (and (stringp val) - (string-match + (string-match-p (concat "[^" (bound-and-true-p mm-7bit-chars) "]") val)) (with-current-buffer reporter-eval-buffer (set @@ -266,10 +295,11 @@ buffer in your bug report. ;; Remove string quotation. (forward-line -1) (when (looking-at - (concat "\\(^.*\\)" "\"" ;; \1 " - "\\((base64-decode-string \\)" "\\\\" ;; \2 \ - "\\(\".*\\)" "\\\\" ;; \3 \ - "\\(\")\\)" "\"$")) ;; \4 " + (eval-when-compile + (concat "\\(^.*\\)" "\"" ;; \1 " + "\\((base64-decode-string \\)" "\\\\" ;; \2 \ + "\\(\".*\\)" "\\\\" ;; \3 \ + "\\(\")\\)" "\"$"))) ;; \4 " (replace-match "\\1\\2\\3\\4") (beginning-of-line) (insert " ;; Variable encoded due to non-printable characters.\n")) @@ -294,7 +324,7 @@ buffer in your bug report. (delq nil (mapcar (lambda (b) - (when (string-match "\\*tramp/" (buffer-name b)) b)) + (when (string-match-p "\\*tramp/" (buffer-name b)) b)) (buffer-list)))) (let ((reporter-eval-buffer buffer) (elbuf (get-buffer-create " *tmp-reporter-buffer*"))) @@ -308,11 +338,11 @@ buffer in your bug report. (sort (append (mapcar - 'intern + #'intern (all-completions "tramp-" (buffer-local-variables buffer))) ;; Non-tramp variables of interest. '(connection-local-variables-alist default-directory)) - 'string<)) + #'string<)) (reporter-dump-variable varsym elbuf)) (lisp-indent-line) (insert ")\n")) @@ -322,7 +352,7 @@ buffer in your bug report. (insert "\nload-path shadows:\n==================\n") (ignore-errors (mapc - (lambda (x) (when (string-match "tramp" x) (insert x "\n"))) + (lambda (x) (when (string-match-p "tramp" x) (insert x "\n"))) (split-string (list-load-path-shadows t) "\n"))) ;; Append buffers only when we are in message mode. @@ -367,30 +397,23 @@ the debug buffer(s).") (setq buffer-read-only t) (goto-char (point-min)) - (if (y-or-n-p "Do you want to append the buffer(s)? ") - ;; OK, let's send. First we delete the buffer list. - (progn - (kill-buffer nil) - (switch-to-buffer curbuf) - (goto-char (point-max)) - (insert (propertize "\n" 'display "\n\ + (when (y-or-n-p "Do you want to append the buffer(s)? ") + ;; OK, let's send. First we delete the buffer list. + (kill-buffer nil) + (switch-to-buffer curbuf) + (goto-char (point-max)) + (insert (propertize "\n" 'display "\n\ This is a special notion of the `gnus/message' package. If you use another mail agent (by copying the contents of this buffer) please ensure that the buffers are attached to your email.\n\n")) - (dolist (buffer buffer-list) - (mml-insert-empty-tag - 'part 'type "text/plain" - 'encoding "base64" 'disposition "attachment" 'buffer buffer - 'description buffer)) - (set-buffer-modified-p nil)) - - ;; Don't send. Delete the message buffer. - (set-buffer curbuf) - (set-buffer-modified-p nil) - (kill-buffer nil) - (throw 'dont-send nil)))))) - -(defalias 'tramp-submit-bug 'tramp-bug) + (dolist (buffer buffer-list) + (mml-insert-empty-tag + 'part 'type "text/plain" + 'encoding "base64" 'disposition "attachment" 'buffer buffer + 'description buffer)) + (set-buffer-modified-p nil)))))) + +(defalias 'tramp-submit-bug #'tramp-bug) (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-cmds 'force))) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index ccb1d1ce327..4f01f8d372f 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -29,19 +29,19 @@ ;;; Code: +;; In Emacs 24 and 25, `tramp-unload-file-name-handlers' is not +;; autoloaded. So we declare it here in order to avoid recursive +;; load. This will be overwritten in tramp.el. +(defun tramp-unload-file-name-handlers ()) + (require 'auth-source) -(require 'advice) -(require 'cl-lib) -(require 'custom) (require 'format-spec) +(require 'ls-lisp) ;; Due to `tramp-handle-insert-directory'. (require 'parse-time) -(require 'password-cache) (require 'shell) -(require 'timer) -(require 'ucs-normalize) +(require 'subr-x) -(require 'trampver) -(require 'tramp-loaddefs) +(declare-function tramp-handle-temporary-file-directory "tramp") ;; For not existing functions, obsolete functions, or functions with a ;; changed argument list, there are compiler warnings. We want to @@ -71,8 +71,8 @@ Add the extension of F, if existing." ;; `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)) + #'temporary-file-directory + #'tramp-handle-temporary-file-directory)) (defun tramp-compat-process-running-p (process-name) "Returns t if system process PROCESS-NAME is running for `user-login-name'." @@ -82,7 +82,7 @@ Add the extension of F, if existing." ((fboundp 'w32-window-exists-p) (tramp-compat-funcall 'w32-window-exists-p process-name process-name)) - ;; GNU Emacs 23. + ;; GNU Emacs 23+. ((and (fboundp 'list-system-processes) (fboundp 'process-attributes)) (let (result) (dolist (pid (tramp-compat-funcall 'list-system-processes) result) @@ -93,146 +93,149 @@ Add the extension of F, if existing." ;; The returned command name could be truncated ;; to 15 characters. Therefore, we cannot check ;; for `string-equal'. - (and comm (string-match + (and comm (string-match-p (concat "^" (regexp-quote comm)) process-name)))) (setq result t))))))))) -;; `user-error' has appeared in Emacs 24.3. -(defsubst tramp-compat-user-error (vec-or-proc format &rest args) - "Signal a pilot error." - (apply - 'tramp-error vec-or-proc - (if (fboundp 'user-error) 'user-error 'error) format args)) - -;; `default-toplevel-value' has been declared in Emacs 24.4. -(unless (fboundp 'default-toplevel-value) - (defalias 'default-toplevel-value 'symbol-value)) - ;; `file-attribute-*' are introduced in Emacs 25.1. -(if (fboundp 'file-attribute-type) - (defalias 'tramp-compat-file-attribute-type 'file-attribute-type) - (defsubst tramp-compat-file-attribute-type (attributes) - "The type field in ATTRIBUTES returned by `file-attributes'. +(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))) - -(if (fboundp 'file-attribute-link-number) - (defalias 'tramp-compat-file-attribute-link-number - 'file-attribute-link-number) - (defsubst tramp-compat-file-attribute-link-number (attributes) - "Return the number of links in ATTRIBUTES returned by `file-attributes'." - (nth 1 attributes))) - -(if (fboundp 'file-attribute-user-id) - (defalias 'tramp-compat-file-attribute-user-id 'file-attribute-user-id) - (defsubst tramp-compat-file-attribute-user-id (attributes) - "The UID field in ATTRIBUTES returned by `file-attributes'. + (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))) + (nth 2 attributes)))) -(if (fboundp 'file-attribute-group-id) - (defalias 'tramp-compat-file-attribute-group-id 'file-attribute-group-id) - (defsubst tramp-compat-file-attribute-group-id (attributes) - "The GID field in ATTRIBUTES returned by `file-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))) + (nth 3 attributes)))) -(if (fboundp 'file-attribute-modification-time) - (defalias 'tramp-compat-file-attribute-modification-time - 'file-attribute-modification-time) - (defsubst tramp-compat-file-attribute-modification-time (attributes) - "The modification time in ATTRIBUTES returned by `file-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 list of integers (HIGH LOW USEC PSEC) in the same style -as (current-time)." - (nth 5 attributes))) - -(if (fboundp 'file-attribute-size) - (defalias 'tramp-compat-file-attribute-size 'file-attribute-size) - (defsubst tramp-compat-file-attribute-size (attributes) - "The size (in bytes) in ATTRIBUTES returned by `file-attributes'. -This is a floating point number if the size is too large for an integer." - (nth 7 attributes))) - -(if (fboundp 'file-attribute-modes) - (defalias 'tramp-compat-file-attribute-modes 'file-attribute-modes) - (defsubst tramp-compat-file-attribute-modes (attributes) - "The file modes in ATTRIBUTES returned by `file-attributes'. +is a Lisp timestamp in the style of `current-time'." + (nth 5 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))) + (nth 8 attributes)))) ;; `format-message' is new in Emacs 25.1. (unless (fboundp 'format-message) - (defalias 'format-message 'format)) + (defalias 'format-message #'format)) ;; `directory-name-p' is new in Emacs 25.1. -(if (fboundp 'directory-name-p) - (defalias 'tramp-compat-directory-name-p 'directory-name-p) - (defsubst tramp-compat-directory-name-p (name) - "Return non-nil if NAME ends with a directory separator character." - (let ((len (length name)) - (lastc ?.)) - (if (> len 0) - (setq lastc (aref name (1- len)))) - (or (= lastc ?/) - (and (memq system-type '(windows-nt ms-dos)) - (= lastc ?\\)))))) +(defalias 'tramp-compat-directory-name-p + (if (fboundp 'directory-name-p) + #'directory-name-p + (lambda (name) + "Return non-nil if NAME ends with a directory separator character." + (let ((len (length name)) + (lastc ?.)) + (if (> len 0) + (setq lastc (aref name (1- len)))) + (or (= lastc ?/) + (and (memq system-type '(windows-nt ms-dos)) + (= lastc ?\\))))))) ;; `file-missing' is introduced in Emacs 26.1. (defconst tramp-file-missing (if (get 'file-missing 'error-conditions) 'file-missing 'file-error) "The error symbol for the `file-missing' error.") -(add-hook 'tramp-unload-hook - (lambda () - (unload-feature 'tramp-loaddefs 'force) - (unload-feature 'tramp-compat 'force))) - -;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' are -;; introduced in Emacs 26. -(eval-and-compile - (if (fboundp 'file-name-quoted-p) - (defalias 'tramp-compat-file-name-quoted-p 'file-name-quoted-p) - (defsubst tramp-compat-file-name-quoted-p (name) +;; `file-local-name', `file-name-quoted-p', `file-name-quote' and +;; `file-name-unquote' are introduced in Emacs 26. +(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' 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))) + #'file-name-quoted-p + (lambda (name &optional top) "Whether NAME is quoted with prefix \"/:\". -If NAME is a remote file name, check the local part of NAME." - (string-match "^/:" (or (file-remote-p name 'localname) name)))) +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)))))) +(defalias 'tramp-compat-file-name-quote (if (fboundp 'file-name-quote) - (defalias 'tramp-compat-file-name-quote 'file-name-quote) - (defsubst tramp-compat-file-name-quote (name) + #'file-name-quote + (lambda (name) "Add the quotation prefix \"/:\" to file NAME. If NAME is a remote file name, the local part of NAME is quoted." (if (tramp-compat-file-name-quoted-p name) name (concat - (file-remote-p name) "/:" (or (file-remote-p name 'localname) name))))) + (file-remote-p name) "/:" (tramp-compat-file-local-name name)))))) +(defalias 'tramp-compat-file-name-unquote (if (fboundp 'file-name-unquote) - (defalias 'tramp-compat-file-name-unquote 'file-name-unquote) - (defsubst tramp-compat-file-name-unquote (name) + #'file-name-unquote + (lambda (name) "Remove quotation prefix \"/:\" from file NAME. If NAME is a remote file name, the local part of NAME is unquoted." - (save-match-data - (let ((localname (or (file-remote-p name 'localname) name))) - (when (tramp-compat-file-name-quoted-p localname) - (setq - localname - (replace-match - (if (= (length localname) 2) "/" "") nil t localname))) - (concat (file-remote-p name) localname)))))) + (let ((localname (tramp-compat-file-local-name name))) + (when (tramp-compat-file-name-quoted-p localname) + (setq + localname (if (= (length localname) 2) "/" (substring localname 2)))) + (concat (file-remote-p name) localname))))) ;; `tramp-syntax' has changed its meaning in Emacs 26. We still ;; support old settings. (defsubst tramp-compat-tramp-syntax () "Return proper value of `tramp-syntax'." + (defvar tramp-syntax) (cond ((eq tramp-syntax 'ftp) 'default) ((eq tramp-syntax 'sep) 'separate) (t tramp-syntax))) @@ -240,11 +243,64 @@ If NAME is a remote file name, the local part of NAME is unquoted." ;; `cl-struct-slot-info' has been introduced with Emacs 25. (defmacro tramp-compat-tramp-file-name-slots () (if (fboundp 'cl-struct-slot-info) - `(cdr (mapcar 'car (cl-struct-slot-info 'tramp-file-name))) - `(cdr (mapcar 'car (get 'tramp-file-name 'cl-struct-slots))))) + '(cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name))) + '(cdr (mapcar #'car (get 'tramp-file-name 'cl-struct-slots))))) + +;; The signature of `tramp-make-tramp-file-name' has been changed. +;; Therefore, we cannot use `url-tramp-convert-url-to-tramp' prior +;; Emacs 26.1. We use `temporary-file-directory' as indicator. +(defconst tramp-compat-use-url-tramp-p (fboundp 'temporary-file-directory) + "Whether to use url-tramp.el.") + +;; `exec-path' is new in Emacs 27.1. +(defalias 'tramp-compat-exec-path + (if (fboundp 'exec-path) + #'exec-path + (lambda () + "List of directories to search programs to run in remote subprocesses." + (let ((handler (find-file-name-handler default-directory 'exec-path))) + (if handler + (funcall handler 'exec-path) + exec-path))))) + +;; `time-equal-p' has appeared in Emacs 27.1. +(defalias 'tramp-compat-time-equal-p + (if (fboundp 'time-equal-p) + #'time-equal-p + (lambda (t1 t2) + "Return non-nil if time value T1 is equal to time value T2. +A nil value for either argument stands for the current time." + (equal (or t1 (current-time)) (or t2 (current-time)))))) + +;; `flatten-tree' has appeared in Emacs 27.1. +(defalias 'tramp-compat-flatten-tree + (if (fboundp 'flatten-tree) + #'flatten-tree + (lambda (tree) + "Take TREE and \"flatten\" it." + (let (elems) + (setq tree (list tree)) + (while (let ((elem (pop tree))) + (cond ((consp elem) + (setq tree (cons (car elem) (cons (cdr elem) tree)))) + (elem + (push elem elems))) + tree)) + (nreverse elems))))) + +;; `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)) + #'progress-reporter-update + (lambda (reporter &optional value _suffix) + (progress-reporter-update reporter value)))) -(provide 'tramp-compat) +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-loaddefs 'force) + (unload-feature 'tramp-compat 'force))) -;;; TODO: +(provide 'tramp-compat) ;;; tramp-compat.el ends here diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index de9bb4024da..2a4fccf57e7 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -53,11 +53,10 @@ present for backward compatibility." (setq file-name-handler-alist (delete a1 (delete a2 file-name-handler-alist))))) -(eval-after-load "ange-ftp" - '(when (functionp 'tramp-disable-ange-ftp) - (tramp-disable-ange-ftp))) +(with-eval-after-load 'ange-ftp + (tramp-disable-ange-ftp)) -;;;###autoload +;;;###tramp-autoload (defun tramp-ftp-enable-ange-ftp () "Reenable Ange-FTP, when Tramp is unloaded." ;; The following code is commented out in Ange-FTP. @@ -86,7 +85,7 @@ present for backward compatibility." ange-ftp-completion-hook-function) file-name-handler-alist))))) -(add-hook 'tramp-ftp-unload-hook 'tramp-ftp-enable-ange-ftp) +(add-hook 'tramp-ftp-unload-hook #'tramp-ftp-enable-ange-ftp) ;; Define FTP method ... ;;;###tramp-autoload @@ -95,22 +94,19 @@ present for backward compatibility." ;; ... and add it to the method list. ;;;###tramp-autoload -(add-to-list 'tramp-methods (cons tramp-ftp-method nil)) +(tramp--with-startup + (add-to-list 'tramp-methods (cons tramp-ftp-method nil)) -;; Add some defaults for `tramp-default-method-alist'. -;;;###tramp-autoload -(add-to-list 'tramp-default-method-alist - (list "\\`ftp\\." nil tramp-ftp-method)) -;;;###tramp-autoload -(add-to-list 'tramp-default-method-alist - (list nil "\\`\\(anonymous\\|ftp\\)\\'" tramp-ftp-method)) + ;; Add some defaults for `tramp-default-method-alist'. + (add-to-list 'tramp-default-method-alist + (list "\\`ftp\\." nil tramp-ftp-method)) + (add-to-list 'tramp-default-method-alist + (list nil "\\`\\(anonymous\\|ftp\\)\\'" tramp-ftp-method)) -;; Add completion function for FTP method. -;;;###tramp-autoload -(eval-after-load 'tramp - '(tramp-set-completion-function - tramp-ftp-method - '((tramp-parse-netrc "~/.netrc")))) + ;; Add completion function for FTP method. + (tramp-set-completion-function + tramp-ftp-method + '((tramp-parse-netrc "~/.netrc")))) ;;;###tramp-autoload (defun tramp-ftp-file-name-handler (operation &rest args) @@ -142,7 +138,7 @@ pass to the OPERATION." ;; because this returns another user but the one declared in ;; "~/.netrc". ((memq operation '(file-directory-p file-exists-p)) - (if (apply 'ange-ftp-hook-function operation args) + (if (apply #'ange-ftp-hook-function operation args) (let ((v (tramp-dissect-file-name (car args) t))) (setf (tramp-file-name-method v) tramp-ftp-method) (tramp-set-connection-property v "started" t)) @@ -176,19 +172,21 @@ pass to the OPERATION." (and (eq inhibit-file-name-operation operation) inhibit-file-name-handlers))) (inhibit-file-name-operation operation)) - (apply 'ange-ftp-hook-function operation args))))))) + (apply #'ange-ftp-hook-function operation args))))))) ;; 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." - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-ftp-method)) + (and (tramp-tramp-file-p filename) + (string= (tramp-file-name-method (tramp-dissect-file-name filename)) + tramp-ftp-method))) ;;;###tramp-autoload -(add-to-list 'tramp-foreign-file-name-handler-alist - (cons 'tramp-ftp-file-name-p 'tramp-ftp-file-name-handler)) +(tramp--with-startup + (add-to-list 'tramp-foreign-file-name-handler-alist + (cons #'tramp-ftp-file-name-p #'tramp-ftp-file-name-handler))) (add-hook 'tramp-unload-hook (lambda () diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 4a4be5c51f3..9d45e6a8ce9 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -47,17 +47,19 @@ ;; discovered during development time, is given in respective ;; comments. -;; The custom option `tramp-gvfs-methods' contains the list of -;; supported connection methods. Per default, these are "afp", "dav", -;; "davs", "gdrive", "obex", "sftp" and "synce". Note that with -;; "obex" it might be necessary to pair with the other bluetooth -;; device, if it hasn't been done already. There might be also some -;; few seconds delay in discovering available bluetooth devices. - -;; Other possible connection methods are "ftp" and "smb". When one of -;; these methods is added to the list, the remote access for that -;; method is performed via GVFS instead of the native Tramp -;; implementation. +;; The user option `tramp-gvfs-methods' contains the list of supported +;; connection methods. Per default, these are "afp", "dav", "davs", +;; "gdrive", "nextcloud" and "sftp". + +;; "gdrive" and "nextcloud" connection methods require a respective +;; account in GNOME Online Accounts, with enabled "Files" service. + +;; Other possible connection methods are "ftp", "http", "https" and +;; "smb". When one of these methods is added to the list, the remote +;; access for that method is performed via GVFS instead of the native +;; Tramp implementation. However, this is not recommended. These +;; methods are listed here for the benefit of file archives, see +;; tramp-archive.el. ;; GVFS offers even more connection methods. The complete list of ;; connection methods of the actual GVFS implementation can be @@ -66,28 +68,26 @@ ;; (message ;; "%s" ;; (mapcar -;; 'car +;; #'car ;; (dbus-call-method ;; :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker ;; tramp-gvfs-interface-mounttracker "ListMountableInfo"))) +;; See also /usr/share/gvfs/mounts + ;; Note that all other connection methods are not tested, beside the ;; ones offered for customization in `tramp-gvfs-methods'. If you ;; request an additional connection method to be supported, please ;; drop me a note. -;; For hostname completion, information is retrieved either from the -;; bluez daemon (for the "obex" method), the hal daemon (for the -;; "synce" method), or from the zeroconf daemon (for the "afp", "dav", -;; "davs", and "sftp" methods). The zeroconf daemon is pre-configured -;; to discover services in the "local" domain. If another domain -;; shall be used for discovering services, the custom option -;; `tramp-gvfs-zeroconf-domain' can be set accordingly. +;; For hostname completion, information is retrieved from the zeroconf +;; daemon (for the "afp", "dav", "davs", and "sftp" methods). The +;; zeroconf daemon is pre-configured to discover services in the +;; "local" domain. If another domain shall be used for discovering +;; services, the user option `tramp-gvfs-zeroconf-domain' can be set +;; accordingly. ;; Restrictions: - -;; * The current GVFS implementation does not allow writing on the -;; remote bluetooth device via OBEX. ;; ;; * Two shares of the same SMB server cannot be mounted in parallel. @@ -97,43 +97,69 @@ ;; option "--without-dbus". Declare used subroutines and variables. (declare-function dbus-get-unique-name "dbusbind.c") +(eval-when-compile (require 'cl-lib)) (require 'tramp) - (require 'dbus) (require 'url-parse) (require 'url-util) -(require 'zeroconf) ;; Pacify byte-compiler. (eval-when-compile (require 'custom)) +(declare-function zeroconf-init "zeroconf") +(declare-function zeroconf-list-service-types "zeroconf") +(declare-function zeroconf-list-services "zeroconf") +(declare-function zeroconf-service-host "zeroconf") +(declare-function zeroconf-service-port "zeroconf") +(declare-function zeroconf-service-txt "zeroconf") + +;; We don't call `dbus-ping', because this would load dbus.el. +(defconst tramp-gvfs-enabled + (ignore-errors + (and (featurep 'dbusbind) + (autoload 'zeroconf-init "zeroconf") + (tramp-compat-funcall 'dbus-get-unique-name :system) + (tramp-compat-funcall 'dbus-get-unique-name :session) + (or (tramp-compat-process-running-p "gvfs-fuse-daemon") + (tramp-compat-process-running-p "gvfsd-fuse")))) + "Non-nil when GVFS is available.") + ;;;###tramp-autoload (defcustom tramp-gvfs-methods - '("afp" "dav" "davs" "gdrive" "obex" "sftp" "synce") + '("afp" "dav" "davs" "gdrive" "nextcloud" "sftp") "List of methods for remote files, accessed with GVFS." :group 'tramp - :version "26.1" + :version "27.1" :type '(repeat (choice (const "afp") (const "dav") (const "davs") (const "ftp") (const "gdrive") - (const "obex") + (const "http") + (const "https") + (const "nextcloud") (const "sftp") - (const "smb") - (const "synce")))) + (const "smb")))) + +(defconst tramp-goa-methods '("gdrive" "nextcloud") + "List of methods which require registration at GNOME Online Accounts.") + +;; Remove GNOME Online Accounts methods if not supported. +(unless (and tramp-gvfs-enabled + (member tramp-goa-service (dbus-list-known-names :session))) + (dolist (method tramp-goa-methods) + (setq tramp-gvfs-methods (delete method tramp-gvfs-methods)))) ;; Add defaults for `tramp-default-user-alist' and `tramp-default-host-alist'. ;;;###tramp-autoload -(when (string-match "\\(.+\\)@\\(\\(?:gmail\\|googlemail\\)\\.com\\)" - user-mail-address) - (add-to-list 'tramp-default-user-alist - `("\\`gdrive\\'" nil ,(match-string 1 user-mail-address))) - (add-to-list 'tramp-default-host-alist - '("\\`gdrive\\'" nil ,(match-string 2 user-mail-address)))) -;;;###tramp-autoload -(add-to-list 'tramp-default-user-alist '("\\`synce\\'" nil nil)) +(tramp--with-startup + (when (string-match "\\(.+\\)@\\(\\(?:gmail\\|googlemail\\)\\.com\\)" + user-mail-address) + (add-to-list 'tramp-default-user-alist + `("\\`gdrive\\'" nil ,(match-string 1 user-mail-address))) + (add-to-list 'tramp-default-host-alist + '("\\`gdrive\\'" nil ,(match-string 2 user-mail-address))))) ;;;###tramp-autoload (defcustom tramp-gvfs-zeroconf-domain "local" @@ -146,9 +172,10 @@ ;; completion. ;;;###tramp-autoload (when (featurep 'dbusbind) - (dolist (elt tramp-gvfs-methods) - (unless (assoc elt tramp-methods) - (add-to-list 'tramp-methods (cons elt nil))))) + (tramp--with-startup + (dolist (elt tramp-gvfs-methods) + (unless (assoc elt tramp-methods) + (add-to-list 'tramp-methods (cons elt nil)))))) (defconst tramp-gvfs-path-tramp (concat dbus-path-emacs "/Tramp") "The preceding object path for own objects.") @@ -156,16 +183,6 @@ (defconst tramp-gvfs-service-daemon "org.gtk.vfs.Daemon" "The well known name of the GVFS daemon.") -;; We don't call `dbus-ping', because this would load dbus.el. -(defconst tramp-gvfs-enabled - (ignore-errors - (and (featurep 'dbusbind) - (tramp-compat-funcall 'dbus-get-unique-name :system) - (tramp-compat-funcall 'dbus-get-unique-name :session) - (or (tramp-compat-process-running-p "gvfs-fuse-daemon") - (tramp-compat-process-running-p "gvfsd-fuse")))) - "Non-nil when GVFS is available.") - (defconst tramp-gvfs-path-mounttracker "/org/gtk/vfs/mounttracker" "The object path of the GVFS daemon.") @@ -287,131 +304,161 @@ It has been changed in GVFS 1.14.") (defconst tramp-gvfs-password-anonymous-supported 16 "Operation supports anonymous users.") -(defconst tramp-bluez-service "org.bluez" - "The well known name of the BLUEZ service.") +;; For the time being, we just need org.goa.Account and org.goa.Files +;; interfaces. We document the other ones, just in case. -(defconst tramp-bluez-interface-manager "org.bluez.Manager" - "The manager interface of the BLUEZ daemon.") +;;;###tramp-autoload +(defconst tramp-goa-service "org.gnome.OnlineAccounts" + "The well known name of the GNOME Online Accounts service.") -;; <interface name='org.bluez.Manager'> -;; <method name='DefaultAdapter'> -;; <arg type='o' direction='out'/> -;; </method> -;; <method name='FindAdapter'> -;; <arg type='s' direction='in'/> -;; <arg type='o' direction='out'/> -;; </method> -;; <method name='ListAdapters'> -;; <arg type='ao' direction='out'/> -;; </method> -;; <signal name='AdapterAdded'> -;; <arg type='o'/> -;; </signal> -;; <signal name='AdapterRemoved'> -;; <arg type='o'/> -;; </signal> -;; <signal name='DefaultAdapterChanged'> -;; <arg type='o'/> -;; </signal> +(defconst tramp-goa-path "/org/gnome/OnlineAccounts" + "The object path of the GNOME Online Accounts.") + +(defconst tramp-goa-path-accounts (concat tramp-goa-path "/Accounts") + "The object path of the GNOME Online Accounts accounts.") + +(defconst tramp-goa-interface-documents "org.gnome.OnlineAccounts.Documents" + "The documents interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Documents'> ;; </interface> -(defconst tramp-bluez-interface-adapter "org.bluez.Adapter" - "The adapter interface of the BLUEZ daemon.") +(defconst tramp-goa-interface-printers "org.gnome.OnlineAccounts.Printers" + "The printers interface of the GNOME Online Accounts.") -;; <interface name='org.bluez.Adapter'> -;; <method name='GetProperties'> -;; <arg type='a{sv}' direction='out'/> -;; </method> -;; <method name='SetProperty'> -;; <arg type='s' direction='in'/> -;; <arg type='v' direction='in'/> -;; </method> -;; <method name='RequestMode'> -;; <arg type='s' direction='in'/> -;; </method> -;; <method name='ReleaseMode'/> -;; <method name='RequestSession'/> -;; <method name='ReleaseSession'/> -;; <method name='StartDiscovery'/> -;; <method name='StopDiscovery'/> -;; <method name='ListDevices'> -;; <arg type='ao' direction='out'/> -;; </method> -;; <method name='CreateDevice'> -;; <arg type='s' direction='in'/> -;; <arg type='o' direction='out'/> -;; </method> -;; <method name='CreatePairedDevice'> -;; <arg type='s' direction='in'/> -;; <arg type='o' direction='in'/> -;; <arg type='s' direction='in'/> -;; <arg type='o' direction='out'/> -;; </method> -;; <method name='CancelDeviceCreation'> -;; <arg type='s' direction='in'/> -;; </method> -;; <method name='RemoveDevice'> -;; <arg type='o' direction='in'/> -;; </method> -;; <method name='FindDevice'> -;; <arg type='s' direction='in'/> -;; <arg type='o' direction='out'/> -;; </method> -;; <method name='RegisterAgent'> -;; <arg type='o' direction='in'/> -;; <arg type='s' direction='in'/> +;; <interface name='org.gnome.OnlineAccounts.Printers'> +;; </interface> + +(defconst tramp-goa-interface-files "org.gnome.OnlineAccounts.Files" + "The files interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Files'> +;; <property type='b' name='AcceptSslErrors' access='read'/> +;; <property type='s' name='Uri' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-contacts "org.gnome.OnlineAccounts.Contacts" + "The contacts interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Contacts'> +;; <property type='b' name='AcceptSslErrors' access='read'/> +;; <property type='s' name='Uri' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-calendar "org.gnome.OnlineAccounts.Calendar" + "The calendar interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Calendar'> +;; <property type='b' name='AcceptSslErrors' access='read'/> +;; <property type='s' name='Uri' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-oauth2based "org.gnome.OnlineAccounts.OAuth2Based" + "The oauth2based interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.OAuth2Based'> +;; <method name='GetAccessToken'> +;; <arg type='s' name='access_token' direction='out'/> +;; <arg type='i' name='expires_in' direction='out'/> ;; </method> -;; <method name='UnregisterAgent'> -;; <arg type='o' direction='in'/> +;; <property type='s' name='ClientId' access='read'/> +;; <property type='s' name='ClientSecret' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-account "org.gnome.OnlineAccounts.Account" + "The account interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Account'> +;; <method name='Remove'/> +;; <method name='EnsureCredentials'> +;; <arg type='i' name='expires_in' direction='out'/> ;; </method> -;; <signal name='DeviceCreated'> -;; <arg type='o'/> -;; </signal> -;; <signal name='DeviceRemoved'> -;; <arg type='o'/> -;; </signal> -;; <signal name='DeviceFound'> -;; <arg type='s'/> -;; <arg type='a{sv}'/> -;; </signal> -;; <signal name='PropertyChanged'> -;; <arg type='s'/> -;; <arg type='v'/> -;; </signal> -;; <signal name='DeviceDisappeared'> -;; <arg type='s'/> -;; </signal> +;; <property type='s' name='ProviderType' access='read'/> +;; <property type='s' name='ProviderName' access='read'/> +;; <property type='s' name='ProviderIcon' access='read'/> +;; <property type='s' name='Id' access='read'/> +;; <property type='b' name='IsLocked' access='read'/> +;; <property type='b' name='IsTemporary' access='readwrite'/> +;; <property type='b' name='AttentionNeeded' access='read'/> +;; <property type='s' name='Identity' access='read'/> +;; <property type='s' name='PresentationIdentity' access='read'/> +;; <property type='b' name='MailDisabled' access='readwrite'/> +;; <property type='b' name='CalendarDisabled' access='readwrite'/> +;; <property type='b' name='ContactsDisabled' access='readwrite'/> +;; <property type='b' name='ChatDisabled' access='readwrite'/> +;; <property type='b' name='DocumentsDisabled' access='readwrite'/> +;; <property type='b' name='MapsDisabled' access='readwrite'/> +;; <property type='b' name='MusicDisabled' access='readwrite'/> +;; <property type='b' name='PrintersDisabled' access='readwrite'/> +;; <property type='b' name='PhotosDisabled' access='readwrite'/> +;; <property type='b' name='FilesDisabled' access='readwrite'/> +;; <property type='b' name='TicketingDisabled' access='readwrite'/> +;; <property type='b' name='TodoDisabled' access='readwrite'/> +;; <property type='b' name='ReadLaterDisabled' access='readwrite'/> ;; </interface> -;;;###tramp-autoload -(defcustom tramp-bluez-discover-devices-timeout 60 - "Defines seconds since last bluetooth device discovery before rescanning. -A value of 0 would require an immediate discovery during hostname -completion, nil means to use always cached values for discovered -devices." - :group 'tramp - :version "23.2" - :type '(choice (const nil) integer)) +(defconst tramp-goa-identity-regexp + (concat "^" "\\(" tramp-user-regexp "\\)?" + "@" "\\(" tramp-host-regexp "\\)?" + "\\(?:" ":""\\(" tramp-port-regexp "\\)" "\\)?") + "Regexp matching GNOME Online Accounts \"PresentationIdentity\" property.") + +(defconst tramp-goa-interface-mail "org.gnome.OnlineAccounts.Mail" + "The mail interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Mail'> +;; <property type='s' name='EmailAddress' access='read'/> +;; <property type='s' name='Name' access='read'/> +;; <property type='b' name='ImapSupported' access='read'/> +;; <property type='b' name='ImapAcceptSslErrors' access='read'/> +;; <property type='s' name='ImapHost' access='read'/> +;; <property type='b' name='ImapUseSsl' access='read'/> +;; <property type='b' name='ImapUseTls' access='read'/> +;; <property type='s' name='ImapUserName' access='read'/> +;; <property type='b' name='SmtpSupported' access='read'/> +;; <property type='b' name='SmtpAcceptSslErrors' access='read'/> +;; <property type='s' name='SmtpHost' access='read'/> +;; <property type='b' name='SmtpUseAuth' access='read'/> +;; <property type='b' name='SmtpAuthLogin' access='read'/> +;; <property type='b' name='SmtpAuthPlain' access='read'/> +;; <property type='b' name='SmtpAuthXoauth2' access='read'/> +;; <property type='b' name='SmtpUseSsl' access='read'/> +;; <property type='b' name='SmtpUseTls' access='read'/> +;; <property type='s' name='SmtpUserName' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-chat "org.gnome.OnlineAccounts.Chat" + "The chat interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Chat'> +;; </interface> -(defvar tramp-bluez-discovery nil - "Indicator for a running bluetooth device discovery. -It keeps the timestamp of last discovery.") +(defconst tramp-goa-interface-photos "org.gnome.OnlineAccounts.Photos" + "The photos interface of the GNOME Online Accounts.") -(defvar tramp-bluez-devices nil - "Alist of detected bluetooth devices. -Every entry is a list (NAME ADDRESS).") +;; <interface name='org.gnome.OnlineAccounts.Photos'> +;; </interface> -(defconst tramp-hal-service "org.freedesktop.Hal" - "The well known name of the HAL service.") +(defconst tramp-goa-path-manager (concat tramp-goa-path "/Manager") + "The object path of the GNOME Online Accounts manager.") -(defconst tramp-hal-path-manager "/org/freedesktop/Hal/Manager" - "The object path of the HAL daemon manager.") +(defconst tramp-goa-interface-documents "org.gnome.OnlineAccounts.Manager" + "The manager interface of the GNOME Online Accounts.") -(defconst tramp-hal-interface-manager "org.freedesktop.Hal.Manager" - "The manager interface of the HAL daemon.") +;; <interface name='org.gnome.OnlineAccounts.Manager'> +;; <method name='AddAccount'> +;; <arg type='s' name='provider' direction='in'/> +;; <arg type='s' name='identity' direction='in'/> +;; <arg type='s' name='presentation_identity' direction='in'/> +;; <arg type='a{sv}' name='credentials' direction='in'/> +;; <arg type='a{ss}' name='details' direction='in'/> +;; <arg type='o' name='account_object_path' direction='out'/> +;; </method> +;; </interface> -(defconst tramp-hal-interface-device "org.freedesktop.Hal.Device" - "The device interface of the HAL daemon.") +;; The basic structure for GNOME Online Accounts. We use a list :type, +;; in order to be compatible with Emacs 24 and 25. +(cl-defstruct (tramp-goa-name (:type list) :named) method user host port) ;; "gvfs-<command>" utilities have been deprecated in GVFS 1.31.1. We ;; must use "gio <command>" tool instead. @@ -421,11 +468,13 @@ Every entry is a list (NAME ADDRESS).") ("gvfs-ls" . "list") ("gvfs-mkdir" . "mkdir") ("gvfs-monitor-file" . "monitor") + ("gvfs-mount" . "mount") ("gvfs-move" . "move") ("gvfs-rm" . "remove") ("gvfs-trash" . "trash")) "List of cons cells, mapping \"gvfs-<command>\" to \"gio <command>\".") +;; <http://www.pygtk.org/docs/pygobject/gio-constants.html> (defconst tramp-gvfs-file-attributes '("name" "type" @@ -470,11 +519,18 @@ Every entry is a list (NAME ADDRESS).") ":[[:blank:]]+\\(.*\\)$") "Regexp to parse GVFS file system attributes with `gvfs-info'.") +(defconst tramp-gvfs-nextcloud-default-prefix "/remote.php/webdav" + "Default prefix for owncloud / nextcloud methods.") + +(defconst tramp-gvfs-nextcloud-default-prefix-regexp + (concat (regexp-quote tramp-gvfs-nextcloud-default-prefix) "$") + "Regexp of default prefix for owncloud / nextcloud methods.") + ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-gvfs-file-name-handler-alist - '((access-file . ignore) + '((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' performed by default handler. @@ -488,16 +544,17 @@ Every entry is a list (NAME ADDRESS).") . tramp-handle-directory-files-and-attributes) (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) + (exec-path . ignore) (expand-file-name . tramp-gvfs-handle-expand-file-name) (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . ignore) (file-attributes . tramp-gvfs-handle-file-attributes) - (file-directory-p . tramp-gvfs-handle-file-directory-p) + (file-directory-p . tramp-handle-file-directory-p) (file-equal-p . tramp-handle-file-equal-p) (file-executable-p . tramp-gvfs-handle-file-executable-p) (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) - (file-local-copy . tramp-gvfs-handle-file-local-copy) + (file-local-copy . tramp-handle-file-local-copy) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-gvfs-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) @@ -518,9 +575,8 @@ Every entry is a list (NAME ADDRESS).") (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-gvfs-handle-file-system-info) (file-truename . tramp-handle-file-truename) - (file-writable-p . tramp-gvfs-handle-file-writable-p) + (file-writable-p . tramp-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) - ;; `find-file-noselect' performed by default handler. ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) @@ -529,6 +585,7 @@ Every entry is a list (NAME ADDRESS).") (make-directory . tramp-gvfs-handle-make-directory) (make-directory-internal . ignore) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) (process-file . ignore) (rename-file . tramp-gvfs-handle-rename-file) @@ -541,10 +598,11 @@ Every entry is a list (NAME ADDRESS).") (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) - (write-region . tramp-gvfs-handle-write-region)) + (write-region . tramp-handle-write-region)) "Alist of handler functions for Tramp GVFS method. Operations not mentioned here will be handled by the default Emacs primitives.") @@ -564,7 +622,7 @@ Operations not mentioned here will be handled by the default Emacs primitives.") First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." (unless tramp-gvfs-enabled - (tramp-compat-user-error nil "Package `tramp-gvfs' not supported")) + (tramp-user-error nil "Package `tramp-gvfs' not supported")) (let ((fn (assoc operation tramp-gvfs-file-name-handler-alist))) (if fn (save-match-data (apply (cdr fn) args)) @@ -572,8 +630,9 @@ pass to the OPERATION." ;;;###tramp-autoload (when (featurep 'dbusbind) - (tramp-register-foreign-file-name-handler - 'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler)) + (tramp--with-startup + (tramp-register-foreign-file-name-handler + #'tramp-gvfs-file-name-p #'tramp-gvfs-file-name-handler))) ;; D-Bus helper function. @@ -601,12 +660,24 @@ Return nil for null BYTE-ARRAY." (cond ((and (consp message) (characterp (car message))) (format "%S" (tramp-gvfs-dbus-byte-array-to-string message))) + ((and (consp message) (atom (cdr message))) + (cons (tramp-gvfs-stringify-dbus-message (car message)) + (tramp-gvfs-stringify-dbus-message (cdr message)))) ((consp message) - (mapcar 'tramp-gvfs-stringify-dbus-message message)) + (mapcar #'tramp-gvfs-stringify-dbus-message message)) ((stringp message) (format "%S" message)) (t message))) +(defun tramp-dbus-function (vec func args) + "Apply a D-Bus function FUNC from dbus.el. +The call will be traced by Tramp with trace level 6." + (let (result) + (tramp-message vec 6 "%s" (cons func args)) + (setq result (apply func args)) + (tramp-message vec 6 "%s" result(tramp-gvfs-stringify-dbus-message result)) + result)) + (defmacro with-tramp-dbus-call-method (vec synchronous bus service path interface method &rest args) "Apply a D-Bus call on bus BUS. @@ -615,22 +686,34 @@ If SYNCHRONOUS is non-nil, the call is synchronously. Otherwise, it is an asynchronous call, with `ignore' as callback function. The other arguments have the same meaning as with `dbus-call-method' -or `dbus-call-method-asynchronously'. Additionally, the call -will be traced by Tramp with trace level 6." +or `dbus-call-method-asynchronously'." `(let ((func (if ,synchronous - 'dbus-call-method 'dbus-call-method-asynchronously)) + #'dbus-call-method #'dbus-call-method-asynchronously)) (args (append (list ,bus ,service ,path ,interface ,method) - (if ,synchronous (list ,@args) (list 'ignore ,@args)))) - result) - (tramp-message ,vec 6 "%s %s" func args) - (setq result (apply func args)) - (tramp-message ,vec 6 "%s" (tramp-gvfs-stringify-dbus-message result)) - result)) + (if ,synchronous (list ,@args) (list 'ignore ,@args))))) + (tramp-dbus-function ,vec func args))) (put 'with-tramp-dbus-call-method 'lisp-indent-function 2) (put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>")) +(defmacro with-tramp-dbus-get-all-properties + (vec bus service path interface) + "Return all properties of INTERFACE. +The call will be traced by Tramp with trace level 6." + ;; Check, that interface exists at object path. Retrieve properties. + `(when (member + ,interface + (tramp-dbus-function + ,vec #'dbus-introspect-get-interface-names + (list ,bus ,service ,path))) + (tramp-dbus-function + ,vec #'dbus-get-all-properties (list ,bus ,service ,path ,interface)))) + +(put 'with-tramp-dbus-get-all-properties 'lisp-indent-function 1) +(put 'with-tramp-dbus-get-all-properties 'edebug-form-spec '(form symbolp body)) +(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-get-all-properties\\>")) + (defvar tramp-gvfs-dbus-event-vector nil "Current Tramp file name to be used, as vector. It is needed when D-Bus signals or errors arrive, because there @@ -639,15 +722,10 @@ is no information where to trace the message.") (defun tramp-gvfs-dbus-event-error (event err) "Called when a D-Bus error message arrives, see `dbus-event-error-functions'." (when tramp-gvfs-dbus-event-vector - (tramp-message tramp-gvfs-dbus-event-vector 10 "%S" event) + (tramp-message tramp-gvfs-dbus-event-vector 6 "%S" event) (tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err)))) -;; `dbus-event-error-hooks' has been renamed to -;; `dbus-event-error-functions' in Emacs 24.3. -(add-hook - (if (boundp 'dbus-event-error-functions) - 'dbus-event-error-functions 'dbus-event-error-hooks) - 'tramp-gvfs-dbus-event-error) +(add-hook 'dbus-event-error-functions #'tramp-gvfs-dbus-event-error) ;; File name primitives. @@ -672,6 +750,7 @@ file names." (unless (memq op '(copy rename)) (error "Unknown operation `%s', must be `copy' or `rename'" op)) + (setq filename (file-truename filename)) (if (file-directory-p filename) (progn (copy-directory filename newname keep-date t) @@ -686,6 +765,8 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) (if (or (and equal-remote (tramp-get-connection-property v "direct-copy-failed" nil)) @@ -706,7 +787,7 @@ file names." v 0 (format "%s %s to %s" msg-operation filename newname) (unless (apply - 'tramp-gvfs-send-command v gvfs-operation + #'tramp-gvfs-send-command v gvfs-operation (append (and (eq op 'copy) (or keep-date preserve-uid-gid) '("--preserve")) @@ -735,13 +816,13 @@ file names." (when (and t1 (eq op 'rename)) (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname))) (when t2 (with-parsed-tramp-file-name newname nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)))))))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname)))))))) (defun tramp-gvfs-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -775,8 +856,8 @@ file names." (tramp-error v 'file-error "Couldn't delete non-empty %s" directory))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (unless (tramp-gvfs-send-command v (if (and trash delete-by-moving-to-trash) "gvfs-trash" "gvfs-rm") @@ -790,8 +871,8 @@ file names." (defun tramp-gvfs-handle-delete-file (filename &optional trash) "Like `delete-file' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (unless (tramp-gvfs-send-command v (if (and trash delete-by-moving-to-trash) "gvfs-trash" "gvfs-rm") @@ -806,12 +887,14 @@ file names." "Like `expand-file-name' for Tramp files." ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". (setq dir (or dir default-directory "/")) + ;; Handle empty NAME. + (when (zerop (length name)) (setq name ".")) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) (setq name (concat (file-name-as-directory dir) name))) ;; If NAME is not a Tramp file, run the real handler. (if (not (tramp-tramp-file-p name)) - (tramp-run-real-handler 'expand-file-name (list name nil)) + (tramp-run-real-handler #'expand-file-name (list name nil)) ;; Dissect NAME. (with-parsed-tramp-file-name name nil ;; If there is a default location, expand tilde. @@ -826,14 +909,14 @@ file names." (tramp-get-connection-property v "default-location" "~") nil t localname 1))) ;; Tilde expansion is not possible. - (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + (when (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)) + (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) ;; We do not pass "/..". - (if (string-match "^\\(afp\\|davs?\\|smb\\)$" method) + (if (string-match-p "^\\(afp\\|davs?\\|smb\\)$" method) (when (string-match "^/[^/]+\\(/\\.\\./?\\)" localname) (setq localname (replace-match "/" t t localname 1))) (when (string-match "^/\\.\\./?" localname) @@ -844,89 +927,86 @@ file names." ;; No tilde characters in file name, do normal ;; `expand-file-name' (this does "/./" and "/../"). (tramp-make-tramp-file-name - method user domain host port - (tramp-run-real-handler 'expand-file-name (list localname)))))) + v (tramp-run-real-handler #'expand-file-name (list localname)))))) (defun tramp-gvfs-get-directory-attributes (directory) "Return GVFS attributes association list of all files in DIRECTORY." - (ignore-errors - ;; Don't modify `last-coding-system-used' by accident. - (let ((last-coding-system-used last-coding-system-used) - result) - (with-parsed-tramp-file-name directory nil - (with-tramp-file-property v localname "directory-attributes" - (tramp-message v 5 "directory gvfs attributes: %s" localname) - ;; Send command. - (tramp-gvfs-send-command - v "gvfs-ls" "-h" "-n" "-a" - (mapconcat 'identity tramp-gvfs-file-attributes ",") - (tramp-gvfs-url-file-name directory)) - ;; Parse output. - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (while (looking-at - (concat "^\\(.+\\)[[:blank:]]" - "\\([[:digit:]]+\\)[[:blank:]]" - "(\\(.+?\\))" - tramp-gvfs-file-attributes-with-gvfs-ls-regexp)) - (let ((item (list (cons "type" (match-string 3)) - (cons "standard::size" (match-string 2)) - (cons "name" (match-string 1))))) - (goto-char (1+ (match-end 3))) - (while (looking-at - (concat - tramp-gvfs-file-attributes-with-gvfs-ls-regexp - "\\(" tramp-gvfs-file-attributes-with-gvfs-ls-regexp - "\\|" "$" "\\)")) - (push (cons (match-string 1) (match-string 2)) item) - (goto-char (match-end 2))) - ;; Add display name as head. - (push - (cons (cdr (or (assoc "standard::display-name" item) - (assoc "name" item))) - (nreverse item)) - result)) - (forward-line))) - result))))) + ;; Don't modify `last-coding-system-used' by accident. + (let ((last-coding-system-used last-coding-system-used) + result) + (with-parsed-tramp-file-name directory nil + (with-tramp-file-property v localname "directory-attributes" + (tramp-message v 5 "directory gvfs attributes: %s" localname) + ;; Send command. + (tramp-gvfs-send-command + v "gvfs-ls" "-h" "-n" "-a" + (string-join tramp-gvfs-file-attributes ",") + (tramp-gvfs-url-file-name directory)) + ;; Parse output. + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (while (looking-at + (concat "^\\(.+\\)[[:blank:]]" + "\\([[:digit:]]+\\)[[:blank:]]" + "(\\(.+?\\))" + tramp-gvfs-file-attributes-with-gvfs-ls-regexp)) + (let ((item (list (cons "type" (match-string 3)) + (cons "standard::size" (match-string 2)) + (cons "name" (match-string 1))))) + (goto-char (1+ (match-end 3))) + (while (looking-at + (concat + tramp-gvfs-file-attributes-with-gvfs-ls-regexp + "\\(" tramp-gvfs-file-attributes-with-gvfs-ls-regexp + "\\|" "$" "\\)")) + (push (cons (match-string 1) (match-string 2)) item) + (goto-char (match-end 2))) + ;; Add display name as head. + (push + (cons (cdr (or (assoc "standard::display-name" item) + (assoc "name" item))) + (nreverse item)) + result)) + (forward-line))) + result)))) (defun tramp-gvfs-get-root-attributes (filename &optional file-system) "Return GVFS attributes association list of FILENAME. If FILE-SYSTEM is non-nil, return file system attributes." - (ignore-errors - ;; Don't modify `last-coding-system-used' by accident. - (let ((last-coding-system-used last-coding-system-used) - result) - (with-parsed-tramp-file-name filename nil - (with-tramp-file-property - v localname - (if file-system "file-system-attributes" "file-attributes") - (tramp-message - v 5 "file%s gvfs attributes: %s" - (if file-system " system" "") localname) - ;; Send command. - (if file-system - (tramp-gvfs-send-command - v "gvfs-info" "--filesystem" (tramp-gvfs-url-file-name filename)) + ;; Don't modify `last-coding-system-used' by accident. + (let ((last-coding-system-used last-coding-system-used) + result) + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property + v localname + (if file-system "file-system-attributes" "file-attributes") + (tramp-message + v 5 "file%s gvfs attributes: %s" + (if file-system " system" "") localname) + ;; Send command. + (if file-system (tramp-gvfs-send-command - v "gvfs-info" (tramp-gvfs-url-file-name filename))) - ;; Parse output. - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (while (re-search-forward - (if file-system - tramp-gvfs-file-system-attributes-regexp - tramp-gvfs-file-attributes-with-gvfs-info-regexp) - nil t) - (push (cons (match-string 1) (match-string 2)) result)) - result)))))) + v "gvfs-info" "--filesystem" (tramp-gvfs-url-file-name filename)) + (tramp-gvfs-send-command + v "gvfs-info" (tramp-gvfs-url-file-name filename))) + ;; Parse output. + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (while (re-search-forward + (if file-system + tramp-gvfs-file-system-attributes-regexp + tramp-gvfs-file-attributes-with-gvfs-info-regexp) + nil t) + (push (cons (match-string 1) (match-string 2)) result)) + result))))) (defun tramp-gvfs-get-file-attributes (filename) "Return GVFS attributes association list of FILENAME." (setq filename (directory-file-name (expand-file-name filename))) (with-parsed-tramp-file-name filename nil (setq localname (tramp-compat-file-name-unquote localname)) - (if (or (and (string-match "^\\(afp\\|davs?\\|smb\\)$" method) - (string-match "^/?\\([^/]+\\)$" localname)) + (if (or (and (string-match-p "^\\(afp\\|davs?\\|smb\\)$" method) + (string-match-p "^/?\\([^/]+\\)$" localname)) (string-equal localname "/")) (tramp-gvfs-get-root-attributes filename) (assoc @@ -936,135 +1016,133 @@ If FILE-SYSTEM is non-nil, return file system attributes." (defun tramp-gvfs-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." (unless id-format (setq id-format 'integer)) - (ignore-errors - (let ((attributes (tramp-gvfs-get-file-attributes filename)) - dirp res-symlink-target res-numlinks res-uid res-gid res-access - res-mod res-change res-size res-filemodes res-inode res-device) - (when attributes - ;; ... directory or symlink - (setq dirp (if (equal "directory" (cdr (assoc "type" attributes))) t)) + (let ((attributes (tramp-gvfs-get-file-attributes filename)) + dirp res-symlink-target res-numlinks res-uid res-gid res-access + res-mod res-change res-size res-filemodes res-inode res-device) + (when attributes + ;; ... directory or symlink + (setq dirp (if (equal "directory" (cdr (assoc "type" attributes))) t)) + (setq res-symlink-target + (cdr (assoc "standard::symlink-target" attributes))) + (when (stringp res-symlink-target) (setq res-symlink-target - (cdr (assoc "standard::symlink-target" attributes))) - ;; ... number links - (setq res-numlinks - (string-to-number - (or (cdr (assoc "unix::nlink" attributes)) "0"))) - ;; ... uid and gid - (setq res-uid - (if (eq id-format 'integer) - (string-to-number - (or (cdr (assoc "unix::uid" attributes)) - (format "%s" tramp-unknown-id-integer))) - (or (cdr (assoc "owner::user" attributes)) - (cdr (assoc "unix::uid" attributes)) - tramp-unknown-id-string))) - (setq res-gid - (if (eq id-format 'integer) - (string-to-number - (or (cdr (assoc "unix::gid" attributes)) - (format "%s" tramp-unknown-id-integer))) - (or (cdr (assoc "owner::group" attributes)) - (cdr (assoc "unix::gid" attributes)) - tramp-unknown-id-string))) - ;; ... last access, modification and change time - (setq res-access - (seconds-to-time - (string-to-number - (or (cdr (assoc "time::access" attributes)) "0")))) - (setq res-mod - (seconds-to-time - (string-to-number - (or (cdr (assoc "time::modified" attributes)) "0")))) - (setq res-change - (seconds-to-time - (string-to-number - (or (cdr (assoc "time::changed" attributes)) "0")))) - ;; ... size - (setq res-size - (string-to-number - (or (cdr (assoc "standard::size" attributes)) "0"))) - ;; ... file mode flags - (setq res-filemodes - (let ((n (cdr (assoc "unix::mode" attributes)))) - (if n - (tramp-file-mode-from-int (string-to-number n)) - (format - "%s%s%s%s------" - (if dirp "d" (if res-symlink-target "l" "-")) - (if (equal (cdr (assoc "access::can-read" attributes)) - "FALSE") - "-" "r") - (if (equal (cdr (assoc "access::can-write" attributes)) - "FALSE") - "-" "w") - (if (equal (cdr (assoc "access::can-execute" attributes)) - "FALSE") - "-" "x"))))) - ;; ... inode and device - (setq res-inode - (let ((n (cdr (assoc "unix::inode" attributes)))) - (if n - (string-to-number n) - (tramp-get-inode (tramp-dissect-file-name filename))))) - (setq res-device - (let ((n (cdr (assoc "unix::device" attributes)))) - (if n - (string-to-number n) - (tramp-get-device (tramp-dissect-file-name filename))))) - - ;; Return data gathered. - (list - ;; 0. t for directory, string (name linked to) for - ;; symbolic link, or nil. - (or dirp res-symlink-target) - ;; 1. Number of links to file. - res-numlinks - ;; 2. File uid. - res-uid - ;; 3. File gid. - res-gid - ;; 4. Last access time, as a list of integers. - ;; 5. Last modification time, likewise. - ;; 6. Last status change time, likewise. - res-access res-mod res-change - ;; 7. Size in bytes (-1, if number is out of range). - res-size - ;; 8. File modes. - res-filemodes - ;; 9. t if file's gid would change if file were deleted - ;; and recreated. - nil - ;; 10. Inode number. - res-inode - ;; 11. Device number. - res-device - ))))) - -(defun tramp-gvfs-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - (eq t (tramp-compat-file-attribute-type - (file-attributes (file-truename filename))))) + ;; Parse unibyte codes "\xNN". We assume they are + ;; non-ASCII codepoints in the range #x80 through #xff. + ;; Convert them to multibyte. + (decode-coding-string + (replace-regexp-in-string + "\\\\x\\([[:xdigit:]]\\{2\\}\\)" + (lambda (x) + (unibyte-string (string-to-number (match-string 1 x) 16))) + res-symlink-target) + 'utf-8))) + ;; ... number links + (setq res-numlinks + (string-to-number + (or (cdr (assoc "unix::nlink" attributes)) "0"))) + ;; ... uid and gid + (setq res-uid + (if (eq id-format 'integer) + (string-to-number + (or (cdr (assoc "unix::uid" attributes)) + (eval-when-compile + (format "%s" tramp-unknown-id-integer)))) + (or (cdr (assoc "owner::user" attributes)) + (cdr (assoc "unix::uid" attributes)) + tramp-unknown-id-string))) + (setq res-gid + (if (eq id-format 'integer) + (string-to-number + (or (cdr (assoc "unix::gid" attributes)) + (eval-when-compile + (format "%s" tramp-unknown-id-integer)))) + (or (cdr (assoc "owner::group" attributes)) + (cdr (assoc "unix::gid" attributes)) + tramp-unknown-id-string))) + ;; ... last access, modification and change time + (setq res-access + (seconds-to-time + (string-to-number + (or (cdr (assoc "time::access" attributes)) "0")))) + (setq res-mod + (seconds-to-time + (string-to-number + (or (cdr (assoc "time::modified" attributes)) "0")))) + (setq res-change + (seconds-to-time + (string-to-number + (or (cdr (assoc "time::changed" attributes)) "0")))) + ;; ... size + (setq res-size + (string-to-number + (or (cdr (assoc "standard::size" attributes)) "0"))) + ;; ... file mode flags + (setq res-filemodes + (let ((n (cdr (assoc "unix::mode" attributes)))) + (if n + (tramp-file-mode-from-int (string-to-number n)) + (format + "%s%s%s%s------" + (if dirp "d" (if res-symlink-target "l" "-")) + (if (equal (cdr (assoc "access::can-read" attributes)) + "FALSE") + "-" "r") + (if (equal (cdr (assoc "access::can-write" attributes)) + "FALSE") + "-" "w") + (if (equal (cdr (assoc "access::can-execute" attributes)) + "FALSE") + "-" "x"))))) + ;; ... inode and device + (setq res-inode + (let ((n (cdr (assoc "unix::inode" attributes)))) + (if n + (string-to-number n) + (tramp-get-inode (tramp-dissect-file-name filename))))) + (setq res-device + (let ((n (cdr (assoc "unix::device" attributes)))) + (if n + (string-to-number n) + (tramp-get-device (tramp-dissect-file-name filename))))) + + ;; Return data gathered. + (list + ;; 0. t for directory, string (name linked to) for + ;; symbolic link, or nil. + (or dirp res-symlink-target) + ;; 1. Number of links to file. + res-numlinks + ;; 2. File uid. + res-uid + ;; 3. File gid. + res-gid + ;; 4. Last access time, as a list of integers. + ;; 5. Last modification time, likewise. + ;; 6. Last status change time, likewise. + res-access res-mod res-change + ;; 7. Size in bytes (-1, if number is out of range). + res-size + ;; 8. File modes. + res-filemodes + ;; 9. t if file's gid would change if file were deleted + ;; and recreated. + nil + ;; 10. Inode number. + res-inode + ;; 11. Device number. + res-device + )))) (defun tramp-gvfs-handle-file-executable-p (filename) "Like `file-executable-p' for Tramp files." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-executable-p" - (tramp-check-cached-permissions v ?x)))) - -(defun tramp-gvfs-handle-file-local-copy (filename) - "Like `file-local-copy' for Tramp files." - (with-parsed-tramp-file-name filename nil - (unless (file-exists-p filename) - (tramp-error - v tramp-file-missing - "Cannot make local copy of non-existing file `%s'" filename)) - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) - tmpfile))) + (and (file-exists-p filename) + (tramp-check-cached-permissions v ?x))))) (defun tramp-gvfs-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (unless (save-match-data (string-match "/" filename)) + (unless (string-match-p "/" filename) (all-completions filename (with-parsed-tramp-file-name (expand-file-name directory) nil @@ -1080,9 +1158,10 @@ If FILE-SYSTEM is non-nil, return file system attributes." "Like `file-notify-add-watch' for Tramp files." (setq file-name (expand-file-name file-name)) (with-parsed-tramp-file-name file-name nil - ;; We cannot watch directories, because `gvfs-monitor-dir' is not - ;; supported for gvfs-mounted directories. - (when (file-directory-p file-name) + ;; TODO: We cannot watch directories, because `gio monitor' is not + ;; supported for gvfs-mounted directories. However, + ;; `file-notify-add-watch' uses directories. + (when (or (not (tramp-gvfs-gio-tool-p v)) (file-directory-p file-name)) (tramp-error v 'file-notify-error "Monitoring not supported for `%s'" file-name)) (let* ((default-directory (file-name-directory file-name)) @@ -1095,69 +1174,83 @@ If FILE-SYSTEM is non-nil, return file system attributes." '(created changed changes-done-hint moved deleted)) ((memq 'attribute-change flags) '(attribute-changed)))) (p (apply - 'start-process + #'start-process "gvfs-monitor" (generate-new-buffer " *gvfs-monitor*") - (if (tramp-gvfs-gio-tool-p v) - `("gio" "monitor" ,(tramp-gvfs-url-file-name file-name))) - `("gvfs-monitor-file" (tramp-gvfs-url-file-name file-name))))) + `("gio" "monitor" ,(tramp-gvfs-url-file-name file-name))))) (if (not (processp p)) (tramp-error v 'file-notify-error "Monitoring not supported for `%s'" file-name) (tramp-message - v 6 "Run `%s', %S" (mapconcat 'identity (process-command p) " ") p) - (tramp-set-connection-property p "vector" v) + v 6 "Run `%s', %S" (string-join (process-command p) " ") p) + (process-put p 'vector v) (process-put p 'events events) (process-put p 'watch-name localname) - (process-put p 'adjust-window-size-function 'ignore) + (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) - (set-process-filter p 'tramp-gvfs-monitor-file-process-filter) + (set-process-filter p #'tramp-gvfs-monitor-process-filter) + (set-process-sentinel p #'tramp-file-notify-process-sentinel) ;; There might be an error if the monitor is not supported. ;; Give the filter a chance to read the output. - (tramp-accept-process-output p 1) + (while (tramp-accept-process-output p 0)) (unless (process-live-p p) (tramp-error - v 'file-notify-error "Monitoring not supported for `%s'" file-name)) + p 'file-notify-error "Monitoring not supported for `%s'" file-name)) p)))) -(defun tramp-gvfs-monitor-file-process-filter (proc string) +(defun tramp-gvfs-monitor-process-filter (proc string) "Read output from \"gvfs-monitor-file\" and add corresponding \ file-notify events." - (let* ((rest-string (process-get proc 'rest-string)) + (let* ((events (process-get proc 'events)) + (rest-string (process-get proc 'rest-string)) (dd (with-current-buffer (process-buffer proc) default-directory)) (ddu (regexp-quote (tramp-gvfs-url-file-name dd)))) (when rest-string (tramp-message proc 10 "Previous string:\n%s" rest-string)) (tramp-message proc 6 "%S\n%s" proc string) (setq string (concat rest-string string) - ;; Attribute change is returned in unused wording. - string (replace-regexp-in-string - "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string)) - (when (string-match "Monitoring not supported" string) + ;; Fix action names. + string (replace-regexp-in-string + "attributes changed" "attribute-changed" string) + string (replace-regexp-in-string + "changes done" "changes-done-hint" string) + string (replace-regexp-in-string + "renamed to" "moved" string)) + ;; https://bugs.launchpad.net/bugs/1742946 + (when + (string-match-p "Monitoring not supported\\|No locations given" string) (delete-process proc)) (while (string-match - (concat "^[\n\r]*" - "File Monitor Event:[\n\r]+" - "File = \\([^\n\r]+\\)[\n\r]+" - "Event = \\([^[:blank:]]+\\)[\n\r]+") + (eval-when-compile + (concat "^.+:" + "[[:space:]]\\(.+\\):" + "[[:space:]]" (regexp-opt tramp-gio-events t) + "\\([[:space:]]\\(.+\\)\\)?$")) string) + (let ((file (match-string 1 string)) - (action (intern-soft - (replace-regexp-in-string - "_" "-" (downcase (match-string 2 string)))))) + (file1 (match-string 4 string)) + (action (intern-soft (match-string 2 string)))) (setq string (replace-match "" nil nil string)) ;; File names are returned as URL paths. We must convert them. (when (string-match ddu file) (setq file (replace-match dd nil nil file))) - (while (string-match "%\\([0-9A-F]\\{2\\}\\)" file) - (setq file - (replace-match - (char-to-string (string-to-number (match-string 1 file) 16)) - nil nil file))) + (while (string-match-p "%\\([0-9A-F]\\{2\\}\\)" file) + (setq file (url-unhex-string file))) + (when (string-match ddu (or file1 "")) + (setq file1 (replace-match dd nil nil file1))) + (while (string-match-p "%\\([0-9A-F]\\{2\\}\\)" (or file1 "")) + (setq file1 (url-unhex-string file1))) + ;; Remove watch when file or directory to be watched is deleted. + (when (and (member action '(moved deleted)) + (string-equal file (process-get proc 'watch-name))) + (delete-process proc)) ;; Usually, we would add an Emacs event now. Unfortunately, ;; `unread-command-events' does not accept several events at ;; once. Therefore, we apply the callback directly. - (tramp-compat-funcall 'file-notify-callback (list proc action file)))) + (when (member action events) + (tramp-compat-funcall + 'file-notify-callback (list proc action file file1))))) ;; Save rest of the string. (when (zerop (length string)) (setq string nil)) @@ -1168,40 +1261,42 @@ file-notify events." "Like `file-readable-p' for Tramp files." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-readable-p" - (tramp-check-cached-permissions v ?r)))) + (and (file-exists-p filename) + (or (tramp-check-cached-permissions v ?r) + ;; If the user is different from what we guess to be + ;; the user, we don't know. Let's check, whether + ;; access is restricted explicitly. + (and (/= (tramp-gvfs-get-remote-uid v 'integer) + (tramp-compat-file-attribute-user-id + (file-attributes filename 'integer))) + (not + (string-equal + "FALSE" + (cdr (assoc + "access::can-read" + (tramp-gvfs-get-file-attributes filename))))))))))) (defun tramp-gvfs-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." (setq filename (directory-file-name (expand-file-name filename))) (with-parsed-tramp-file-name filename nil ;; We don't use cached values. - (tramp-set-file-property v localname "file-system-attributes" 'undef) + (tramp-flush-file-property v localname "file-system-attributes") (let* ((attr (tramp-gvfs-get-root-attributes filename 'file-system)) (size (cdr (assoc "filesystem::size" attr))) (used (cdr (assoc "filesystem::used" attr))) (free (cdr (assoc "filesystem::free" attr)))) (when (and (stringp size) (stringp used) (stringp free)) - (list (string-to-number (concat size "e0")) - (- (string-to-number (concat size "e0")) - (string-to-number (concat used "e0"))) - (string-to-number (concat free "e0"))))))) - -(defun tramp-gvfs-handle-file-writable-p (filename) - "Like `file-writable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-tramp-file-property v localname "file-writable-p" - (if (file-exists-p filename) - (tramp-check-cached-permissions v ?w) - ;; If file doesn't exist, check if directory is writable. - (and (file-directory-p (file-name-directory filename)) - (file-writable-p (file-name-directory filename))))))) + (list (string-to-number size) + (- (string-to-number size) (string-to-number used)) + (string-to-number free)))))) (defun tramp-gvfs-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." (setq dir (directory-file-name (expand-file-name dir))) (with-parsed-tramp-file-name dir nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (save-match-data (let ((ldir (file-name-directory dir))) ;; Make missing directory parts. "gvfs-mkdir -p ..." does not @@ -1228,56 +1323,14 @@ file-notify events." 'rename filename newname ok-if-already-exists 'keep-date 'preserve-uid-gid) (tramp-run-real-handler - 'rename-file (list filename newname ok-if-already-exists)))) - -(defun tramp-gvfs-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 - (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 ((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 - ;; modtime data to be clobbered from the temp file. We call - ;; `set-visited-file-modtime' ourselves later on. - (tramp-run-real-handler - 'write-region (list start end tmpfile append 'no-message lockname)) - (condition-case nil - (rename-file tmpfile filename 'ok-if-already-exists) - (error - (delete-file tmpfile) - (tramp-error - v 'file-error "Couldn't write region to `%s'" filename)))) - - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) - - ;; Set file modification time. - (when (or (eq visit t) (stringp visit)) - (set-visited-file-modtime - (tramp-compat-file-attribute-modification-time - (file-attributes filename)))) - - ;; The end. - (when (and (null noninteractive) - (or (eq visit t) (null visit) (stringp visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook))) + #'rename-file (list filename newname ok-if-already-exists)))) ;; File name conversions. (defun tramp-gvfs-url-file-name (filename) "Return FILENAME in URL syntax." - ;; "/" must NOT be hexlified. + ;; "/" must NOT be hexified. (setq filename (tramp-compat-file-name-unquote filename)) (let ((url-unreserved-chars (cons ?/ url-unreserved-chars)) result) @@ -1288,6 +1341,10 @@ file-notify events." (with-parsed-tramp-file-name filename nil (when (string-equal "gdrive" method) (setq method "google-drive")) + (when (string-equal "nextcloud" method) + (setq method "davs" + localname + (concat (tramp-gvfs-get-remote-prefix v) localname))) (when (and user domain) (setq user (concat domain ";" user))) (url-parse-make-urlobj @@ -1312,24 +1369,6 @@ file-notify events." (dbus-unescape-from-identifier (replace-regexp-in-string "^.*/\\([^/]+\\)$" "\\1" object-path))) -(defun tramp-bluez-address (device) - "Return bluetooth device address from a given bluetooth DEVICE name." - (when (stringp device) - (if (string-match tramp-ipv6-regexp device) - (match-string 0 device) - (cadr (assoc device (tramp-bluez-list-devices)))))) - -(defun tramp-bluez-device (address) - "Return bluetooth device name from a given bluetooth device ADDRESS. -ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." - (when (stringp address) - (while (string-match "[][]" address) - (setq address (replace-match "" t t address))) - (let (result) - (dolist (item (tramp-bluez-list-devices) result) - (when (string-match address (cadr item)) - (setq result (car item))))))) - ;; D-Bus GVFS functions. @@ -1361,13 +1400,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (unless (tramp-get-connection-property l "first-password-request" nil) (tramp-clear-passwd l)) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method l-method - tramp-current-user user - tramp-current-domain l-domain - tramp-current-host l-host - tramp-current-port l-port - password (tramp-read-passwd + (setq password (tramp-read-passwd (tramp-get-connection-process l) pw-prompt)) ;; Return result. @@ -1406,7 +1439,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (tramp-get-connection-process v) message ;; In theory, there can be several choices. ;; Until now, there is only the question whether - ;; to accept an unknown host signature. + ;; to accept an unknown host signature or certificate. (with-temp-buffer ;; Preserve message for `progress-reporter'. (with-temp-message "" @@ -1447,6 +1480,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (while (stringp (car elt)) (setq elt (cdr elt))) (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string (cadr elt))) (mount-spec (cl-caddr elt)) + (prefix (tramp-gvfs-dbus-byte-array-to-string (car mount-spec))) (default-location (tramp-gvfs-dbus-byte-array-to-string (cl-cadddr elt))) (method (tramp-gvfs-dbus-byte-array-to-string @@ -1462,53 +1496,56 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (cadr (assoc "port" (cadr mount-spec))))) (ssl (tramp-gvfs-dbus-byte-array-to-string (cadr (assoc "ssl" (cadr mount-spec))))) - (prefix (concat - (tramp-gvfs-dbus-byte-array-to-string - (car mount-spec)) - (tramp-gvfs-dbus-byte-array-to-string - (or (cadr (assoc "share" (cadr mount-spec))) - (cadr (assoc "volume" (cadr mount-spec)))))))) + (uri (tramp-gvfs-dbus-byte-array-to-string + (cadr (assoc "uri" (cadr mount-spec)))))) (when (string-match "^\\(afp\\|smb\\)" method) (setq method (match-string 1 method))) - (when (string-equal "obex" method) - (setq host (tramp-bluez-device host))) (when (and (string-equal "dav" method) (string-equal "true" ssl)) (setq method "davs")) + (when (and (string-equal "davs" method) + (string-match-p + tramp-gvfs-nextcloud-default-prefix-regexp prefix)) + (setq method "nextcloud")) (when (string-equal "google-drive" method) (setq method "gdrive")) - (with-parsed-tramp-file-name - (tramp-make-tramp-file-name method user domain host port "") nil - (tramp-message - v 6 "%s %s" - signal-name (tramp-gvfs-stringify-dbus-message mount-info)) - (tramp-set-file-property v "/" "list-mounts" 'undef) - (if (string-equal (downcase signal-name) "unmounted") - (tramp-flush-file-property v "/") - ;; Set prefix, mountpoint and location. - (unless (string-equal prefix "/") - (tramp-set-file-property v "/" "prefix" prefix)) - (tramp-set-file-property v "/" "fuse-mountpoint" fuse-mountpoint) - (tramp-set-connection-property - v "default-location" default-location))))))) + (when (and (string-equal "http" method) (stringp uri)) + (setq uri (url-generic-parse-url uri) + method (url-type uri) + user (url-user uri) + host (url-host uri) + port (url-portspec uri))) + (when (member method tramp-gvfs-methods) + (with-parsed-tramp-file-name + (tramp-make-tramp-file-name method user domain host port "") nil + (tramp-message + v 6 "%s %s" + signal-name (tramp-gvfs-stringify-dbus-message mount-info)) + (tramp-flush-file-property v "/" "list-mounts") + (if (string-equal (downcase signal-name) "unmounted") + (tramp-flush-file-properties v "/") + ;; Set mountpoint and location. + (tramp-set-file-property v "/" "fuse-mountpoint" fuse-mountpoint) + (tramp-set-connection-property + v "default-location" default-location)))))))) (when tramp-gvfs-enabled (dbus-register-signal :session nil tramp-gvfs-path-mounttracker tramp-gvfs-interface-mounttracker "mounted" - 'tramp-gvfs-handler-mounted-unmounted) + #'tramp-gvfs-handler-mounted-unmounted) (dbus-register-signal :session nil tramp-gvfs-path-mounttracker tramp-gvfs-interface-mounttracker "Mounted" - 'tramp-gvfs-handler-mounted-unmounted) + #'tramp-gvfs-handler-mounted-unmounted) (dbus-register-signal :session nil tramp-gvfs-path-mounttracker tramp-gvfs-interface-mounttracker "unmounted" - 'tramp-gvfs-handler-mounted-unmounted) + #'tramp-gvfs-handler-mounted-unmounted) (dbus-register-signal :session nil tramp-gvfs-path-mounttracker tramp-gvfs-interface-mounttracker "Unmounted" - 'tramp-gvfs-handler-mounted-unmounted)) + #'tramp-gvfs-handler-mounted-unmounted)) (defun tramp-gvfs-connection-mounted-p (vec) "Check, whether the location is already mounted." @@ -1529,6 +1566,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string (cadr elt))) (mount-spec (cl-caddr elt)) + (prefix (tramp-gvfs-dbus-byte-array-to-string (car mount-spec))) (default-location (tramp-gvfs-dbus-byte-array-to-string (cl-cadddr elt))) (method (tramp-gvfs-dbus-byte-array-to-string @@ -1544,43 +1582,59 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (cadr (assoc "port" (cadr mount-spec))))) (ssl (tramp-gvfs-dbus-byte-array-to-string (cadr (assoc "ssl" (cadr mount-spec))))) - (prefix (concat - (tramp-gvfs-dbus-byte-array-to-string - (car mount-spec)) - (tramp-gvfs-dbus-byte-array-to-string - (or - (cadr (assoc "share" (cadr mount-spec))) - (cadr (assoc "volume" (cadr mount-spec)))))))) + (uri (tramp-gvfs-dbus-byte-array-to-string + (cadr (assoc "uri" (cadr mount-spec))))) + (share (tramp-gvfs-dbus-byte-array-to-string + (or + (cadr (assoc "share" (cadr mount-spec))) + (cadr (assoc "volume" (cadr mount-spec))))))) (when (string-match "^\\(afp\\|smb\\)" method) (setq method (match-string 1 method))) - (when (string-equal "obex" method) - (setq host (tramp-bluez-device host))) (when (and (string-equal "dav" method) (string-equal "true" ssl)) (setq method "davs")) + (when (and (string-equal "davs" method) + (string-match-p + tramp-gvfs-nextcloud-default-prefix-regexp prefix)) + (setq method "nextcloud")) (when (string-equal "google-drive" method) (setq method "gdrive")) - (when (and (string-equal "synce" method) (zerop (length user))) - (setq user (or (tramp-file-name-user vec) ""))) + (when (and (string-equal "http" method) (stringp uri)) + (setq uri (url-generic-parse-url uri) + method (url-type uri) + user (url-user uri) + host (url-host uri) + port (url-portspec uri))) (when (and (string-equal method (tramp-file-name-method vec)) (string-equal user (tramp-file-name-user vec)) (string-equal domain (tramp-file-name-domain vec)) (string-equal host (tramp-file-name-host vec)) (string-equal port (tramp-file-name-port vec)) - (string-match (concat "^" (regexp-quote prefix)) - (tramp-file-name-unquote-localname vec))) - ;; Set prefix, mountpoint and location. - (unless (string-equal prefix "/") - (tramp-set-file-property vec "/" "prefix" prefix)) + (string-match-p (concat "^/" (regexp-quote (or share ""))) + (tramp-file-name-unquote-localname vec))) + ;; Set mountpoint and location. (tramp-set-file-property vec "/" "fuse-mountpoint" fuse-mountpoint) (tramp-set-connection-property vec "default-location" default-location) (throw 'mounted t))))))) +(defun tramp-gvfs-unmount (vec) + "Unmount the object identified by VEC." + (setf (tramp-file-name-localname vec) "/" + (tramp-file-name-hop vec) nil) + (when (tramp-gvfs-connection-mounted-p vec) + (tramp-gvfs-send-command + vec "gvfs-mount" "-u" + (tramp-gvfs-url-file-name (tramp-make-tramp-file-name vec)))) + (while (tramp-gvfs-connection-mounted-p vec) + (read-event nil nil 0.1)) + (tramp-flush-connection-properties vec) + (tramp-flush-connection-properties (tramp-get-connection-process vec))) + (defun tramp-gvfs-mount-spec-entry (key value) "Construct a mount-spec entry to be used in a mount_spec. It was \"a(say)\", but has changed to \"a{sv})\"." - (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature) + (if (string-match-p "^(aya{sv})" tramp-gvfs-mountlocation-signature) (list :dict-entry key (list :variant (tramp-gvfs-dbus-string-to-byte-array value))) (list :struct key (tramp-gvfs-dbus-string-to-byte-array value)))) @@ -1595,7 +1649,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (localname (tramp-file-name-unquote-localname vec)) (share (when (string-match "^/?\\([^/]+\\)" localname) (match-string 1 localname))) - (ssl (if (string-match "^davs" method) "true" "false")) + (ssl (if (string-match-p "^davs\\|^nextcloud" method) "true" "false")) (mount-spec `(:array ,@(cond @@ -1603,11 +1657,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (list (tramp-gvfs-mount-spec-entry "type" "smb-share") (tramp-gvfs-mount-spec-entry "server" host) (tramp-gvfs-mount-spec-entry "share" share))) - ((string-equal "obex" method) - (list (tramp-gvfs-mount-spec-entry "type" method) - (tramp-gvfs-mount-spec-entry - "host" (concat "[" (tramp-bluez-address host) "]")))) - ((string-match "\\`dav" method) + ((string-match-p "^dav\\|^nextcloud" method) (list (tramp-gvfs-mount-spec-entry "type" "dav") (tramp-gvfs-mount-spec-entry "host" host) (tramp-gvfs-mount-spec-entry "ssl" ssl))) @@ -1618,7 +1668,17 @@ It was \"a(say)\", but has changed to \"a{sv})\"." ((string-equal "gdrive" method) (list (tramp-gvfs-mount-spec-entry "type" "google-drive") (tramp-gvfs-mount-spec-entry "host" host))) - (t + ((string-equal "nextcloud" method) + (list (tramp-gvfs-mount-spec-entry "type" "owncloud") + (tramp-gvfs-mount-spec-entry "host" host))) + ((string-match-p "^http" method) + (list (tramp-gvfs-mount-spec-entry "type" "http") + (tramp-gvfs-mount-spec-entry + "uri" + (url-recreate-url + (url-parse-make-urlobj + method user nil host port "/" nil nil t))))) + (t (list (tramp-gvfs-mount-spec-entry "type" method) (tramp-gvfs-mount-spec-entry "host" host)))) ,@(when user @@ -1628,10 +1688,10 @@ It was \"a(say)\", but has changed to \"a{sv})\"." ,@(when port (list (tramp-gvfs-mount-spec-entry "port" port))))) (mount-pref - (if (and (string-match "\\`dav" method) + (if (and (string-match-p "^dav" method) (string-match "^/?[^/]+" localname)) (match-string 0 localname) - "/"))) + (tramp-gvfs-get-remote-prefix vec)))) ;; Return. `(:struct ,(tramp-gvfs-dbus-string-to-byte-array mount-pref) ,mount-spec))) @@ -1643,20 +1703,15 @@ It was \"a(say)\", but has changed to \"a{sv})\"." "The uid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." (with-tramp-connection-property vec (format "uid-%s" id-format) - (let ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (domain (tramp-file-name-domain vec)) - (host (tramp-file-name-host vec)) - (port (tramp-file-name-port vec)) + (let ((user (tramp-file-name-user vec)) (localname (tramp-get-connection-property vec "default-location" nil))) (cond - ((and user (equal id-format 'string)) user) + ((and (equal id-format 'string) user)) (localname (tramp-compat-file-attribute-user-id (file-attributes - (tramp-make-tramp-file-name method user domain host port localname) - id-format))) + (tramp-make-tramp-file-name vec localname) id-format))) ((equal id-format 'integer) tramp-unknown-id-integer) ((equal id-format 'string) tramp-unknown-id-string))))) @@ -1664,25 +1719,28 @@ 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) - (let ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (domain (tramp-file-name-domain vec)) - (host (tramp-file-name-host vec)) - (port (tramp-file-name-port vec)) - (localname + (let ((localname (tramp-get-connection-property vec "default-location" nil))) (cond (localname (tramp-compat-file-attribute-group-id (file-attributes - (tramp-make-tramp-file-name method user domain host port localname) - id-format))) + (tramp-make-tramp-file-name vec localname) id-format))) ((equal id-format 'integer) tramp-unknown-id-integer) ((equal id-format 'string) tramp-unknown-id-string))))) (defvar tramp-gvfs-get-remote-uid-gid-in-progress nil "Indication, that remote uid and gid determination is in progress.") +(defun tramp-gvfs-get-remote-prefix (vec) + "The prefix of the remote connection VEC. +This is relevant for GNOME Online Accounts." + (with-tramp-connection-property vec "prefix" + ;; Ensure that GNOME Online Accounts are cached. + (when (member (tramp-file-name-method vec) tramp-goa-methods) + (tramp-get-goa-accounts vec)) + (tramp-get-connection-property (tramp-make-goa-name vec) "prefix" "/"))) + (defun tramp-gvfs-maybe-open-connection (vec) "Maybe open a connection VEC. Does not do anything if a connection is already open, but re-opens the @@ -1696,33 +1754,40 @@ connection if a previous connection has died for some reason." ;; better solution? (unless (get-buffer-process (tramp-get-connection-buffer vec)) (let ((p (make-network-process - :name (tramp-buffer-name vec) + :name (tramp-get-connection-name vec) :buffer (tramp-get-connection-buffer vec) :server t :host 'local :service t :noquery t))) + (process-put p 'vector vec) (set-process-query-on-exit-flag p nil))) (unless (tramp-gvfs-connection-mounted-p vec) - (let* ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (domain (tramp-file-name-domain vec)) - (host (tramp-file-name-host vec)) - (port (tramp-file-name-port vec)) - (localname (tramp-file-name-unquote-localname vec)) - (object-path - (tramp-gvfs-object-path - (tramp-make-tramp-file-name method user domain host port "")))) + (let ((method (tramp-file-name-method vec)) + (user (tramp-file-name-user vec)) + (host (tramp-file-name-host vec)) + (localname (tramp-file-name-unquote-localname vec)) + (object-path + (tramp-gvfs-object-path (tramp-make-tramp-file-name vec 'noloc)))) (when (and (string-equal method "afp") (string-equal localname "/")) - (tramp-error vec 'file-error "Filename must contain an AFP volume")) + (tramp-user-error vec "Filename must contain an AFP volume")) - (when (and (string-match method "davs?") + (when (and (string-match-p "davs?" method) (string-equal localname "/")) - (tramp-error vec 'file-error "Filename must contain a WebDAV share")) + (tramp-user-error vec "Filename must contain a WebDAV share")) (when (and (string-equal method "smb") (string-equal localname "/")) - (tramp-error vec 'file-error "Filename must contain a Windows share")) + (tramp-user-error vec "Filename must contain a Windows share")) + + (when (member method tramp-goa-methods) + ;; Ensure that GNOME Online Accounts are cached. + (tramp-get-goa-accounts vec) + (when (tramp-get-connection-property + (tramp-make-goa-name vec) "FilesDisabled" t) + (tramp-user-error + vec "There is no Online Account `%s'" + (tramp-make-tramp-file-name vec 'noloc)))) (with-tramp-progress-reporter vec 3 @@ -1738,25 +1803,26 @@ connection if a previous connection has died for some reason." (dbus-register-method :session dbus-service-emacs object-path tramp-gvfs-interface-mountoperation "askPassword" - 'tramp-gvfs-handler-askpassword) + #'tramp-gvfs-handler-askpassword) (dbus-register-method :session dbus-service-emacs object-path tramp-gvfs-interface-mountoperation "AskPassword" - 'tramp-gvfs-handler-askpassword) + #'tramp-gvfs-handler-askpassword) - ;; There could be a callback of "askQuestion" when adding fingerprint. + ;; There could be a callback of "askQuestion" when adding + ;; fingerprints or checking certificates. (dbus-register-method :session dbus-service-emacs object-path tramp-gvfs-interface-mountoperation "askQuestion" - 'tramp-gvfs-handler-askquestion) + #'tramp-gvfs-handler-askquestion) (dbus-register-method :session dbus-service-emacs object-path tramp-gvfs-interface-mountoperation "AskQuestion" - 'tramp-gvfs-handler-askquestion) + #'tramp-gvfs-handler-askquestion) ;; The call must be asynchronously, because of the "askPassword" ;; or "askQuestion" callbacks. - (if (string-match "(so)$" tramp-gvfs-mountlocation-signature) + (if (string-match-p "(so)$" tramp-gvfs-mountlocation-signature) (with-tramp-dbus-call-method vec nil :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation @@ -1791,6 +1857,9 @@ connection if a previous connection has died for some reason." (tramp-get-file-property vec "/" "fuse-mountpoint" "") "/") (tramp-error vec 'file-error "FUSE mount denied")) + ;; Save the password. + (ignore-errors (funcall tramp-password-save-function)) + ;; Set connection-local variables. (tramp-set-connection-local-variables vec) @@ -1799,7 +1868,7 @@ connection if a previous connection has died for some reason." (tramp-get-connection-process vec) "connected" t)))) ;; In `tramp-check-cached-permissions', the connection properties - ;; {uig,gid}-{integer,string} are used. We set them to proper values. + ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. (unless tramp-gvfs-get-remote-uid-gid-in-progress (let ((tramp-gvfs-get-remote-uid-gid-in-progress t)) (tramp-gvfs-get-remote-uid vec 'integer) @@ -1832,88 +1901,78 @@ is applied, and it returns t if the return code is zero." (with-current-buffer (tramp-get-connection-buffer vec) (tramp-gvfs-maybe-open-connection vec) (erase-buffer) - (or (zerop (apply 'tramp-call-process vec command nil t nil args)) + (or (zerop (apply #'tramp-call-process vec command nil t nil args)) ;; Remove information about mounted connection. - (and (tramp-flush-file-property vec "/") nil))))) + (and (tramp-flush-file-properties vec "/") nil))))) -;; D-Bus BLUEZ functions. - -(defun tramp-bluez-list-devices () - "Return all discovered bluetooth devices as list. -Every entry is a list (NAME ADDRESS). - -If `tramp-bluez-discover-devices-timeout' is an integer, and the last -discovery happened more time before indicated there, a rescan will be -started, which lasts some ten seconds. Otherwise, cached results will -be used." - ;; Reset the scanned devices list if time has passed. - (and (integerp tramp-bluez-discover-devices-timeout) - (integerp tramp-bluez-discovery) - (> (tramp-time-diff (current-time) tramp-bluez-discovery) - tramp-bluez-discover-devices-timeout) - (setq tramp-bluez-devices nil)) - - ;; Rescan if needed. - (unless tramp-bluez-devices - (let ((object-path - (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t - :system tramp-bluez-service "/" - tramp-bluez-interface-manager "DefaultAdapter"))) - (setq tramp-bluez-devices nil - tramp-bluez-discovery t) - (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector nil - :system tramp-bluez-service object-path - tramp-bluez-interface-adapter "StartDiscovery") - (while tramp-bluez-discovery - (read-event nil nil 0.1)))) - (setq tramp-bluez-discovery (current-time)) - (tramp-message tramp-gvfs-dbus-event-vector 10 "%s" tramp-bluez-devices) - tramp-bluez-devices) - -(defun tramp-bluez-property-changed (property value) - "Signal handler for the \"org.bluez.Adapter.PropertyChanged\" signal." - (tramp-message tramp-gvfs-dbus-event-vector 6 "%s %s" property value) - (cond - ((string-equal property "Discovering") - (unless (car value) - ;; "Discovering" FALSE means discovery run has been completed. - ;; We stop it, because we don't need another run. - (setq tramp-bluez-discovery nil) - (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t - :system tramp-bluez-service (dbus-event-path-name last-input-event) - tramp-bluez-interface-adapter "StopDiscovery"))))) - -(when tramp-gvfs-enabled - (dbus-register-signal - :system nil nil tramp-bluez-interface-adapter "PropertyChanged" - 'tramp-bluez-property-changed)) - -(defun tramp-bluez-device-found (device args) - "Signal handler for the \"org.bluez.Adapter.DeviceFound\" signal." - (tramp-message tramp-gvfs-dbus-event-vector 6 "%s %s" device args) - (let ((alias (car (cadr (assoc "Alias" args)))) - (address (car (cadr (assoc "Address" args))))) - ;; Maybe we shall check the device class for being a proper - ;; device, and call also SDP in order to find the obex service. - (add-to-list 'tramp-bluez-devices (list alias address)))) - -(when tramp-gvfs-enabled - (dbus-register-signal - :system nil nil tramp-bluez-interface-adapter "DeviceFound" - 'tramp-bluez-device-found)) - -(defun tramp-bluez-parse-device-names (_ignore) - "Return a list of (nil host) tuples allowed to access." - (mapcar - (lambda (x) (list nil (car x))) - (tramp-bluez-list-devices))) - -;; Add completion function for OBEX method. -(when (and tramp-gvfs-enabled - (member tramp-bluez-service (dbus-list-known-names :system))) - (tramp-set-completion-function - "obex" '((tramp-bluez-parse-device-names "")))) +;; D-Bus GNOME Online Accounts functions. + +(defun tramp-make-goa-name (vec) + "Transform VEC into a `tramp-goa-name' structure." + (when (tramp-file-name-p vec) + (make-tramp-goa-name + :method (tramp-file-name-method vec) + :user (tramp-file-name-user vec) + :host (tramp-file-name-host vec) + :port (tramp-file-name-port vec)))) + +(defun tramp-get-goa-accounts (vec) + "Retrieve GNOME Online Accounts, and cache them. +The hash key is a `tramp-goa-name' structure. The value is an +alist of the properties of `tramp-goa-interface-account' and +`tramp-goa-interface-files' of the corresponding GNOME online +account. Additionally, a property \"prefix\" is added. +VEC is used only for traces." + (with-tramp-connection-property (tramp-make-goa-name vec) "goa-accounts" + (dolist + (object-path + (mapcar + #'car + (tramp-dbus-function + vec #'dbus-get-all-managed-objects + `(:session ,tramp-goa-service ,tramp-goa-path)))) + (let* ((account-properties + (with-tramp-dbus-get-all-properties vec + :session tramp-goa-service object-path + tramp-goa-interface-account)) + (files-properties + (with-tramp-dbus-get-all-properties vec + :session tramp-goa-service object-path + tramp-goa-interface-files)) + (identity + (or (cdr (assoc "PresentationIdentity" account-properties)) "")) + key) + ;; Only accounts which matter. + (when (and + (not (cdr (assoc "FilesDisabled" account-properties))) + (member + (cdr (assoc "ProviderType" account-properties)) + '("google" "owncloud")) + (string-match tramp-goa-identity-regexp identity)) + (setq key (make-tramp-goa-name + :method (cdr (assoc "ProviderType" account-properties)) + :user (match-string 1 identity) + :host (match-string 2 identity) + :port (match-string 3 identity))) + (when (string-equal (tramp-goa-name-method key) "google") + (setf (tramp-goa-name-method key) "gdrive")) + (when (string-equal (tramp-goa-name-method key) "owncloud") + (setf (tramp-goa-name-method key) "nextcloud")) + ;; Cache all properties. + (dolist (prop (nconc account-properties files-properties)) + (tramp-set-connection-property key (car prop) (cdr prop))) + ;; Cache "prefix". + (tramp-message + vec 10 "%s prefix %s" key + (tramp-set-connection-property + key "prefix" + (directory-file-name + (url-filename + (url-generic-parse-url + (tramp-get-connection-property key "Uri" "file:///"))))))))) + ;; Mark, that goa accounts have been cached. + "cached")) ;; D-Bus zeroconf functions. @@ -1936,15 +1995,12 @@ be used." (list user host))) (zeroconf-list-services service))) -;; We use the TRIM argument of `split-string', which exist since Emacs -;; 24.4. I mask this for older Emacs versions, there is no harm. (defun tramp-gvfs-parse-device-names (service) "Return a list of (user host) tuples allowed to access. This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." (let ((result (ignore-errors - (tramp-compat-funcall - 'split-string + (split-string (shell-command-to-string (format "avahi-browse -trkp %s" service)) "[\n\r]+" 'omit "^\\+;.*$")))) (delete-dups @@ -1952,8 +2008,7 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." (lambda (x) (let* ((list (split-string x ";")) (host (nth 6 list)) - (text (tramp-compat-funcall - 'split-string (nth 9 list) "\" \"" 'omit "\"")) + (text (split-string (nth 9 list) "\" \"" 'omit "\"")) user) ;; A user is marked in a TXT field like "u=guest". (while text @@ -1997,41 +2052,6 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." (tramp-set-completion-function "smb" '((tramp-gvfs-parse-device-names "_smb._tcp")))))))) - -;; D-Bus SYNCE functions. - -(defun tramp-synce-list-devices () - "Return all discovered synce devices as list. -They are retrieved from the hal daemon." - (let (tramp-synce-devices) - (dolist (device - (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t - :system tramp-hal-service tramp-hal-path-manager - tramp-hal-interface-manager "GetAllDevices")) - (when (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t - :system tramp-hal-service device tramp-hal-interface-device - "PropertyExists" "sync.plugin") - (let ((prop - (with-tramp-dbus-call-method - tramp-gvfs-dbus-event-vector t - :system tramp-hal-service device tramp-hal-interface-device - "GetPropertyString" "pda.pocketpc.name"))) - (unless (member prop tramp-synce-devices) - (push prop tramp-synce-devices))))) - (tramp-message tramp-gvfs-dbus-event-vector 10 "%s" tramp-synce-devices) - tramp-synce-devices)) - -(defun tramp-synce-parse-device-names (_ignore) - "Return a list of (nil host) tuples allowed to access." - (mapcar - (lambda (x) (list nil x)) - (tramp-synce-list-devices))) - -;; Add completion function for SYNCE method. -(when tramp-gvfs-enabled - (tramp-set-completion-function - "synce" '((tramp-synce-parse-device-names "")))) - (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-gvfs 'force))) @@ -2040,15 +2060,14 @@ They are retrieved from the hal daemon." ;;; TODO: +;; * (Customizable) unmount when exiting Emacs. See tramp-archive.el. +;; ;; * Host name completion for existing mount points (afp-server, -;; smb-server) or via smb-network. +;; smb-server, google-drive, nextcloud) or via smb-network or network. ;; ;; * Check, how two shares of the same SMB server can be mounted in ;; parallel. ;; -;; * Apply SDP on bluetooth devices, in order to filter out obex -;; capability. -;; -;; * Implement obex for other serial communication but bluetooth. +;; * What's up with ftps dns-sd afc admin computer? ;;; tramp-gvfs.el ends here diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el new file mode 100644 index 00000000000..0c706da1ca1 --- /dev/null +++ b/lisp/net/tramp-integration.el @@ -0,0 +1,196 @@ +;;; tramp-integration.el --- Tramp integration into other packages -*- lexical-binding:t -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; Keywords: comm, processes +;; Package: tramp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This assembles all integration of Tramp with other packages. + +;;; Code: + +(require 'tramp-compat) + +;; Pacify byte-compiler. +(require 'cl-lib) +(declare-function recentf-cleanup "recentf") +(declare-function tramp-dissect-file-name "tramp") +(declare-function tramp-file-name-equal-p "tramp") +(declare-function tramp-tramp-file-p "tramp") +(defvar eshell-path-env) +(defvar recentf-exclude) +(defvar tramp-current-connection) +(defvar tramp-postfix-host-format) + +;;; Fontification of `read-file-name': + +(defvar tramp-rfn-eshadow-overlay) +(make-variable-buffer-local 'tramp-rfn-eshadow-overlay) + +(defun tramp-rfn-eshadow-setup-minibuffer () + "Set up a minibuffer for `file-name-shadow-mode'. +Adds another overlay hiding filename parts according to Tramp's +special handling of `substitute-in-file-name'." + (when minibuffer-completing-file-name + (setq tramp-rfn-eshadow-overlay + (make-overlay (minibuffer-prompt-end) (minibuffer-prompt-end))) + ;; Copy rfn-eshadow-overlay properties. + (let ((props (overlay-properties rfn-eshadow-overlay))) + (while props + ;; The `field' property prevents correct minibuffer + ;; completion; we exclude it. + (if (not (eq (car props) 'field)) + (overlay-put tramp-rfn-eshadow-overlay (pop props) (pop props)) + (pop props) (pop props)))))) + +(add-hook 'rfn-eshadow-setup-minibuffer-hook + #'tramp-rfn-eshadow-setup-minibuffer) +(add-hook 'tramp-unload-hook + (lambda () + (remove-hook 'rfn-eshadow-setup-minibuffer-hook + #'tramp-rfn-eshadow-setup-minibuffer))) + +(defun tramp-rfn-eshadow-update-overlay-regexp () + (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 +`file-name-shadow-mode'; the minibuffer should have already +been set up by `rfn-eshadow-setup-minibuffer'." + ;; In remote files name, there is a shadowing just for the local part. + (ignore-errors + (let ((end (or (overlay-end rfn-eshadow-overlay) + (minibuffer-prompt-end))) + ;; We do not want to send any remote command. + (non-essential t)) + (when (tramp-tramp-file-p (buffer-substring end (point-max))) + (save-excursion + (save-restriction + (narrow-to-region + (1+ (or (string-match-p + (tramp-rfn-eshadow-update-overlay-regexp) + (buffer-string) end) + end)) + (point-max)) + (let ((rfn-eshadow-overlay tramp-rfn-eshadow-overlay) + (rfn-eshadow-update-overlay-hook nil) + file-name-handler-alist) + (move-overlay rfn-eshadow-overlay (point-max) (point-max)) + (rfn-eshadow-update-overlay)))))))) + +(add-hook 'rfn-eshadow-update-overlay-hook + #'tramp-rfn-eshadow-update-overlay) +(add-hook 'tramp-unload-hook + (lambda () + (remove-hook 'rfn-eshadow-update-overlay-hook + #'tramp-rfn-eshadow-update-overlay))) + +;;; Integration of eshell.el: + +;; eshell.el keeps the path in `eshell-path-env'. We must change it +;; when `default-directory' points to another host. +(defun tramp-eshell-directory-change () + "Set `eshell-path-env' to $PATH of the host related to `default-directory'." + ;; Remove last element of `(exec-path)', which is `exec-directory'. + ;; Use `path-separator' as it does eshell. + (setq eshell-path-env + (mapconcat + #'identity (butlast (tramp-compat-exec-path)) path-separator))) + +(with-eval-after-load 'esh-util + (add-hook 'eshell-mode-hook + #'tramp-eshell-directory-change) + (add-hook 'eshell-directory-change-hook + #'tramp-eshell-directory-change) + (add-hook 'tramp-integration-unload-hook + (lambda () + (remove-hook 'eshell-mode-hook + #'tramp-eshell-directory-change) + (remove-hook 'eshell-directory-change-hook + #'tramp-eshell-directory-change)))) + +;;; Integration of recentf.el: + +(defun tramp-recentf-exclude-predicate (name) + "Predicate to exclude a remote file name from recentf. +NAME must be equal to `tramp-current-connection'." + (when (file-remote-p name) + (tramp-file-name-equal-p + (tramp-dissect-file-name name) (car tramp-current-connection)))) + +(defun tramp-recentf-cleanup (vec) + "Remove all file names related to VEC from recentf." + (when (bound-and-true-p recentf-list) + (let ((tramp-current-connection `(,vec)) + (recentf-exclude '(tramp-recentf-exclude-predicate))) + (recentf-cleanup)))) + +(defun tramp-recentf-cleanup-all () + "Remove all remote file names from recentf." + (when (bound-and-true-p recentf-list) + (let ((recentf-exclude '(file-remote-p))) + (recentf-cleanup)))) + +(with-eval-after-load 'recentf + (add-hook 'tramp-cleanup-connection-hook + #'tramp-recentf-cleanup) + (add-hook 'tramp-cleanup-all-connections-hook + #'tramp-recentf-cleanup-all) + (add-hook 'tramp-integration-unload-hook + (lambda () + (remove-hook 'tramp-cleanup-connection-hook + #'tramp-recentf-cleanup) + (remove-hook 'tramp-cleanup-all-connections-hook + #'tramp-recentf-cleanup-all)))) + +;;; Default connection-local variables for Tramp: + +(defconst tramp-connection-local-default-profile + '((shell-file-name . "/bin/sh") + (shell-command-switch . "-c")) + "Default connection-local variables for remote connections.") + +;; `connection-local-set-profile-variables' and +;; `connection-local-set-profiles' exists since Emacs 26.1. +(with-eval-after-load 'shell + (tramp-compat-funcall + 'connection-local-set-profile-variables + 'tramp-connection-local-default-profile + tramp-connection-local-default-profile) + (tramp-compat-funcall + 'connection-local-set-profiles + `(:application tramp) + 'tramp-connection-local-default-profile)) + +(add-hook 'tramp-unload-hook + (lambda () (unload-feature 'tramp-integration 'force))) + +(provide 'tramp-integration) + +;;; tramp-integration.el ends here diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el new file mode 100644 index 00000000000..9b3eab34771 --- /dev/null +++ b/lisp/net/tramp-rclone.el @@ -0,0 +1,611 @@ +;;; tramp-rclone.el --- Tramp access functions to cloud storages -*- lexical-binding:t -*- + +;; Copyright (C) 2018-2019 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; Keywords: comm, processes +;; Package: tramp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; rclone is a command line program to sync files and directories to +;; and from cloud storages. Tramp uses its mount utility to access +;; files and directories there. The configuration of rclone for +;; different storage systems is performed outside Tramp, see rclone(1). + +;; A remote file under rclone control has the form +;; "/rclone:<remote>:/path/to/file". <remote> is the name of a +;; storage system in rclone's configuration. Therefore, such a remote +;; file name does not know of any user or port specification. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'tramp) + +;;;###tramp-autoload +(defconst tramp-rclone-method "rclone" + "When this method name is used, forward all calls to rclone mounts.") + +;;;###tramp-autoload +(defcustom tramp-rclone-program "rclone" + "Name of the rclone program." + :group 'tramp + :version "27.1" + :type 'string) + +;;;###tramp-autoload +(tramp--with-startup + (add-to-list 'tramp-methods + `(,tramp-rclone-method + (tramp-mount-args nil) + (tramp-copyto-args nil) + (tramp-moveto-args nil) + (tramp-about-args ("--full")))) + + (add-to-list 'tramp-default-host-alist `(,tramp-rclone-method nil "")) + + (tramp-set-completion-function + tramp-rclone-method '((tramp-rclone-parse-device-names "")))) + + +;; New handlers should be added here. +;;;###tramp-autoload +(defconst tramp-rclone-file-name-handler-alist + '((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' performed by default handler. + (copy-file . tramp-rclone-handle-copy-file) + (delete-directory . tramp-rclone-handle-delete-directory) + (delete-file . tramp-rclone-handle-delete-file) + ;; `diff-latest-backup-file' performed by default handler. + (directory-file-name . tramp-handle-directory-file-name) + (directory-files . tramp-rclone-handle-directory-files) + (directory-files-and-attributes + . tramp-handle-directory-files-and-attributes) + (dired-compress-file . ignore) + (dired-uncache . tramp-handle-dired-uncache) + (exec-path . ignore) + (expand-file-name . tramp-handle-expand-file-name) + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) + (file-acl . ignore) + (file-attributes . tramp-rclone-handle-file-attributes) + (file-directory-p . tramp-handle-file-directory-p) + (file-equal-p . tramp-handle-file-equal-p) + (file-executable-p . tramp-rclone-handle-file-executable-p) + (file-exists-p . tramp-handle-file-exists-p) + (file-in-directory-p . tramp-handle-file-in-directory-p) + (file-local-copy . tramp-handle-file-local-copy) + (file-modes . tramp-handle-file-modes) + (file-name-all-completions . tramp-rclone-handle-file-name-all-completions) + (file-name-as-directory . tramp-handle-file-name-as-directory) + (file-name-case-insensitive-p . tramp-handle-file-name-case-insensitive-p) + (file-name-completion . tramp-handle-file-name-completion) + (file-name-directory . tramp-handle-file-name-directory) + (file-name-nondirectory . tramp-handle-file-name-nondirectory) + ;; `file-name-sans-versions' performed by default handler. + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) + (file-notify-add-watch . ignore) + (file-notify-rm-watch . ignore) + (file-notify-valid-p . ignore) + (file-ownership-preserved-p . ignore) + (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) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-system-info . tramp-rclone-handle-file-system-info) + (file-truename . tramp-handle-file-truename) + (file-writable-p . tramp-handle-file-writable-p) + (find-backup-file-name . tramp-handle-find-backup-file-name) + ;; `get-file-buffer' performed by default handler. + (insert-directory . tramp-handle-insert-directory) + (insert-file-contents . tramp-handle-insert-file-contents) + (load . tramp-handle-load) + (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) + (make-directory . tramp-rclone-handle-make-directory) + (make-directory-internal . ignore) + (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-process . ignore) + (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-file . ignore) + (rename-file . tramp-rclone-handle-rename-file) + (set-file-acl . ignore) + (set-file-modes . ignore) + (set-file-selinux-context . ignore) + (set-file-times . ignore) + (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) + (shell-command . ignore) + (start-file-process . ignore) + (substitute-in-file-name . tramp-handle-substitute-in-file-name) + (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-set-file-uid-gid . ignore) + (unhandled-file-name-directory . ignore) + (vc-registered . ignore) + (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (write-region . tramp-handle-write-region)) + "Alist of handler functions for Tramp RCLONE method. +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))) + +;;;###tramp-autoload +(defun tramp-rclone-file-name-handler (operation &rest args) + "Invoke the rclone handler for OPERATION. +First arg specifies the OPERATION, second arg is a list of arguments to +pass to the OPERATION." + (let ((fn (assoc operation tramp-rclone-file-name-handler-alist))) + (if fn + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args)))) + +;;;###tramp-autoload +(tramp--with-startup + (tramp-register-foreign-file-name-handler + #'tramp-rclone-file-name-p #'tramp-rclone-file-name-handler)) + +;;;###tramp-autoload +(defun tramp-rclone-parse-device-names (_ignore) + "Return a list of (nil host) tuples allowed to access." + (with-tramp-connection-property nil "rclone-device-names" + (delq nil + (mapcar + (lambda (line) + (when (string-match "^\\(\\S-+\\):$" line) + `(nil ,(match-string 1 line)))) + (tramp-process-lines nil tramp-rclone-program "listremotes"))))) + + +;; File name primitives. + +(defun tramp-rclone-do-copy-or-rename-file + (op filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Copy or rename a remote file. +OP must be `copy' or `rename' and indicates the operation to perform. +FILENAME specifies the file to copy or rename, NEWNAME is the name of +the new file (for copy) or the new name of the file (for rename). +OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already. +KEEP-DATE means to make sure that NEWNAME has the same timestamp +as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep +the uid and gid if both files are on the same host. +PRESERVE-EXTENDED-ATTRIBUTES is ignored. + +This function is invoked by `tramp-rclone-handle-copy-file' and +`tramp-rclone-handle-rename-file'. It is an error if OP is neither +of `copy' and `rename'. FILENAME and NEWNAME must be absolute +file names." + (unless (memq op '(copy rename)) + (error "Unknown operation `%s', must be `copy' or `rename'" op)) + + (setq filename (file-truename filename)) + (if (file-directory-p filename) + (progn + (copy-directory filename newname keep-date t) + (when (eq op 'rename) (delete-directory filename 'recursive))) + + (let ((t1 (tramp-tramp-file-p filename)) + (t2 (tramp-tramp-file-p newname)) + (rclone-operation (if (eq op 'copy) "copyto" "moveto")) + (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) + + (with-parsed-tramp-file-name (if t1 filename newname) nil + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (if (or (and t1 (not (tramp-rclone-file-name-p filename))) + (and t2 (not (tramp-rclone-file-name-p newname)))) + + ;; We cannot copy or rename directly. + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (if (eq op 'copy) + (copy-file + filename tmpfile t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file filename tmpfile t)) + (rename-file tmpfile newname ok-if-already-exists)) + + ;; Direct action. + (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) + (unless (zerop + (tramp-rclone-send-command + v rclone-operation + (tramp-rclone-remote-file-name filename) + (tramp-rclone-remote-file-name newname))) + (tramp-error + v 'file-error + "Error %s `%s' `%s'" msg-operation filename newname))) + + (when (and t1 (eq op 'rename)) + (with-parsed-tramp-file-name filename v1 + (tramp-flush-file-properties + v1 (file-name-directory v1-localname)) + (tramp-flush-file-properties v1 v1-localname) + (when (tramp-rclone-file-name-p filename) + (tramp-rclone-flush-directory-cache v1) + ;; The mount point's directory cache might need time + ;; to flush. + (while (file-exists-p filename) + (tramp-flush-file-properties + v1 (file-name-directory v1-localname)) + (tramp-flush-file-properties v1 v1-localname))))) + + (when t2 + (with-parsed-tramp-file-name newname v2 + (tramp-flush-file-properties + v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname) + (when (tramp-rclone-file-name-p newname) + (tramp-rclone-flush-directory-cache v2) + ;; The mount point's directory cache might need time + ;; to flush. + (while (not (file-exists-p newname)) + (tramp-flush-file-properties + v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname)))))))))) + +(defun tramp-rclone-handle-copy-file + (filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Like `copy-file' for Tramp files." + (setq filename (expand-file-name filename)) + (setq newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-rclone-do-copy-or-rename-file + 'copy filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + (tramp-run-real-handler + #'copy-file + (list filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes)))) + +(defun tramp-rclone-handle-delete-directory + (directory &optional recursive trash) + "Like `delete-directory' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name directory) nil + (delete-directory (tramp-rclone-local-file-name directory) recursive trash) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) + (tramp-rclone-flush-directory-cache v))) + +(defun tramp-rclone-handle-delete-file (filename &optional trash) + "Like `delete-file' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (delete-file (tramp-rclone-local-file-name filename) trash) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (tramp-rclone-flush-directory-cache v))) + +(defun tramp-rclone-handle-directory-files + (directory &optional full match nosort) + "Like `directory-files' for Tramp files." + (when (file-directory-p directory) + (setq directory (file-name-as-directory (expand-file-name directory))) + (with-parsed-tramp-file-name directory nil + (let ((result + (directory-files + (tramp-rclone-local-file-name directory) full match))) + ;; Massage the result. + (when full + (let ((local (concat "^" (regexp-quote (tramp-rclone-mount-point v)))) + (remote (funcall (if (tramp-compat-file-name-quoted-p directory) + #'tramp-compat-file-name-quote #'identity) + (file-remote-p directory)))) + (setq result + (mapcar + (lambda (x) (replace-regexp-in-string local remote x)) + result)))) + ;; Some storage systems do not return "." and "..". + (dolist (item '(".." ".")) + (when (and (string-match-p (or match (regexp-quote item)) item) + (not + (member (if full (setq item (concat directory item)) item) + result))) + (setq result (cons item result)))) + ;; Return result. + (if nosort result (sort result #'string<)))))) + +(defun tramp-rclone-handle-file-attributes (filename &optional id-format) + "Like `file-attributes' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property + v localname (format "file-attributes-%s" id-format) + (file-attributes (tramp-rclone-local-file-name filename) id-format)))) + +(defun tramp-rclone-handle-file-executable-p (filename) + "Like `file-executable-p' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property v localname "file-executable-p" + (file-executable-p (tramp-rclone-local-file-name filename))))) + +(defun tramp-rclone-handle-file-name-all-completions (filename directory) + "Like `file-name-all-completions' for Tramp files." + (all-completions + filename + (delete-dups + (append + (file-name-all-completions + filename (tramp-rclone-local-file-name directory)) + ;; Some storage systems do not return "." and "..". + (let (result) + (dolist (item '(".." ".") result) + (when (string-prefix-p filename item) + (catch 'match + (dolist (elt completion-regexp-list) + (unless (string-match-p elt item) (throw 'match nil))) + (setq result (cons (concat item "/") result)))))))))) + +(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-rclone-local-file-name filename))))) + +(defun tramp-rclone-handle-file-system-info (filename) + "Like `file-system-info' for Tramp files." + (ignore-errors + (unless (file-directory-p filename) + (setq filename (file-name-directory filename))) + (with-parsed-tramp-file-name (expand-file-name filename) nil + (tramp-message v 5 "file system info: %s" localname) + (tramp-rclone-send-command v "about" (concat host ":")) + (with-current-buffer (tramp-get-connection-buffer v) + (let (total used free) + (goto-char (point-min)) + (while (not (eobp)) + (when (looking-at "Total: [[:space:]]+\\([[:digit:]]+\\)") + (setq total (string-to-number (match-string 1)))) + (when (looking-at "Used: [[:space:]]+\\([[:digit:]]+\\)") + (setq used (string-to-number (match-string 1)))) + (when (looking-at "Free: [[:space:]]+\\([[:digit:]]+\\)") + (setq free (string-to-number (match-string 1)))) + (forward-line)) + (when used + ;; The used number of bytes is not part of the result. As + ;; side effect, we store it as file property. + (tramp-set-file-property v localname "used-bytes" used)) + ;; Result. + (when (and total free) + (list total free (- total free)))))))) + +(defun tramp-rclone-handle-insert-directory + (filename switches &optional wildcard full-directory-p) + "Like `insert-directory' for Tramp files." + (insert-directory + (tramp-rclone-local-file-name filename) switches wildcard full-directory-p) + (goto-char (point-min)) + (while (search-forward (tramp-rclone-local-file-name filename) nil 'noerror) + (replace-match filename))) + +(defun tramp-rclone-handle-insert-file-contents + (filename &optional visit beg end replace) + "Like `insert-file-contents' for Tramp files." + (let ((result + (insert-file-contents + (tramp-rclone-local-file-name filename) visit beg end replace))) + (prog1 + (list (expand-file-name filename) (cadr result)) + (when visit (setq buffer-file-name filename))))) + +(defun tramp-rclone-handle-make-directory (dir &optional parents) + "Like `make-directory' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name dir) nil + (make-directory (tramp-rclone-local-file-name dir) parents) + ;; When PARENTS is non-nil, DIR could be a chain of non-existent + ;; directories a/b/c/... Instead of checking, we simply flush the + ;; whole file cache. + (tramp-flush-file-properties v localname) + (tramp-flush-directory-properties + v (if parents "/" (file-name-directory localname))) + (tramp-rclone-flush-directory-cache v))) + +(defun tramp-rclone-handle-rename-file + (filename newname &optional ok-if-already-exists) + "Like `rename-file' for Tramp files." + (setq filename (expand-file-name filename)) + (setq newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-rclone-do-copy-or-rename-file + 'rename filename newname ok-if-already-exists + 'keep-date 'preserve-uid-gid) + (tramp-run-real-handler + #'rename-file (list filename newname ok-if-already-exists)))) + + +;; File name conversions. + +(defun tramp-rclone-mount-point (vec) + "Return local mount point of VEC." + (expand-file-name + (concat + tramp-temp-name-prefix (tramp-file-name-method vec) + "." (tramp-file-name-host vec)) + (tramp-compat-temporary-file-directory))) + +(defun tramp-rclone-mounted-p (vec) + "Check, whether storage system determined by VEC is mounted." + (when (tramp-get-connection-process vec) + ;; We cannot use `with-connection-property', because we don't want + ;; to cache a nil result. + (or (tramp-get-connection-property + (tramp-get-connection-process vec) "mounted" nil) + (let* ((default-directory temporary-file-directory) + (mount (shell-command-to-string "mount -t fuse.rclone"))) + (tramp-message vec 6 "%s" "mount -t fuse.rclone") + (tramp-message vec 6 "\n%s" mount) + (tramp-set-connection-property + (tramp-get-connection-process vec) "mounted" + (when (string-match + (format + "^\\(%s:\\S-*\\)" (regexp-quote (tramp-file-name-host vec))) + mount) + (match-string 1 mount))))))) + +(defun tramp-rclone-flush-directory-cache (vec) + "Flush directory cache of VEC mount." + (let ((rclone-pid + ;; Identify rclone process. + (when (tramp-get-connection-process vec) + (with-tramp-connection-property + (tramp-get-connection-process vec) "rclone-pid" + (catch 'pid + (dolist (pid (list-system-processes)) ;; "pidof rclone" ? + (and (string-match-p + (regexp-quote + (format "rclone mount %s:" (tramp-file-name-host vec))) + (or (cdr (assoc 'args (process-attributes pid))) "")) + (throw 'pid pid)))))))) + ;; Send a SIGHUP in order to flush directory cache. + (when rclone-pid + (tramp-message + vec 6 "Send SIGHUP %d: %s" + rclone-pid (cdr (assoc 'args (process-attributes rclone-pid)))) + (signal-process rclone-pid 'SIGHUP)))) + +(defun tramp-rclone-local-file-name (filename) + "Return local mount name of FILENAME." + (setq filename (tramp-compat-file-name-unquote (expand-file-name filename))) + (with-parsed-tramp-file-name filename nil + ;; As long as we call `tramp-rclone-maybe-open-connection' here, + ;; we cache the result. + (with-tramp-file-property v localname "local-file-name" + (tramp-rclone-maybe-open-connection v) + (let ((quoted (tramp-compat-file-name-quoted-p localname)) + (localname (tramp-compat-file-name-unquote localname))) + (funcall + (if quoted #'tramp-compat-file-name-quote #'identity) + (expand-file-name + (if (file-name-absolute-p localname) + (substring localname 1) localname) + (tramp-rclone-mount-point v))))))) + +(defun tramp-rclone-remote-file-name (filename) + "Return FILENAME as used in the `rclone' command." + (setq filename (tramp-compat-file-name-unquote (expand-file-name filename))) + (if (tramp-rclone-file-name-p filename) + (with-parsed-tramp-file-name filename nil + ;; As long as we call `tramp-rclone-maybe-open-connection' here, + ;; we cache the result. + (with-tramp-file-property v localname "remote-file-name" + (tramp-rclone-maybe-open-connection v) + ;; TODO: This shall be handled by `expand-file-name'. + (setq localname + (replace-regexp-in-string "^\\." "" (or localname ""))) + (format "%s%s" (tramp-rclone-mounted-p v) localname))) + ;; It is a local file name. + filename)) + +(defun tramp-rclone-maybe-open-connection (vec) + "Maybe open a connection VEC. +Does not do anything if a connection is already open, but re-opens the +connection if a previous connection has died for some reason." + (let ((host (tramp-file-name-host vec))) + (when (rassoc `(,host) (tramp-rclone-parse-device-names nil)) + (if (zerop (length host)) + (tramp-error vec 'file-error "Storage %s not connected" host)) + + ;; During completion, don't reopen a new connection. 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. + (when (and (tramp-completion-mode-p) + (null (get-process (tramp-buffer-name vec)))) + (throw 'non-essential 'non-essential)) + + ;; We need a process bound to the connection buffer. Therefore, + ;; we create a dummy process. Maybe there is a better solution? + (unless (get-buffer-process (tramp-get-connection-buffer vec)) + (let ((p (make-network-process + :name (tramp-get-connection-name vec) + :buffer (tramp-get-connection-buffer vec) + :server t :host 'local :service t :noquery t))) + (process-put p 'vector vec) + (set-process-query-on-exit-flag p nil) + + ;; Set connection-local variables. + (tramp-set-connection-local-variables vec))) + + ;; Create directory. + (unless (file-directory-p (tramp-rclone-mount-point vec)) + (make-directory (tramp-rclone-mount-point vec) 'parents)) + + ;; Mount. This command does not return, so we use 0 as + ;; DESTINATION of `tramp-call-process'. + (unless (tramp-rclone-mounted-p vec) + (apply + #'tramp-call-process + vec tramp-rclone-program nil 0 nil + (delq nil + `("mount" ,(concat host ":/") + ,(tramp-rclone-mount-point vec) + ;; This could be nil. + ,(tramp-get-method-parameter vec 'tramp-mount-args)))) + (while (not (file-exists-p (tramp-make-tramp-file-name vec 'localname))) + (tramp-cleanup-connection vec 'keep-debug 'keep-password)) + + ;; Mark it as connected. + (tramp-set-connection-property + (tramp-get-connection-process vec) "connected" t)))) + + ;; In `tramp-check-cached-permissions', the connection properties + ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. + (with-tramp-connection-property + vec "uid-integer" (tramp-get-local-uid 'integer)) + (with-tramp-connection-property + vec "gid-integer" (tramp-get-local-gid 'integer)) + (with-tramp-connection-property + vec "uid-string" (tramp-get-local-uid 'string)) + (with-tramp-connection-property + vec "gid-string" (tramp-get-local-gid 'string))) + +(defun tramp-rclone-send-command (vec &rest args) + "Send the COMMAND to connection VEC." + (with-current-buffer (tramp-get-connection-buffer vec) + (erase-buffer) + (let ((flags (tramp-get-method-parameter + vec (intern (format "tramp-%s-args" (car args)))))) + (apply #'tramp-call-process + vec tramp-rclone-program nil t nil (append args flags))))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-rclone 'force))) + +(provide 'tramp-rclone) + +;;; TODO: + +;; * If possible, get rid of "rclone mount". Maybe it is more +;; performant then. + +;;; tramp-rclone.el ends here diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 18ae2951084..6a82fef4f70 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -27,12 +27,9 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) (require 'tramp) -;; Pacify byte-compiler. -(eval-when-compile - (require 'dired)) - (declare-function dired-remove-file "dired-aux") (defvar dired-compress-file-suffixes) (defvar vc-handled-backends) @@ -41,14 +38,13 @@ (defvar vc-hg-program) ;;;###tramp-autoload -(defcustom tramp-inline-compress-start-size - (unless (memq system-type '(windows-nt)) 4096) +(defcustom tramp-inline-compress-start-size 4096 "The minimum size of compressing where inline transfer. -When inline transfer, compress transferred data of file -whose size is this value or above (up to `tramp-copy-size-limit'). +When inline transfer, compress transferred data of file whose +size is this value or above (up to `tramp-copy-size-limit' for +out-of-band methods). If it is nil, no compression at all will be applied." :group 'tramp - :version "26.3" :type '(choice (const nil) integer)) ;;;###tramp-autoload @@ -89,7 +85,6 @@ the default storage location, e.g. \"$HOME/.sh_history\"." (defconst tramp-display-escape-sequence-regexp "\e[[;0-9]+m" "Terminal control escape sequences for display attributes.") -;;;###tramp-autoload (defconst tramp-device-escape-sequence-regexp "\e[[0-9]+n" "Terminal control escape sequences for device status.") @@ -135,285 +130,264 @@ The string is used in `tramp-methods'.") ;; Initialize `tramp-methods' with the supported methods. ;;;###tramp-autoload -(add-to-list 'tramp-methods - '("rcp" - (tramp-login-program "rsh") - (tramp-login-args (("%h") ("-l" "%u"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-copy-program "rcp") - (tramp-copy-args (("-p" "%k") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("remcp" - (tramp-login-program "remsh") - (tramp-login-args (("%h") ("-l" "%u"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-copy-program "rcp") - (tramp-copy-args (("-p" "%k"))) - (tramp-copy-keep-date t))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("scp" - (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-copy-program "scp") - (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") ("-r") ("%c"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("scpx" - (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") - ("-e" "none") ("-t" "-t") ("%h") ("/bin/sh"))) - (tramp-async-args (("-q"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-copy-program "scp") - (tramp-copy-args (("-P" "%p") ("-p" "%k") - ("-q") ("-r") ("%c"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("rsync" - (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-copy-program "rsync") - (tramp-copy-args (("-t" "%k") ("-p") ("-r") ("-s") ("-c"))) - (tramp-copy-env (("RSYNC_RSH") ("ssh" "%c"))) - (tramp-copy-keep-date t) - (tramp-copy-keep-tmpfile t) - (tramp-copy-recursive t))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("rsh" - (tramp-login-program "rsh") - (tramp-login-args (("%h") ("-l" "%u"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("remsh" - (tramp-login-program "remsh") - (tramp-login-args (("%h") ("-l" "%u"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("ssh" - (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("sshx" - (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") - ("-e" "none") ("-t" "-t") ("%h") ("/bin/sh"))) - (tramp-async-args (("-q"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("telnet" - (tramp-login-program "telnet") - (tramp-login-args (("%h") ("%p") ("2>/dev/null"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("nc" - (tramp-login-program "telnet") - (tramp-login-args (("%h") ("%p") ("2>/dev/null"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-copy-program "nc") - ;; We use "-v" for better error tracking. - (tramp-copy-args (("-w" "1") ("-v") ("%h") ("%r"))) - (tramp-remote-copy-program "nc") - ;; We use "-p" as required for newer busyboxes. For older - ;; busybox/nc versions, the value must be (("-l") ("%r")). This - ;; can be achieved by tweaking `tramp-connection-properties'. - (tramp-remote-copy-args (("-l") ("-p" "%r") ("2>/dev/null"))))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("su" - (tramp-login-program "su") - (tramp-login-args (("-") ("%u"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-connection-timeout 10))) -;;;###tramp-autoload -(add-to-list - 'tramp-methods - '("sg" - (tramp-login-program "sg") - (tramp-login-args (("-") ("%u"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-args ("-c")) - (tramp-connection-timeout 10))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("sudo" - (tramp-login-program "sudo") - ;; The password template must be masked. Otherwise, it could be - ;; interpreted as password prompt if the remote host echoes the command. - (tramp-login-args (("-u" "%u") ("-s") ("-H") - ("-p" "P\"\"a\"\"s\"\"s\"\"w\"\"o\"\"r\"\"d\"\":"))) - ;; Local $SHELL could be a nasty one, like zsh or fish. Let's override it. - (tramp-login-env (("SHELL") ("/bin/sh"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-connection-timeout 10))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("doas" - (tramp-login-program "doas") - (tramp-login-args (("-u" "%u") ("-s"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-args ("-c")) - (tramp-connection-timeout 10))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("ksu" - (tramp-login-program "ksu") - (tramp-login-args (("%u") ("-q"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-connection-timeout 10))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("krlogin" - (tramp-login-program "krlogin") - (tramp-login-args (("%h") ("-l" "%u") ("-x"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - `("plink" - (tramp-login-program "plink") - ;; ("%h") must be a single element, see `tramp-compute-multi-hops'. - (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t") - ("%h") ("\"") - (,(format - "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" - tramp-terminal-type - tramp-initial-end-of-output)) - ("/bin/sh") ("\""))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - `("plinkx" - (tramp-login-program "plink") - (tramp-login-args (("-load") ("%h") ("-t") ("\"") - (,(format - "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" - tramp-terminal-type - tramp-initial-end-of-output)) - ("/bin/sh") ("\""))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - `("pscp" - (tramp-login-program "plink") - (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t") - ("%h") ("\"") - (,(format - "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" - tramp-terminal-type - tramp-initial-end-of-output)) - ("/bin/sh") ("\""))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-copy-program "pscp") - (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-scp") ("-p" "%k") - ("-q") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - `("psftp" - (tramp-login-program "plink") - (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t") - ("%h") ("\"") - (,(format - "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" - tramp-terminal-type - tramp-initial-end-of-output)) - ("/bin/sh") ("\""))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-copy-program "pscp") - (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-sftp") ("-p" "%k") - ("-q"))) - (tramp-copy-keep-date t))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("fcp" - (tramp-login-program "fsh") - (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-i") ("-c")) - (tramp-copy-program "fcp") - (tramp-copy-args (("-p" "%k"))) - (tramp-copy-keep-date t))) - -;;;###tramp-autoload -(add-to-list 'tramp-default-method-alist - `(,tramp-local-host-regexp "\\`root\\'" "su")) - -;;;###tramp-autoload -(add-to-list 'tramp-default-user-alist - `(,(concat "\\`" (regexp-opt '("su" "sudo" "doas" "ksu")) "\\'") - nil "root")) -;; Do not add "ssh" based methods, otherwise ~/.ssh/config would be ignored. -;; Do not add "plink" based methods, they ask interactively for the user. -;;;###tramp-autoload -(add-to-list 'tramp-default-user-alist - `(,(concat - "\\`" - (regexp-opt - '("rcp" "remcp" "rsh" "telnet" "nc" "krlogin" "fcp")) - "\\'") - nil ,(user-login-name))) +(tramp--with-startup + (add-to-list 'tramp-methods + '("rcp" + (tramp-login-program "rsh") + (tramp-login-args (("%h") ("-l" "%u"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-copy-program "rcp") + (tramp-copy-args (("-p" "%k") ("-r"))) + (tramp-copy-keep-date t) + (tramp-copy-recursive t))) + (add-to-list 'tramp-methods + '("remcp" + (tramp-login-program "remsh") + (tramp-login-args (("%h") ("-l" "%u"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-copy-program "rcp") + (tramp-copy-args (("-p" "%k"))) + (tramp-copy-keep-date t))) + (add-to-list 'tramp-methods + '("scp" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") + ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-copy-program "scp") + (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") ("-r") ("%c"))) + (tramp-copy-keep-date t) + (tramp-copy-recursive t))) + (add-to-list 'tramp-methods + '("scpx" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") + ("-e" "none") ("-t" "-t") ("%h") ("/bin/sh"))) + (tramp-async-args (("-q"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-copy-program "scp") + (tramp-copy-args (("-P" "%p") ("-p" "%k") + ("-q") ("-r") ("%c"))) + (tramp-copy-keep-date t) + (tramp-copy-recursive t))) + (add-to-list 'tramp-methods + '("rsync" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") + ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-copy-program "rsync") + (tramp-copy-args (("-t" "%k") ("-p") ("-r") ("-s") ("-c"))) + (tramp-copy-env (("RSYNC_RSH") ("ssh" "%c"))) + (tramp-copy-keep-date t) + (tramp-copy-keep-tmpfile t) + (tramp-copy-recursive t))) + (add-to-list 'tramp-methods + '("rsh" + (tramp-login-program "rsh") + (tramp-login-args (("%h") ("-l" "%u"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + (add-to-list 'tramp-methods + '("remsh" + (tramp-login-program "remsh") + (tramp-login-args (("%h") ("-l" "%u"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + (add-to-list 'tramp-methods + '("ssh" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") + ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + (add-to-list 'tramp-methods + '("sshx" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") + ("-e" "none") ("-t" "-t") ("%h") ("/bin/sh"))) + (tramp-async-args (("-q"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + (add-to-list 'tramp-methods + '("telnet" + (tramp-login-program "telnet") + (tramp-login-args (("%h") ("%p") ("2>/dev/null"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + (add-to-list 'tramp-methods + '("nc" + (tramp-login-program "telnet") + (tramp-login-args (("%h") ("%p") ("2>/dev/null"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-copy-program "nc") + ;; We use "-v" for better error tracking. + (tramp-copy-args (("-w" "1") ("-v") ("%h") ("%r"))) + (tramp-remote-copy-program "nc") + ;; We use "-p" as required for newer busyboxes. For older + ;; busybox/nc versions, the value must be (("-l") ("%r")). This + ;; can be achieved by tweaking `tramp-connection-properties'. + (tramp-remote-copy-args (("-l") ("-p" "%r") ("2>/dev/null"))))) + (add-to-list 'tramp-methods + '("su" + (tramp-login-program "su") + (tramp-login-args (("-") ("%u"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10))) + (add-to-list 'tramp-methods + '("sg" + (tramp-login-program "sg") + (tramp-login-args (("-") ("%u"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10))) + (add-to-list 'tramp-methods + '("sudo" + (tramp-login-program "sudo") + ;; The password template must be masked. Otherwise, + ;; it could be interpreted as password prompt if the + ;; remote host echoes the command. + (tramp-login-args (("-u" "%u") ("-s") ("-H") + ("-p" "P\"\"a\"\"s\"\"s\"\"w\"\"o\"\"r\"\"d\"\":"))) + ;; Local $SHELL could be a nasty one, like zsh or + ;; fish. Let's override it. + (tramp-login-env (("SHELL") ("/bin/sh"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10) + (tramp-session-timeout 300))) + (add-to-list 'tramp-methods + '("doas" + (tramp-login-program "doas") + (tramp-login-args (("-u" "%u") ("-s"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10) + (tramp-session-timeout 300))) + (add-to-list 'tramp-methods + '("ksu" + (tramp-login-program "ksu") + (tramp-login-args (("%u") ("-q"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10))) + (add-to-list 'tramp-methods + '("krlogin" + (tramp-login-program "krlogin") + (tramp-login-args (("%h") ("-l" "%u") ("-x"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + (add-to-list 'tramp-methods + `("plink" + (tramp-login-program "plink") + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t") + ("%h") ("\"") + (,(format + "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" + tramp-terminal-type + tramp-initial-end-of-output)) + ("/bin/sh") ("\""))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + (add-to-list 'tramp-methods + `("plinkx" + (tramp-login-program "plink") + (tramp-login-args (("-load") ("%h") ("-t") ("\"") + (,(format + "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" + tramp-terminal-type + tramp-initial-end-of-output)) + ("/bin/sh") ("\""))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + (add-to-list 'tramp-methods + `("pscp" + (tramp-login-program "plink") + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t") + ("%h") ("\"") + (,(format + "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" + tramp-terminal-type + tramp-initial-end-of-output)) + ("/bin/sh") ("\""))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-copy-program "pscp") + (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-scp") ("-p" "%k") + ("-q") ("-r"))) + (tramp-copy-keep-date t) + (tramp-copy-recursive t))) + (add-to-list 'tramp-methods + `("psftp" + (tramp-login-program "plink") + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t") + ("%h") ("\"") + (,(format + "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" + tramp-terminal-type + tramp-initial-end-of-output)) + ("/bin/sh") ("\""))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-copy-program "pscp") + (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-sftp") ("-p" "%k") + ("-q"))) + (tramp-copy-keep-date t))) + (add-to-list 'tramp-methods + '("fcp" + (tramp-login-program "fsh") + (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-i") ("-c")) + (tramp-copy-program "fcp") + (tramp-copy-args (("-p" "%k"))) + (tramp-copy-keep-date t))) + + (add-to-list 'tramp-default-method-alist + `(,tramp-local-host-regexp "\\`root\\'" "su")) + + (add-to-list 'tramp-default-user-alist + `(,(concat "\\`" (regexp-opt '("su" "sudo" "doas" "ksu")) "\\'") + nil "root")) + ;; Do not add "ssh" based methods, otherwise ~/.ssh/config would be ignored. + ;; Do not add "plink" based methods, they ask interactively for the user. + (add-to-list 'tramp-default-user-alist + `(,(concat + "\\`" + (regexp-opt + '("rcp" "remcp" "rsh" "telnet" "nc" "krlogin" "fcp")) + "\\'") + nil ,(user-login-name)))) ;;;###tramp-autoload (defconst tramp-completion-function-alist-rsh @@ -461,33 +435,32 @@ The string is used in `tramp-methods'.") "Default list of (FUNCTION REGISTRY) pairs to be examined for putty sessions.") ;;;###tramp-autoload -(eval-after-load 'tramp - '(progn - (tramp-set-completion-function "rcp" tramp-completion-function-alist-rsh) - (tramp-set-completion-function "remcp" tramp-completion-function-alist-rsh) - (tramp-set-completion-function "scp" tramp-completion-function-alist-ssh) - (tramp-set-completion-function "scpx" tramp-completion-function-alist-ssh) - (tramp-set-completion-function "rsync" tramp-completion-function-alist-ssh) - (tramp-set-completion-function "rsh" tramp-completion-function-alist-rsh) - (tramp-set-completion-function "remsh" tramp-completion-function-alist-rsh) - (tramp-set-completion-function "ssh" tramp-completion-function-alist-ssh) - (tramp-set-completion-function "sshx" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "telnet" tramp-completion-function-alist-telnet) - (tramp-set-completion-function "nc" tramp-completion-function-alist-telnet) - (tramp-set-completion-function "su" tramp-completion-function-alist-su) - (tramp-set-completion-function "sudo" tramp-completion-function-alist-su) - (tramp-set-completion-function "doas" tramp-completion-function-alist-su) - (tramp-set-completion-function "ksu" tramp-completion-function-alist-su) - (tramp-set-completion-function "sg" tramp-completion-function-alist-sg) - (tramp-set-completion-function - "krlogin" tramp-completion-function-alist-rsh) - (tramp-set-completion-function "plink" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "plinkx" tramp-completion-function-alist-putty) - (tramp-set-completion-function "pscp" tramp-completion-function-alist-ssh) - (tramp-set-completion-function "psftp" tramp-completion-function-alist-ssh) - (tramp-set-completion-function "fcp" tramp-completion-function-alist-ssh))) +(tramp--with-startup + (tramp-set-completion-function "rcp" tramp-completion-function-alist-rsh) + (tramp-set-completion-function "remcp" tramp-completion-function-alist-rsh) + (tramp-set-completion-function "scp" tramp-completion-function-alist-ssh) + (tramp-set-completion-function "scpx" tramp-completion-function-alist-ssh) + (tramp-set-completion-function "rsync" tramp-completion-function-alist-ssh) + (tramp-set-completion-function "rsh" tramp-completion-function-alist-rsh) + (tramp-set-completion-function "remsh" tramp-completion-function-alist-rsh) + (tramp-set-completion-function "ssh" tramp-completion-function-alist-ssh) + (tramp-set-completion-function "sshx" tramp-completion-function-alist-ssh) + (tramp-set-completion-function + "telnet" tramp-completion-function-alist-telnet) + (tramp-set-completion-function "nc" tramp-completion-function-alist-telnet) + (tramp-set-completion-function "su" tramp-completion-function-alist-su) + (tramp-set-completion-function "sudo" tramp-completion-function-alist-su) + (tramp-set-completion-function "doas" tramp-completion-function-alist-su) + (tramp-set-completion-function "ksu" tramp-completion-function-alist-su) + (tramp-set-completion-function "sg" tramp-completion-function-alist-sg) + (tramp-set-completion-function + "krlogin" tramp-completion-function-alist-rsh) + (tramp-set-completion-function "plink" tramp-completion-function-alist-ssh) + (tramp-set-completion-function + "plinkx" tramp-completion-function-alist-putty) + (tramp-set-completion-function "pscp" tramp-completion-function-alist-ssh) + (tramp-set-completion-function "psftp" tramp-completion-function-alist-ssh) + (tramp-set-completion-function "fcp" tramp-completion-function-alist-ssh)) ;; "getconf PATH" yields: ;; HP-UX: /usr/bin:/usr/ccs/bin:/opt/ansic/bin:/opt/langtools/bin:/opt/fortran/bin @@ -696,7 +669,7 @@ else $uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; printf( - \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) -1)\\n\", + \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u %%u t %%u -1)\\n\", $type, $stat[3], $uid, @@ -709,8 +682,7 @@ printf( $stat[10] & 0xffff, $stat[7], $stat[2], - $stat[1] >> 16 & 0xffff, - $stat[1] & 0xffff + $stat[1] );' \"$1\" \"$2\" 2>/dev/null" "Perl script to produce output suitable for use with `file-attributes' on the remote file system. @@ -947,24 +919,19 @@ od -v -t x1 -A n </dev/null && \ busybox awk '{}' </dev/null" "Test command for checking `tramp-awk-encode' and `tramp-awk-decode'.") -(defconst tramp-stat-marker "/////" - "Marker in stat commands for file attributes.") - -(defconst tramp-stat-quoted-marker "\\/\\/\\/\\/\\/" - "Quoted marker in stat commands for file attributes.") - (defconst tramp-vc-registered-read-file-names "echo \"(\" while read file; do + quoted=`echo \"$file\" | sed -e \"s/\\\"/\\\\\\\\\\\\\\\\\\\"/\"` if %s \"$file\"; then - echo \"(\\\"$file\\\" \\\"file-exists-p\\\" t)\" + echo \"(\\\"$quoted\\\" \\\"file-exists-p\\\" t)\" else - echo \"(\\\"$file\\\" \\\"file-exists-p\\\" nil)\" + echo \"(\\\"$quoted\\\" \\\"file-exists-p\\\" nil)\" fi if %s \"$file\"; then - echo \"(\\\"$file\\\" \\\"file-readable-p\\\" t)\" + echo \"(\\\"$quoted\\\" \\\"file-readable-p\\\" t)\" else - echo \"(\\\"$file\\\" \\\"file-readable-p\\\" nil)\" + echo \"(\\\"$quoted\\\" \\\"file-readable-p\\\" nil)\" fi done echo \")\"" @@ -977,7 +944,7 @@ of command line.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-sh-file-name-handler-alist - '(;; `access-file' performed by default handler. + '((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) @@ -991,6 +958,7 @@ of command line.") . tramp-sh-handle-directory-files-and-attributes) (dired-compress-file . tramp-sh-handle-dired-compress-file) (dired-uncache . tramp-handle-dired-uncache) + (exec-path . tramp-sh-handle-exec-path) (expand-file-name . tramp-sh-handle-expand-file-name) (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . tramp-sh-handle-file-acl) @@ -1023,7 +991,6 @@ of command line.") (file-truename . tramp-sh-handle-file-truename) (file-writable-p . tramp-sh-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) - ;; `find-file-noselect' performed by default handler. ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-sh-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) @@ -1032,6 +999,7 @@ of command line.") (make-directory . tramp-sh-handle-make-directory) ;; `make-directory-internal' performed by default handler. (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-file . tramp-sh-handle-process-file) (rename-file . tramp-sh-handle-rename-file) @@ -1041,9 +1009,10 @@ of command line.") (set-file-times . tramp-sh-handle-set-file-times) (set-visited-file-modtime . tramp-sh-handle-set-visited-file-modtime) (shell-command . tramp-handle-shell-command) - (start-file-process . tramp-sh-handle-start-file-process) + (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-set-file-uid-gid . tramp-sh-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) (vc-registered . tramp-sh-handle-vc-registered) (verify-visited-file-modtime . tramp-sh-handle-verify-visited-file-modtime) @@ -1061,15 +1030,17 @@ of the symlink. If TARGET is a Tramp file, only the localname component is used as the target of the symlink." (if (not (tramp-tramp-file-p (expand-file-name linkname))) (tramp-run-real-handler - 'make-symbolic-link (list target linkname ok-if-already-exists)) + #'make-symbolic-link (list target linkname ok-if-already-exists)) (with-parsed-tramp-file-name linkname nil ;; If TARGET is a Tramp name, use just the localname component. - (when (and (tramp-tramp-file-p target) - (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target))))) + ;; Don't check for a proper method. + (let ((non-essential t)) + (when (and (tramp-tramp-file-p target) + (tramp-file-name-equal-p v (tramp-dissect-file-name target))) + (setq target + (tramp-file-name-localname + (tramp-dissect-file-name (expand-file-name target)))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -1079,7 +1050,7 @@ component is used as the target of the symlink." (let ((ln (tramp-get-remote-ln v)) (cwd (tramp-run-real-handler - 'file-name-directory (list localname)))) + #'file-name-directory (list localname)))) (unless ln (tramp-error v 'file-error @@ -1098,8 +1069,8 @@ component is used as the target of the symlink." (tramp-error v 'file-already-exists localname) (delete-file linkname))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) ;; Right, they are on the same host, regardless of user, ;; method, etc. We now make the link on the remote @@ -1123,10 +1094,10 @@ component is used as the target of the symlink." ;; Preserve trailing "/". (funcall (if (string-equal (file-name-nondirectory filename) "") - 'file-name-as-directory 'identity) + #'file-name-as-directory #'identity) (with-parsed-tramp-file-name (expand-file-name filename) nil (tramp-make-tramp-file-name - method user domain host port + v (with-tramp-file-property v localname "file-truename" (let ((result nil) ; result steps in reverse order (quoted (tramp-compat-file-name-quoted-p localname)) @@ -1171,19 +1142,16 @@ component is used as the target of the symlink." (setq thisstep (pop steps)) (tramp-message v 5 "Check %s" - (mapconcat 'identity - (append '("") (reverse result) (list thisstep)) - "/")) + (string-join + (append '("") (reverse result) (list thisstep)) "/")) (setq symlink-target (tramp-compat-file-attribute-type (file-attributes (tramp-make-tramp-file-name - method user domain host port - (mapconcat 'identity - (append '("") - (reverse result) - (list thisstep)) - "/"))))) + v + (string-join + (append '("") (reverse result) (list thisstep)) "/") + 'nohop)))) (cond ((string= "." thisstep) (tramp-message v 5 "Ignoring step `.'")) ((string= ".." thisstep) @@ -1208,12 +1176,8 @@ component is used as the target of the symlink." "Maximum number (%d) of symlinks exceeded" numchase-limit)) (setq result (reverse result)) ;; Combine list to form string. - (setq result - (if result - (mapconcat 'identity (cons "" result) "/") - "/")) - (when (string= "" result) - (setq result "/"))))) + (setq result (if result (string-join (cons "" result) "/") "/")) + (when (string-empty-p result) (setq result "/"))))) ;; Detect cycle. (when (and (file-symlink-p filename) @@ -1227,7 +1191,8 @@ component is used as the target of the symlink." (let (file-name-handler-alist) (setq result (tramp-compat-file-name-quote result)))) (tramp-message v 4 "True name of `%s' is `%s'" localname result) - result)))))) + result)) + 'nohop)))) ;; Basic functions. @@ -1255,18 +1220,24 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname (format "file-attributes-%s" id-format) - (save-excursion - (tramp-convert-file-attributes - v - (or - (cond - ((tramp-get-remote-stat v) - (tramp-do-file-attributes-with-stat v localname id-format)) - ((tramp-get-remote-perl v) - (tramp-do-file-attributes-with-perl v localname id-format)) - (t nil)) - ;; The scripts could fail, for example with huge file size. - (tramp-do-file-attributes-with-ls v localname id-format))))))))) + (tramp-convert-file-attributes + v + (or + (cond + ((tramp-get-remote-stat v) + (tramp-do-file-attributes-with-stat v localname id-format)) + ((tramp-get-remote-perl v) + (tramp-do-file-attributes-with-perl v localname id-format)) + (t nil)) + ;; The scripts could fail, for example with huge file size. + (tramp-do-file-attributes-with-ls v localname id-format)))))))) + +(defun tramp-sh--quoting-style-options (vec) + (or + (tramp-get-ls-command-with + vec "--quoting-style=literal --show-control-chars") + (tramp-get-ls-command-with vec "-w") + "")) (defun tramp-do-file-attributes-with-ls (vec localname &optional id-format) "Implement `file-attributes' for Tramp files using the ls(1) command." @@ -1293,12 +1264,7 @@ component is used as the target of the symlink." (if (eq id-format 'integer) "-ildn" "-ild") ;; On systems which have no quoting style, file names ;; with special characters could fail. - (cond - ((tramp-get-ls-command-with-quoting-style vec) - "--quoting-style=c") - ((tramp-get-ls-command-with-w-option vec) - "-w") - (t "")) + (tramp-sh--quoting-style-options vec) (tramp-shell-quote-argument localname))) ;; Parse `ls -l' output ... (with-current-buffer (tramp-get-buffer vec) @@ -1331,7 +1297,7 @@ component is used as the target of the symlink." (when symlinkp (search-forward "-> ") (setq res-symlink-target - (if (tramp-get-ls-command-with-quoting-style vec) + (if (looking-at-p "\"") (read (current-buffer)) (buffer-substring (point) (point-at-eol))))) ;; Return data gathered. @@ -1345,13 +1311,10 @@ component is used as the target of the symlink." res-uid ;; 3. File gid. res-gid - ;; 4. Last access time, as a list of integers. Normally - ;; this would be in the same format as `current-time', but - ;; the subseconds part is not currently implemented, and - ;; (0 0) denotes an unknown time. - ;; 5. Last modification time, likewise. - ;; 6. Last status change time, likewise. - '(0 0) '(0 0) '(0 0) ;CCC how to find out? + ;; 4. Last access time. + ;; 5. Last modification time. + ;; 6. Last status change time. + tramp-time-dont-know tramp-time-dont-know tramp-time-dont-know ;; 7. Size in bytes (-1, if number is out of range). res-size ;; 8. File modes, as a string of ten letters or dashes as in ls -l. @@ -1382,15 +1345,16 @@ component is used as the target of the symlink." (tramp-send-command-and-read vec (format - (concat - ;; On Opsware, pdksh (which is the true name of ksh there) - ;; doesn't parse correctly the sequence "((". Therefore, we add - ;; a space. Apostrophes in the stat output are masked as - ;; `tramp-stat-marker', in order to make a proper shell escape of - ;; them in file names. - "( (%s %s || %s -h %s) && (%s -c " - "'((%s%%N%s) %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 %s%%A%s t %%ie0 -1)' " - "%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g') || echo nil)") + (eval-when-compile + (concat + ;; On Opsware, pdksh (which is the true name of ksh there) + ;; doesn't parse correctly the sequence "((". Therefore, we + ;; add a space. Apostrophes in the stat output are masked as + ;; `tramp-stat-marker', in order to make a proper shell escape + ;; of them in file names. + "( (%s %s || %s -h %s) && (%s -c " + "'((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " + "%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g') || echo nil)")) (tramp-get-file-exists-command vec) (tramp-shell-quote-argument localname) (tramp-get-test-command vec) @@ -1398,9 +1362,11 @@ component is used as the target of the symlink." (tramp-get-remote-stat vec) tramp-stat-marker tramp-stat-marker (if (eq id-format 'integer) - "%ue0" (concat tramp-stat-marker "%U" tramp-stat-marker)) + "%u" + (eval-when-compile (concat tramp-stat-marker "%U" tramp-stat-marker))) (if (eq id-format 'integer) - "%ge0" (concat tramp-stat-marker "%G" tramp-stat-marker)) + "%g" + (eval-when-compile (concat tramp-stat-marker "%G" tramp-stat-marker))) tramp-stat-marker tramp-stat-marker (tramp-shell-quote-argument localname) tramp-stat-quoted-marker))) @@ -1411,20 +1377,17 @@ component is used as the target of the symlink." (error "Can't set-visited-file-modtime: buffer `%s' not visiting a file" (buffer-name))) (if time-list - (tramp-run-real-handler 'set-visited-file-modtime (list time-list)) + (tramp-run-real-handler #'set-visited-file-modtime (list time-list)) (let ((f (buffer-file-name)) coding-system-used) (with-parsed-tramp-file-name f nil (let* ((remote-file-name-inhibit-cache t) (attr (file-attributes f)) - ;; '(-1 65535) means file doesn't exists yet. (modtime (or (tramp-compat-file-attribute-modification-time attr) - '(-1 65535)))) + tramp-time-doesnt-exist))) (setq coding-system-used last-coding-system-used) - ;; We use '(0 0) as a don't-know value. See also - ;; `tramp-do-file-attributes-with-ls'. - (if (not (equal modtime '(0 0))) - (tramp-run-real-handler 'set-visited-file-modtime (list modtime)) + (if (not (tramp-compat-time-equal-p modtime tramp-time-dont-know)) + (tramp-run-real-handler #'set-visited-file-modtime (list modtime)) (progn (tramp-send-command v @@ -1452,7 +1415,7 @@ of." ;; recorded last modification time, or there is no established ;; connection. (if (or (not f) - (eq (visited-file-modtime) 0) + (zerop (float-time (visited-file-modtime))) (not (file-remote-p f nil 'connected))) t (with-parsed-tramp-file-name f nil @@ -1463,16 +1426,10 @@ of." (cond ;; File exists, and has a known modtime. - ((and attr (not (equal modtime '(0 0)))) - (< (abs (tramp-time-diff - modtime - ;; For compatibility, deal with both the old - ;; (HIGH . LOW) and the new (HIGH LOW) return - ;; values of `visited-file-modtime'. - (if (atom (cdr mt)) - (list (car mt) (cdr mt)) - mt))) - 2)) + ((and attr + (not + (tramp-compat-time-equal-p modtime tramp-time-dont-know))) + (< (abs (tramp-time-diff modtime mt)) 2)) ;; Modtime has the don't know value. (attr (tramp-send-command @@ -1488,13 +1445,13 @@ of." v localname "visited-file-modtime-ild" ""))) ;; If file does not exist, say it is not modified if and ;; only if that agrees with the buffer's record. - (t (equal mt '(-1 65535)))))))))) + (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist))))))))) (defun tramp-sh-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) ;; FIXME: extract the proper text from chmod's stderr. (tramp-barf-unless-okay v @@ -1505,11 +1462,14 @@ of." "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (when (tramp-get-remote-touch v) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) - (let ((time (if (or (null time) (equal time '(0 0))) - (current-time) - time))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (let ((time + (if (or (null time) + (tramp-compat-time-equal-p time tramp-time-doesnt-exist) + (tramp-compat-time-equal-p time tramp-time-dont-know)) + (current-time) + time))) (tramp-send-command-and-check v (format "env TZ=UTC %s %s %s" @@ -1519,39 +1479,26 @@ of." "") (tramp-shell-quote-argument localname))))))) -(defun tramp-set-file-uid-gid (filename &optional uid gid) - "Set the ownership for FILENAME. -If UID and GID are provided, these values are used; otherwise uid -and gid of the corresponding user is taken. Both parameters must -be non-negative integers." +(defun tramp-sh-handle-set-file-uid-gid (filename &optional uid gid) + "Like `tramp-set-file-uid-gid' for Tramp files." ;; Modern Unices allow chown only for root. So we might need ;; another implementation, see `dired-do-chown'. OTOH, it is mostly ;; working with su(do)? when it is needed, so it shall succeed in ;; the majority of cases. ;; Don't modify `last-coding-system-used' by accident. (let ((last-coding-system-used last-coding-system-used)) - (if (tramp-tramp-file-p filename) - (with-parsed-tramp-file-name filename nil - (if (and (zerop (user-uid)) (tramp-local-host-p v)) - ;; If we are root on the local host, we can do it directly. - (tramp-set-file-uid-gid localname uid gid) - (let ((uid (or (and (natnump uid) uid) - (tramp-get-remote-uid v 'integer))) - (gid (or (and (natnump gid) gid) - (tramp-get-remote-gid v 'integer)))) - (tramp-send-command - v (format - "chown %d:%d %s" uid gid - (tramp-shell-quote-argument localname)))))) - - ;; We handle also the local part, because there doesn't exist - ;; `set-file-uid-gid'. On W32 "chown" does not work. - (unless (memq system-type '(ms-dos windows-nt)) - (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer))) - (gid (or (and (natnump gid) gid) (tramp-get-local-gid 'integer)))) - (tramp-call-process - nil "chown" nil nil nil - (format "%d:%d" uid gid) (shell-quote-argument filename))))))) + (with-parsed-tramp-file-name filename nil + (if (and (zerop (user-uid)) (tramp-local-host-p v)) + ;; If we are root on the local host, we can do it directly. + (tramp-set-file-uid-gid localname uid gid) + (let ((uid (or (and (natnump uid) uid) + (tramp-get-remote-uid v 'integer))) + (gid (or (and (natnump gid) gid) + (tramp-get-remote-gid v 'integer)))) + (tramp-send-command + v (format + "chown %d:%d %s" uid gid + (tramp-shell-quote-argument localname)))))))) (defun tramp-remote-selinux-p (vec) "Check, whether SELINUX is enabled on the remote host." @@ -1563,8 +1510,9 @@ be non-negative integers." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-selinux-context" (let ((context '(nil nil nil nil)) - (regexp (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):" - "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)"))) + (regexp (eval-when-compile + (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):" + "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)")))) (when (and (tramp-remote-selinux-p v) (tramp-send-command-and-check v (format @@ -1598,8 +1546,7 @@ be non-negative integers." (if (and user role type range) (tramp-set-file-property v localname "file-selinux-context" context) - (tramp-set-file-property - v localname "file-selinux-context" 'undef)) + (tramp-flush-file-property v localname "file-selinux-context")) t))))) (defun tramp-remote-acl-p (vec) @@ -1639,7 +1586,7 @@ be non-negative integers." (tramp-set-file-property v localname "file-acl" acl-string) t) ;; In case of errors, we return nil. - (tramp-set-file-property v localname "file-acl-string" 'undef) + (tramp-flush-file-property v localname "file-acl-string") nil))) ;; Simple functions using the `test' command. @@ -1669,28 +1616,26 @@ be non-negative integers." ;; something smarter about it. (defun tramp-sh-handle-file-newer-than-file-p (file1 file2) "Like `file-newer-than-file-p' for Tramp files." - (cond ((not (file-exists-p file1)) - nil) - ((not (file-exists-p file2)) - t) - ;; We are sure both files exist at this point. - (t - (save-excursion - ;; We try to get the mtime of both files. If they are not - ;; equal to the "dont-know" value, then we subtract the times - ;; and obtain the result. + (cond ((not (file-exists-p file1)) nil) + ((not (file-exists-p file2)) t) + (t ;; We are sure both files exist at this point. We try to + ;; get the mtime of both files. If they are not equal to + ;; the "dont-know" value, then we subtract the times and + ;; obtain the result. (let ((fa1 (file-attributes file1)) (fa2 (file-attributes file2))) (if (and (not - (equal (tramp-compat-file-attribute-modification-time fa1) - '(0 0))) + (tramp-compat-time-equal-p + (tramp-compat-file-attribute-modification-time fa1) + tramp-time-dont-know)) (not - (equal (tramp-compat-file-attribute-modification-time fa2) - '(0 0)))) - (> 0 (tramp-time-diff - (tramp-compat-file-attribute-modification-time fa2) - (tramp-compat-file-attribute-modification-time fa1))) + (tramp-compat-time-equal-p + (tramp-compat-file-attribute-modification-time fa2) + tramp-time-dont-know))) + (time-less-p + (tramp-compat-file-attribute-modification-time fa2) + (tramp-compat-file-attribute-modification-time fa1)) ;; If one of them is the dont-know value, then we can ;; still try to run a shell command on the remote host. ;; However, this only works if both files are Tramp @@ -1705,7 +1650,7 @@ be non-negative integers." file1 file2))) (with-parsed-tramp-file-name file1 nil (tramp-run-test2 - (tramp-get-test-nt-command v) file1 file2)))))))) + (tramp-get-test-nt-command v) file1 file2))))))) ;; Functions implemented using the basic functions above. @@ -1762,25 +1707,22 @@ be non-negative integers." (with-tramp-file-property v localname (format "directory-files-and-attributes-%s" id-format) - (save-excursion - (mapcar - (lambda (x) - (cons (car x) - (tramp-convert-file-attributes v (cdr x)))) - (or - (cond - ((tramp-get-remote-stat v) - (tramp-do-directory-files-and-attributes-with-stat - v localname id-format)) - ((tramp-get-remote-perl v) - (tramp-do-directory-files-and-attributes-with-perl - v localname id-format)) - (t nil))))))))) + (mapcar + (lambda (x) + (cons (car x) (tramp-convert-file-attributes v (cdr x)))) + (cond + ((tramp-get-remote-stat v) + (tramp-do-directory-files-and-attributes-with-stat + v localname id-format)) + ((tramp-get-remote-perl v) + (tramp-do-directory-files-and-attributes-with-perl + v localname id-format)) + (t nil))))))) result item) (while temp (setq item (pop temp)) - (when (or (null match) (string-match match (car item))) + (when (or (null match) (string-match-p match (car item))) (when full (setcar item (expand-file-name (car item) directory))) (push item result))) @@ -1814,33 +1756,32 @@ be non-negative integers." (tramp-send-command-and-read vec (format - (concat - ;; We must care about file names with spaces, or starting with - ;; "-"; this would confuse xargs. "ls -aQ" might be a solution, - ;; but it does not work on all remote systems. Apostrophes in - ;; the stat output are masked as `tramp-stat-marker', in order to - ;; make a proper shell escape of them in file names. - "cd %s && echo \"(\"; (%s %s -a | " - "xargs %s -c " - "'(%s%%n%s (%s%%N%s) %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 %s%%A%s t %%ie0 -1)' " - "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"") + (eval-when-compile + (concat + ;; We must care about file names with spaces, or starting with + ;; "-"; this would confuse xargs. "ls -aQ" might be a + ;; solution, but it does not work on all remote systems. + ;; Apostrophes in the stat output are masked as + ;; `tramp-stat-marker', in order to make a proper shell escape + ;; of them in file names. + "cd %s && echo \"(\"; (%s %s -a | " + "xargs %s -c " + "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " + "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"")) (tramp-shell-quote-argument localname) (tramp-get-ls-command vec) ;; On systems which have no quoting style, file names with special ;; characters could fail. - (cond - ((tramp-get-ls-command-with-quoting-style vec) - "--quoting-style=shell") - ((tramp-get-ls-command-with-w-option vec) - "-w") - (t "")) + (tramp-sh--quoting-style-options vec) (tramp-get-remote-stat vec) tramp-stat-marker tramp-stat-marker tramp-stat-marker tramp-stat-marker (if (eq id-format 'integer) - "%ue0" (concat tramp-stat-marker "%U" tramp-stat-marker)) + "%u" + (eval-when-compile (concat tramp-stat-marker "%U" tramp-stat-marker))) (if (eq id-format 'integer) - "%ge0" (concat tramp-stat-marker "%G" tramp-stat-marker)) + "%g" + (eval-when-compile (concat tramp-stat-marker "%G" tramp-stat-marker))) tramp-stat-marker tramp-stat-marker tramp-stat-quoted-marker))) @@ -1848,7 +1789,7 @@ be non-negative integers." ;; files. (defun tramp-sh-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (unless (save-match-data (string-match "/" filename)) + (unless (string-match-p "/" filename) (all-completions filename (with-parsed-tramp-file-name (expand-file-name directory) nil @@ -1867,12 +1808,13 @@ be non-negative integers." (format "tramp_perl_file_name_all_completions %s" (tramp-shell-quote-argument localname))) - (format (concat - "(cd %s 2>&1 && %s -a 2>/dev/null" - " | while IFS= read f; do" - " if %s -d \"$f\" 2>/dev/null;" - " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done" - " && \\echo ok) || \\echo fail") + (format (eval-when-compile + (concat + "(cd %s 2>&1 && %s -a 2>/dev/null" + " | while IFS= read f; do" + " if %s -d \"$f\" 2>/dev/null;" + " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done" + " && \\echo ok) || \\echo fail")) (tramp-shell-quote-argument localname) (tramp-get-ls-command v) (tramp-get-test-command v)))) @@ -1883,7 +1825,7 @@ be non-negative integers." ;; Check result code, found in last line of output. (forward-line -1) - (if (looking-at "^fail$") + (if (looking-at-p "^fail$") (progn ;; Grab error message from line before last line ;; (it was put there by `cd 2>&1'). @@ -1896,7 +1838,7 @@ be non-negative integers." ;; then it should end in `ok'. If neither are in the ;; buffer something went seriously wrong on the remote ;; side. - (unless (looking-at "^ok$") + (unless (looking-at-p "^ok$") (tramp-error v 'file-error "\ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" @@ -1933,8 +1875,8 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" v2-localname))))) (tramp-error v2 'file-already-exists newname) (delete-file newname))) - (tramp-flush-file-property v2 (file-name-directory v2-localname)) - (tramp-flush-file-property v2 v2-localname) + (tramp-flush-file-properties v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname) (tramp-barf-unless-okay v1 (format "%s %s %s" ln @@ -1987,7 +1929,7 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" (setq newname (expand-file-name (file-name-nondirectory dirname) newname))) - (when (not (file-directory-p (file-name-directory newname))) + (unless (file-directory-p (file-name-directory newname)) (make-directory (file-name-directory newname) parents)) (tramp-do-copy-or-rename-file-out-of-band 'copy dirname newname keep-date)) @@ -2000,8 +1942,8 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" ;; When newname did exist, we have wrong cached values. (when t2 (with-parsed-tramp-file-name newname nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)))))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname)))))) (defun tramp-sh-handle-rename-file (filename newname &optional ok-if-already-exists) @@ -2017,7 +1959,7 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" 'rename filename newname ok-if-already-exists 'keep-time 'preserve-uid-gid) (tramp-run-real-handler - 'rename-file (list filename newname ok-if-already-exists)))) + #'rename-file (list filename newname ok-if-already-exists)))) (defun tramp-do-copy-or-rename-file (op filename newname &optional ok-if-already-exists keep-date @@ -2051,11 +1993,13 @@ file names." (length (tramp-compat-file-attribute-size (file-attributes (file-truename filename)))) (attributes (and preserve-extended-attributes - (apply 'file-extended-attributes (list filename))))) + (apply #'file-extended-attributes (list filename))))) (with-parsed-tramp-file-name (if t1 filename newname) nil (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter v 0 (format "%s %s to %s" @@ -2123,19 +2067,21 @@ file names." ;; errors, because ACL strings could be incompatible. (when attributes (ignore-errors - (apply 'set-file-extended-attributes (list newname attributes)))) + (apply #'set-file-extended-attributes (list newname attributes)))) ;; In case of `rename', we must flush the cache of the source file. (when (and t1 (eq op 'rename)) (with-parsed-tramp-file-name filename v1 - (tramp-flush-file-property v1 (file-name-directory v1-localname)) - (tramp-flush-file-property v1 v1-localname))) + (tramp-flush-file-properties + v1 (file-name-directory v1-localname)) + (tramp-flush-file-properties v1 v1-localname))) ;; When newname did exist, we have wrong cached values. (when t2 (with-parsed-tramp-file-name newname v2 - (tramp-flush-file-property v2 (file-name-directory v2-localname)) - (tramp-flush-file-property v2 v2-localname)))))))) + (tramp-flush-file-properties + v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname)))))))) (defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date) "Use an Emacs buffer to copy or rename a file. @@ -2197,8 +2143,8 @@ the uid and gid from FILENAME." v 'file-error "Unknown operation `%s', must be `copy' or `rename'" op)))) - (localname1 (if t1 (file-remote-p filename 'localname) filename)) - (localname2 (if t2 (file-remote-p newname 'localname) newname)) + (localname1 (tramp-compat-file-local-name filename)) + (localname2 (tramp-compat-file-local-name newname)) (prefix (file-remote-p (if t1 filename newname))) cmd-result) (when (and (eq op 'copy) (file-directory-p filename)) @@ -2236,8 +2182,7 @@ the uid and gid from FILENAME." (or (eq op 'copy) (zerop (logand - (file-modes (file-name-directory localname1)) - (string-to-number "1000" 8)))) + (file-modes (file-name-directory localname1)) #o1000))) (file-writable-p (file-name-directory localname2)) (or (file-directory-p localname2) (file-writable-p localname2)))) @@ -2246,7 +2191,8 @@ the uid and gid from FILENAME." localname1 localname2 ok-if-already-exists keep-date preserve-uid-gid) (tramp-run-real-handler - 'rename-file (list localname1 localname2 ok-if-already-exists)))) + #'rename-file + (list localname1 localname2 ok-if-already-exists)))) ;; We can do it directly with `tramp-send-command' ((and (file-readable-p (concat prefix localname1)) @@ -2281,8 +2227,7 @@ the uid and gid from FILENAME." ;; We must change the ownership as remote user. ;; Since this does not work reliable, we also ;; give read permissions. - (set-file-modes - (concat prefix tmpfile) (string-to-number "0777" 8)) + (set-file-modes (concat prefix tmpfile) #o0777) (tramp-set-file-uid-gid (concat prefix tmpfile) (tramp-get-local-uid 'integer) @@ -2292,11 +2237,11 @@ the uid and gid from FILENAME." (copy-file localname1 tmpfile t keep-date preserve-uid-gid) (tramp-run-real-handler - 'rename-file (list localname1 tmpfile t))) + #'rename-file (list localname1 tmpfile t))) ;; We must change the ownership as local user. ;; Since this does not work reliable, we also ;; give read permissions. - (set-file-modes tmpfile (string-to-number "0777" 8)) + (set-file-modes tmpfile #o0777) (tramp-set-file-uid-gid tmpfile (tramp-get-remote-uid v 'integer) @@ -2314,7 +2259,7 @@ the uid and gid from FILENAME." (tramp-get-buffer v))) (t1 (tramp-run-real-handler - 'rename-file + #'rename-file (list tmpfile localname2 ok-if-already-exists))))) ;; Save exit. @@ -2359,21 +2304,13 @@ The method used must be an out-of-band method." (expand-file-name ".." tmpfile) 'recursive) (delete-file tmpfile))))) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method (tramp-file-name-method v) - tramp-current-user (or (tramp-file-name-user v) - (tramp-get-connection-property - v "login-as" nil)) - tramp-current-domain (tramp-file-name-domain v) - tramp-current-host (tramp-file-name-host v) - tramp-current-port (tramp-file-name-port v)) - ;; Check which ones of source and target are Tramp files. (setq source (funcall - (if (and (file-directory-p filename) + (if (and (string-equal method "rsync") + (file-directory-p filename) (not (file-exists-p newname))) - 'file-name-as-directory - 'identity) + #'file-name-as-directory + #'identity) (if t1 (tramp-make-copy-program-file-name v) (tramp-unquote-shell-quote-argument filename))) @@ -2427,7 +2364,7 @@ The method used must be an out-of-band method." (mapcar (lambda (x) (setq x (mapcar (lambda (y) (format-spec y spec)) x)) - (unless (member "" x) (mapconcat 'identity x " "))) + (unless (member "" x) (string-join x " "))) (tramp-get-method-parameter v 'tramp-copy-env))) remote-copy-program @@ -2457,7 +2394,7 @@ The method used must be an out-of-band method." "Cannot find remote listener: %s" remote-copy-program)) (setq remote-copy-program (mapconcat - 'identity + #'identity (append (list remote-copy-program) remote-copy-args (list (if t1 (concat "<" source) (concat ">" target)) "&")) @@ -2478,9 +2415,7 @@ The method used must be an out-of-band method." ;; The default directory must be remote. (let ((default-directory (file-name-directory (if t1 filename newname))) - (process-environment (copy-sequence process-environment)) - ;; We do not want to run timers. - timer-list timer-idle-list) + (process-environment (copy-sequence process-environment))) ;; Set the transfer process properties. (tramp-set-connection-property v "process-name" (buffer-name (current-buffer))) @@ -2503,7 +2438,7 @@ The method used must be an out-of-band method." ;; copying of large files can last longer than 60 secs. (let* ((command (mapconcat - 'identity (append (list copy-program) copy-args) + #'identity (append (list copy-program) copy-args) " ")) (p (let ((default-directory (tramp-compat-temporary-file-directory))) @@ -2512,8 +2447,8 @@ The method used must be an out-of-band method." (tramp-get-connection-buffer v) command)))) (tramp-message orig-vec 6 "%s" command) - (tramp-set-connection-property p "vector" orig-vec) - (process-put p 'adjust-window-size-function 'ignore) + (process-put p 'vector orig-vec) + (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 @@ -2523,8 +2458,8 @@ The method used must be an out-of-band method." p v nil tramp-actions-copy-out-of-band)))) ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil) + (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))) @@ -2555,20 +2490,23 @@ The method used must be an out-of-band method." "Like `make-directory' for Tramp files." (setq dir (expand-file-name dir)) (with-parsed-tramp-file-name dir nil - (tramp-flush-directory-property v (file-name-directory localname)) - (save-excursion - (tramp-barf-unless-okay - v (format "%s %s" - (if parents "mkdir -p" "mkdir") - (tramp-shell-quote-argument localname)) - "Couldn't make directory %s" dir)))) + ;; When PARENTS is non-nil, DIR could be a chain of non-existent + ;; directories a/b/c/... Instead of checking, we simply flush the + ;; whole cache. + (tramp-flush-directory-properties + v (if parents "/" (file-name-directory localname))) + (tramp-barf-unless-okay + v (format "%s %s" + (if parents "mkdir -p" "mkdir") + (tramp-shell-quote-argument localname)) + "Couldn't make directory %s" dir))) (defun tramp-sh-handle-delete-directory (directory &optional recursive trash) "Like `delete-directory' for Tramp files." (setq directory (expand-file-name directory)) (with-parsed-tramp-file-name directory nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (tramp-barf-unless-okay v (format "cd / && %s %s" (or (and trash (tramp-get-remote-trash v)) @@ -2580,8 +2518,8 @@ The method used must be an out-of-band method." "Like `delete-file' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (tramp-barf-unless-okay v (format "%s %s" (or (and trash (tramp-get-remote-trash v)) "rm -f") @@ -2594,48 +2532,49 @@ The method used must be an out-of-band method." "Like `dired-compress-file' for Tramp files." ;; Code stolen mainly from dired-aux.el. (with-parsed-tramp-file-name file nil - (tramp-flush-file-property v localname) - (save-excursion - (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 (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)))))))))) + (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))))))))) (defun tramp-sh-handle-insert-directory (filename switches &optional wildcard full-directory-p) "Like `insert-directory' for Tramp files." (setq filename (expand-file-name filename)) (unless switches (setq switches "")) + ;; Check, whether directory is accessible. + (unless wildcard + (access-file filename "Reading directory")) (with-parsed-tramp-file-name filename nil (if (and (featurep 'ls-lisp) (not (symbol-value 'ls-lisp-use-insert-directory-program))) @@ -2643,19 +2582,21 @@ The method used must be an out-of-band method." filename switches wildcard full-directory-p) (when (stringp switches) (setq switches (split-string switches))) - (when (tramp-get-ls-command-with-quoting-style v) - (setq switches (append switches '("--quoting-style=literal")))) - (when (and (member "--dired" switches) - (not (tramp-get-ls-command-with-dired v))) + (when (tramp-get-ls-command-with ;FIXME: tramp-sh--quoting-style-options? + v "--quoting-style=literal --show-control-chars") + (setq switches + (append + switches '("--quoting-style=literal" "--show-control-chars")))) + (unless (tramp-get-ls-command-with v "--dired") (setq switches (delete "--dired" switches))) (when wildcard (setq wildcard (tramp-run-real-handler - 'file-name-nondirectory (list localname))) + #'file-name-nondirectory (list localname))) (setq localname (tramp-run-real-handler - 'file-name-directory (list localname)))) + #'file-name-directory (list localname)))) (unless (or full-directory-p (member "-d" switches)) (setq switches (append switches '("-d")))) - (setq switches (mapconcat 'tramp-shell-quote-argument switches " ")) + (setq switches (mapconcat #'tramp-shell-quote-argument switches " ")) (when wildcard (setq switches (concat switches " " wildcard))) (tramp-message @@ -2677,10 +2618,10 @@ The method used must be an out-of-band method." v (format "cd %s" (tramp-shell-quote-argument (tramp-run-real-handler - 'file-name-directory (list localname)))) + #'file-name-directory (list localname)))) "Couldn't `cd %s'" (tramp-shell-quote-argument - (tramp-run-real-handler 'file-name-directory (list localname)))) + (tramp-run-real-handler #'file-name-directory (list localname)))) (tramp-send-command v (format "%s %s %s 2>/dev/null" @@ -2689,11 +2630,11 @@ The method used must be an out-of-band method." (if (or wildcard (zerop (length (tramp-run-real-handler - 'file-name-nondirectory (list localname))))) + #'file-name-nondirectory (list localname))))) "" (tramp-shell-quote-argument (tramp-run-real-handler - 'file-name-nondirectory (list localname))))))) + #'file-name-nondirectory (list localname))))))) (save-restriction (let ((beg (point))) @@ -2707,7 +2648,7 @@ The method used must be an out-of-band method." ;; Check for "--dired" output. (forward-line -2) - (when (looking-at "//SUBDIRED//") + (when (looking-at-p "//SUBDIRED//") (forward-line -1)) (when (looking-at "//DIRED//\\s-+") (let ((databeg (match-end 0)) @@ -2728,7 +2669,7 @@ The method used must be an out-of-band method." ;; Some busyboxes are reluctant to discard colors. (unless - (string-match "color" (tramp-get-connection-property v "ls" "")) + (string-match-p "color" (tramp-get-connection-property v "ls" "")) (goto-char beg) (while (re-search-forward tramp-display-escape-sequence-regexp nil t) @@ -2772,15 +2713,17 @@ If the localname part of the given file name starts with \"/../\" then the result will be a local, non-Tramp, file name." ;; If DIR is not given, use `default-directory' or "/". (setq dir (or dir default-directory "/")) + ;; Handle empty NAME. + (when (zerop (length name)) (setq name ".")) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) (setq name (concat (file-name-as-directory 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)) + (tramp-run-real-handler #'expand-file-name (list name nil)) ;; Dissect NAME. (with-parsed-tramp-file-name name nil - (unless (tramp-run-real-handler 'file-name-absolute-p (list localname)) + (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 @@ -2796,7 +2739,7 @@ the result will be a local, non-Tramp, file name." ;; appropriate either, because ssh and companions might ;; use a user name from the config file. (when (and (string-equal uname "~") - (string-match "\\`su\\(do\\)?\\'" method)) + (string-match-p "\\`su\\(do\\)?\\'" method)) (setq uname (concat uname user))) (setq uname (with-tramp-connection-property v uname @@ -2816,165 +2759,210 @@ the result will be a local, non-Tramp, file name." ;; be problems with UNC shares or Cygwin mounts. (let ((default-directory (tramp-compat-temporary-file-directory))) (tramp-make-tramp-file-name - method user domain host port - (tramp-drop-volume-letter - (tramp-run-real-handler - 'expand-file-name (list localname))) - hop))))) + v (tramp-drop-volume-letter + (tramp-run-real-handler + #'expand-file-name (list localname)))))))) ;;; Remote commands: -(defun tramp-process-sentinel (proc event) - "Flush file caches." - (unless (process-live-p proc) - (let ((vec (tramp-get-connection-property proc "vector" nil))) - (when vec - (tramp-message vec 5 "Sentinel called: `%S' `%s'" proc event) - (tramp-flush-connection-property proc) - (tramp-flush-directory-property vec ""))))) - ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once ;; connection has been setup. -(defun tramp-sh-handle-start-file-process (name buffer program &rest args) - "Like `start-file-process' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name default-directory) nil - (let* ((buffer - (if buffer - (get-buffer-create buffer) - ;; BUFFER can be nil. We use a temporary buffer. - (generate-new-buffer tramp-temp-buffer-name))) - ;; When PROGRAM matches "*sh", and the first arg is "-c", - ;; it might be that the arguments exceed the command line - ;; length. Therefore, we modify the command. - (heredoc (and (stringp program) - (string-match "sh$" program) - (string-equal "-c" (car args)) - (= (length args) 2))) - ;; When PROGRAM is nil, we just provide a tty. - (args (if (not heredoc) args - (let ((i 250)) - (while (and (< i (length (cadr args))) - (string-match " " (cadr args) i)) - (setcdr - args - (list (replace-match " \\\\\n" nil nil (cadr args)))) - (setq i (+ i 250)))) - (cdr args))) - ;; Use a human-friendly prompt, for example for `shell'. - ;; We discard hops, if existing, that's why we cannot use - ;; `file-remote-p'. - (prompt (format "PS1=%s %s" - (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-domain v) - (tramp-file-name-host v) - (tramp-file-name-port v) - (tramp-file-name-localname v)) - tramp-initial-end-of-output)) - ;; We use as environment the difference to toplevel - ;; `process-environment'. - env uenv - (env (dolist (elt (cons prompt process-environment) env) - (or (member elt (default-toplevel-value 'process-environment)) - (if (string-match "=" elt) - (setq env (append env `(,elt))) - (if (tramp-get-env-with-u-option v) - (setq env (append `("-u" ,elt) env)) - (setq uenv (cons elt uenv))))))) - (command - (when (stringp program) - (format "cd %s && %s exec %s env %s %s" - (tramp-shell-quote-argument localname) - (if uenv - (format - "unset %s &&" - (mapconcat 'tramp-shell-quote-argument uenv " ")) - "") - (if heredoc (format "<<'%s'" tramp-end-of-heredoc) "") - (mapconcat 'tramp-shell-quote-argument env " ") - (if heredoc - (format "%s\n(\n%s\n) </dev/tty\n%s" - program (car args) tramp-end-of-heredoc) - (mapconcat 'tramp-shell-quote-argument - (cons program args) " "))))) - (tramp-process-connection-type - (or (null program) tramp-process-connection-type)) - (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) - (name1 name) - (i 0) - ;; We do not want to raise an error when - ;; `start-file-process' has been started several times in - ;; `eshell' and friends. - tramp-current-connection - ;; We do not want to run timers. - timer-list timer-idle-list - p) - - (while (get-process name1) - ;; NAME must be unique as process name. - (setq i (1+ i) - name1 (format "%s<%d>" name i))) - (setq name name1) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) - - (with-current-buffer (tramp-get-connection-buffer v) - (unwind-protect - ;; We catch this event. Otherwise, `start-process' could - ;; be called on the local host. - (save-excursion - (save-restriction - ;; Activate narrowing in order to save BUFFER - ;; contents. Clear also the modification time; - ;; otherwise we might be interrupted by - ;; `verify-visited-file-modtime'. - (let ((buffer-undo-list t) - (buffer-read-only nil) - (mark (point-max))) - (clear-visited-file-modtime) - (narrow-to-region (point-max) (point-max)) - ;; We call `tramp-maybe-open-connection', in order - ;; to cleanup the prompt afterwards. - (catch 'suppress - (tramp-maybe-open-connection v) - (setq p (tramp-get-connection-process v)) - ;; Set the pid of the remote shell. This is - ;; needed when sending signals remotely. - (let ((pid (tramp-send-command-and-read v "echo $$"))) - (process-put p 'remote-pid pid) - (tramp-set-connection-property p "remote-pid" pid)) - (widen) - (delete-region mark (point-max)) - (narrow-to-region (point-max) (point-max)) - ;; Now do it. - (if command - ;; Send the command. - (tramp-send-command v command nil t) ; nooutput - ;; Check, whether a pty is associated. - (unless (process-get p 'remote-tty) - (tramp-error - v 'file-error - "pty association is not supported for `%s'" name)))) - ;; Set query flag and process marker for this - ;; process. We ignore errors, because the process - ;; could have finished already. - (ignore-errors - (set-process-query-on-exit-flag p t) - (set-marker (process-mark p) (point))) - ;; Return process. - p))) +(defun tramp-sh-handle-make-process (&rest args) + "Like `make-process' for Tramp files." + (when args + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let ((name (plist-get args :name)) + (buffer (plist-get args :buffer)) + (command (plist-get args :command)) + (coding (plist-get args :coding)) + (noquery (plist-get args :noquery)) + (connection-type (plist-get args :connection-type)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + (stderr (plist-get args :stderr))) + (unless (stringp name) + (signal 'wrong-type-argument (list #'stringp name))) + (unless (or (null buffer) (bufferp buffer) (stringp buffer)) + (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (consp command) + (signal 'wrong-type-argument (list #'consp command))) + (unless (or (null coding) + (and (symbolp coding) (memq coding coding-system-list)) + (and (consp coding) + (memq (car coding) coding-system-list) + (memq (cdr coding) coding-system-list))) + (signal 'wrong-type-argument (list #'symbolp coding))) + (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (signal 'wrong-type-argument (list #'symbolp connection-type))) + (unless (or (null filter) (functionp filter)) + (signal 'wrong-type-argument (list #'functionp filter))) + (unless (or (null sentinel) (functionp sentinel)) + (signal 'wrong-type-argument (list #'functionp sentinel))) + (unless (or (null stderr) (bufferp stderr) (stringp stderr)) + (signal 'wrong-type-argument (list #'stringp stderr))) + + (let* ((buffer + (if buffer + (get-buffer-create buffer) + ;; BUFFER can be nil. We use a temporary buffer. + (generate-new-buffer tramp-temp-buffer-name))) + (stderr (and stderr (get-buffer-create stderr))) + (tmpstderr (and stderr (tramp-make-tramp-temp-file v))) + (program (car command)) + (args (cdr command)) + ;; When PROGRAM matches "*sh", and the first arg is + ;; "-c", it might be that the arguments exceed the + ;; command line length. Therefore, we modify the + ;; command. + (heredoc (and (stringp program) + (string-match-p "sh$" program) + (string-equal "-c" (car args)) + (= (length args) 2))) + ;; When PROGRAM is nil, we just provide a tty. + (args (if (not heredoc) args + (let ((i 250)) + (while (and (< i (length (cadr args))) + (string-match " " (cadr args) i)) + (setcdr + args + (list + (replace-match " \\\\\n" nil nil (cadr args)))) + (setq i (+ i 250)))) + (cdr args))) + ;; Use a human-friendly prompt, for example for + ;; `shell'. We discard hops, if existing, that's why + ;; we cannot use `file-remote-p'. + (prompt (format "PS1=%s %s" + (tramp-make-tramp-file-name v nil 'nohop) + tramp-initial-end-of-output)) + ;; We use as environment the difference to toplevel + ;; `process-environment'. + env uenv + (env (dolist (elt (cons prompt process-environment) env) + (or (member + elt (default-toplevel-value 'process-environment)) + (if (string-match-p "=" elt) + (setq env (append env `(,elt))) + (if (tramp-get-env-with-u-option v) + (setq env (append `("-u" ,elt) env)) + (setq uenv (cons elt uenv))))))) + (command + (when (stringp program) + (format "cd %s && %s exec %s %s env %s %s" + (tramp-shell-quote-argument localname) + (if uenv + (format + "unset %s &&" + (mapconcat + #'tramp-shell-quote-argument uenv " ")) + "") + (if heredoc (format "<<'%s'" tramp-end-of-heredoc) "") + (if tmpstderr (format "2>'%s'" tmpstderr) "") + (mapconcat #'tramp-shell-quote-argument env " ") + (if heredoc + (format "%s\n(\n%s\n) </dev/tty\n%s" + program (car args) tramp-end-of-heredoc) + (mapconcat #'tramp-shell-quote-argument + (cons program args) " "))))) + (tramp-process-connection-type + (or (null program) tramp-process-connection-type)) + (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) + (name1 name) + (i 0) + ;; We do not want to raise an error when `make-process' + ;; has been started several times in `eshell' and + ;; friends. + tramp-current-connection + p) + + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + (setq name name1) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) - ;; Save exit. - (if (string-match tramp-temp-buffer-name (buffer-name)) - (ignore-errors - (set-process-buffer p nil) - (kill-buffer (current-buffer))) - (set-buffer-modified-p bmp)) - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil)))))) + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + ;; We catch this event. Otherwise, `make-process' could + ;; be called on the local host. + (save-excursion + (save-restriction + ;; Activate narrowing in order to save BUFFER + ;; contents. Clear also the modification time; + ;; otherwise we might be interrupted by + ;; `verify-visited-file-modtime'. + (let ((buffer-undo-list t) + (inhibit-read-only t) + (mark (point-max))) + (clear-visited-file-modtime) + (narrow-to-region (point-max) (point-max)) + ;; We call `tramp-maybe-open-connection', in + ;; order to cleanup the prompt afterwards. + (catch 'suppress + (tramp-maybe-open-connection v) + (setq p (tramp-get-connection-process v)) + ;; Set the pid of the remote shell. This is + ;; needed when sending signals remotely. + (let ((pid (tramp-send-command-and-read v "echo $$"))) + (process-put p 'remote-pid pid) + (tramp-set-connection-property p "remote-pid" pid)) + ;; `tramp-maybe-open-connection' and + ;; `tramp-send-command-and-read' could have + ;; trashed the connection buffer. Remove this. + (widen) + (delete-region mark (point-max)) + (narrow-to-region (point-max) (point-max)) + ;; Now do it. + (if command + ;; Send the command. + (tramp-send-command v command nil t) ; nooutput + ;; Check, whether a pty is associated. + (unless (process-get p 'remote-tty) + (tramp-error + v 'file-error + "pty association is not supported for `%s'" + name)))) + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + ;; Set query flag and process marker for this + ;; process. We ignore errors, because the + ;; process could have finished already. + (ignore-errors + (set-process-query-on-exit-flag p (null noquery)) + (set-marker (process-mark p) (point))) + ;; Provide error buffer. This shows only + ;; initial error messages; messages arriving + ;; later on shall be inserted by `auto-revert'. + ;; The temporary file will still be existing. + ;; TODO: Write a sentinel, which deletes the + ;; temporary file. + (when tmpstderr + ;; We must flush them here already; otherwise + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + (with-current-buffer stderr + (insert-file-contents + (tramp-make-tramp-file-name v tmpstderr) 'visit) + (auto-revert-mode))) + ;; Return process. + p))) + + ;; Save exit. + (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (ignore-errors + (set-process-buffer p nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp)) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer")))))))) (defun tramp-sh-handle-process-file (program &optional infile destination display &rest args) @@ -2986,12 +2974,12 @@ the result will be a local, non-Tramp, file name." (with-parsed-tramp-file-name default-directory nil (let (command env uenv input tmpinput stderr tmpstderr outbuf ret) ;; Compute command. - (setq command (mapconcat 'tramp-shell-quote-argument + (setq command (mapconcat #'tramp-shell-quote-argument (cons program args) " ")) ;; We use as environment the difference to toplevel `process-environment'. (dolist (elt process-environment) (or (member elt (default-toplevel-value 'process-environment)) - (if (string-match "=" elt) + (if (string-match-p "=" elt) (setq env (append env `(,elt))) (if (tramp-get-env-with-u-option v) (setq env (append `("-u" ,elt) env)) @@ -3000,12 +2988,12 @@ the result will be a local, non-Tramp, file name." (setq command (format "env %s %s" - (mapconcat 'tramp-shell-quote-argument env " ") command))) + (mapconcat #'tramp-shell-quote-argument env " ") command))) (when uenv (setq command (format "unset %s && %s" - (mapconcat 'tramp-shell-quote-argument uenv " ") command))) + (mapconcat #'tramp-shell-quote-argument uenv " ") command))) ;; Determine input. (if (null infile) (setq input "/dev/null") @@ -3015,8 +3003,7 @@ the result will be a local, non-Tramp, file name." (setq input (with-parsed-tramp-file-name infile nil localname)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) - tmpinput - (tramp-make-tramp-file-name method user domain host port input)) + tmpinput (tramp-make-tramp-file-name v input 'nohop)) (copy-file infile tmpinput t))) (when input (setq command (format "%s <%s" command input))) @@ -3049,8 +3036,7 @@ the result will be a local, non-Tramp, file name." ;; 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 - method user domain host port stderr)))) + tmpstderr (tramp-make-tramp-file-name v stderr 'nohop)))) ;; stderr to be discarded. ((null (cadr destination)) (setq stderr "/dev/null")))) @@ -3096,13 +3082,20 @@ the result will be a local, non-Tramp, file name." (when tmpinput (delete-file tmpinput)) (unless process-file-side-effects - (tramp-flush-directory-property v "")) + (tramp-flush-directory-properties v "")) ;; Return exit status. (if (equal ret -1) (keyboard-quit) ret)))) +(defun tramp-sh-handle-exec-path () + "Like `exec-path' for Tramp files." + (append + (tramp-get-remote-path (tramp-dissect-file-name default-directory)) + ;; The equivalent to `exec-directory'. + `(,(tramp-compat-file-local-name default-directory)))) + (defun tramp-sh-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil @@ -3126,50 +3119,49 @@ the result will be a local, non-Tramp, file name." ;; Use inline encoding for file transfer. (rem-enc - (save-excursion - (with-tramp-progress-reporter - v 3 - (format-message "Encoding remote file `%s' with `%s'" - filename rem-enc) - (tramp-barf-unless-okay - v (format rem-enc (tramp-shell-quote-argument localname)) - "Encoding remote file failed")) - - (with-tramp-progress-reporter - v 3 (format-message "Decoding local file `%s' with `%s'" - tmpfile loc-dec) - (if (functionp loc-dec) - ;; If local decoding is a function, we call it. - ;; We must disable multibyte, because - ;; `uudecode-decode-region' doesn't handle it - ;; correctly. Unset `file-name-handler-alist'. - ;; Otherwise, epa-file gets confused. - (let (file-name-handler-alist - (coding-system-for-write 'binary)) - (with-temp-file tmpfile - (set-buffer-multibyte nil) - (insert-buffer-substring (tramp-get-buffer v)) - (funcall loc-dec (point-min) (point-max)))) - - ;; If tramp-decoding-function is not defined for this - ;; method, we invoke tramp-decoding-command instead. - (let ((tmpfile2 (tramp-compat-make-temp-file filename))) - ;; Unset `file-name-handler-alist'. Otherwise, - ;; epa-file gets confused. - (let (file-name-handler-alist - (coding-system-for-write 'binary)) - (with-current-buffer (tramp-get-buffer v) - (write-region - (point-min) (point-max) tmpfile2 nil 'no-message))) - (unwind-protect - (tramp-call-local-coding-command - loc-dec tmpfile2 tmpfile) - (delete-file tmpfile2))))) - - ;; Set proper permissions. - (set-file-modes tmpfile (tramp-default-file-modes filename)) - ;; Set local user ownership. - (tramp-set-file-uid-gid tmpfile))) + (with-tramp-progress-reporter + v 3 + (format-message + "Encoding remote file `%s' with `%s'" filename rem-enc) + (tramp-barf-unless-okay + v (format rem-enc (tramp-shell-quote-argument localname)) + "Encoding remote file failed")) + + (with-tramp-progress-reporter + v 3 (format-message + "Decoding local file `%s' with `%s'" tmpfile loc-dec) + (if (functionp loc-dec) + ;; If local decoding is a function, we call it. We + ;; must disable multibyte, because + ;; `uudecode-decode-region' doesn't handle it + ;; correctly. Unset `file-name-handler-alist'. + ;; Otherwise, epa-file gets confused. + (let (file-name-handler-alist + (coding-system-for-write 'binary)) + (with-temp-file tmpfile + (set-buffer-multibyte nil) + (insert-buffer-substring (tramp-get-buffer v)) + (funcall loc-dec (point-min) (point-max)))) + + ;; If tramp-decoding-function is not defined for this + ;; method, we invoke tramp-decoding-command instead. + (let ((tmpfile2 (tramp-compat-make-temp-file filename))) + ;; Unset `file-name-handler-alist'. Otherwise, + ;; epa-file gets confused. + (let (file-name-handler-alist + (coding-system-for-write 'binary)) + (with-current-buffer (tramp-get-buffer v) + (write-region + (point-min) (point-max) tmpfile2 nil 'no-message))) + (unwind-protect + (tramp-call-local-coding-command + loc-dec tmpfile2 tmpfile) + (delete-file tmpfile2))))) + + ;; Set proper permissions. + (set-file-modes tmpfile (tramp-default-file-modes filename)) + ;; Set local user ownership. + (tramp-set-file-uid-gid tmpfile)) ;; Oops, I don't know what to do. (t (tramp-error @@ -3213,7 +3205,8 @@ the result will be a local, non-Tramp, file name." (file-writable-p localname))))) ;; Short track: if we are on the local host, we can run directly. (tramp-run-real-handler - 'write-region (list start end localname append 'no-message lockname)) + #'write-region + (list start end localname append 'no-message lockname)) (let* ((modes (save-excursion (tramp-default-file-modes filename))) ;; We use this to save the value of @@ -3249,7 +3242,7 @@ the result will be a local, non-Tramp, file name." (tramp-find-file-name-coding-system-alist filename tmpfile))) (condition-case err (tramp-run-real-handler - 'write-region + #'write-region (list start end tmpfile append 'no-message lockname)) ((error quit) (setq tramp-temp-buffer-file-name nil) @@ -3265,9 +3258,7 @@ the result will be a local, non-Tramp, file name." ;; handles permissions. ;; Ensure that it is still readable. (when modes - (set-file-modes - tmpfile - (logior (or modes 0) (string-to-number "0400" 8)))) + (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 @@ -3335,8 +3326,9 @@ the result will be a local, non-Tramp, file name." loc-enc tmpfile t)) (tramp-error v 'file-error - (concat "Cannot write to `%s', " - "local encoding command `%s' failed") + (eval-when-compile + (concat "Cannot write to `%s', " + "local encoding command `%s' failed")) filename loc-enc)))) ;; Send buffer into remote decoding command which @@ -3381,8 +3373,9 @@ the result will be a local, non-Tramp, file name." (buffer-string)))) (tramp-error v 'file-error - (concat "Couldn't write region to `%s'," - " decode using `%s' failed") + (eval-when-compile + (concat "Couldn't write region to `%s'," + " decode using `%s' failed")) filename rem-dec))))) ;; Save exit. @@ -3392,16 +3385,17 @@ the result will be a local, non-Tramp, file name." (t (tramp-error v 'file-error - (concat "Method `%s' should specify both encoding and " - "decoding command or an scp program") + (eval-when-compile + (concat "Method `%s' should specify both encoding and " + "decoding command or an scp program")) method)))) ;; Make `last-coding-system-used' have the right value. (when coding-system-used (set 'last-coding-system-used coding-system-used)))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) ;; We must protect `last-coding-system-used', now we have set it ;; to its correct value. @@ -3444,88 +3438,89 @@ the result will be a local, non-Tramp, file name." ;; any other remote command. (defun tramp-sh-handle-vc-registered (file) "Like `vc-registered' for Tramp files." - (with-temp-message "" - (with-parsed-tramp-file-name file nil - (with-tramp-progress-reporter - v 3 (format-message "Checking `vc-registered' for %s" file) - - ;; There could be new files, created by the vc backend. We - ;; cannot reuse the old cache entries, therefore. In - ;; `tramp-get-file-property', `remote-file-name-inhibit-cache' - ;; could also be a timestamp as `current-time' returns. This - ;; means invalidate all cache entries with an older timestamp. - (let (tramp-vc-registered-file-names - (remote-file-name-inhibit-cache (current-time)) - (file-name-handler-alist - `((,tramp-file-name-regexp . tramp-vc-file-name-handler)))) - - ;; Here we collect only file names, which need an operation. - (tramp-with-demoted-errors - v "Error in 1st pass of `vc-registered': %s" - (tramp-run-real-handler 'vc-registered (list file))) - (tramp-message v 10 "\n%s" tramp-vc-registered-file-names) - - ;; Send just one command, in order to fill the cache. - (when tramp-vc-registered-file-names - (tramp-maybe-send-script - v - (format tramp-vc-registered-read-file-names - (tramp-get-file-exists-command v) - (format "%s -r" (tramp-get-test-command v))) - "tramp_vc_registered_read_file_names") - - (dolist - (elt - (ignore-errors - ;; We cannot use `tramp-send-command-and-read', - ;; because this does not cooperate well with - ;; heredoc documents. - (tramp-send-command - v - (format - "tramp_vc_registered_read_file_names <<'%s'\n%s\n%s\n" - tramp-end-of-heredoc - (mapconcat 'tramp-shell-quote-argument - tramp-vc-registered-file-names - "\n") - tramp-end-of-heredoc)) - (with-current-buffer (tramp-get-connection-buffer v) - ;; Read the expression. - (goto-char (point-min)) - (read (current-buffer))))) - - (tramp-set-file-property - v (car elt) (cadr elt) (cadr (cdr elt)))))) - - ;; Second run. Now all `file-exists-p' or `file-readable-p' - ;; calls shall be answered from the file cache. We unset - ;; `process-file-side-effects' and `remote-file-name-inhibit-cache' - ;; in order to keep the cache. - (let ((vc-handled-backends vc-handled-backends) - remote-file-name-inhibit-cache process-file-side-effects) - ;; Reduce `vc-handled-backends' in order to minimize process calls. - (when (and (memq 'Bzr vc-handled-backends) - (boundp 'vc-bzr-program) - (not (with-tramp-connection-property v vc-bzr-program - (tramp-find-executable - v vc-bzr-program (tramp-get-remote-path v))))) - (setq vc-handled-backends (remq 'Bzr vc-handled-backends))) - (when (and (memq 'Git vc-handled-backends) - (boundp 'vc-git-program) - (not (with-tramp-connection-property v vc-git-program - (tramp-find-executable - v vc-git-program (tramp-get-remote-path v))))) - (setq vc-handled-backends (remq 'Git vc-handled-backends))) - (when (and (memq 'Hg vc-handled-backends) - (boundp 'vc-hg-program) - (not (with-tramp-connection-property v vc-hg-program - (tramp-find-executable - v vc-hg-program (tramp-get-remote-path v))))) - (setq vc-handled-backends (remq 'Hg vc-handled-backends))) - ;; Run. - (tramp-with-demoted-errors - v "Error in 2nd pass of `vc-registered': %s" - (tramp-run-real-handler 'vc-registered (list file)))))))) + (when vc-handled-backends + (with-temp-message "" + (with-parsed-tramp-file-name file nil + (with-tramp-progress-reporter + v 3 (format-message "Checking `vc-registered' for %s" file) + + ;; There could be new files, created by the vc backend. We + ;; cannot reuse the old cache entries, therefore. In + ;; `tramp-get-file-property', `remote-file-name-inhibit-cache' + ;; could also be a timestamp as `current-time' returns. This + ;; means invalidate all cache entries with an older timestamp. + (let (tramp-vc-registered-file-names + (remote-file-name-inhibit-cache (current-time)) + (file-name-handler-alist + `((,tramp-file-name-regexp . tramp-vc-file-name-handler)))) + + ;; Here we collect only file names, which need an operation. + (tramp-with-demoted-errors + v "Error in 1st pass of `vc-registered': %s" + (tramp-run-real-handler #'vc-registered (list file))) + (tramp-message v 10 "\n%s" tramp-vc-registered-file-names) + + ;; Send just one command, in order to fill the cache. + (when tramp-vc-registered-file-names + (tramp-maybe-send-script + v + (format tramp-vc-registered-read-file-names + (tramp-get-file-exists-command v) + (format "%s -r" (tramp-get-test-command v))) + "tramp_vc_registered_read_file_names") + + (dolist + (elt + (ignore-errors + ;; We cannot use `tramp-send-command-and-read', + ;; because this does not cooperate well with + ;; heredoc documents. + (tramp-send-command + v + (format + "tramp_vc_registered_read_file_names <<'%s'\n%s\n%s\n" + tramp-end-of-heredoc + (mapconcat #'tramp-shell-quote-argument + tramp-vc-registered-file-names + "\n") + tramp-end-of-heredoc)) + (with-current-buffer (tramp-get-connection-buffer v) + ;; Read the expression. + (goto-char (point-min)) + (read (current-buffer))))) + + (tramp-set-file-property + v (car elt) (cadr elt) (cadr (cdr elt)))))) + + ;; Second run. Now all `file-exists-p' or `file-readable-p' + ;; calls shall be answered from the file cache. We unset + ;; `process-file-side-effects' and `remote-file-name-inhibit-cache' + ;; in order to keep the cache. + (let ((vc-handled-backends vc-handled-backends) + remote-file-name-inhibit-cache process-file-side-effects) + ;; Reduce `vc-handled-backends' in order to minimize process calls. + (when (and (memq 'Bzr vc-handled-backends) + (boundp 'vc-bzr-program) + (not (with-tramp-connection-property v vc-bzr-program + (tramp-find-executable + v vc-bzr-program (tramp-get-remote-path v))))) + (setq vc-handled-backends (remq 'Bzr vc-handled-backends))) + (when (and (memq 'Git vc-handled-backends) + (boundp 'vc-git-program) + (not (with-tramp-connection-property v vc-git-program + (tramp-find-executable + v vc-git-program (tramp-get-remote-path v))))) + (setq vc-handled-backends (remq 'Git vc-handled-backends))) + (when (and (memq 'Hg vc-handled-backends) + (boundp 'vc-hg-program) + (not (with-tramp-connection-property v vc-hg-program + (tramp-find-executable + v vc-hg-program (tramp-get-remote-path v))))) + (setq vc-handled-backends (remq 'Hg vc-handled-backends))) + ;; Run. + (tramp-with-demoted-errors + v "Error in 2nd pass of `vc-registered': %s" + (tramp-run-real-handler #'vc-registered (list file))))))))) ;;;###tramp-autoload (defun tramp-sh-file-name-handler (operation &rest args) @@ -3538,34 +3533,40 @@ Fall back to normal file name handler if no Tramp handler exists." ;; This must be the last entry, because `identity' always matches. ;;;###tramp-autoload -(tramp-register-foreign-file-name-handler - 'identity 'tramp-sh-file-name-handler 'append) +(tramp--with-startup + (tramp-register-foreign-file-name-handler + #'identity #'tramp-sh-file-name-handler 'append)) (defun tramp-vc-file-name-handler (operation &rest args) "Invoke special file name handler, which collects files to be handled." (save-match-data (let ((filename (tramp-replace-environment-variables - (apply 'tramp-file-name-for-operation operation args))) + (apply #'tramp-file-name-for-operation operation args))) (fn (assoc operation tramp-sh-file-name-handler-alist))) - (with-parsed-tramp-file-name filename nil - (cond - ;; That's what we want: file names, for which checks are - ;; applied. We assume that VC uses only `file-exists-p' and - ;; `file-readable-p' checks; otherwise we must extend the - ;; list. We do not perform any action, but return nil, in - ;; order to keep `vc-registered' running. - ((and fn (memq operation '(file-exists-p file-readable-p))) - (add-to-list 'tramp-vc-registered-file-names localname 'append) - nil) - ;; `process-file' and `start-file-process' shall be ignored. - ((and fn (eq operation 'process-file) 0)) - ((and fn (eq operation 'start-file-process) nil)) - ;; Tramp file name handlers like `expand-file-name'. They - ;; must still work. - (fn (save-match-data (apply (cdr fn) args))) - ;; Default file name handlers, we don't care. - (t (tramp-run-real-handler operation args))))))) + (if (tramp-tramp-file-p filename) + (with-parsed-tramp-file-name filename nil + (cond + ;; That's what we want: file names, for which checks are + ;; applied. We assume that VC uses only `file-exists-p' + ;; and `file-readable-p' checks; otherwise we must extend + ;; the list. We do not perform any action, but return + ;; nil, in order to keep `vc-registered' running. + ((and fn (memq operation '(file-exists-p file-readable-p))) + (add-to-list 'tramp-vc-registered-file-names localname 'append) + nil) + ;; `process-file' and `start-file-process' shall be ignored. + ((and fn (eq operation 'process-file) 0)) + ((and fn (eq operation 'start-file-process) nil)) + ;; Tramp file name handlers like `expand-file-name'. They + ;; must still work. + (fn (save-match-data (apply (cdr fn) args))) + ;; Default file name handlers, we don't care. + (t (tramp-run-real-handler operation args)))) + + ;; When `tramp-mode' is not enabled, or the file name is + ;; quoted, we don't do anything. + (tramp-run-real-handler operation args))))) (defun tramp-sh-handle-file-notify-add-watch (file-name flags _callback) "Like `file-notify-add-watch' for Tramp files." @@ -3574,29 +3575,19 @@ Fall back to normal file name handler if no Tramp handler exists." (let ((default-directory (file-name-directory file-name)) command events filter p sequence) (cond - ;; gvfs-monitor-dir. - ((setq command (tramp-get-remote-gvfs-monitor-dir v)) - (setq filter 'tramp-sh-gvfs-monitor-dir-process-filter - events - (cond - ((and (memq 'change flags) (memq 'attribute-change flags)) - '(created changed changes-done-hint moved deleted - attribute-changed)) - ((memq 'change flags) - '(created changed changes-done-hint moved deleted)) - ((memq 'attribute-change flags) '(attribute-changed))) - sequence `(,command ,localname))) - ;; inotifywait. + ;; "inotifywait". ((setq command (tramp-get-remote-inotifywait v)) - (setq filter 'tramp-sh-inotifywait-process-filter + (setq filter #'tramp-sh-inotifywait-process-filter events (cond ((and (memq 'change flags) (memq 'attribute-change flags)) - (concat "create,modify,move,moved_from,moved_to,move_self," - "delete,delete_self,attrib,ignored")) + (eval-when-compile + (concat "create,modify,move,moved_from,moved_to,move_self," + "delete,delete_self,attrib,ignored"))) ((memq 'change flags) - (concat "create,modify,move,moved_from,moved_to,move_self," - "delete,delete_self,ignored")) + (eval-when-compile + (concat "create,modify,move,moved_from,moved_to,move_self," + "delete,delete_self,ignored"))) ((memq 'attribute-change flags) "attrib,ignored")) sequence `(,command "-mq" "-e" ,events ,localname) ;; Make events a list of symbols. @@ -3604,6 +3595,30 @@ Fall back to normal file name handler if no Tramp handler exists." (mapcar (lambda (x) (intern-soft (replace-regexp-in-string "_" "-" x))) (split-string events "," 'omit)))) + ;; "gio monitor". + ((setq command (tramp-get-remote-gio-monitor v)) + (setq filter #'tramp-sh-gio-monitor-process-filter + events + (cond + ((and (memq 'change flags) (memq 'attribute-change flags)) + '(created changed changes-done-hint moved deleted + attribute-changed)) + ((memq 'change flags) + '(created changed changes-done-hint moved deleted)) + ((memq 'attribute-change flags) '(attribute-changed))) + sequence `(,command "monitor" ,localname))) + ;; "gvfs-monitor-dir". + ((setq command (tramp-get-remote-gvfs-monitor-dir v)) + (setq filter #'tramp-sh-gvfs-monitor-dir-process-filter + events + (cond + ((and (memq 'change flags) (memq 'attribute-change flags)) + '(created changed changes-done-hint moved deleted + attribute-changed)) + ((memq 'change flags) + '(created changed changes-done-hint moved deleted)) + ((memq 'attribute-change flags) '(attribute-changed))) + sequence `(,command ,localname))) ;; None. (t (tramp-error v 'file-notify-error @@ -3611,7 +3626,7 @@ Fall back to normal file name handler if no Tramp handler exists." (file-remote-p file-name)))) ;; Start process. (setq p (apply - 'start-file-process + #'start-file-process (file-name-nondirectory command) (generate-new-buffer (format " *%s*" (file-name-nondirectory command))) @@ -3621,22 +3636,82 @@ Fall back to normal file name handler if no Tramp handler exists." (tramp-error v 'file-notify-error "`%s' failed to start on remote host" - (mapconcat 'identity sequence " ")) - (tramp-message v 6 "Run `%s', %S" (mapconcat 'identity sequence " ") p) - (tramp-set-connection-property p "vector" v) + (string-join sequence " ")) + (tramp-message v 6 "Run `%s', %S" (string-join sequence " ") p) + (process-put p 'vector v) ;; Needed for process filter. (process-put p 'events events) (process-put p 'watch-name localname) (set-process-query-on-exit-flag p nil) (set-process-filter p filter) + (set-process-sentinel p #'tramp-file-notify-process-sentinel) ;; There might be an error if the monitor is not supported. ;; Give the filter a chance to read the output. - (tramp-accept-process-output p 1) + (while (tramp-accept-process-output p 0)) (unless (process-live-p p) (tramp-error - v 'file-notify-error "Monitoring not supported for `%s'" file-name)) + p 'file-notify-error "Monitoring not supported for `%s'" file-name)) p)))) +(defun tramp-sh-gio-monitor-process-filter (proc string) + "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))) + (rest-string (process-get proc 'rest-string))) + (when rest-string + (tramp-message proc 10 "Previous string:\n%s" rest-string)) + (tramp-message proc 6 "%S\n%s" proc string) + (setq string (concat rest-string string) + ;; Fix action names. + string (replace-regexp-in-string + "attributes changed" "attribute-changed" string) + string (replace-regexp-in-string + "changes done" "changes-done-hint" string) + string (replace-regexp-in-string + "renamed to" "moved" string)) + ;; https://bugs.launchpad.net/bugs/1742946 + (when + (string-match-p "Monitoring not supported\\|No locations given" string) + (delete-process proc)) + + ;; Delete empty lines. + (setq string (replace-regexp-in-string "\n\n" "\n" string)) + + (while (string-match + (eval-when-compile + (concat "^[^:]+:" + "[[:space:]]\\([^:]+\\):" + "[[:space:]]" (regexp-opt tramp-gio-events t) + "\\([[:space:]]\\([^:]+\\)\\)?$")) + string) + + (let* ((file (match-string 1 string)) + (file1 (match-string 4 string)) + (object + (list + proc + (list + (intern-soft (match-string 2 string))) + ;; File names are returned as absolute paths. We must + ;; add the remote prefix. + (concat remote-prefix file) + (when file1 (concat remote-prefix file1))))) + (setq string (replace-match "" nil nil string)) + ;; Usually, we would add an Emacs event now. Unfortunately, + ;; `unread-command-events' does not accept several events at + ;; once. Therefore, we apply the handler directly. + (when (member (cl-caadr object) events) + (tramp-compat-funcall + (lookup-key special-event-map [file-notify]) + `(file-notify ,object file-notify-callback))))) + + ;; Save rest of the string. + (when (zerop (length string)) (setq string nil)) + (when string (tramp-message proc 10 "Rest string:\n%s" string)) + (process-put proc 'rest-string string))) + (defun tramp-sh-gvfs-monitor-dir-process-filter (proc string) "Read output from \"gvfs-monitor-dir\" and add corresponding \ file-notify events." @@ -3652,15 +3727,14 @@ file-notify events." ;; Attribute change is returned in unused wording. string (replace-regexp-in-string "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string)) - (when (string-match "Monitoring not supported" string) - (delete-process proc)) (while (string-match - (concat "^[\n\r]*" - "Directory Monitor Event:[\n\r]+" - "Child = \\([^\n\r]+\\)[\n\r]+" - "\\(Other = \\([^\n\r]+\\)[\n\r]+\\)?" - "Event = \\([^[:blank:]]+\\)[\n\r]+") + (eval-when-compile + (concat "^[\n\r]*" + "Directory Monitor Event:[\n\r]+" + "Child = \\([^\n\r]+\\)[\n\r]+" + "\\(Other = \\([^\n\r]+\\)[\n\r]+\\)?" + "Event = \\([^[:blank:]]+\\)[\n\r]+")) string) (let* ((file (match-string 1 string)) (file1 (match-string 3 string)) @@ -3676,16 +3750,12 @@ file-notify events." (concat remote-prefix file) (when file1 (concat remote-prefix file1))))) (setq string (replace-match "" nil nil string)) - ;; Remove watch when file or directory to be watched is deleted. - (when (and (member (cl-caadr object) '(moved deleted)) - (string-equal file (process-get proc 'watch-name))) - (delete-process proc)) ;; Usually, we would add an Emacs event now. Unfortunately, ;; `unread-command-events' does not accept several events at ;; once. Therefore, we apply the handler directly. (when (member (cl-caadr object) events) (tramp-compat-funcall - 'file-notify-handle-event + (lookup-key special-event-map [file-notify]) `(file-notify ,object file-notify-callback))))) ;; Save rest of the string. @@ -3699,12 +3769,12 @@ file-notify events." (tramp-message proc 6 "%S\n%s" proc string) (dolist (line (split-string string "[\n\r]+" 'omit)) ;; Check, whether there is a problem. - (unless - (string-match - (concat "^[^[:blank:]]+" - "[[:blank:]]+\\([^[:blank:]]+\\)+" - "\\([[:blank:]]+\\([^\n\r]+\\)\\)?") - line) + (unless (string-match + (eval-when-compile + (concat "^[^[:blank:]]+" + "[[:blank:]]+\\([^[:blank:]]+\\)+" + "\\([[:blank:]]+\\([^\n\r]+\\)\\)?")) + line) (tramp-error proc 'file-notify-error "%s" line)) (let ((object @@ -3716,15 +3786,12 @@ file-notify events." (replace-regexp-in-string "_" "-" (downcase x)))) (split-string (match-string 1 line) "," 'omit)) (match-string 3 line)))) - ;; Remove watch when file or directory to be watched is deleted. - (when (member (cl-caadr object) '(move-self delete-self ignored)) - (delete-process proc)) ;; Usually, we would add an Emacs event now. Unfortunately, ;; `unread-command-events' does not accept several events at ;; once. Therefore, we apply the handler directly. (when (member (cl-caadr object) events) (tramp-compat-funcall - 'file-notify-handle-event + (lookup-key special-event-map [file-notify]) `(file-notify ,object file-notify-callback))))))) (defun tramp-sh-handle-file-system-info (filename) @@ -3735,21 +3802,26 @@ file-notify events." (tramp-message v 5 "file system info: %s" localname) (tramp-send-command v (format - "%s --block-size=1 --output=size,used,avail %s" + "%s %s" (tramp-get-remote-df v) (tramp-shell-quote-argument localname))) (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) (forward-line) (when (looking-at - (concat "[[:space:]]*\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)")) - (list (string-to-number (concat (match-string 1) "e0")) - ;; The second value is the used size. We need the - ;; free size. - (- (string-to-number (concat (match-string 1) "e0")) - (string-to-number (concat (match-string 2) "e0"))) - (string-to-number (concat (match-string 3) "e0"))))))))) + (eval-when-compile + (concat "\\(?:^/[^[:space:]]*[[:space:]]\\)?" + "[[:space:]]*\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)"))) + (mapcar + (lambda (d) + (* d (tramp-get-connection-property v "df-blocksize" 0))) + (list (string-to-number (match-string 1)) + ;; The second value is the used size. We need the + ;; free size. + (- (string-to-number (match-string 1)) + (string-to-number (match-string 2))) + (string-to-number (match-string 3)))))))))) ;;; Internal Functions: @@ -3768,7 +3840,7 @@ Only send the definition if it has not already been done." (setq script (replace-regexp-in-string (make-string 1 ?\t) (make-string 8 ? ) script)) ;; The script could contain a call of Perl. This is masked with `%s'. - (when (and (string-match "%s" script) + (when (and (string-match-p "%s" script) (not (tramp-get-remote-perl vec))) (tramp-error vec 'file-error "No Perl available on remote host")) (tramp-barf-unless-okay @@ -3829,12 +3901,12 @@ This function expects to be in the right *tramp* buffer." ;; 5.11") have problems with this command, we disable the call ;; therefore. (unless (or ignore-path - (string-match - (regexp-opt '("SunOS 5.10" "SunOS 5.11")) + (string-match-p + (eval-when-compile (regexp-opt '("SunOS 5.10" "SunOS 5.11"))) (tramp-get-connection-property vec "uname" ""))) (tramp-send-command vec (format "which \\%s | wc -w" progname)) (goto-char (point-min)) - (if (looking-at "^\\s-*1$") + (if (looking-at-p "^\\s-*1$") (setq result (concat "\\" progname)))) (unless result (when ignore-tilde @@ -3848,14 +3920,15 @@ This function expects to be in the right *tramp* buffer." (setq dirlist (nreverse newdl)))) (tramp-send-command vec - (format (concat "while read d; " - "do if test -x $d/%s && test -f $d/%s; " - "then echo tramp_executable $d/%s; " - "break; fi; done <<'%s'\n" - "%s\n%s") + (format (eval-when-compile + (concat "while read d; " + "do if test -x $d/%s && test -f $d/%s; " + "then echo tramp_executable $d/%s; " + "break; fi; done <<'%s'\n" + "%s\n%s")) progname progname progname tramp-end-of-heredoc - (mapconcat 'identity dirlist "\n") + (string-join dirlist "\n") tramp-end-of-heredoc)) (goto-char (point-max)) (when (search-backward "tramp_executable " nil t) @@ -3864,15 +3937,33 @@ This function expects to be in the right *tramp* buffer." (setq result (buffer-substring (point) (point-at-eol))))) result))) +;; On hydra.nixos.org, the $PATH environment variable is too long to +;; send it. This is likely not due to PATH_MAX, but PIPE_BUF. We +;; check it, and use a temporary file in case of. See Bug#33781. (defun tramp-set-remote-path (vec) "Sets the remote environment PATH to existing directories. I.e., for each directory in `tramp-remote-path', it is tested whether it exists and if so, it is added to the environment variable PATH." - (tramp-message vec 5 "Setting $PATH environment variable") - (tramp-send-command - vec (format "PATH=%s; export PATH" - (mapconcat 'identity (tramp-get-remote-path vec) ":")))) + (let ((command + (format + "PATH=%s; export PATH" (string-join (tramp-get-remote-path vec) ":"))) + (pipe-buf + (or (with-tramp-connection-property vec "pipe-buf" + (tramp-send-command-and-read + vec "getconf PIPE_BUF / 2>/dev/null || echo nil" 'noerror)) + 4096)) + tmpfile) + (tramp-message vec 5 "Setting $PATH environment variable") + (if (< (length command) pipe-buf) + (tramp-send-command vec command) + ;; Use a temporary file. + (setq tmpfile + (tramp-make-tramp-file-name vec (tramp-make-tramp-temp-file vec))) + (write-region command nil tmpfile) + (tramp-send-command + vec (format ". %s" (tramp-compat-file-local-name tmpfile))) + (delete-file tmpfile)))) ;; ------------------------------------------------------------ ;; -- Communication with external shell -- @@ -3941,7 +4032,7 @@ file exists and nonzero exit status otherwise." item extra-args) (while (and alist (null extra-args)) (setq item (pop alist)) - (when (string-match (car item) shell) + (when (string-match-p (car item) shell) (setq extra-args (cdr item)))) ;; It is useful to set the prompt in the following command ;; because some people have a setting for $PS1 which /bin/sh @@ -3962,9 +4053,10 @@ file exists and nonzero exit status otherwise." ;; initial probes to ensure the remote shell is usable.) (tramp-send-command vec (format - (concat - "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " - "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s") + (eval-when-compile + (concat + "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " + "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s")) tramp-terminal-type emacs-version tramp-version ; INSIDE_EMACS (or (getenv-internal "ENV" tramp-remote-process-environment) "") @@ -4002,13 +4094,14 @@ file exists and nonzero exit status otherwise." ;; CCC: "root" does not exist always, see my QNAP TS-459. ;; Which check could we apply instead? (tramp-send-command vec "echo ~root" t) - (if (or (string-match "^~root$" (buffer-string)) + (if (or (string-match-p "^~root$" (buffer-string)) ;; The default shell (ksh93) of OpenSolaris and ;; Solaris is buggy. We've got reports for ;; "SunOS 5.10" and "SunOS 5.11" so far. - (string-match (regexp-opt '("SunOS 5.10" "SunOS 5.11")) - (tramp-get-connection-property - vec "uname" ""))) + (string-match-p + (eval-when-compile + (regexp-opt '("SunOS 5.10" "SunOS 5.11"))) + (tramp-get-connection-property vec "uname" ""))) (or (tramp-find-executable vec "bash" (tramp-get-remote-path vec) t t) @@ -4019,9 +4112,10 @@ file exists and nonzero exit status otherwise." default-shell (tramp-message vec 2 - (concat - "Couldn't find a remote shell which groks tilde " - "expansion, using `%s'") + (eval-when-compile + (concat + "Couldn't find a remote shell which groks tilde " + "expansion, using `%s'")) default-shell))) default-shell))) @@ -4038,7 +4132,7 @@ file exists and nonzero exit status otherwise." "Wait for shell prompt and barf if none appears. Looks at process PROC to see if a shell prompt appears in TIMEOUT seconds. If not, it produces an error message with the given ERROR-ARGS." - (let ((vec (tramp-get-connection-property proc "vector" nil))) + (let ((vec (process-get proc 'vector))) (condition-case nil (tramp-wait-for-regexp proc timeout @@ -4046,7 +4140,7 @@ seconds. If not, it produces an error message with the given ERROR-ARGS." "\\(%s\\|%s\\)\\'" shell-prompt-pattern tramp-shell-prompt-pattern)) (error (delete-process proc) - (apply 'tramp-error-with-buffer + (apply #'tramp-error-with-buffer (tramp-get-connection-buffer vec) vec 'file-error error-args))))) (defun tramp-open-connection-setup-interactive-shell (proc vec) @@ -4067,7 +4161,7 @@ process to set up. VEC specifies the connection." (tramp-send-command vec "echo foo" t) (with-current-buffer (process-buffer proc) (goto-char (point-min)) - (when (looking-at "echo foo") + (when (looking-at-p "echo foo") (tramp-set-connection-property proc "remote-echo" t) (tramp-message vec 5 "Remote echo still on. Ok.") ;; Make sure backspaces and their echo are enabled and no line @@ -4106,10 +4200,10 @@ process to set up. VEC specifies the connection." ;; Use MULE to select the right EOL convention for communicating ;; with the process. (let ((cs (or (and (memq 'utf-8-hfs (coding-system-list)) - (string-match "^Darwin" uname) + (string-match-p "^Darwin" uname) (cons 'utf-8-hfs 'utf-8-hfs)) (and (memq 'utf-8 (coding-system-list)) - (string-match "utf-?8" (tramp-get-remote-locale vec)) + (string-match-p "utf-?8" (tramp-get-remote-locale vec)) (cons 'utf-8 'utf-8)) (process-coding-system proc) (cons 'undecided 'undecided))) @@ -4119,7 +4213,7 @@ process to set up. VEC specifies the connection." cs-encode (or (cdr cs) 'undecided) cs-encode (coding-system-change-eol-conversion - cs-encode (if (string-match "^Darwin" uname) 'mac 'unix))) + cs-encode (if (string-match-p "^Darwin" uname) 'mac 'unix))) (tramp-send-command vec "(echo foo ; echo bar)" t) (goto-char (point-min)) (when (search-forward "\r" nil t) @@ -4143,7 +4237,7 @@ process to set up. VEC specifies the connection." (t (tramp-message vec 5 "Checking remote host type for `send-process-string' bug") - (if (string-match "^FreeBSD" uname) 500 0)))) + (if (string-match-p "^FreeBSD" uname) 500 0)))) ;; Set remote PATH variable. (tramp-set-remote-path vec) @@ -4166,11 +4260,11 @@ process to set up. VEC specifies the connection." ;; IRIX64 bash expands "!" even when in single quotes. This ;; destroys our shell functions, we must disable it. See ;; <http://stackoverflow.com/questions/3291692/irix-bash-shell-expands-expression-in-single-quotes-yet-shouldnt>. - (when (string-match "^IRIX64" uname) + (when (string-match-p "^IRIX64" uname) (tramp-send-command vec "set +H" t)) ;; Disable tab expansion. - (if (string-match "BSD\\|Darwin" uname) + (if (string-match-p "BSD\\|Darwin" uname) (tramp-send-command vec "stty tabs" t) (tramp-send-command vec "stty tab0" t)) @@ -4196,7 +4290,7 @@ process to set up. VEC specifies the connection." (append `(,(tramp-get-remote-locale vec)) (copy-sequence tramp-remote-process-environment)))) (setq item (split-string item "=" 'omit)) - (setcdr item (mapconcat 'identity (cdr item) "=")) + (setcdr item (string-join (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))) @@ -4206,12 +4300,12 @@ process to set up. VEC specifies the connection." (format "while read var val; do export $var=\"$val\"; done <<'%s'\n%s\n%s" tramp-end-of-heredoc - (mapconcat 'identity vars "\n") + (string-join vars "\n") tramp-end-of-heredoc) t)) (when unset (tramp-send-command - vec (format "unset %s" (mapconcat 'identity unset " ")) t))))) + vec (format "unset %s" (string-join unset " ")) t))))) ;; Old text from documentation of tramp-methods: ;; Using a uuencode/uudecode inline method is discouraged, please use one @@ -4237,7 +4331,7 @@ Each item is a list that looks like this: \(FORMAT ENCODING DECODING) -FORMAT is symbol describing the encoding/decoding format. It can be +FORMAT is a symbol describing the encoding/decoding format. It can be `b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing. ENCODING and DECODING can be strings, giving commands, or symbols, @@ -4317,16 +4411,14 @@ Goes through the list `tramp-local-coding-commands' and vec 5 "Checking local encoding function `%s'" loc-enc) (tramp-message vec 5 "Checking local encoding command `%s' for sanity" loc-enc) - (unless (zerop (tramp-call-local-coding-command - loc-enc nil nil)) + (unless (zerop (tramp-call-local-coding-command loc-enc nil nil)) (throw 'wont-work-local nil))) (if (not (stringp loc-dec)) (tramp-message vec 5 "Checking local decoding function `%s'" loc-dec) (tramp-message vec 5 "Checking local decoding command `%s' for sanity" loc-dec) - (unless (zerop (tramp-call-local-coding-command - loc-dec nil nil)) + (unless (zerop (tramp-call-local-coding-command loc-dec nil nil)) (throw 'wont-work-local nil))) ;; Search for remote coding commands with the same format (while (and remote-commands (not found)) @@ -4344,7 +4436,7 @@ Goes through the list `tramp-local-coding-commands' and (throw 'wont-work-remote nil))) ;; Check if remote perl exists when necessary. (when (and (symbolp rem-enc) - (string-match "perl" (symbol-name rem-enc)) + (string-match-p "perl" (symbol-name rem-enc)) (not (tramp-get-remote-perl vec))) (throw 'wont-work-remote nil)) ;; Check if remote encoding and decoding commands can be @@ -4355,9 +4447,9 @@ Goes through the list `tramp-local-coding-commands' and ;; actually check the output it gives. And also, when ;; redirecting "mimencode" output to /dev/null, then as root ;; it might change the permissions of /dev/null! - (when (not (stringp rem-enc)) + (unless (stringp rem-enc) (let ((name (symbol-name rem-enc))) - (while (string-match (regexp-quote "-") name) + (while (string-match "-" name) (setq name (replace-match "_" nil t name))) (tramp-maybe-send-script vec (symbol-value rem-enc) name) (setq rem-enc name))) @@ -4368,13 +4460,13 @@ Goes through the list `tramp-local-coding-commands' and vec (format "%s </dev/null" rem-enc) t) (throw 'wont-work-remote nil)) - (when (not (stringp rem-dec)) + (unless (stringp rem-dec) (let ((name (symbol-name rem-dec)) (value (symbol-value rem-dec)) tmpfile) - (while (string-match (regexp-quote "-") name) + (while (string-match "-" name) (setq name (replace-match "_" nil t name))) - (when (string-match "\\(^\\|[^%]\\)%t" value) + (when (string-match-p "\\(^\\|[^%]\\)%t" value) (setq tmpfile (make-temp-name (expand-file-name @@ -4384,8 +4476,7 @@ Goes through the list `tramp-local-coding-commands' and (format-spec value (format-spec-make - ?t - (file-remote-p tmpfile 'localname))))) + ?t (tramp-compat-file-local-name tmpfile))))) (tramp-maybe-send-script vec value name) (setq rem-dec name))) (tramp-message @@ -4397,9 +4488,9 @@ Goes through the list `tramp-local-coding-commands' and t) (throw 'wont-work-remote nil)) - (with-current-buffer (tramp-get-buffer vec) + (with-current-buffer (tramp-get-connection-buffer vec) (goto-char (point-min)) - (unless (looking-at (regexp-quote magic)) + (unless (looking-at-p (regexp-quote magic)) (throw 'wont-work-remote nil))) ;; `rem-enc' and `rem-dec' could be a string meanwhile. @@ -4429,12 +4520,12 @@ means standard output and thus the current buffer), or nil (which means discard it)." (tramp-call-process nil tramp-encoding-shell - (when (and input (not (string-match "%s" cmd))) input) + (when (and input (not (string-match-p "%s" cmd))) input) (if (eq output t) t nil) nil tramp-encoding-command-switch (concat - (if (string-match "%s" cmd) (format cmd input) cmd) + (if (string-match-p "%s" cmd) (format cmd input) cmd) (if (stringp output) (concat " >" output) "")))) (defconst tramp-inline-compress-commands @@ -4442,6 +4533,7 @@ means discard it)." ("env GZIP= gzip" "env GZIP= gzip -d") ("bzip2" "bzip2 -d") ("xz" "xz -d") + ("zstd --rm" "zstd -d --rm") ("compress" "compress -d")) "List of compress and decompress commands for inline transfer. Each item is a list that looks like this: @@ -4467,27 +4559,36 @@ Goes through the list `tramp-inline-compress-commands'." vec 5 "Checking local compress commands `%s', `%s' for sanity" compress decompress) - (unless - (zerop - (tramp-call-local-coding-command - (format - "echo %s | %s | %s" magic - ;; Windows shells need the program file name after - ;; the pipe symbol be quoted if they use forward - ;; slashes as directory separators. - (mapconcat - 'shell-quote-argument (split-string compress) " ") - (mapconcat - 'shell-quote-argument (split-string decompress) " ")) - nil nil)) - (throw 'next nil)) - (tramp-message + (with-temp-buffer + (unless (zerop + (tramp-call-local-coding-command + (format + "echo %s | %s | %s" magic + ;; Windows shells need the program file name + ;; after the pipe symbol be quoted if they use + ;; forward slashes as directory separators. + (mapconcat + #'tramp-unquote-shell-quote-argument + (split-string compress) " ") + (mapconcat + #'tramp-unquote-shell-quote-argument + (split-string decompress) " ")) + nil t)) + (throw 'next nil)) + (goto-char (point-min)) + (unless (looking-at-p (regexp-quote magic)) + (throw 'next nil))) + (tramp-message vec 5 "Checking remote compress commands `%s', `%s' for sanity" compress decompress) (unless (tramp-send-command-and-check vec (format "echo %s | %s | %s" magic compress decompress) t) (throw 'next nil)) + (with-current-buffer (tramp-get-buffer vec) + (goto-char (point-min)) + (unless (looking-at-p (regexp-quote magic)) + (throw 'next nil))) (setq found t))) ;; Did we find something? @@ -4510,28 +4611,27 @@ Goes through the list `tramp-inline-compress-commands'." (defun tramp-compute-multi-hops (vec) "Expands VEC according to `tramp-default-proxies-alist'." - (let ((target-alist `(,vec)) + (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. (dolist (proxy (reverse (split-string hops tramp-postfix-hop-regexp 'omit))) - (let ((user (tramp-file-name-user item)) - (host (tramp-file-name-host item)) - (proxy (concat - tramp-prefix-format proxy tramp-postfix-host-format))) - (tramp-message - vec 5 "Add proxy (\"%s\" \"%s\" \"%s\")" - (and (stringp host) (regexp-quote host)) - (and (stringp user) (regexp-quote user)) - proxy) + (let* ((host-port (tramp-file-name-host-port item)) + (user-domain (tramp-file-name-user-domain item)) + (proxy (concat + tramp-prefix-format proxy tramp-postfix-host-format)) + (entry + (list (and (stringp host-port) + (concat "^" (regexp-quote host-port) "$")) + (and (stringp user-domain) + (concat "^" (regexp-quote user-domain) "$")) + (propertize proxy 'tramp-ad-hoc t)))) + (tramp-message vec 5 "Add %S to `tramp-default-proxies-alist'" entry) ;; Add the hop. - (add-to-list - 'tramp-default-proxies-alist - (list (and (stringp host) (regexp-quote host)) - (and (stringp user) (regexp-quote user)) - proxy)) + (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) @@ -4545,11 +4645,15 @@ Goes through the list `tramp-inline-compress-commands'." proxy (eval (nth 2 item))) (when (and ;; Host. - (string-match (or (eval (nth 0 item)) "") - (or (tramp-file-name-host (car target-alist)) "")) + (string-match-p + (or (eval (nth 0 item)) "") + (or (tramp-file-name-host-port (car target-alist)) + "")) ;; User. - (string-match (or (eval (nth 1 item)) "") - (or (tramp-file-name-user (car target-alist)) ""))) + (string-match-p + (or (eval (nth 1 item)) "") + (or (tramp-file-name-user-domain (car target-alist)) + ""))) (if (null proxy) ;; No more hops needed. (setq choices nil) @@ -4572,30 +4676,30 @@ Goes through the list `tramp-inline-compress-commands'." (while (setq item (pop choices)) (when (or (not (tramp-get-method-parameter item 'tramp-login-program)) (tramp-get-method-parameter item 'tramp-copy-program)) - (tramp-error - vec 'file-error - "Method `%s' is not supported for multi-hops." + (setq tramp-default-proxies-alist saved-tdpa) + (tramp-user-error + vec "Method `%s' is not supported for multi-hops." (tramp-file-name-method item))))) - ;; In case the host name is not used for the remote shell - ;; command, the user could be misguided by applying a random - ;; host name. - (let* ((v (car target-alist)) - (method (tramp-file-name-method v)) - (host (tramp-file-name-host v))) - (unless - (or - ;; There are multi-hops. - (cdr target-alist) - ;; The host name is used for the remote shell command. - (member '("%h") (tramp-get-method-parameter v 'tramp-login-args)) - ;; The host is local. We cannot use `tramp-local-host-p' - ;; here, because it opens a connection as well. - (string-match tramp-local-host-regexp host)) - (tramp-error - v 'file-error - "Host `%s' looks like a remote host, `%s' can only use the local host" - host method))) + ;; Some methods ("su", "sg", "sudo", "doas", "ksu") do not use the + ;; host name in their command template. In this case, the remote + ;; file name must use either a local host name (first hop), or a + ;; host name matching the previous hop. + (let ((previous-host (or tramp-local-host-regexp ""))) + (setq choices target-alist) + (while (setq item (pop choices)) + (let ((host (tramp-file-name-host item))) + (unless + (or + ;; The host name is used for the remote shell command. + (member + '("%h") (tramp-get-method-parameter item 'tramp-login-args)) + ;; The host name must match previous hop. + (string-match-p previous-host host)) + (setq tramp-default-proxies-alist saved-tdpa) + (tramp-user-error + vec "Host name `%s' does not match `%s'" host previous-host)) + (setq previous-host (concat "^" (regexp-quote host) "$"))))) ;; Result. target-alist)) @@ -4617,7 +4721,7 @@ Goes through the list `tramp-inline-compress-commands'." (ignore-errors (when (executable-find "ssh") (with-tramp-progress-reporter - vec 4 "Computing ControlMaster options" + vec 4 "Computing ControlMaster options" (with-temp-buffer (tramp-call-process vec "ssh" nil t nil "-o" "ControlMaster") (goto-char (point-min)) @@ -4647,6 +4751,19 @@ Goes through the list `tramp-inline-compress-commands'." " -o ControlPersist=no"))))))))) tramp-ssh-controlmaster-options))) +(defun tramp-timeout-session (vec) + "Close the connection VEC after a session timeout. +If there is just some editing, retry it after 5 seconds." + (if (and tramp-locked tramp-locker + (tramp-file-name-equal-p vec (car tramp-current-connection))) + (progn + (tramp-message + vec 5 "Cannot timeout session, trying it again in %s seconds." 5) + (run-at-time 5 nil 'tramp-timeout-session vec)) + (tramp-message + vec 3 "Timeout session %s" (tramp-make-tramp-file-name vec 'localname)) + (tramp-cleanup-connection vec 'keep-debug))) + (defun tramp-maybe-open-connection (vec) "Maybe open a connection VEC. Does not do anything if a connection is already open, but re-opens the @@ -4661,9 +4778,12 @@ connection if a previous connection has died for some reason." (unless (or (process-live-p p) (not (tramp-file-name-equal-p vec (car tramp-current-connection))) - (> (tramp-time-diff - (current-time) (cdr tramp-current-connection)) - (or tramp-connection-min-time-diff 0))) + (time-less-p + ;; `current-time' can be removed once we get rid of Emacs 24. + (time-since (or (cdr tramp-current-connection) (current-time))) + ;; `seconds-to-time' can be removed once we get rid + ;; of Emacs 24. + (seconds-to-time (or tramp-connection-min-time-diff 0)))) (throw 'suppress 'suppress)) ;; If too much time has passed since last command was sent, look @@ -4674,11 +4794,11 @@ connection if a previous connection has died for some reason." ;; try to send a command from time to time, then look again ;; whether the process is really alive. (condition-case nil - (when (and (> (tramp-time-diff - (current-time) - (tramp-get-connection-property - p "last-cmd-time" '(0 0 0))) - 60) + ;; `seconds-to-time' can be removed once we get rid of Emacs 24. + (when (and (time-less-p (seconds-to-time 60) + (time-since + (tramp-get-connection-property + p "last-cmd-time" (seconds-to-time 0)))) (process-live-p p)) (tramp-send-command vec "echo are you awake" t t) (unless (and (process-live-p p) @@ -4729,7 +4849,8 @@ connection if a previous connection has died for some reason." (setenv "PS1" tramp-initial-end-of-output) (unless (stringp tramp-encoding-shell) (tramp-error vec 'file-error "`tramp-encoding-shell' not set")) - (let* ((target-alist (tramp-compute-multi-hops vec)) + (let* ((current-host (system-name)) + (target-alist (tramp-compute-multi-hops vec)) ;; We will apply `tramp-ssh-controlmaster-options' ;; only for the first hop. (options (tramp-ssh-controlmaster-options vec)) @@ -4744,7 +4865,7 @@ connection if a previous connection has died for some reason." (p (let ((default-directory (tramp-compat-temporary-file-directory))) (apply - 'start-process + #'start-process (tramp-get-connection-name vec) (tramp-get-connection-buffer vec) (if tramp-encoding-command-interactive @@ -4752,16 +4873,14 @@ connection if a previous connection has died for some reason." tramp-encoding-command-interactive) (list tramp-encoding-shell)))))) - ;; Set sentinel and query flag. - (tramp-set-connection-property p "vector" vec) - (set-process-sentinel p 'tramp-process-sentinel) - (process-put p 'adjust-window-size-function 'ignore) + ;; Set sentinel and query flag. Initialize variables. + (set-process-sentinel p #'tramp-process-sentinel) + (process-put p 'vector vec) + (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) - (setq tramp-current-connection (cons vec (current-time)) - tramp-current-host (system-name)) + (setq tramp-current-connection (cons vec (current-time))) - (tramp-message - vec 6 "%s" (mapconcat 'identity (process-command p) " ")) + (tramp-message vec 6 "%s" (string-join (process-command p) " ")) ;; Check whether process is alive. (tramp-barf-if-no-shell-prompt @@ -4812,16 +4931,24 @@ connection if a previous connection has died for some reason." ;; Check, whether there is a restricted shell. (dolist (elt tramp-restricted-shell-hosts-alist) - (when (string-match elt tramp-current-host) + (when (string-match-p elt current-host) (setq r-shell t))) - - ;; Set variables for computing the prompt for - ;; reading password. - (setq tramp-current-method l-method - tramp-current-user l-user - tramp-current-domain l-domain - tramp-current-host l-host - tramp-current-port l-port) + (setq current-host l-host) + + ;; 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)) + + ;; Set session timeout. + (when (tramp-get-method-parameter + hop 'tramp-session-timeout) + (tramp-set-connection-property + p "session-timeout" + (tramp-get-method-parameter + hop 'tramp-session-timeout))) ;; Add login environment. (when login-env @@ -4830,7 +4957,7 @@ connection if a previous connection has died for some reason." (mapcar (lambda (x) (setq x (mapcar (lambda (y) (format-spec y spec)) x)) - (unless (member "" x) (mapconcat 'identity x " "))) + (unless (member "" x) (string-join x " "))) login-env)) (while login-env (setq command @@ -4859,7 +4986,7 @@ connection if a previous connection has died for some reason." (mapconcat (lambda (x) (setq x (mapcar (lambda (y) (format-spec y spec)) x)) - (unless (member "" x) (mapconcat 'identity x " "))) + (unless (member "" x) (string-join x " "))) login-args " ") ;; Local shell could be a Windows COMSPEC. It ;; doesn't know the ";" syntax, but we must exit @@ -4886,6 +5013,12 @@ connection if a previous connection has died for some reason." ;; Set connection-local variables. (tramp-set-connection-local-variables vec) + ;; Activate session timeout. + (when (tramp-get-connection-property p "session-timeout" nil) + (run-at-time + (tramp-get-connection-property p "session-timeout" nil) nil + 'tramp-timeout-session vec)) + ;; Make initial shell settings. (tramp-open-connection-setup-interactive-shell p vec) @@ -4914,7 +5047,7 @@ function waits for output unless NOOUTPUT is set." ;; `tramp-echo-mark', so the remote shell sees two consecutive ;; trailing line endings and sends two prompts after executing ;; the command, which confuses `tramp-wait-for-output'. - (when (and (not (string= command "")) + (when (and (not (string-empty-p command)) (string-equal (substring command -1) "\n")) (setq command (substring command 0 -1))) ;; No need to restore a trailing newline here since `tramp-send-string' @@ -4945,7 +5078,7 @@ function waits for output unless NOOUTPUT is set." (regexp1 (format "\\(^\\|\000\\)%s" regexp)) (found (tramp-wait-for-regexp proc timeout regexp1))) (if found - (let (buffer-read-only) + (let ((inhibit-read-only t)) ;; A simple-minded busybox has sent " ^H" sequences. ;; Delete them. (goto-char (point-min)) @@ -4992,7 +5125,7 @@ DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null." (skip-chars-forward "^ ") (prog1 (zerop (read (current-buffer))) - (let (buffer-read-only) + (let ((inhibit-read-only t)) (delete-region (match-beginning 0) (point-max)))))) (defun tramp-barf-unless-okay (vec command fmt &rest args) @@ -5000,7 +5133,7 @@ DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null." Similar to `tramp-send-command-and-check' but accepts two more arguments FMT and ARGS which are passed to `error'." (or (tramp-send-command-and-check vec command) - (apply 'tramp-error vec 'file-error fmt args))) + (apply #'tramp-error vec 'file-error fmt args))) (defun tramp-send-command-and-read (vec command &optional noerror marker) "Run COMMAND and return the output, which must be a Lisp expression. @@ -5008,7 +5141,7 @@ If MARKER is a regexp, read the output after that string. In case there is no valid Lisp expression and NOERROR is nil, it raises an error." (when (if noerror - (tramp-send-command-and-check vec command) + (ignore-errors (tramp-send-command-and-check vec command)) (tramp-barf-unless-okay vec command "`%s' returns with error" command)) (with-current-buffer (tramp-get-connection-buffer vec) @@ -5034,92 +5167,92 @@ raises an error." "`%s' does not return a valid Lisp expression: `%s'" command (buffer-string)))))))) +;; FIXME: Move to tramp.el? +;;;###tramp-autoload (defun tramp-convert-file-attributes (vec attr) "Convert `file-attributes' ATTR generated by perl script, stat or ls. Convert file mode bits to string and set virtual device number. Return ATTR." (when attr - ;; Remove color escape sequences from symlink. - (when (stringp (car attr)) - (while (string-match tramp-display-escape-sequence-regexp (car attr)) - (setcar attr (replace-match "" nil nil (car attr))))) - ;; Convert uid and gid. Use `tramp-unknown-id-integer' as - ;; indication of unusable value. - (when (and (numberp (nth 2 attr)) (< (nth 2 attr) 0)) - (setcar (nthcdr 2 attr) tramp-unknown-id-integer)) - (when (and (floatp (nth 2 attr)) - (<= (nth 2 attr) most-positive-fixnum)) - (setcar (nthcdr 2 attr) (round (nth 2 attr)))) - (when (and (numberp (nth 3 attr)) (< (nth 3 attr) 0)) - (setcar (nthcdr 3 attr) tramp-unknown-id-integer)) - (when (and (floatp (nth 3 attr)) - (<= (nth 3 attr) most-positive-fixnum)) - (setcar (nthcdr 3 attr) (round (nth 3 attr)))) - ;; Convert last access time. - (unless (listp (nth 4 attr)) - (setcar (nthcdr 4 attr) - (list (floor (nth 4 attr) 65536) - (floor (mod (nth 4 attr) 65536))))) - ;; Convert last modification time. - (unless (listp (nth 5 attr)) - (setcar (nthcdr 5 attr) - (list (floor (nth 5 attr) 65536) - (floor (mod (nth 5 attr) 65536))))) - ;; Convert last status change time. - (unless (listp (nth 6 attr)) - (setcar (nthcdr 6 attr) - (list (floor (nth 6 attr) 65536) - (floor (mod (nth 6 attr) 65536))))) - ;; Convert file size. - (when (< (nth 7 attr) 0) - (setcar (nthcdr 7 attr) -1)) - (when (and (floatp (nth 7 attr)) - (<= (nth 7 attr) most-positive-fixnum)) - (setcar (nthcdr 7 attr) (round (nth 7 attr)))) - ;; Convert file mode bits to string. - (unless (stringp (nth 8 attr)) - (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr))) + (save-match-data + ;; Remove color escape sequences from symlink. (when (stringp (car attr)) - (aset (nth 8 attr) 0 ?l))) - ;; Convert directory indication bit. - (when (string-match "^d" (nth 8 attr)) - (setcar attr t)) - ;; Convert symlink from `tramp-do-file-attributes-with-stat'. - (when (consp (car attr)) - (if (and (stringp (caar attr)) - (string-match ".+ -> .\\(.+\\)." (caar attr))) - (setcar attr (match-string 1 (caar attr))) - (setcar attr nil))) - ;; Set file's gid change bit. - (setcar (nthcdr 9 attr) - (if (numberp (nth 3 attr)) - (not (= (nth 3 attr) - (tramp-get-remote-gid vec 'integer))) - (not (string-equal - (nth 3 attr) - (tramp-get-remote-gid vec 'string))))) - ;; Convert inode. - (unless (listp (nth 10 attr)) - (setcar (nthcdr 10 attr) - (condition-case nil - (let ((high (nth 10 attr)) - middle low) - (if (<= high most-positive-fixnum) - (floor high) - ;; The low 16 bits. - (setq low (mod high #x10000) - high (/ high #x10000)) + (while (string-match tramp-display-escape-sequence-regexp (car attr)) + (setcar attr (replace-match "" nil nil (car attr))))) + ;; Convert uid and gid. Use `tramp-unknown-id-integer' as + ;; indication of unusable value. + (when (and (numberp (nth 2 attr)) (< (nth 2 attr) 0)) + (setcar (nthcdr 2 attr) tramp-unknown-id-integer)) + (when (and (floatp (nth 2 attr)) + (<= (nth 2 attr) most-positive-fixnum)) + (setcar (nthcdr 2 attr) (round (nth 2 attr)))) + (when (and (numberp (nth 3 attr)) (< (nth 3 attr) 0)) + (setcar (nthcdr 3 attr) tramp-unknown-id-integer)) + (when (and (floatp (nth 3 attr)) + (<= (nth 3 attr) most-positive-fixnum)) + (setcar (nthcdr 3 attr) (round (nth 3 attr)))) + ;; Convert last access time. + (unless (listp (nth 4 attr)) + (setcar (nthcdr 4 attr) (seconds-to-time (nth 4 attr)))) + ;; Convert last modification time. + (unless (listp (nth 5 attr)) + (setcar (nthcdr 5 attr) (seconds-to-time (nth 5 attr)))) + ;; Convert last status change time. + (unless (listp (nth 6 attr)) + (setcar (nthcdr 6 attr) (seconds-to-time (nth 6 attr)))) + ;; Convert file size. + (when (< (nth 7 attr) 0) + (setcar (nthcdr 7 attr) -1)) + (when (and (floatp (nth 7 attr)) + (<= (nth 7 attr) most-positive-fixnum)) + (setcar (nthcdr 7 attr) (round (nth 7 attr)))) + ;; Convert file mode bits to string. + (unless (stringp (nth 8 attr)) + (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr))) + (when (stringp (car attr)) + (aset (nth 8 attr) 0 ?l))) + ;; Convert directory indication bit. + (when (string-match-p "^d" (nth 8 attr)) + (setcar attr t)) + ;; Convert symlink from `tramp-do-file-attributes-with-stat'. + ;; Decode also multibyte string. + (when (consp (car attr)) + (setcar attr + (and (stringp (caar attr)) + (string-match ".+ -> .\\(.+\\)." (caar attr)) + (decode-coding-string + (match-string 1 (caar attr)) 'utf-8)))) + ;; Set file's gid change bit. + (setcar (nthcdr 9 attr) + (if (numberp (nth 3 attr)) + (not (= (nth 3 attr) + (tramp-get-remote-gid vec 'integer))) + (not (string-equal + (nth 3 attr) + (tramp-get-remote-gid vec 'string))))) + ;; Convert inode. + (when (floatp (nth 10 attr)) + (setcar (nthcdr 10 attr) + (condition-case nil + (let ((high (nth 10 attr)) + middle low) (if (<= high most-positive-fixnum) - (cons (floor high) (floor low)) - ;; The middle 24 bits. - (setq middle (mod high #x1000000) - high (/ high #x1000000)) - (cons (floor high) (cons (floor middle) (floor low)))))) - ;; Inodes can be incredible huge. We must hide this. - (error (tramp-get-inode vec))))) - ;; Set virtual device number. - (setcar (nthcdr 11 attr) - (tramp-get-device vec)) + (floor high) + ;; The low 16 bits. + (setq low (mod high #x10000) + high (/ high #x10000)) + (if (<= high most-positive-fixnum) + (cons (floor high) (floor low)) + ;; The middle 24 bits. + (setq middle (mod high #x1000000) + high (/ high #x1000000)) + (cons (floor high) + (cons (floor middle) (floor low)))))) + ;; Inodes can be incredible huge. We must hide this. + (error (tramp-get-inode vec))))) + ;; Set virtual device number. + (setcar (nthcdr 11 attr) + (tramp-get-device vec))) attr)) (defun tramp-shell-case-fold (string) @@ -5139,16 +5272,17 @@ Return ATTR." (host (tramp-file-name-host vec)) (localname (directory-file-name (tramp-file-name-unquote-localname vec)))) - (when (string-match tramp-ipv6-regexp host) + (when (string-match-p tramp-ipv6-regexp host) (setq host (format "[%s]" host))) - (unless (string-match "ftp$" method) + (unless (string-match-p "ftp$" method) (setq localname (tramp-shell-quote-argument localname))) (cond ((tramp-get-method-parameter vec 'tramp-remote-copy-program) localname) ((not (zerop (length user))) - (format "%s@%s:%s" user host (shell-quote-argument localname))) - (t (format "%s:%s" host (shell-quote-argument localname)))))) + (format + "%s@%s:%s" user host (tramp-unquote-shell-quote-argument localname))) + (t (format "%s:%s" host (tramp-unquote-shell-quote-argument localname)))))) (defun tramp-method-out-of-band-p (vec size) "Return t if this is an out-of-band method, nil otherwise." @@ -5168,94 +5302,90 @@ Return ATTR." (defun tramp-get-remote-path (vec) "Compile list of remote directories for $PATH. Nonexistent directories are removed from spec." - (with-tramp-connection-property - ;; When `tramp-own-remote-path' is in `tramp-remote-path', we - ;; cache the result for the session only. Otherwise, the result - ;; is cached persistently. - (if (memq 'tramp-own-remote-path tramp-remote-path) - (tramp-get-connection-process vec) - vec) - "remote-path" - (let* ((remote-path (copy-tree tramp-remote-path)) - (elt1 (memq 'tramp-default-remote-path remote-path)) - (elt2 (memq 'tramp-own-remote-path remote-path)) - (default-remote-path - (when elt1 - (or - (tramp-send-command-and-read - vec "echo \\\"`getconf PATH 2>/dev/null`\\\"" 'noerror) - ;; Default if "getconf" is not available. - (progn - (tramp-message - vec 3 - "`getconf PATH' not successful, using default value \"%s\"." - "/bin:/usr/bin") - "/bin:/usr/bin")))) - (own-remote-path - ;; The login shell could return more than just the $PATH - ;; string. So we use `tramp-end-of-heredoc' as marker. - (when elt2 - (or - (tramp-send-command-and-read - vec - (format - "%s %s %s 'echo %s \\\"$PATH\\\"'" - (tramp-get-method-parameter vec 'tramp-remote-shell) - (mapconcat - 'identity - (tramp-get-method-parameter vec 'tramp-remote-shell-login) - " ") - (mapconcat - 'identity - (tramp-get-method-parameter vec 'tramp-remote-shell-args) - " ") - (tramp-shell-quote-argument tramp-end-of-heredoc)) - 'noerror (regexp-quote tramp-end-of-heredoc)) - (progn - (tramp-message - vec 2 "Could not retrieve `tramp-own-remote-path'") - nil))))) - - ;; Replace place holder `tramp-default-remote-path'. - (when elt1 - (setcdr elt1 - (append - (split-string (or default-remote-path "") ":" 'omit) - (cdr elt1))) - (setq remote-path (delq 'tramp-default-remote-path remote-path))) - - ;; Replace place holder `tramp-own-remote-path'. - (when elt2 - (setcdr elt2 - (append - (split-string (or own-remote-path "") ":" 'omit) - (cdr elt2))) - (setq remote-path (delq 'tramp-own-remote-path remote-path))) - - ;; Remove double entries. - (setq elt1 remote-path) - (while (consp elt1) - (while (and (car elt1) (setq elt2 (member (car elt1) (cdr elt1)))) - (setcar elt2 nil)) - (setq elt1 (cdr elt1))) - - ;; Remove non-existing directories. - (delq - nil - (mapcar - (lambda (x) - (and - (stringp x) - (file-directory-p - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) + (with-current-buffer (tramp-get-connection-buffer vec) + ;; Expand connection-local variables. + (tramp-set-connection-local-variables vec) + (with-tramp-connection-property + ;; When `tramp-own-remote-path' is in `tramp-remote-path', we + ;; cache the result for the session only. Otherwise, the + ;; result is cached persistently. + (if (memq 'tramp-own-remote-path tramp-remote-path) + (tramp-get-connection-process vec) + vec) + "remote-path" + (let* ((remote-path (copy-tree tramp-remote-path)) + (elt1 (memq 'tramp-default-remote-path remote-path)) + (elt2 (memq 'tramp-own-remote-path remote-path)) + (default-remote-path + (when elt1 + (or + (tramp-send-command-and-read + vec "echo \\\"`getconf PATH 2>/dev/null`\\\"" 'noerror) + ;; Default if "getconf" is not available. + (progn + (tramp-message + vec 3 + "`getconf PATH' not successful, using default value \"%s\"." + "/bin:/usr/bin") + "/bin:/usr/bin")))) + (own-remote-path + ;; The login shell could return more than just the $PATH + ;; string. So we use `tramp-end-of-heredoc' as marker. + (when elt2 + (or + (tramp-send-command-and-read + vec + (format + "%s %s %s 'echo %s \\\"$PATH\\\"'" + (tramp-get-method-parameter vec 'tramp-remote-shell) + (mapconcat + #'identity + (tramp-get-method-parameter vec 'tramp-remote-shell-login) + " ") + (mapconcat + #'identity + (tramp-get-method-parameter vec 'tramp-remote-shell-args) + " ") + (tramp-shell-quote-argument tramp-end-of-heredoc)) + 'noerror (regexp-quote tramp-end-of-heredoc)) + (progn + (tramp-message + vec 2 "Could not retrieve `tramp-own-remote-path'") + nil))))) + + ;; Replace place holder `tramp-default-remote-path'. + (when elt1 + (setcdr elt1 + (append + (split-string (or default-remote-path "") ":" 'omit) + (cdr elt1))) + (setq remote-path (delq 'tramp-default-remote-path remote-path))) + + ;; Replace place holder `tramp-own-remote-path'. + (when elt2 + (setcdr elt2 + (append + (split-string (or own-remote-path "") ":" 'omit) + (cdr elt2))) + (setq remote-path (delq 'tramp-own-remote-path remote-path))) + + ;; Remove double entries. + (setq elt1 remote-path) + (while (consp elt1) + (while (and (car elt1) (setq elt2 (member (car elt1) (cdr elt1)))) + (setcar elt2 nil)) + (setq elt1 (cdr elt1))) + + ;; Remove non-existing directories. + (delq + nil + (mapcar + (lambda (x) + (and + (stringp x) + (file-directory-p (tramp-make-tramp-file-name vec x 'nohop)) x)) - x)) - remote-path))))) + remote-path)))))) (defun tramp-get-remote-locale (vec) "Determine remote locale, supporting UTF8 if possible." @@ -5266,8 +5396,8 @@ Nonexistent directories are removed from spec." (with-current-buffer (tramp-get-connection-buffer vec) (while candidates (goto-char (point-min)) - (if (string-match (format "^%s\r?$" (regexp-quote (car candidates))) - (buffer-string)) + (if (string-match-p (format "^%s\r?$" (regexp-quote (car candidates))) + (buffer-string)) (setq locale (car candidates) candidates nil) (setq candidates (cdr candidates))))) @@ -5287,7 +5417,7 @@ Nonexistent directories are removed from spec." ;; Check parameters. On busybox, "ls" output coloring is ;; enabled by default sometimes. So we try to disable it ;; when possible. $LS_COLORING is not supported there. - ;; Some "ls" versions are sensible wrt the order of + ;; Some "ls" versions are sensitive to the order of ;; arguments, they fail when "-al" is after the ;; "--color=never" argument (for example on FreeBSD). (when (tramp-send-command-and-check @@ -5300,36 +5430,23 @@ Nonexistent directories are removed from spec." (setq dl (cdr dl)))))) (tramp-error vec 'file-error "Couldn't find a proper `ls' command")))) -(defun tramp-get-ls-command-with-dired (vec) - "Check, whether the remote `ls' command supports the --dired option." - (save-match-data - (with-tramp-connection-property vec "ls-dired" - (tramp-message vec 5 "Checking, whether `ls --dired' works") - ;; Some "ls" versions are sensible wrt the order of arguments, - ;; they fail when "-al" is after the "--dired" argument (for - ;; example on FreeBSD). - (tramp-send-command-and-check - vec (format "%s --dired -al /dev/null" (tramp-get-ls-command vec)))))) - -(defun tramp-get-ls-command-with-quoting-style (vec) - "Check, whether the remote `ls' command supports the --quoting-style option." - (save-match-data - (with-tramp-connection-property vec "ls-quoting-style" - (tramp-message vec 5 "Checking, whether `ls --quoting-style=shell' works") +(defun tramp-get-ls-command-with (vec option) + "Return OPTION, if the remote `ls' command supports the OPTION option." + (with-tramp-connection-property vec (concat "ls" option) + (tramp-message vec 5 "Checking, whether `ls %s' works" option) + ;; Some "ls" versions are sensitive to the order of arguments, + ;; they fail when "-al" is after the "--dired" argument (for + ;; example on FreeBSD). Busybox does not support this kind of + ;; options. + (and + (not (tramp-send-command-and-check - vec (format "%s --quoting-style=shell -al /dev/null" - (tramp-get-ls-command vec)))))) - -(defun tramp-get-ls-command-with-w-option (vec) - "Check, whether the remote `ls' command supports the -w option." - (save-match-data - (with-tramp-connection-property vec "ls-w-option" - (tramp-message vec 5 "Checking, whether `ls -w' works") - ;; Option "-w" is available on BSD systems. No argument is - ;; given, because this could return wrong results in case "ls" - ;; supports the "-w NUM" argument, as for busyboxes. - (tramp-send-command-and-check - vec (format "%s -alw" (tramp-get-ls-command vec)))))) + vec + (format + "%s --help 2>&1 | grep -iq busybox" (tramp-get-ls-command vec)))) + (tramp-send-command-and-check + vec (format "%s %s -al /dev/null" (tramp-get-ls-command vec) option)) + option))) (defun tramp-get-test-command (vec) "Determine remote `test' command." @@ -5351,7 +5468,7 @@ Nonexistent directories are removed from spec." vec (format "( %s / -nt / )" (tramp-get-test-command vec))) (with-current-buffer (tramp-get-buffer vec) (goto-char (point-min)) - (when (looking-at (regexp-quote tramp-end-of-output)) + (when (looking-at-p (regexp-quote tramp-end-of-output)) (format "%s %%s -nt %%s" (tramp-get-test-command vec))))) (progn (tramp-send-command @@ -5413,7 +5530,7 @@ Nonexistent directories are removed from spec." tmp (tramp-send-command-and-read vec (format "%s -c '(\"%%N\" %%s)' /" result) 'noerror)) (unless (and (listp tmp) (stringp (car tmp)) - (string-match "^\\(`/'\\|‘/’\\)$" (car tmp)) + (string-match-p "^\\(`/'\\|‘/’\\)$" (car tmp)) (integerp (cadr tmp))) (setq result nil))) result))) @@ -5458,7 +5575,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." "%s -t %s %s" result (format-time-string "%Y%m%d%H%M.%S") - (file-remote-p tmpfile 'localname)))) + (tramp-compat-file-local-name tmpfile)))) (delete-file tmpfile)) result))) @@ -5466,12 +5583,30 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." "Determine remote `df' command." (with-tramp-connection-property vec "df" (tramp-message vec 5 "Finding a suitable `df' command") - (let ((result (tramp-find-executable vec "df" (tramp-get-remote-path vec)))) - (and - result - (tramp-send-command-and-check - vec (format "%s --block-size=1 --output=size,used,avail /" result)) - result)))) + (let ((df (tramp-find-executable vec "df" (tramp-get-remote-path vec))) + result) + (when df + (cond + ;; coreutils. + ((tramp-send-command-and-check + vec + (format + "%s /" + (setq result + (format "%s --block-size=1 --output=size,used,avail" df)))) + (tramp-set-connection-property vec "df-blocksize" 1) + result) + ;; POSIX.1 + ((tramp-send-command-and-check + vec (format "%s /" (setq result (format "%s -k" df)))) + (tramp-set-connection-property vec "df-blocksize" 1024) + result)))))) + +(defun tramp-get-remote-gio-monitor (vec) + "Determine remote `gio-monitor' command." + (with-tramp-connection-property vec "gio-monitor" + (tramp-message vec 5 "Finding a suitable `gio-monitor' command") + (tramp-find-executable vec "gio" (tramp-get-remote-path vec) t t))) (defun tramp-get-remote-gvfs-monitor-dir (vec) "Determine remote `gvfs-monitor-dir' command." @@ -5541,7 +5676,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." (tramp-get-remote-python vec) (if (equal id-format 'integer) "import os; print (os.getuid())" - "import os, pwd; print ('\\\"' + pwd.getpwuid(os.getuid())[0] + '\\\"')")))) + "import os, pwd; print ('\\\"' + pwd.getpwuid(os.getuid())[0] + '\\\"')")))) (defun tramp-get-remote-uid (vec id-format) "The uid of the remote connection VEC, in ID-FORMAT. @@ -5592,7 +5727,7 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-get-remote-python vec) (if (equal id-format 'integer) "import os; print (os.getgid())" - "import os, grp; print ('\\\"' + grp.getgrgid(os.getgid())[0] + '\\\"')")))) + "import os, grp; print ('\\\"' + grp.getgrgid(os.getgid())[0] + '\\\"')")))) (defun tramp-get-remote-gid (vec id-format) "The gid of the remote connection VEC, in ID-FORMAT. @@ -5658,14 +5793,14 @@ function cell is returned to be applied on a buffer." (tramp-find-inline-encoding vec) (tramp-get-connection-property (tramp-get-connection-process vec) prop nil))) - (prop1 (if (string-match "encoding" prop) + (prop1 (if (string-match-p "encoding" prop) "inline-compress" "inline-decompress")) compress) ;; The connection property might have been cached. So we must ;; send the script to the remote side - maybe. - (when (and coding (symbolp coding) (string-match "remote" prop)) + (when (and coding (symbolp coding) (string-match-p "remote" prop)) (let ((name (symbol-name coding))) - (while (string-match (regexp-quote "-") name) + (while (string-match "-" name) (setq name (replace-match "_" nil t name))) (tramp-maybe-send-script vec (symbol-value coding) name) (setq coding name))) @@ -5675,35 +5810,35 @@ function cell is returned to be applied on a buffer." ;; Return the value. (cond ((and compress (symbolp coding)) - (if (string-match "decompress" prop1) + (if (string-match-p "decompress" prop1) `(lambda (beg end) (,coding beg end) (let ((coding-system-for-write 'binary) (coding-system-for-read 'binary)) (apply - 'tramp-call-process-region ',vec (point-min) (point-max) + #'tramp-call-process-region ',vec (point-min) (point-max) (car (split-string ,compress)) t t nil (cdr (split-string ,compress))))) `(lambda (beg end) (let ((coding-system-for-write 'binary) (coding-system-for-read 'binary)) (apply - 'tramp-call-process-region ',vec beg end + #'tramp-call-process-region ',vec beg end (car (split-string ,compress)) t t nil (cdr (split-string ,compress)))) (,coding (point-min) (point-max))))) ((symbolp coding) coding) - ((and compress (string-match "decoding" prop)) + ((and compress (string-match-p "decoding" prop)) (format ;; Windows shells need the program file name after ;; the pipe symbol be quoted if they use forward ;; slashes as directory separators. (cond - ((and (string-match "local" prop) + ((and (string-match-p "local" prop) (memq system-type '(windows-nt))) "(%s | \"%s\")") - ((string-match "local" prop) "(%s | %s)") + ((string-match-p "local" prop) "(%s | %s)") (t "(%s | %s >%%s)")) coding compress)) (compress @@ -5711,14 +5846,14 @@ function cell is returned to be applied on a buffer." ;; Windows shells need the program file name after ;; the pipe symbol be quoted if they use forward ;; slashes as directory separators. - (if (and (string-match "local" prop) + (if (and (string-match-p "local" prop) (memq system-type '(windows-nt))) "(%s <%%s | \"%s\")" "(%s <%%s | %s)") compress coding)) - ((string-match "decoding" prop) + ((string-match-p "decoding" prop) (cond - ((string-match "local" prop) (format "%s" coding)) + ((string-match-p "local" prop) (format "%s" coding)) (t (format "%s >%%s" coding)))) (t (format "%s <%%s" coding))))))) @@ -5742,10 +5877,6 @@ function cell is returned to be applied on a buffer." ;; gets confused about the file locking status. Try to find out why ;; the workaround doesn't work. ;; -;; * Allow out-of-band methods as _last_ multi-hop. Open a connection -;; until the last but one hop via `start-file-process'. Apply it -;; also for ftp and smb. -;; ;; * WIBNI if we had a command "trampclient"? If I was editing in ;; some shell with root privileges, it would be nice if I could ;; just call @@ -5819,5 +5950,11 @@ function cell is returned to be applied on a buffer." ;; which could immediately be passed on to the remote side, and ;; later on checks the return value of those calls as and when ;; needed. (Stefan Monnier) +;; +;; * Implement detaching/re-attaching remote sessions. By this, a +;; session could be reused after a connection loss. Use dtach, or +;; screen, or tmux, or mosh. +;; +;; * Implement `:stderr' of `make-process' as pipe process. ;;; tramp-sh.el ends here diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 894c0de4aa7..9b87ed40cb0 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -27,6 +27,7 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) (require 'tramp) ;; Define SMB method ... @@ -37,30 +38,27 @@ ;; ... and add it to the method list. ;;;###tramp-autoload (unless (memq system-type '(cygwin windows-nt)) - (add-to-list 'tramp-methods - `(,tramp-smb-method - ;; We define an empty command, because `tramp-smb-call-winexe' - ;; opens already the powershell. Used in `tramp-handle-shell-command'. - (tramp-remote-shell "") - ;; This is just a guess. We don't know whether the share "C$" - ;; is available for public use, and whether the user has write - ;; access. - (tramp-tmpdir "/C$/Temp") - ;; Another guess. We might implement a better check later on. - (tramp-case-insensitive t)))) + (tramp--with-startup + (add-to-list 'tramp-methods + `(,tramp-smb-method + ;; This is just a guess. We don't know whether the share "C$" + ;; is available for public use, and whether the user has write + ;; access. + (tramp-tmpdir "/C$/Temp") + ;; Another guess. We might implement a better check later on. + (tramp-case-insensitive t))))) ;; Add a default for `tramp-default-user-alist'. Rule: For the SMB method, ;; the anonymous user is chosen. ;;;###tramp-autoload -(add-to-list 'tramp-default-user-alist - `(,(concat "\\`" tramp-smb-method "\\'") nil nil)) +(tramp--with-startup + (add-to-list 'tramp-default-user-alist + `(,(concat "\\`" tramp-smb-method "\\'") nil nil)) -;; Add completion function for SMB method. -;;;###tramp-autoload -(eval-after-load 'tramp - '(tramp-set-completion-function - tramp-smb-method - '((tramp-parse-netrc "~/.netrc")))) + ;; Add completion function for SMB method. + (tramp-set-completion-function + tramp-smb-method + '((tramp-parse-netrc "~/.netrc")))) ;;;###tramp-autoload (defcustom tramp-smb-program "smbclient" @@ -101,7 +99,7 @@ call, letting the SMB client use the default one." (defconst tramp-smb-errors (mapconcat - 'identity + #'identity `(;; Connection error / timeout / unknown command. "Connection\\( to \\S-+\\)? failed" "Read from server failed, maybe it closed the connection" @@ -119,6 +117,7 @@ call, letting the SMB client use the default one." "ERRnoaccess" "ERRnomem" "ERRnosuchshare" + ;; See /usr/include/samba-4.0/core/ntstatus.h. ;; Windows 4.0 (Windows NT), Windows 5.0 (Windows 2000), ;; Windows 5.1 (Windows XP), Windows 5.2 (Windows Server 2003), ;; Windows 6.0 (Windows Vista), Windows 6.1 (Windows 7), @@ -129,6 +128,7 @@ call, letting the SMB client use the default one." "NT_STATUS_CANNOT_DELETE" "NT_STATUS_CONNECTION_DISCONNECTED" "NT_STATUS_CONNECTION_REFUSED" + "NT_STATUS_CONNECTION_RESET" "NT_STATUS_DIRECTORY_NOT_EMPTY" "NT_STATUS_DUPLICATE_NAME" "NT_STATUS_FILE_IS_A_DIRECTORY" @@ -143,12 +143,14 @@ call, letting the SMB client use the default one." "NT_STATUS_NO_LOGON_SERVERS" "NT_STATUS_NO_SUCH_FILE" "NT_STATUS_NO_SUCH_USER" + "NT_STATUS_NOT_A_DIRECTORY" "NT_STATUS_OBJECT_NAME_COLLISION" "NT_STATUS_OBJECT_NAME_INVALID" "NT_STATUS_OBJECT_NAME_NOT_FOUND" "NT_STATUS_OBJECT_PATH_SYNTAX_BAD" "NT_STATUS_PASSWORD_MUST_CHANGE" "NT_STATUS_RESOURCE_NAME_NOT_FOUND" + "NT_STATUS_REVISION_MISMATCH" "NT_STATUS_SHARING_VIOLATION" "NT_STATUS_TRUSTED_RELATIONSHIP_FAILURE" "NT_STATUS_UNSUCCESSFUL" @@ -211,7 +213,7 @@ 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' performed by default handler. + '((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) @@ -225,11 +227,12 @@ See `tramp-actions-before-shell' for more info.") . tramp-handle-directory-files-and-attributes) (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) + (exec-path . ignore) (expand-file-name . tramp-smb-handle-expand-file-name) - (file-accessible-directory-p . tramp-smb-handle-file-directory-p) + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . tramp-smb-handle-file-acl) (file-attributes . tramp-smb-handle-file-attributes) - (file-directory-p . tramp-smb-handle-file-directory-p) + (file-directory-p . tramp-handle-file-directory-p) (file-file-equal-p . tramp-handle-file-equal-p) (file-executable-p . tramp-handle-file-exists-p) (file-exists-p . tramp-handle-file-exists-p) @@ -257,7 +260,6 @@ See `tramp-actions-before-shell' for more info.") (file-truename . tramp-handle-file-truename) (file-writable-p . tramp-smb-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) - ;; `find-file-noselect' performed by default handler. ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-smb-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) @@ -266,6 +268,7 @@ See `tramp-actions-before-shell' for more info.") (make-directory . tramp-smb-handle-make-directory) (make-directory-internal . tramp-smb-handle-make-directory-internal) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-process . ignore) (make-symbolic-link . tramp-smb-handle-make-symbolic-link) (process-file . tramp-smb-handle-process-file) (rename-file . tramp-smb-handle-rename-file) @@ -278,6 +281,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-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) @@ -316,8 +320,9 @@ This can be used to disable echo etc." ;;;###tramp-autoload (defsubst tramp-smb-file-name-p (filename) "Check if it's a filename for SMB servers." - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-smb-method)) + (and (tramp-tramp-file-p filename) + (string= (tramp-file-name-method (tramp-dissect-file-name filename)) + tramp-smb-method))) ;;;###tramp-autoload (defun tramp-smb-file-name-handler (operation &rest args) @@ -331,8 +336,9 @@ pass to the OPERATION." ;;;###tramp-autoload (unless (memq system-type '(cygwin windows-nt)) - (tramp-register-foreign-file-name-handler - 'tramp-smb-file-name-p 'tramp-smb-file-name-handler)) + (tramp--with-startup + (tramp-register-foreign-file-name-handler + #'tramp-smb-file-name-p #'tramp-smb-file-name-handler))) ;; File name primitives. @@ -365,8 +371,8 @@ pass to the OPERATION." (delete-file newname))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v2 (file-name-directory v2-localname)) - (tramp-flush-file-property v2 v2-localname) + (tramp-flush-file-properties v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname) (unless (tramp-smb-send-command v1 @@ -401,7 +407,7 @@ pass to the OPERATION." (if copy-contents ;; We must do it file-wise. (tramp-run-real-handler - 'copy-directory (list dirname newname keep-date parents copy-contents)) + #'copy-directory (list dirname newname keep-date parents copy-contents)) (setq dirname (expand-file-name dirname) newname (expand-file-name newname)) @@ -444,13 +450,6 @@ pass to the OPERATION." (if (not (file-directory-p newname)) (make-directory newname parents)) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - (let* ((share (tramp-smb-get-share v)) (localname (file-name-as-directory (replace-regexp-in-string @@ -459,9 +458,7 @@ pass to the OPERATION." (expand-file-name tramp-temp-name-prefix (tramp-compat-temporary-file-directory)))) - (args (list (concat "//" host "/" share) "-E")) - ;; We do not want to run timers. - timer-list timer-idle-list) + (args (list (concat "//" host "/" share) "-E"))) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -477,7 +474,8 @@ pass to the OPERATION." (append args (list "-D" (tramp-unquote-shell-quote-argument localname) - "-c" (shell-quote-argument "tar qc - *") + "-c" (tramp-unquote-shell-quote-argument + "tar qc - *") "|" "tar" "xfC" "-" (tramp-unquote-shell-quote-argument tmpdir))) @@ -488,7 +486,8 @@ pass to the OPERATION." args (list "-D" (tramp-unquote-shell-quote-argument localname) - "-c" (shell-quote-argument "tar qx -"))))) + "-c" (tramp-unquote-shell-quote-argument + "tar qx -"))))) (unwind-protect (with-temp-buffer @@ -514,15 +513,15 @@ pass to the OPERATION." ;; password can be handled. (let* ((default-directory tmpdir) (p (apply - 'start-process + #'start-process (tramp-get-connection-name v) (tramp-get-connection-buffer v) tramp-smb-program args))) (tramp-message - v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" v) - (process-put p 'adjust-window-size-function 'ignore) + 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) (tramp-process-actions p v nil tramp-smb-actions-with-tar) @@ -531,8 +530,8 @@ pass to the OPERATION." (tramp-message v 6 "\n%s" (buffer-string)))) ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") (when t1 (delete-directory tmpdir 'recursive)))) ;; Handle KEEP-DATE argument. @@ -549,13 +548,13 @@ pass to the OPERATION." ;; When newname did exist, we have wrong cached values. (when t2 (with-parsed-tramp-file-name newname nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname)))) ;; We must do it file-wise. (t (tramp-run-real-handler - 'copy-directory (list dirname newname keep-date parents))))))))) + #'copy-directory (list dirname newname keep-date parents))))))))) (defun tramp-smb-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -589,14 +588,16 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (expand-file-name (file-name-nondirectory filename) newname))) (with-parsed-tramp-file-name newname nil - (when (and (not ok-if-already-exists) - (file-exists-p newname)) + (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (unless (tramp-smb-get-share v) (tramp-error v 'file-error "Target `%s' must contain a share name" newname)) @@ -630,8 +631,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (with-parsed-tramp-file-name directory nil ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (unless (tramp-smb-send-command v (format "%s \"%s\"" @@ -656,8 +657,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (with-parsed-tramp-file-name filename nil ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (unless (tramp-smb-send-command v (format "%s \"%s\"" @@ -673,13 +674,13 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (defun tramp-smb-handle-directory-files (directory &optional full match nosort) "Like `directory-files' for Tramp files." - (let ((result (mapcar 'directory-file-name + (let ((result (mapcar #'directory-file-name (file-name-all-completions "" directory)))) ;; Discriminate with regexp. (when match (setq result (delete nil - (mapcar (lambda (x) (when (string-match match x) x)) + (mapcar (lambda (x) (when (string-match-p match x) x)) result)))) ;; Append directory. (when full @@ -688,19 +689,21 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (lambda (x) (format "%s/%s" directory x)) result))) ;; Sort them if necessary. - (unless nosort (setq result (sort result 'string-lessp))) + (unless nosort (setq result (sort result #'string-lessp))) result)) (defun tramp-smb-handle-expand-file-name (name &optional dir) "Like `expand-file-name' for Tramp files." ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". (setq dir (or dir default-directory "/")) + ;; Handle empty NAME. + (when (zerop (length name)) (setq name ".")) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) (setq name (concat (file-name-as-directory dir) name))) ;; If NAME is not a Tramp file, run the real handler. (if (not (tramp-tramp-file-p name)) - (tramp-run-real-handler 'expand-file-name (list name nil)) + (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, @@ -713,92 +716,83 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (match-string 1 localname)) nil nil localname))) ;; Make the file name absolute. - (unless (tramp-run-real-handler 'file-name-absolute-p (list localname)) + (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) ;; No tilde characters in file name, do normal ;; `expand-file-name' (this does "/./" and "/../"). (tramp-make-tramp-file-name - method user domain host port - (tramp-run-real-handler 'expand-file-name (list localname)))))) + v (tramp-run-real-handler #'expand-file-name (list localname)))))) (defun tramp-smb-action-get-acl (proc vec) "Read ACL data from connection buffer." (unless (process-live-p proc) ;; Accept pending output. - (while (tramp-accept-process-output proc 0.1)) + (while (tramp-accept-process-output proc)) (with-current-buffer (tramp-get-connection-buffer vec) ;; There might be a hidden password prompt. (widen) (tramp-message vec 10 "\n%s" (buffer-string)) (goto-char (point-min)) - (while (and (not (eobp)) (not (looking-at "^REVISION:"))) + (while (and (not (eobp)) (not (looking-at-p "^REVISION:"))) (forward-line) (delete-region (point-min) (point))) - (while (and (not (eobp)) (looking-at "^.+:.+")) + (while (and (not (eobp)) (looking-at-p "^.+:.+")) (forward-line)) (delete-region (point) (point-max)) (throw 'tramp-action 'ok)))) (defun tramp-smb-handle-file-acl (filename) "Like `file-acl' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-tramp-file-property v localname "file-acl" - (when (executable-find tramp-smb-acl-program) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - - (let* ((share (tramp-smb-get-share v)) - (localname (replace-regexp-in-string - "\\\\" "/" (tramp-smb-get-localname v))) - (args (list (concat "//" host "/" share) "-E")) - ;; We do not want to run timers. - timer-list timer-idle-list) - - (if (not (zerop (length user))) - (setq args (append args (list "-U" user))) - (setq args (append args (list "-N")))) - - (when domain (setq args (append args (list "-W" domain)))) - (when port (setq args (append args (list "-p" port)))) - (when tramp-smb-conf - (setq args (append args (list "-s" tramp-smb-conf)))) - (setq - args - (append args (list (tramp-unquote-shell-quote-argument localname) - "2>/dev/null"))) - - (unwind-protect - (with-temp-buffer - ;; 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)) - - ;; Use an asynchronous processes. By this, password - ;; can be handled. - (let ((p (apply - 'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - tramp-smb-acl-program args))) - - (tramp-message - v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" v) - (process-put p 'adjust-window-size-function 'ignore) - (set-process-query-on-exit-flag p nil) - (tramp-process-actions p v nil tramp-smb-actions-get-acl) - (when (> (point-max) (point-min)) - (substring-no-properties (buffer-string))))) - - ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil))))))) + (ignore-errors + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-acl" + (when (executable-find tramp-smb-acl-program) + (let* ((share (tramp-smb-get-share v)) + (localname (replace-regexp-in-string + "\\\\" "/" (tramp-smb-get-localname v))) + (args (list (concat "//" host "/" share) "-E"))) + + (if (not (zerop (length user))) + (setq args (append args (list "-U" user))) + (setq args (append args (list "-N")))) + + (when domain (setq args (append args (list "-W" domain)))) + (when port (setq args (append args (list "-p" port)))) + (when tramp-smb-conf + (setq args (append args (list "-s" tramp-smb-conf)))) + (setq + args + (append args (list (tramp-unquote-shell-quote-argument localname) + "2>/dev/null"))) + + (unwind-protect + (with-temp-buffer + ;; 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)) + + ;; Use an asynchronous process. By this, password can + ;; be handled. + (let ((p (apply + #'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + tramp-smb-acl-program 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) + (tramp-process-actions p v nil tramp-smb-actions-get-acl) + (when (> (point-max) (point-min)) + (substring-no-properties (buffer-string))))) + + ;; Reset the transfer process properties. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer")))))))) (defun tramp-smb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." @@ -825,19 +819,19 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Check result. (when entry - (list (and (string-match "d" (nth 1 entry)) - t) ;0 file type - -1 ;1 link count - uid ;2 uid - gid ;3 gid - '(0 0) ;4 atime - (nth 3 entry) ;5 mtime - '(0 0) ;6 ctime - (nth 2 entry) ;7 size - (nth 1 entry) ;8 mode - nil ;9 gid weird - inode ;10 inode number - device)))))))) ;11 file system number + (list (and (string-match-p "d" (nth 1 entry)) + t) ;0 file type + -1 ;1 link count + uid ;2 uid + gid ;3 gid + tramp-time-dont-know ;4 atime + (nth 3 entry) ;5 mtime + tramp-time-dont-know ;6 ctime + (nth 2 entry) ;7 size + (nth 1 entry) ;8 mode + nil ;9 gid weird + inode ;10 inode number + device)))))))) ;11 file system number (defun tramp-smb-do-file-attributes-with-stat (vec &optional id-format) "Implement `file-attributes' for Tramp files using stat command." @@ -915,13 +909,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (list id link uid gid atime mtime ctime size mode nil inode (tramp-get-device vec)))))))) -(defun tramp-smb-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - (and (file-exists-p filename) - (eq ?d - (aref (tramp-compat-file-attribute-modes (file-attributes filename)) - 0)))) - (defun tramp-smb-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name (file-truename filename) nil @@ -949,15 +936,14 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." filename (with-parsed-tramp-file-name (expand-file-name directory) nil (with-tramp-file-property v localname "file-name-all-completions" - (save-match-data - (delete-dups - (mapcar - (lambda (x) - (list - (if (string-match "d" (nth 1 x)) - (file-name-as-directory (nth 0 x)) - (nth 0 x)))) - (tramp-smb-get-file-entries directory)))))))) + (delete-dups + (mapcar + (lambda (x) + (list + (if (string-match-p "d" (nth 1 x)) + (file-name-as-directory (nth 0 x)) + (nth 0 x)))) + (tramp-smb-get-file-entries directory))))))) (defun tramp-smb-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." @@ -972,21 +958,19 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (goto-char (point-min)) (forward-line) (when (looking-at - (concat "[[:space:]]*\\([[:digit:]]+\\)" - " blocks of size \\([[:digit:]]+\\)" - "\\. \\([[:digit:]]+\\) blocks available")) - (setq blocksize (string-to-number (concat (match-string 2) "e0")) - total (* blocksize - (string-to-number (concat (match-string 1) "e0"))) - avail (* blocksize - (string-to-number (concat (match-string 3) "e0"))))) + (eval-when-compile + (concat "[[:space:]]*\\([[:digit:]]+\\)" + " blocks of size \\([[:digit:]]+\\)" + "\\. \\([[:digit:]]+\\) blocks available"))) + (setq blocksize (string-to-number (match-string 2)) + total (* blocksize (string-to-number (match-string 1))) + avail (* blocksize (string-to-number (match-string 3))))) (forward-line) (when (looking-at "Total number of bytes: \\([[:digit:]]+\\)") ;; The used number of bytes is not part of the result. As ;; side effect, we store it as file property. (tramp-set-file-property - v localname "used-bytes" - (string-to-number (concat (match-string 1) "e0")))) + v localname "used-bytes" (string-to-number (match-string 1)))) ;; Result. (when (and total avail) (list total (- total avail) avail))))))) @@ -994,7 +978,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (defun tramp-smb-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." (if (file-exists-p filename) - (string-match + (string-match-p "w" (or (tramp-compat-file-attribute-modes (file-attributes filename)) "")) (let ((dir (file-name-directory filename))) @@ -1014,6 +998,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Called from `dired-add-entry'. (setq filename (file-name-as-directory filename)) (setq filename (directory-file-name filename))) + ;; Check, whether directory is accessible. + (unless wildcard + (access-file filename "Reading directory")) (with-parsed-tramp-file-name filename nil (with-tramp-progress-reporter v 0 (format "Opening directory %s" filename) (save-match-data @@ -1046,7 +1033,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Check for matching entries. (mapcar (lambda (x) - (when (string-match + (when (string-match-p (format "^%s" base) (nth 0 x)) x)) entries) @@ -1058,17 +1045,17 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (sort entries (lambda (x y) - (if (string-match "t" switches) + (if (string-match-p "t" switches) ;; Sort by date. (time-less-p (nth 3 y) (nth 3 x)) ;; Sort by name. (string-lessp (nth 0 x) (nth 0 y)))))) ;; Handle "-F" switch. - (when (string-match "F" switches) + (when (string-match-p "F" switches) (mapc (lambda (x) - (when (not (zerop (length (car x)))) + (unless (zerop (length (car x))) (cond ((char-equal ?d (string-to-char (nth 1 x))) (setcar x (concat (car x) "/"))) @@ -1086,7 +1073,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Print entries. (mapc (lambda (x) - (when (not (zerop (length (nth 0 x)))) + (unless (zerop (length (nth 0 x))) (let ((attr (when (tramp-smb-get-stat-capability v) (ignore-errors @@ -1094,7 +1081,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (expand-file-name (nth 0 x) (file-name-directory filename)) 'string))))) - (when (string-match "l" switches) + (when (string-match-p "l" switches) (insert (format "%10s %3d %-8s %-8s %8s %s " @@ -1104,10 +1091,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (or (tramp-compat-file-attribute-group-id attr) "nogroup") (or (tramp-compat-file-attribute-size attr) (nth 2 x)) (format-time-string - (if (time-less-p (time-subtract (current-time) (nth 3 x)) - tramp-half-a-year) + (if (time-less-p + ;; Half a year. + (time-since (nth 3 x)) (days-to-time 183)) "%b %e %R" - "%b %e %Y") + "%b %e %Y") (nth 3 x))))) ; date ;; We mark the file name. The inserted name could be @@ -1124,7 +1112,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (put-text-property start (point) 'dired-filename t)) ;; Insert symlink. - (when (and (string-match "l" switches) + (when (and (string-match-p "l" switches) (stringp (tramp-compat-file-attribute-type attr))) (insert " -> " (tramp-compat-file-attribute-type attr)))) @@ -1139,18 +1127,17 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (unless (file-name-absolute-p dir) (setq dir (expand-file-name dir default-directory))) (with-parsed-tramp-file-name dir nil - (save-match-data - (let* ((ldir (file-name-directory dir))) - ;; Make missing directory parts. - (when (and parents - (tramp-smb-get-share v) - (not (file-directory-p ldir))) - (make-directory ldir parents)) - ;; Just do it. - (when (file-directory-p ldir) - (make-directory-internal dir)) - (unless (file-directory-p dir) - (tramp-error v 'file-error "Couldn't make directory %s" dir)))))) + (let* ((ldir (file-name-directory dir))) + ;; Make missing directory parts. + (when (and parents + (tramp-smb-get-share v) + (not (file-directory-p ldir))) + (make-directory ldir parents)) + ;; Just do it. + (when (file-directory-p ldir) + (make-directory-internal dir)) + (unless (file-directory-p dir) + (tramp-error v 'file-error "Couldn't make directory %s" dir))))) (defun tramp-smb-handle-make-directory-internal (directory) "Like `make-directory-internal' for Tramp files." @@ -1158,21 +1145,19 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (unless (file-name-absolute-p directory) (setq directory (expand-file-name directory default-directory))) (with-parsed-tramp-file-name directory nil - (save-match-data - (let* ((file (tramp-smb-get-localname v))) - (when (file-directory-p (file-name-directory directory)) - (tramp-smb-send-command - v - (if (tramp-smb-get-cifs-capabilities v) - (format "posix_mkdir \"%s\" %o" file (default-file-modes)) - (format "mkdir \"%s\"" file))) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)) - (unless (file-directory-p directory) - (tramp-error - v 'file-error "Couldn't make directory %s" directory)))))) + (let* ((file (tramp-smb-get-localname v))) + (when (file-directory-p (file-name-directory directory)) + (tramp-smb-send-command + v + (if (tramp-smb-get-cifs-capabilities v) + (format "posix_mkdir \"%s\" %o" file (default-file-modes)) + (format "mkdir \"%s\"" file))) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname)) + (unless (file-directory-p directory) + (tramp-error v 'file-error "Couldn't make directory %s" directory))))) (defun tramp-smb-handle-make-symbolic-link (target linkname &optional ok-if-already-exists) @@ -1182,15 +1167,17 @@ of the symlink. If TARGET is a Tramp file, only the localname component is used as the target of the symlink." (if (not (tramp-tramp-file-p (expand-file-name linkname))) (tramp-run-real-handler - 'make-symbolic-link (list target linkname ok-if-already-exists)) + #'make-symbolic-link (list target linkname ok-if-already-exists)) (with-parsed-tramp-file-name linkname nil ;; If TARGET is a Tramp name, use just the localname component. - (when (and (tramp-tramp-file-p target) - (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target))))) + ;; Don't check for a proper method. + (let ((non-essential t)) + (when (and (tramp-tramp-file-p target) + (tramp-file-name-equal-p v (tramp-dissect-file-name target))) + (setq target + (tramp-file-name-localname + (tramp-dissect-file-name (expand-file-name target)))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -1215,8 +1202,8 @@ component is used as the target of the symlink." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (unless (tramp-smb-send-command @@ -1226,7 +1213,7 @@ component is used as the target of the symlink." (tramp-error v 'file-error "error with make-symbolic-link, see buffer `%s' for details" - (buffer-name))))))) + (tramp-get-connection-buffer v))))))) (defun tramp-smb-handle-process-file (program &optional infile destination display &rest args) @@ -1239,8 +1226,6 @@ component is used as the target of the symlink." (let* ((name (file-name-nondirectory program)) (name1 name) (i 0) - ;; We do not want to run timers. - timer-list timer-idle-list input tmpinput outbuf command ret) ;; Determine input. @@ -1251,8 +1236,7 @@ component is used as the target of the symlink." (setq input (with-parsed-tramp-file-name infile nil localname)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) - tmpinput - (tramp-make-tramp-file-name method user domain host port input)) + tmpinput (tramp-make-tramp-file-name v input)) (copy-file infile tmpinput t)) ;; Transform input into a filename powershell does understand. (setq input (format "//%s%s" host input))) @@ -1282,7 +1266,7 @@ component is used as the target of the symlink." (setq outbuf (current-buffer)))) ;; Construct command. - (setq command (mapconcat 'identity (cons program args) " ") + (setq command (string-join (cons program args) " ") command (if input (format "get-content %s | & %s" @@ -1333,14 +1317,14 @@ component is used as the target of the symlink." ;; Cleanup. We remove all file cache values for the connection, ;; because the remote process could have changed them. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") (when tmpinput (delete-file tmpinput)) (unless outbuf (kill-buffer (tramp-get-connection-property v "process-buffer" nil))) (unless process-file-side-effects - (tramp-flush-directory-property v "")) + (tramp-flush-directory-properties v "")) ;; Return exit status. (if (equal ret -1) @@ -1353,54 +1337,55 @@ component is used as the target of the symlink." (setq filename (expand-file-name filename) newname (expand-file-name newname)) - (when (and (not ok-if-already-exists) - (file-exists-p newname)) - (tramp-error - (tramp-dissect-file-name - (if (tramp-tramp-file-p filename) filename newname)) - 'file-already-exists newname)) - - (with-tramp-progress-reporter - (tramp-dissect-file-name - (if (tramp-tramp-file-p filename) filename newname)) - 0 (format "Renaming %s to %s" filename newname) - - (if (and (not (file-exists-p newname)) - (tramp-equal-remote filename newname) - (string-equal - (tramp-smb-get-share (tramp-dissect-file-name filename)) - (tramp-smb-get-share (tramp-dissect-file-name newname)))) - ;; We can rename directly. - (with-parsed-tramp-file-name filename v1 - (with-parsed-tramp-file-name newname v2 - - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v1 (file-name-directory v1-localname)) - (tramp-flush-file-property v1 v1-localname) - (tramp-flush-file-property v2 (file-name-directory v2-localname)) - (tramp-flush-file-property v2 v2-localname) - (unless (tramp-smb-get-share v2) - (tramp-error - v2 'file-error "Target `%s' must contain a share name" newname)) - (unless (tramp-smb-send-command - v2 (format "rename \"%s\" \"%s\"" - (tramp-smb-get-localname v1) - (tramp-smb-get-localname v2))) - (tramp-error v2 'file-error "Cannot rename `%s'" filename)))) - - ;; We must rename via copy. - (copy-file - filename newname ok-if-already-exists 'keep-time 'preserve-uid-gid) - (if (file-directory-p filename) - (delete-directory filename 'recursive) - (delete-file filename))))) + (with-parsed-tramp-file-name + (if (tramp-tramp-file-p filename) filename newname) nil + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (with-tramp-progress-reporter + v 0 (format "Renaming %s to %s" filename newname) + + (if (and (not (file-exists-p newname)) + (tramp-equal-remote filename newname) + (string-equal + (tramp-smb-get-share (tramp-dissect-file-name filename)) + (tramp-smb-get-share (tramp-dissect-file-name newname)))) + ;; We can rename directly. + (with-parsed-tramp-file-name filename v1 + (with-parsed-tramp-file-name newname v2 + + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties + v1 (file-name-directory v1-localname)) + (tramp-flush-file-properties v1 v1-localname) + (tramp-flush-file-properties + v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname) + (unless (tramp-smb-get-share v2) + (tramp-error + v2 'file-error + "Target `%s' must contain a share name" newname)) + (unless (tramp-smb-send-command + v2 (format "rename \"%s\" \"%s\"" + (tramp-smb-get-localname v1) + (tramp-smb-get-localname v2))) + (tramp-error v2 'file-error "Cannot rename `%s'" filename)))) + + ;; We must rename via copy. + (copy-file + filename newname ok-if-already-exists 'keep-time 'preserve-uid-gid) + (if (file-directory-p filename) + (delete-directory filename 'recursive) + (delete-file filename)))))) (defun tramp-smb-action-set-acl (proc vec) - "Read ACL data from connection buffer." + "Set ACL data." (unless (process-live-p proc) ;; Accept pending output. - (while (tramp-accept-process-output proc 0.1)) + (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)))) @@ -1409,23 +1394,15 @@ component is used as the target of the symlink." "Like `set-file-acl' for Tramp files." (ignore-errors (with-parsed-tramp-file-name filename nil - (when (and (stringp acl-string) (executable-find tramp-smb-acl-program)) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - (tramp-set-file-property v localname "file-acl" 'undef) + (tramp-flush-file-property v localname "file-acl") + (when (and (stringp acl-string) (executable-find tramp-smb-acl-program)) (let* ((share (tramp-smb-get-share v)) (localname (replace-regexp-in-string "\\\\" "/" (tramp-smb-get-localname v))) (args (list (concat "//" host "/" share) "-E" "-S" (replace-regexp-in-string - "\n" "," acl-string))) - ;; We do not want to run timers. - timer-list timer-idle-list) + "\n" "," acl-string)))) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -1452,15 +1429,14 @@ component is used as the target of the symlink." ;; Use an asynchronous process. By this, password can ;; be handled. (let ((p (apply - 'start-process + #'start-process (tramp-get-connection-name v) (tramp-get-connection-buffer v) tramp-smb-acl-program args))) - (tramp-message - v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" v) - (process-put p 'adjust-window-size-function 'ignore) + (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) (tramp-process-actions p v nil tramp-smb-actions-set-acl) (goto-char (point-max)) @@ -1478,14 +1454,14 @@ component is used as the target of the symlink." t))) ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil))))))) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer"))))))) (defun tramp-smb-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil (when (tramp-smb-get-cifs-capabilities v) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v localname) (unless (tramp-smb-send-command v (format "chmod \"%s\" %o" (tramp-smb-get-localname v) mode)) (tramp-error @@ -1502,12 +1478,10 @@ component is used as the target of the symlink." (get-buffer-create buffer) ;; BUFFER can be nil. We use a temporary buffer. (generate-new-buffer tramp-temp-buffer-name))) - (command (mapconcat 'identity (cons program args) " ")) + (command (string-join (cons program args) " ")) (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) (name1 name) - (i 0) - ;; We do not want to run timers. - timer-list timer-idle-list) + (i 0)) (unwind-protect (save-excursion (save-restriction @@ -1535,13 +1509,13 @@ component is used as the target of the symlink." ;; Save exit. (with-current-buffer (tramp-get-connection-buffer v) - (if (string-match tramp-temp-buffer-name (buffer-name)) + (if (string-match-p tramp-temp-buffer-name (buffer-name)) (progn (set-process-buffer (tramp-get-connection-process v) nil) (kill-buffer (current-buffer))) (set-buffer-modified-p bmp))) - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil))))) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer"))))) (defun tramp-smb-handle-substitute-in-file-name (filename) "Like `handle-substitute-in-file-name' for Tramp files. @@ -1557,7 +1531,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (concat (file-remote-p filename) (replace-match "\\1" nil nil localname))))) (condition-case nil - (tramp-run-real-handler 'substitute-in-file-name (list filename)) + (tramp-run-real-handler #'substitute-in-file-name (list filename)) (error filename)))) (defun tramp-smb-handle-write-region @@ -1574,8 +1548,8 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (let ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) @@ -1584,7 +1558,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." ;; modtime data to be clobbered from the temp file. We call ;; `set-visited-file-modtime' ourselves later on. (tramp-run-real-handler - 'write-region (list start end tmpfile append 'no-message lockname)) + #'write-region (list start end tmpfile append 'no-message lockname)) (with-tramp-progress-reporter v 3 (format "Moving tmp file %s to %s" tmpfile filename) @@ -1644,6 +1618,13 @@ If VEC has no cifs capabilities, exchange \"/\" by \"\\\\\"." (when (string-match "\\(\\$\\$\\)\\(/\\|$\\)" localname) (setq localname (replace-match "$" nil nil localname 1))) + ;; A period followed by a space, or trailing periods and spaces, + ;; are not supported. + (when (string-match-p "\\. \\|\\.$\\| $" localname) + (tramp-error + vec 'file-error + "Invalid file name %s" (tramp-make-tramp-file-name vec localname))) + localname))) ;; Share names of a host are cached. It is very unlikely that the @@ -1793,7 +1774,7 @@ Result is the list (LOCALNAME MODE SIZE MTIME)." (cl-return)) ;; weekday. - (if (string-match "\\(\\w+\\)$" line) + (if (string-match-p "\\(\\w+\\)$" line) (setq line (substring line 0 -5)) (cl-return)) @@ -1814,12 +1795,12 @@ Result is the list (LOCALNAME MODE SIZE MTIME)." (if (string-match "\\([ACDEHNORrsSTV]+\\)?$" line) (setq mode (or (match-string 1 line) "") - mode (save-match-data (format + mode (format "%s%s" - (if (string-match "D" mode) "d" "-") + (if (string-match-p "D" mode) "d" "-") (mapconcat (lambda (_x) "") " " - (concat "r" (if (string-match "R" mode) "-" "w") "x")))) + (concat "r" (if (string-match-p "R" mode) "-" "w") "x"))) line (substring line 0 -6)) (cl-return)) @@ -1835,7 +1816,7 @@ Result is the list (LOCALNAME MODE SIZE MTIME)." sec min hour day (cdr (assoc (downcase month) parse-time-months)) year) - '(0 0))) + tramp-time-dont-know)) (list localname mode size mtime)))) (defun tramp-smb-get-cifs-capabilities (vec) @@ -1908,8 +1889,8 @@ If ARGUMENT is non-nil, use it as argument for tramp-smb-version (tramp-get-connection-property vec "smbclient-version" tramp-smb-version)) - (tramp-flush-directory-property vec "") - (tramp-flush-connection-property vec)) + (tramp-flush-directory-properties vec "") + (tramp-flush-connection-properties vec)) (tramp-set-connection-property vec "smbclient-version" tramp-smb-version))) @@ -1919,11 +1900,11 @@ If ARGUMENT is non-nil, use it as argument for ;; connection timeout. (with-current-buffer buf (goto-char (point-min)) - (when (and (> (tramp-time-diff - (current-time) - (tramp-get-connection-property - p "last-cmd-time" '(0 0 0))) - 60) + ;; `seconds-to-time' can be removed once we get rid of Emacs 24. + (when (and (time-less-p (seconds-to-time 60) + (time-since + (tramp-get-connection-property + p "last-cmd-time" (seconds-to-time 0)))) (process-live-p p) (re-search-forward tramp-smb-errors nil t)) (delete-process p) @@ -1936,6 +1917,14 @@ If ARGUMENT is non-nil, use it as argument for share (tramp-get-connection-property p "smb-share" "")))) + ;; During completion, don't reopen a new connection. 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. + (when (and (tramp-completion-mode-p) + (null (get-process (tramp-buffer-name vec)))) + (throw 'non-essential 'non-essential)) + (save-match-data ;; There might be unread output from checking for share names. (when buf (with-current-buffer buf (erase-buffer))) @@ -1984,19 +1973,11 @@ If ARGUMENT is non-nil, use it as argument for tramp-smb-winexe-program tramp-smb-program) args)))) - (tramp-message - vec 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" vec) - (process-put p 'adjust-window-size-function 'ignore) + (tramp-message vec 6 "%s" (string-join (process-command p) " ")) + (process-put p 'vector vec) + (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method tramp-smb-method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - (condition-case err (let (tramp-message-show-message) ;; Play login scenario. @@ -2007,20 +1988,22 @@ If ARGUMENT is non-nil, use it as argument for tramp-smb-actions-without-share)) ;; Check server version. - (unless argument - (with-current-buffer (tramp-get-connection-buffer vec) - (goto-char (point-min)) - (search-forward-regexp tramp-smb-server-version nil t) - (let ((smbserver-version (match-string 0))) - (unless - (string-equal - smbserver-version - (tramp-get-connection-property - vec "smbserver-version" smbserver-version)) - (tramp-flush-directory-property vec "") - (tramp-flush-connection-property vec)) - (tramp-set-connection-property - vec "smbserver-version" smbserver-version)))) + ;; FIXME: With recent smbclient versions, this + ;; information isn't printed anymore. + ;; (unless argument + ;; (with-current-buffer (tramp-get-connection-buffer vec) + ;; (goto-char (point-min)) + ;; (search-forward-regexp tramp-smb-server-version nil t) + ;; (let ((smbserver-version (match-string 0))) + ;; (unless + ;; (string-equal + ;; smbserver-version + ;; (tramp-get-connection-property + ;; vec "smbserver-version" smbserver-version)) + ;; (tramp-flush-directory-properties vec "") + ;; (tramp-flush-connection-properties vec)) + ;; (tramp-set-connection-property + ;; vec "smbserver-version" smbserver-version)))) ;; Set chunksize to 1. smbclient reads its input ;; character by character; if we send the string @@ -2056,51 +2039,27 @@ If ARGUMENT is non-nil, use it as argument for ;; We don't use timeouts. If needed, the caller shall wrap around. (defun tramp-smb-wait-for-output (vec) "Wait for output from smbclient command. -Returns nil if an error message has appeared." +Removes smb prompt. Returns nil if an error message has appeared." (with-current-buffer (tramp-get-connection-buffer vec) (let ((p (get-buffer-process (current-buffer))) - (found (progn (goto-char (point-min)) - (re-search-forward tramp-smb-prompt nil t))) - (err (progn (goto-char (point-min)) - (re-search-forward tramp-smb-errors nil t))) - buffer-read-only) - - ;; Algorithm: get waiting output. See if last line contains - ;; `tramp-smb-prompt' sentinel or `tramp-smb-errors' strings. - ;; If not, wait a bit and again get waiting output. - (while (and (not found) (not err) (process-live-p p)) - - ;; Accept pending output. - (tramp-accept-process-output p 0.1) - - ;; Search for prompt. - (goto-char (point-min)) - (setq found (re-search-forward tramp-smb-prompt nil t)) - - ;; Search for errors. - (goto-char (point-min)) - (setq err (re-search-forward tramp-smb-errors nil t))) - - ;; When the process is still alive, read pending output. - (while (and (not found) (process-live-p p)) - - ;; Accept pending output. - (tramp-accept-process-output p 0.1) - - ;; Search for prompt. - (goto-char (point-min)) - (setq found (re-search-forward tramp-smb-prompt nil t))) + (inhibit-read-only t)) + ;; Read pending output. + (while (not (re-search-forward tramp-smb-prompt nil t)) + (while (tramp-accept-process-output p 0)) + (goto-char (point-min))) (tramp-message vec 6 "\n%s" (buffer-string)) ;; Remove prompt. - (when found + (goto-char (point-min)) + (when (re-search-forward tramp-smb-prompt nil t) (goto-char (point-max)) (re-search-backward tramp-smb-prompt nil t) (delete-region (point) (point-max))) ;; Return value is whether no error message has appeared. - (not err)))) + (goto-char (point-min)) + (not (re-search-forward tramp-smb-errors nil t))))) (defun tramp-smb-kill-winexe-function () "Send SIGKILL to the winexe process." @@ -2111,7 +2070,6 @@ Returns nil if an error message has appeared." (defun tramp-smb-call-winexe (vec) "Apply a remote command, if possible, using `tramp-smb-winexe-program'." - ;; Check for program. (unless (executable-find tramp-smb-winexe-program) (tramp-error diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el new file mode 100644 index 00000000000..0ded85fb554 --- /dev/null +++ b/lisp/net/tramp-sudoedit.el @@ -0,0 +1,894 @@ +;;; tramp-sudoedit.el --- Functions for accessing under root permissions -*- lexical-binding:t -*- + +;; Copyright (C) 2018-2019 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; Keywords: comm, processes +;; Package: tramp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; The "sudoedit" Tramp method allows to edit a file as a different +;; user on the local host. Contrary to the "sudo" method, all magic +;; file name functions are implemented by single "sudo ..." commands. +;; The purpose is to make editing such a file as secure as possible; +;; there must be no session running in the Emacs background which +;; could be attacked from inside Emacs. + +;; Consequently, external processes are not implemented. + +;;; Code: + +(require 'tramp) + +;;;###tramp-autoload +(defconst tramp-sudoedit-method "sudoedit" + "When this method name is used, call sudoedit for editing a file.") + +;;;###tramp-autoload +(tramp--with-startup + (add-to-list 'tramp-methods + `(,tramp-sudoedit-method + (tramp-sudo-login (("sudo") ("-u" "%u") ("-S") ("-H") + ("-p" "Password:") ("--"))))) + + (add-to-list 'tramp-default-user-alist '("\\`sudoedit\\'" nil "root")) + + (tramp-set-completion-function + tramp-sudoedit-method tramp-completion-function-alist-su)) + +(defconst tramp-sudoedit-sudo-actions + '((tramp-password-prompt-regexp tramp-action-password) + (tramp-wrong-passwd-regexp tramp-action-permission-denied) + (tramp-process-alive-regexp tramp-sudoedit-action-sudo)) + "List of pattern/action pairs. +This list is used for sudo calls. + +See `tramp-actions-before-shell' for more info.") + +;;;###tramp-autoload +(defconst tramp-sudoedit-file-name-handler-alist + '((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' performed by default handler. + (copy-file . tramp-sudoedit-handle-copy-file) + (delete-directory . tramp-sudoedit-handle-delete-directory) + (delete-file . tramp-sudoedit-handle-delete-file) + (diff-latest-backup-file . ignore) + ;; `directory-file-name' performed by default handler. + (directory-files . tramp-handle-directory-files) + (directory-files-and-attributes + . tramp-handle-directory-files-and-attributes) + (dired-compress-file . ignore) + (dired-uncache . tramp-handle-dired-uncache) + (exec-path . ignore) + (expand-file-name . tramp-sudoedit-handle-expand-file-name) + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) + (file-acl . tramp-sudoedit-handle-file-acl) + (file-attributes . tramp-sudoedit-handle-file-attributes) + (file-directory-p . tramp-handle-file-directory-p) + (file-equal-p . tramp-handle-file-equal-p) + (file-executable-p . tramp-sudoedit-handle-file-executable-p) + (file-exists-p . tramp-sudoedit-handle-file-exists-p) + (file-in-directory-p . tramp-handle-file-in-directory-p) + (file-local-copy . tramp-handle-file-local-copy) + (file-modes . tramp-handle-file-modes) + (file-name-all-completions + . tramp-sudoedit-handle-file-name-all-completions) + (file-name-as-directory . tramp-handle-file-name-as-directory) + (file-name-case-insensitive-p . tramp-handle-file-name-case-insensitive-p) + (file-name-completion . tramp-handle-file-name-completion) + (file-name-directory . tramp-handle-file-name-directory) + (file-name-nondirectory . tramp-handle-file-name-nondirectory) + ;; `file-name-sans-versions' performed by default handler. + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) + (file-notify-add-watch . ignore) + (file-notify-rm-watch . ignore) + (file-notify-valid-p . ignore) + (file-ownership-preserved-p . ignore) + (file-readable-p . tramp-sudoedit-handle-file-readable-p) + (file-regular-p . tramp-handle-file-regular-p) + (file-remote-p . tramp-handle-file-remote-p) + (file-selinux-context . tramp-sudoedit-handle-file-selinux-context) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-system-info . tramp-sudoedit-handle-file-system-info) + (file-truename . tramp-sudoedit-handle-file-truename) + (file-writable-p . tramp-sudoedit-handle-file-writable-p) + (find-backup-file-name . tramp-handle-find-backup-file-name) + ;; `get-file-buffer' performed by default handler. + (insert-directory . tramp-handle-insert-directory) + (insert-file-contents . tramp-handle-insert-file-contents) + (load . tramp-handle-load) + (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) + (make-directory . tramp-sudoedit-handle-make-directory) + (make-directory-internal . ignore) + (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-process . ignore) + (make-symbolic-link . tramp-sudoedit-handle-make-symbolic-link) + (process-file . ignore) + (rename-file . tramp-sudoedit-handle-rename-file) + (set-file-acl . tramp-sudoedit-handle-set-file-acl) + (set-file-modes . tramp-sudoedit-handle-set-file-modes) + (set-file-selinux-context . tramp-sudoedit-handle-set-file-selinux-context) + (set-file-times . tramp-sudoedit-handle-set-file-times) + (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) + (shell-command . ignore) + (start-file-process . ignore) + (substitute-in-file-name . tramp-handle-substitute-in-file-name) + (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-set-file-uid-gid . tramp-sudoedit-handle-set-file-uid-gid) + (unhandled-file-name-directory . ignore) + (vc-registered . ignore) + (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (write-region . tramp-sudoedit-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))) + +;;;###tramp-autoload +(defun tramp-sudoedit-file-name-handler (operation &rest args) + "Invoke the SUDOEDIT handler for OPERATION. +First arg specifies the OPERATION, second arg is a list of arguments to +pass to the OPERATION." + (let ((fn (assoc operation tramp-sudoedit-file-name-handler-alist))) + (if fn + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args)))) + +;;;###tramp-autoload +(tramp--with-startup + (tramp-register-foreign-file-name-handler + #'tramp-sudoedit-file-name-p #'tramp-sudoedit-file-name-handler)) + + +;; File name primitives. + +(defun tramp-sudoedit-handle-add-name-to-file + (filename newname &optional ok-if-already-exists) + "Like `add-name-to-file' for Tramp files." + (unless (tramp-equal-remote filename newname) + (with-parsed-tramp-file-name + (if (tramp-tramp-file-p filename) filename newname) nil + (tramp-error + v 'file-error + "add-name-to-file: %s" + "only implemented for same method, same user, same host"))) + (with-parsed-tramp-file-name filename v1 + (with-parsed-tramp-file-name newname v2 + ;; Do the 'confirm if exists' thing. + (when (file-exists-p newname) + ;; What to do? + (if (or (null ok-if-already-exists) ; not allowed to exist + (and (numberp ok-if-already-exists) + (not (yes-or-no-p + (format + "File %s already exists; make it a link anyway? " + v2-localname))))) + (tramp-error v2 'file-already-exists newname) + (delete-file newname))) + (tramp-flush-file-properties v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname) + (unless + (tramp-sudoedit-send-command + v1 "ln" + (tramp-compat-file-name-unquote v1-localname) + (tramp-compat-file-name-unquote v2-localname)) + (tramp-error + v1 'file-error + "error with add-name-to-file, see buffer `%s' for details" + (buffer-name)))))) + +(defun tramp-sudoedit-do-copy-or-rename-file + (op filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Copy or rename a remote file. +OP must be `copy' or `rename' and indicates the operation to perform. +FILENAME specifies the file to copy or rename, NEWNAME is the name of +the new file (for copy) or the new name of the file (for rename). +OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already. +KEEP-DATE means to make sure that NEWNAME has the same timestamp +as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep +the uid and gid if both files are on the same host. +PRESERVE-EXTENDED-ATTRIBUTES activates selinux and acl commands. + +This function is invoked by `tramp-sudoedit-handle-copy-file' and +`tramp-sudoedit-handle-rename-file'. It is an error if OP is +neither of `copy' and `rename'. FILENAME and NEWNAME must be +absolute file names." + (unless (memq op '(copy rename)) + (error "Unknown operation `%s', must be `copy' or `rename'" op)) + + (setq filename (file-truename filename)) + (if (file-directory-p filename) + (progn + (copy-directory filename newname keep-date t) + (when (eq op 'rename) (delete-directory filename 'recursive))) + + (let ((t1 (tramp-sudoedit-file-name-p filename)) + (t2 (tramp-sudoedit-file-name-p newname)) + (file-times (tramp-compat-file-attribute-modification-time + (file-attributes filename))) + (file-modes (tramp-default-file-modes filename)) + (attributes (and preserve-extended-attributes + (apply #'file-extended-attributes (list filename)))) + (sudoedit-operation + (cond + ((and (eq op 'copy) preserve-uid-gid) '("cp" "-f" "-p")) + ((eq op 'copy) '("cp" "-f")) + ((eq op 'rename) '("mv" "-f")))) + (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) + + (with-parsed-tramp-file-name (if t1 filename newname) nil + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (if (or (and (file-remote-p filename) (not t1)) + (and (file-remote-p newname) (not t2))) + ;; We cannot copy or rename directly. + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (if (eq op 'copy) + (copy-file filename tmpfile t) + (rename-file filename tmpfile t)) + (rename-file tmpfile newname ok-if-already-exists)) + + ;; Direct action. + (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) + (unless (tramp-sudoedit-send-command + v sudoedit-operation + (tramp-compat-file-name-unquote + (tramp-compat-file-local-name filename)) + (tramp-compat-file-name-unquote + (tramp-compat-file-local-name newname))) + (tramp-error + v 'file-error + "Error %s `%s' `%s'" msg-operation filename newname)))) + + ;; When `newname' is local, we must change the ownership to + ;; the local user. + (unless (file-remote-p newname) + (tramp-set-file-uid-gid + (concat (file-remote-p filename) newname) + (tramp-get-local-uid 'integer) + (tramp-get-local-gid 'integer))) + + ;; Set the time and mode. Mask possible errors. + (when keep-date + (ignore-errors + (set-file-times newname file-times) + (set-file-modes newname file-modes))) + + ;; Handle `preserve-extended-attributes'. We ignore possible + ;; errors, because ACL strings could be incompatible. + (when attributes + (ignore-errors + (apply #'set-file-extended-attributes (list newname attributes)))) + + (when (and t1 (eq op 'rename)) + (with-parsed-tramp-file-name filename v1 + (tramp-flush-file-properties + v1 (file-name-directory v1-localname)) + (tramp-flush-file-properties v1 v1-localname))) + + (when t2 + (with-parsed-tramp-file-name newname v2 + (tramp-flush-file-properties + v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname))))))) + +(defun tramp-sudoedit-handle-copy-file + (filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Like `copy-file' for Tramp files." + (setq filename (expand-file-name filename)) + (setq newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-sudoedit-do-copy-or-rename-file + 'copy filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + (tramp-run-real-handler + #'copy-file + (list filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes)))) + +(defun tramp-sudoedit-handle-delete-directory + (directory &optional recursive trash) + "Like `delete-directory' for Tramp files." + (setq directory (expand-file-name directory)) + (with-parsed-tramp-file-name directory nil + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) + (unless + (tramp-sudoedit-send-command + v (or (and trash "trash") + (if recursive '("rm" "-rf") "rmdir")) + (tramp-compat-file-name-unquote localname)) + (tramp-error v 'file-error "Couldn't delete %s" directory)))) + +(defun tramp-sudoedit-handle-delete-file (filename &optional trash) + "Like `delete-file' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (unless + (tramp-sudoedit-send-command + v (if (and trash delete-by-moving-to-trash) "trash" "rm") + (tramp-compat-file-name-unquote localname)) + ;; Propagate the error. + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (tramp-error-with-buffer + nil v 'file-error "Couldn't delete %s" filename))))) + +(defun tramp-sudoedit-handle-expand-file-name (name &optional dir) + "Like `expand-file-name' for Tramp files. +If the localname part of the given file name starts with \"/../\" then +the result will be a local, non-Tramp, file name." + ;; If DIR is not given, use `default-directory' or "/". + (setq dir (or dir default-directory "/")) + ;; Handle empty NAME. + (when (zerop (length name)) (setq name ".")) + ;; Unless NAME is absolute, concat DIR and NAME. + (unless (file-name-absolute-p name) + (setq name (concat (file-name-as-directory dir) name))) + (with-parsed-tramp-file-name name nil + ;; Tilde expansion if necessary. We cannot accept "~/", because + ;; under sudo "~/" is expanded to the local user home directory + ;; but to the root home directory. + (when (zerop (length localname)) + (setq localname "~")) + (unless (file-name-absolute-p localname) + (setq localname (format "~%s/%s" user 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 normal `expand-file-name' (this does "~user/", "/./" and "/../"). + (tramp-make-tramp-file-name v (expand-file-name localname)))) + +(defun tramp-sudoedit-remote-acl-p (vec) + "Check, whether ACL is enabled on the remote host." + (with-tramp-connection-property (tramp-get-connection-process vec) "acl-p" + (zerop (tramp-call-process vec "getfacl" nil nil nil "/")))) + +(defun tramp-sudoedit-handle-file-acl (filename) + "Like `file-acl' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-acl" + (let ((result (and (tramp-sudoedit-remote-acl-p v) + (tramp-sudoedit-send-command-string + v "getfacl" "-acp" + (tramp-compat-file-name-unquote localname))))) + ;; The acl string must have a trailing \n, which is not + ;; provided by `tramp-sudoedit-send-command-string'. Add it. + (and (stringp result) (concat result "\n")))))) + +(defun tramp-sudoedit-handle-file-attributes (filename &optional id-format) + "Like `file-attributes' for Tramp files." + (unless id-format (setq id-format 'integer)) + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property + v localname (format "file-attributes-%s" id-format) + (tramp-message v 5 "file attributes: %s" localname) + (ignore-errors + (tramp-convert-file-attributes + v + (tramp-sudoedit-send-command-and-read + v "env" "QUOTING_STYLE=locale" "stat" "-c" + (format + ;; Apostrophes in the stat output are masked as + ;; `tramp-stat-marker', in order to make a proper shell + ;; escape of them in file names. + "((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)" + tramp-stat-marker tramp-stat-marker + (if (eq id-format 'integer) + "%u" + (eval-when-compile + (concat tramp-stat-marker "%U" tramp-stat-marker))) + (if (eq id-format 'integer) + "%g" + (eval-when-compile + (concat tramp-stat-marker "%G" tramp-stat-marker))) + tramp-stat-marker tramp-stat-marker) + (tramp-compat-file-name-unquote localname))))))) + +(defun tramp-sudoedit-handle-file-executable-p (filename) + "Like `file-executable-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-executable-p" + (tramp-sudoedit-send-command + v "test" "-x" (tramp-compat-file-name-unquote localname))))) + +(defun tramp-sudoedit-handle-file-exists-p (filename) + "Like `file-exists-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-exists-p" + (tramp-sudoedit-send-command + v "test" "-e" (tramp-compat-file-name-unquote localname))))) + +(defun tramp-sudoedit-handle-file-name-all-completions (filename directory) + "Like `file-name-all-completions' for Tramp files." + (all-completions + filename + (with-parsed-tramp-file-name (expand-file-name directory) nil + (with-tramp-file-property v localname "file-name-all-completions" + (tramp-sudoedit-send-command + v "ls" "-a1" "--quoting-style=literal" "--show-control-chars" + (if (zerop (length localname)) + "" (tramp-compat-file-name-unquote localname))) + (mapcar + (lambda (f) + (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))))))))) + +(defun tramp-sudoedit-handle-file-readable-p (filename) + "Like `file-readable-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-readable-p" + (tramp-sudoedit-send-command + v "test" "-r" (tramp-compat-file-name-unquote localname))))) + +(defun tramp-sudoedit-handle-set-file-modes (filename mode) + "Like `set-file-modes' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (unless (tramp-sudoedit-send-command + v "chmod" (format "%o" mode) + (tramp-compat-file-name-unquote localname)) + (tramp-error + v 'file-error "Error while changing file's mode %s" filename)))) + +(defun tramp-sudoedit-remote-selinux-p (vec) + "Check, whether SELINUX is enabled on the remote host." + (with-tramp-connection-property (tramp-get-connection-process vec) "selinux-p" + (zerop (tramp-call-process vec "selinuxenabled")))) + +(defun tramp-sudoedit-handle-file-selinux-context (filename) + "Like `file-selinux-context' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-selinux-context" + (let ((context '(nil nil nil nil)) + (regexp (eval-when-compile + (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):" + "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)")))) + (when (and (tramp-sudoedit-remote-selinux-p v) + (tramp-sudoedit-send-command + v "ls" "-d" "-Z" + (tramp-compat-file-name-unquote localname))) + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (when (re-search-forward regexp (point-at-eol) t) + (setq context (list (match-string 1) (match-string 2) + (match-string 3) (match-string 4)))))) + ;; Return the context. + context)))) + +(defun tramp-sudoedit-handle-file-system-info (filename) + "Like `file-system-info' for Tramp files." + (ignore-errors + (with-parsed-tramp-file-name (expand-file-name filename) nil + (tramp-message v 5 "file system info: %s" localname) + (when (tramp-sudoedit-send-command + v "df" "--block-size=1" "--output=size,used,avail" + (tramp-compat-file-name-unquote localname))) + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (forward-line) + (when (looking-at + (eval-when-compile + (concat "[[:space:]]*\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)"))) + (list (string-to-number (match-string 1)) + ;; The second value is the used size. We need the + ;; free size. + (- (string-to-number (match-string 1)) + (string-to-number (match-string 2))) + (string-to-number (match-string 3)))))))) + +(defun tramp-sudoedit-handle-set-file-times (filename &optional time) + "Like `set-file-times' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (let ((time + (if (or (null time) + (tramp-compat-time-equal-p time tramp-time-doesnt-exist) + (tramp-compat-time-equal-p time tramp-time-dont-know)) + (current-time) + time))) + (tramp-sudoedit-send-command + v "env" "TZ=UTC" "touch" "-t" + (format-time-string "%Y%m%d%H%M.%S" time t) + (tramp-compat-file-name-unquote localname))))) + +(defun tramp-sudoedit-handle-file-truename (filename) + "Like `file-truename' for Tramp files." + ;; Preserve trailing "/". + (funcall + (if (string-equal (file-name-nondirectory filename) "") + #'file-name-as-directory #'identity) + (with-parsed-tramp-file-name (expand-file-name filename) nil + (tramp-make-tramp-file-name + v + (with-tramp-file-property v localname "file-truename" + (let ((quoted (tramp-compat-file-name-quoted-p localname)) + (localname (tramp-compat-file-name-unquote localname)) + result) + (tramp-message v 4 "Finding true name for `%s'" filename) + (setq result (tramp-sudoedit-send-command-string + v "readlink" "--canonicalize-missing" localname)) + ;; Detect cycle. + (when (and (file-symlink-p filename) + (string-equal result localname)) + (tramp-error + v 'file-error + "Apparent cycle of symbolic links for %s" filename)) + ;; If the resulting localname looks remote, we must quote it + ;; for security reasons. + (when (or quoted (file-remote-p result)) + (let (file-name-handler-alist) + (setq result (tramp-compat-file-name-quote result)))) + (tramp-message v 4 "True name of `%s' is `%s'" localname result) + result)) + 'nohop)))) + +(defun tramp-sudoedit-handle-file-writable-p (filename) + "Like `file-writable-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-writable-p" + (if (file-exists-p filename) + (tramp-sudoedit-send-command + v "test" "-w" (tramp-compat-file-name-unquote localname)) + (let ((dir (file-name-directory filename))) + (and (file-exists-p dir) + (file-writable-p dir))))))) + +(defun tramp-sudoedit-handle-make-directory (dir &optional parents) + "Like `make-directory' for Tramp files." + (setq dir (expand-file-name dir)) + (with-parsed-tramp-file-name dir nil + ;; When PARENTS is non-nil, DIR could be a chain of non-existent + ;; directories a/b/c/... Instead of checking, we simply flush the + ;; whole cache. + (tramp-flush-directory-properties + v (if parents "/" (file-name-directory localname))) + (unless (tramp-sudoedit-send-command + v (if parents '("mkdir" "-p") "mkdir") + (tramp-compat-file-name-unquote localname)) + (tramp-error v 'file-error "Couldn't make directory %s" dir)))) + +(defun tramp-sudoedit-handle-make-symbolic-link + (target linkname &optional ok-if-already-exists) + "Like `make-symbolic-link' for Tramp files. +If TARGET is a non-Tramp file, it is used verbatim as the target +of the symlink. If TARGET is a Tramp file, only the localname +component is used as the target of the symlink." + (if (not (tramp-tramp-file-p (expand-file-name linkname))) + (tramp-run-real-handler + #'make-symbolic-link (list target linkname ok-if-already-exists)) + + (with-parsed-tramp-file-name linkname nil + ;; If TARGET is a Tramp name, use just the localname component. + ;; Don't check for a proper method. + (let ((non-essential t)) + (when (and (tramp-tramp-file-p target) + (tramp-file-name-equal-p v (tramp-dissect-file-name target))) + (setq target + (tramp-file-name-localname + (tramp-dissect-file-name (expand-file-name target)))))) + + ;; If TARGET is still remote, quote it. + (if (tramp-tramp-file-p target) + (make-symbolic-link + (let (file-name-handler-alist) (tramp-compat-file-name-quote target)) + linkname ok-if-already-exists) + + ;; Do the 'confirm if exists' thing. + (when (file-exists-p linkname) + ;; What to do? + (if (or (null ok-if-already-exists) ; not allowed to exist + (and (numberp ok-if-already-exists) + (not + (yes-or-no-p + (format + "File %s already exists; make it a link anyway? " + localname))))) + (tramp-error v 'file-already-exists localname) + (delete-file linkname))) + + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (tramp-sudoedit-send-command + v "ln" "-sf" + (tramp-compat-file-name-unquote target) + (tramp-compat-file-name-unquote localname)))))) + +(defun tramp-sudoedit-handle-rename-file + (filename newname &optional ok-if-already-exists) + "Like `rename-file' for Tramp files." + (setq filename (expand-file-name filename)) + (setq newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-sudoedit-do-copy-or-rename-file + 'rename filename newname ok-if-already-exists + 'keep-date 'preserve-uid-gid) + (tramp-run-real-handler + 'rename-file (list filename newname ok-if-already-exists)))) + +(defun tramp-sudoedit-handle-set-file-acl (filename acl-string) + "Like `set-file-acl' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (when (and (stringp acl-string) (tramp-sudoedit-remote-acl-p v)) + ;; Massage `acl-string'. + (setq acl-string (string-join (split-string acl-string "\n" 'omit) ",")) + (prog1 + (tramp-sudoedit-send-command + v "setfacl" "-m" + acl-string (tramp-compat-file-name-unquote localname)) + (tramp-flush-file-property v localname "file-acl"))))) + +(defun tramp-sudoedit-handle-set-file-selinux-context (filename context) + "Like `set-file-selinux-context' for Tramp files." + (with-parsed-tramp-file-name filename nil + (when (and (consp context) + (tramp-sudoedit-remote-selinux-p v)) + (let ((user (and (stringp (nth 0 context)) (nth 0 context))) + (role (and (stringp (nth 1 context)) (nth 1 context))) + (type (and (stringp (nth 2 context)) (nth 2 context))) + (range (and (stringp (nth 3 context)) (nth 3 context)))) + (when (tramp-sudoedit-send-command + v "chcon" + (when user (format "--user=%s" user)) + (when role (format "--role=%s" role)) + (when type (format "--type=%s" type)) + (when range (format "--range=%s" range)) + (tramp-compat-file-name-unquote localname)) + (if (and user role type range) + (tramp-set-file-property + v localname "file-selinux-context" context) + (tramp-flush-file-property v localname "file-selinux-context")) + t))))) + +(defun tramp-sudoedit-get-remote-uid (vec id-format) + "The uid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (with-tramp-connection-property vec (format "uid-%s" id-format) + (if (equal id-format 'integer) + (tramp-sudoedit-send-command-and-read vec "id" "-u") + (tramp-sudoedit-send-command-string vec "id" "-un")))) + +(defun tramp-sudoedit-get-remote-gid (vec id-format) + "The gid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (with-tramp-connection-property vec (format "gid-%s" id-format) + (if (equal id-format 'integer) + (tramp-sudoedit-send-command-and-read vec "id" "-g") + (tramp-sudoedit-send-command-string vec "id" "-gn")))) + +(defun tramp-sudoedit-handle-set-file-uid-gid (filename &optional uid gid) + "Like `tramp-set-file-uid-gid' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-sudoedit-send-command + v "chown" + (format "%d:%d" + (or uid (tramp-sudoedit-get-remote-uid v 'integer)) + (or gid (tramp-sudoedit-get-remote-gid v 'integer))) + (tramp-compat-file-name-unquote + (tramp-compat-file-local-name filename))))) + +(defun tramp-sudoedit-handle-write-region + (start end filename &optional append visit lockname mustbenew) + "Like `write-region' for Tramp files." + (with-parsed-tramp-file-name filename nil + (let ((uid (or (tramp-compat-file-attribute-user-id + (file-attributes filename 'integer)) + (tramp-sudoedit-get-remote-uid v 'integer))) + (gid (or (tramp-compat-file-attribute-group-id + (file-attributes filename 'integer)) + (tramp-sudoedit-get-remote-gid v 'integer))) + (modes (tramp-default-file-modes filename))) + (prog1 + (tramp-handle-write-region + start end filename append visit lockname mustbenew) + + ;; Set the ownership and modes. 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)) + (set-file-modes filename modes))))) + + +;; Internal functions. + +;; Used in `tramp-sudoedit-sudo-actions'. +(defun tramp-sudoedit-action-sudo (proc vec) + "Check, whether a sudo process has finished. +Remove unneeded output." + ;; There might be pending output for the exit status. + (unless (process-live-p proc) + (while (tramp-accept-process-output proc 0)) + ;; Delete narrowed region, it would be in the way reading a Lisp form. + (goto-char (point-min)) + (widen) + (delete-region (point-min) (point)) + ;; Delete empty lines. + (goto-char (point-min)) + (while (and (not (eobp)) (= (point) (point-at-eol))) + (forward-line)) + (delete-region (point-min) (point)) + (tramp-message vec 3 "Process has finished.") + (throw 'tramp-action 'ok))) + +(defun tramp-sudoedit-maybe-open-connection (vec) + "Maybe open a connection VEC. +Does not do anything if a connection is already open, but re-opens the +connection if a previous connection has died for some reason." + ;; We need a process bound to the connection buffer. Therefore, we + ;; create a dummy process. Maybe there is a better solution? + (unless (tramp-get-connection-process vec) + + ;; During completion, don't reopen a new connection. 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. + (when (and (tramp-completion-mode-p) + (null (get-process (tramp-buffer-name vec)))) + (throw 'non-essential 'non-essential)) + + (let ((p (make-network-process + :name (tramp-get-connection-name vec) + :buffer (tramp-get-connection-buffer vec) + :server t :host 'local :service t :noquery t))) + (process-put p 'vector vec) + (set-process-query-on-exit-flag p nil) + + ;; Set connection-local variables. + (tramp-set-connection-local-variables vec) + + ;; Mark it as connected. + (tramp-set-connection-property p "connected" t)) + + ;; In `tramp-check-cached-permissions', the connection properties + ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. + (tramp-sudoedit-get-remote-uid vec 'integer) + (tramp-sudoedit-get-remote-gid vec 'integer) + (tramp-sudoedit-get-remote-uid vec 'string) + (tramp-sudoedit-get-remote-gid vec 'string))) + +(defun tramp-sudoedit-send-command (vec &rest args) + "Send commands ARGS to connection VEC. +If an element of ARGS is a list, it will be flattened. If an +element of ARGS is nil, it will be deleted. +Erases temporary buffer before sending the command. Returns nil +in case of error, t otherwise." + (tramp-sudoedit-maybe-open-connection vec) + (with-current-buffer (tramp-get-connection-buffer vec) + (erase-buffer) + (let* ((login (tramp-get-method-parameter vec 'tramp-sudo-login)) + (host (or (tramp-file-name-host vec) "")) + (user (or (tramp-file-name-user vec) "")) + (spec (format-spec-make ?h host ?u user)) + (args (append + (tramp-compat-flatten-tree + (mapcar + (lambda (x) + (setq x (mapcar (lambda (y) (format-spec y spec)) x)) + (unless (member "" x) x)) + login)) + (tramp-compat-flatten-tree (delq nil args)))) + (delete-exited-processes t) + (process-connection-type tramp-process-connection-type) + (p (apply #'start-process + (tramp-get-connection-name vec) (current-buffer) args)) + ;; We suppress the messages `Waiting for prompts from remote shell'. + (tramp-verbose (if (= tramp-verbose 3) 2 tramp-verbose)) + ;; We do not want to save the password. + auth-source-save-behavior) + (tramp-message vec 6 "%s" (string-join (process-command p) " ")) + ;; Avoid process status message in output buffer. + (set-process-sentinel p #'ignore) + (process-put p 'vector vec) + (process-put p 'adjust-window-size-function #'ignore) + (set-process-query-on-exit-flag p nil) + (tramp-process-actions p vec nil tramp-sudoedit-sudo-actions) + (tramp-message vec 6 "%s\n%s" (process-exit-status p) (buffer-string)) + (prog1 + (zerop (process-exit-status p)) + (delete-process p))))) + +(defun tramp-sudoedit-send-command-and-read (vec &rest args) + "Run command ARGS and return the output, which must be a Lisp expression. +In case there is no valid Lisp expression, it raises an error." + (when (apply #'tramp-sudoedit-send-command vec args) + (with-current-buffer (tramp-get-connection-buffer vec) + ;; Replace stat marker. + (goto-char (point-min)) + (when (search-forward tramp-stat-marker nil t) + (goto-char (point-min)) + (while (search-forward "\"" nil t) + (replace-match "\\\"" nil 'literal)) + (goto-char (point-min)) + (while (search-forward tramp-stat-marker nil t) + (replace-match "\""))) + ;; Read the expression. + (tramp-message vec 6 "\n%s" (buffer-string)) + (goto-char (point-min)) + (condition-case nil + (prog1 (read (current-buffer)) + ;; Error handling. + (when (re-search-forward "\\S-" (point-at-eol) t) + (error nil))) + (error (tramp-error + vec 'file-error + "`%s' does not return a valid Lisp expression: `%s'" + (car args) (buffer-string))))))) + +(defun tramp-sudoedit-send-command-string (vec &rest args) + "Run command ARGS and return the output as astring." + (when (apply #'tramp-sudoedit-send-command vec args) + (with-current-buffer (tramp-get-connection-buffer vec) + (tramp-message vec 6 "\n%s" (buffer-string)) + (goto-char (point-max)) + ;(delete-blank-lines) + (while (looking-back "[ \t\n]+" nil 'greedy) + (delete-region (match-beginning 0) (point))) + (when (> (point-max) (point-min)) + (substring-no-properties (buffer-string)))))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-sudoedit 'force))) + +(provide 'tramp-sudoedit) + +;;; TODO: + +;; * Fix *-selinux functions. Likely, this is due to wrong file +;; ownership after `write-region' and/or `copy-file'. + +;;; tramp-sudoedit.el ends here diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 315e7099479..717ced80f28 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -7,6 +7,9 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp +;; Version: 2.4.3-pre +;; Package-Requires: ((emacs "24.4")) +;; URL: https://savannah.gnu.org/projects/tramp ;; This file is part of GNU Emacs. @@ -35,8 +38,6 @@ ;; Notes: ;; ----- ;; -;; This package only works for Emacs 24.1 and higher. -;; ;; Also see the todo list at the bottom of this file. ;; ;; The current version of Tramp can be retrieved from the following URL: @@ -56,12 +57,13 @@ ;;; Code: (require 'tramp-compat) +(require 'tramp-integration) +(require 'trampver) ;; Pacify byte-compiler. (require 'cl-lib) +(declare-function netrc-parse "netrc") (defvar auto-save-file-name-transforms) -(defvar eshell-path-env) -(defvar ls-lisp-use-insert-directory-program) (defvar outline-regexp) ;;; User Customizable Internal Variables: @@ -73,6 +75,16 @@ :link '(custom-manual "(tramp)Top") :version "22.1") +(eval-and-compile ;; So it's also available in tramp-loaddefs.el! + (defvar tramp--startup-hook nil + "Forms to be executed at the end of tramp.el.") + + (defmacro tramp--with-startup (&rest body) + "Schedule BODY to be executed at the end of tramp.el." + `(add-hook 'tramp--startup-hook (lambda () ,@body)))) + +(require 'tramp-loaddefs) + ;; Maybe we need once a real Tramp mode, with key bindings etc. ;;;###autoload (defcustom tramp-mode t @@ -122,8 +134,10 @@ This setting has precedence over `auto-save-file-name-transforms'." :type '(choice (const :tag "Use default" nil) (directory :tag "Auto save directory name"))) +;; Suppress `shell-file-name' for w32 systems. (defcustom tramp-encoding-shell - (or (tramp-compat-funcall 'w32-shell-name) "/bin/sh") + (let (shell-file-name) + (or (tramp-compat-funcall 'w32-shell-name) "/bin/sh")) "Use this program for encoding and decoding commands on the local host. This shell is used to execute the encoding and decoding command on the local host, so if you want to use `~' in those commands, you should @@ -146,27 +160,31 @@ use for the remote host." :group 'tramp :type '(file :must-match t)) +;; Suppress `shell-file-name' for w32 systems. (defcustom tramp-encoding-command-switch - (if (tramp-compat-funcall 'w32-shell-dos-semantics) "/c" "-c") + (let (shell-file-name) + (if (tramp-compat-funcall 'w32-shell-dos-semantics) "/c" "-c")) "Use this switch together with `tramp-encoding-shell' for local commands. See the variable `tramp-encoding-shell' for more information." :group 'tramp :type 'string) +;; Suppress `shell-file-name' for w32 systems. (defcustom tramp-encoding-command-interactive - (unless (tramp-compat-funcall 'w32-shell-dos-semantics) "-i") + (let (shell-file-name) + (unless (tramp-compat-funcall 'w32-shell-dos-semantics) "-i")) "Use this switch together with `tramp-encoding-shell' for interactive shells. See the variable `tramp-encoding-shell' for more information." :version "24.1" :group 'tramp :type '(choice (const nil) string)) -;;;###tramp-autoload (defvar tramp-methods nil "Alist of methods for remote files. This is a list of entries of the form (NAME PARAM1 PARAM2 ...). Each NAME stands for a remote access method. Each PARAM is a pair of the form (KEY VALUE). The following KEYs are defined: + * `tramp-remote-shell' This specifies the shell to use on the remote host. This MUST be a Bourne-like shell. It is normally not necessary to @@ -175,19 +193,23 @@ pair of the form (KEY VALUE). The following KEYs are defined: for it. Also note that \"/bin/sh\" exists on all Unixen, this might not be true for the value that you decide to use. You Have Been Warned. + * `tramp-remote-shell-login' This specifies the arguments to let `tramp-remote-shell' run as a login shell. It defaults to (\"-l\"), but some shells, like ksh, require another argument. See `tramp-connection-properties' for a way to overwrite the default value. + * `tramp-remote-shell-args' For implementation of `shell-command', this specifies the arguments to let `tramp-remote-shell' run a single command. + * `tramp-login-program' This specifies the name of the program to use for logging in to the remote host. This may be the name of rsh or a workalike program, or the name of telnet or a workalike, or the name of su or a workalike. + * `tramp-login-args' This specifies the list of arguments to pass to the above mentioned program. Please note that this is a list of list of arguments, @@ -203,55 +225,88 @@ pair of the form (KEY VALUE). The following KEYs are defined: `tramp-make-tramp-temp-file'. \"%k\" indicates the keep-date parameter of a program, if exists. \"%c\" adds additional `tramp-ssh-controlmaster-options' options for the first hop. + The existence of `tramp-login-args', combined with the absence of + `tramp-copy-args', is an indication that the method is capable of + multi-hops. + * `tramp-login-env' A list of environment variables and their values, which will be set when calling `tramp-login-program'. + * `tramp-async-args' When an asynchronous process is started, we know already that the connection works. Therefore, we can pass additional parameters to suppress diagnostic messages, in order not to tamper the process output. + * `tramp-copy-program' This specifies the name of the program to use for remotely copying the file; this might be the absolute filename of scp or the name of a workalike program. It is always applied on the local host. + * `tramp-copy-args' This specifies the list of parameters to pass to the above mentioned program, the hints for `tramp-login-args' also apply here. + * `tramp-copy-env' A list of environment variables and their values, which will be set when calling `tramp-copy-program'. + * `tramp-remote-copy-program' The listener program to be applied on remote side, if needed. + * `tramp-remote-copy-args' The list of parameters to pass to the listener program, the hints for `tramp-login-args' also apply here. Additionally, \"%r\" could be used here and in `tramp-copy-args'. It denotes a randomly chosen port for the remote listener. + * `tramp-copy-keep-date' This specifies whether the copying program when the preserves the timestamp of the original file. + * `tramp-copy-keep-tmpfile' This specifies whether a temporary local file shall be kept for optimization reasons (useful for \"rsync\" methods). + * `tramp-copy-recursive' Whether the operation copies directories recursively. + * `tramp-default-port' The default port of a method. + * `tramp-tmpdir' A directory on the remote host for temporary files. If not specified, \"/tmp\" is taken as default. + * `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. + + * `tramp-session-timeout' + How long a Tramp connection keeps open before being disconnected. + This is useful for methods like \"su\" or \"sudo\", which + shouldn't run an open connection in the background forever. + * `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 perform further checks on the remote host. See `tramp-connection-properties' for a way to overwrite this. + * `tramp-mount-args' + * `tramp-copyto-args' + * `tramp-moveto-args' + * `tramp-about-args' + These parameters, a list of list like `tramp-login-args', are used + for the \"rclone\" method, and are appended to the respective + \"rclone\" commands. In general, they shouldn't be changed inside + `tramp-methods'; it is recommended to change their values via + `tramp-connection-properties'. Unlike `tramp-login-args' there is + no pattern replacement. + What does all this mean? Well, you should specify `tramp-login-program' for all methods; this program is used to log in to the remote site. Then, there are two ways to actually transfer the files between the local and the @@ -304,7 +359,6 @@ Also see `tramp-default-method-alist'." :group 'tramp :type 'string) -;;;###tramp-autoload (defcustom tramp-default-method-alist nil "Default method to use for specific host/user pairs. This is an alist of items (HOST USER METHOD). The first matching item @@ -334,7 +388,6 @@ This variable is regarded as obsolete, and will be removed soon." :group 'tramp :type '(choice (const nil) string)) -;;;###tramp-autoload (defcustom tramp-default-user-alist nil "Default user to use for specific method/host pairs. This is an alist of items (METHOD HOST USER). The first matching item @@ -356,7 +409,6 @@ Useful for su and sudo methods mostly." :group 'tramp :type 'string) -;;;###tramp-autoload (defcustom tramp-default-host-alist nil "Default host to use for specific method/user pairs. This is an alist of items (METHOD USER HOST). The first matching item @@ -378,11 +430,17 @@ empty string for the method name." This is an alist of items (HOST USER PROXY). The first matching item specifies the proxy to be passed for a file name located on a remote target matching USER@HOST. HOST and USER are regular -expressions. PROXY must be a Tramp filename without a localname -part. Method and user name on PROXY are optional, which is -interpreted with the default values. PROXY can contain the -patterns %h and %u, which are replaced by the strings matching -HOST or USER, respectively. +expressions, which could also cover a domain (USER%DOMAIN) or +port (HOST#PORT). PROXY must be a Tramp filename without a +localname part. Method and user name on PROXY are optional, +which is interpreted with the default values. + +PROXY can contain the patterns %h and %u, which are replaced by +the strings matching HOST or USER (without DOMAIN and PORT parts), +respectively. + +If an entry is added while parsing ad-hoc hop definitions, PROXY +carries the non-nil text property `tramp-ad-hoc'. HOST, USER or PROXY could also be Lisp forms, which will be evaluated. The result must be a string or nil, which is @@ -410,14 +468,18 @@ host runs a registered shell, it shall be added to this list, too." :group 'tramp :type '(repeat (regexp :tag "Host regexp"))) -;;;###tramp-autoload -(defconst tramp-local-host-regexp +(defcustom tramp-local-host-regexp (concat "\\`" (regexp-opt (list "localhost" "localhost6" (system-name) "127.0.0.1" "::1") t) "\\'") - "Host names which are regarded as local host.") + "Host names which are regarded as local host. +If the local host runs a chrooted environment, set this to nil." + :version "27.1" + :group 'tramp + :type '(choice (const :tag "Chrooted environment" nil) + (regexp :tag "Host regexp"))) (defvar tramp-completion-function-alist nil "Alist of methods for remote files. @@ -510,10 +572,7 @@ This regexp must match both `tramp-initial-end-of-output' and :type 'regexp) (defcustom tramp-password-prompt-regexp - (format "^.*\\(%s\\).*:\^@? *" - ;; `password-word-equivalents' has been introduced with Emacs 24.4. - (regexp-opt (or (bound-and-true-p password-word-equivalents) - '("password" "passphrase")))) + (format "^.*\\(%s\\).*:\^@? *" (regexp-opt password-word-equivalents)) "Regexp matching password-like prompts. The regexp should match at end of buffer. @@ -549,7 +608,10 @@ The regexp should match at end of buffer." (defcustom tramp-yesno-prompt-regexp (concat - (regexp-opt '("Are you sure you want to continue connecting (yes/no)?") t) + (regexp-opt + '("Are you sure you want to continue connecting (yes/no)?" + "Are you sure you want to continue connecting (yes/no/[fingerprint])?") + t) "\\s-*") "Regular expression matching all yes/no queries which need to be confirmed. The confirmation should be done with yes or no. @@ -632,7 +694,6 @@ Useful for \"rsync\" like methods.") (make-variable-buffer-local 'tramp-temp-buffer-file-name) (put 'tramp-temp-buffer-file-name 'permanent-local t) -;;;###tramp-autoload (defcustom tramp-syntax 'default "Tramp filename syntax to be used. @@ -651,8 +712,8 @@ Customize. See also `tramp-change-syntax'." (const :tag "Ange-FTP" simplified) (const :tag "XEmacs" separate)) :require 'tramp - :initialize 'custom-initialize-set - :set 'tramp-set-syntax) + :initialize #'custom-initialize-default + :set #'tramp-set-syntax) (defun tramp-set-syntax (symbol value) "Set SYMBOL to value VALUE. @@ -660,7 +721,7 @@ Used in user option `tramp-syntax'. There are further variables to be set, depending on VALUE." ;; Check allowed values. (unless (memq value (tramp-syntax-values)) - (tramp-compat-user-error "Wrong `tramp-syntax' %s" tramp-syntax)) + (tramp-user-error "Wrong `tramp-syntax' %s" value)) ;; Cleanup existing buffers. (unless (eq (symbol-value symbol) value) (tramp-cleanup-all-buffers)) @@ -692,14 +753,15 @@ to be set, depending on VALUE." ;; value of `tramp-file-name-regexp'. Other Tramp syntax variables ;; must be initialized as well to proper values. We do not call ;; `custom-set-variable', this would load Tramp via custom.el. -(eval-after-load 'tramp - '(tramp-set-syntax 'tramp-syntax (tramp-compat-tramp-syntax))) +(tramp--with-startup + (tramp-set-syntax 'tramp-syntax (tramp-compat-tramp-syntax))) (defun tramp-syntax-values () "Return possible values of `tramp-syntax', a list" (let ((values (cdr (get 'tramp-syntax 'custom-type)))) - (setq values (mapcar 'last values) - values (mapcar 'car values)))) + (setq values (mapcar #'last values) + values (mapcar #'car values)) + values)) (defun tramp-lookup-syntax (alist) "Look up a syntax string in ALIST according to `tramp-compat-tramp-syntax.' @@ -716,14 +778,14 @@ Raise an error if `tramp-syntax' is invalid." (defun tramp-build-prefix-format () (tramp-lookup-syntax tramp-prefix-format-alist)) -(defvar tramp-prefix-format (tramp-build-prefix-format) +(defvar tramp-prefix-format nil ;Initialized when defining `tramp-syntax'! "String matching the very beginning of Tramp file names. Used in `tramp-make-tramp-file-name'.") (defun tramp-build-prefix-regexp () (concat "^" (regexp-quote tramp-prefix-format))) -(defvar tramp-prefix-regexp (tramp-build-prefix-regexp) +(defvar tramp-prefix-regexp nil ;Initialized when defining `tramp-syntax'! "Regexp matching the very beginning of Tramp file names. Should always start with \"^\". Derived from `tramp-prefix-format'.") @@ -736,7 +798,7 @@ Should always start with \"^\". Derived from `tramp-prefix-format'.") (defun tramp-build-method-regexp () (tramp-lookup-syntax tramp-method-regexp-alist)) -(defvar tramp-method-regexp (tramp-build-method-regexp) +(defvar tramp-method-regexp nil ;Initialized when defining `tramp-syntax'! "Regexp matching methods identifiers. The `ftp' syntax does not support methods.") @@ -749,7 +811,7 @@ The `ftp' syntax does not support methods.") (defun tramp-build-postfix-method-format () (tramp-lookup-syntax tramp-postfix-method-format-alist)) -(defvar tramp-postfix-method-format (tramp-build-postfix-method-format) +(defvar tramp-postfix-method-format nil ;Init'd when defining `tramp-syntax'! "String matching delimiter between method and user or host names. The `ftp' syntax does not support methods. Used in `tramp-make-tramp-file-name'.") @@ -757,18 +819,16 @@ Used in `tramp-make-tramp-file-name'.") (defun tramp-build-postfix-method-regexp () (regexp-quote tramp-postfix-method-format)) -(defvar tramp-postfix-method-regexp (tramp-build-postfix-method-regexp) +(defvar tramp-postfix-method-regexp nil ;Init'd when defining `tramp-syntax'! "Regexp matching delimiter between method and user or host names. Derived from `tramp-postfix-method-format'.") (defconst tramp-user-regexp "[^/|: \t]+" "Regexp matching user names.") -;;;###tramp-autoload (defconst tramp-prefix-domain-format "%" "String matching delimiter between user and domain names.") -;;;###tramp-autoload (defconst tramp-prefix-domain-regexp (regexp-quote tramp-prefix-domain-format) "Regexp matching delimiter between user and domain names. Derived from `tramp-prefix-domain-format'.") @@ -802,21 +862,21 @@ Derived from `tramp-postfix-user-format'.") (defun tramp-build-prefix-ipv6-format () (tramp-lookup-syntax tramp-prefix-ipv6-format-alist)) -(defvar tramp-prefix-ipv6-format (tramp-build-prefix-ipv6-format) +(defvar tramp-prefix-ipv6-format nil ;Initialized when defining `tramp-syntax'! "String matching left hand side of IPv6 addresses. Used in `tramp-make-tramp-file-name'.") (defun tramp-build-prefix-ipv6-regexp () (regexp-quote tramp-prefix-ipv6-format)) -(defvar tramp-prefix-ipv6-regexp (tramp-build-prefix-ipv6-regexp) +(defvar tramp-prefix-ipv6-regexp nil ;Initialized when defining `tramp-syntax'! "Regexp matching left hand side of IPv6 addresses. Derived from `tramp-prefix-ipv6-format'.") ;; The following regexp is a bit sloppy. But it shall serve our ;; purposes. It covers also IPv4 mapped IPv6 addresses, like in ;; "::ffff:192.168.0.1". -(defconst tramp-ipv6-regexp "\\(?:\\(?:[a-zA-Z0-9]+\\)?:\\)+[a-zA-Z0-9.]+" +(defconst tramp-ipv6-regexp "\\(?:[a-zA-Z0-9]*:\\)+[a-zA-Z0-9.]+" "Regexp matching IPv6 addresses.") (defconst tramp-postfix-ipv6-format-alist @@ -828,14 +888,14 @@ Derived from `tramp-prefix-ipv6-format'.") (defun tramp-build-postfix-ipv6-format () (tramp-lookup-syntax tramp-postfix-ipv6-format-alist)) -(defvar tramp-postfix-ipv6-format (tramp-build-postfix-ipv6-format) +(defvar tramp-postfix-ipv6-format nil ;Initialized when defining `tramp-syntax'! "String matching right hand side of IPv6 addresses. Used in `tramp-make-tramp-file-name'.") (defun tramp-build-postfix-ipv6-regexp () (regexp-quote tramp-postfix-ipv6-format)) -(defvar tramp-postfix-ipv6-regexp (tramp-build-postfix-ipv6-regexp) +(defvar tramp-postfix-ipv6-regexp nil ;Initialized when defining `tramp-syntax'! "Regexp matching right hand side of IPv6 addresses. Derived from `tramp-postfix-ipv6-format'.") @@ -871,18 +931,18 @@ Derived from `tramp-postfix-hop-format'.") (defun tramp-build-postfix-host-format () (tramp-lookup-syntax tramp-postfix-host-format-alist)) -(defvar tramp-postfix-host-format (tramp-build-postfix-host-format) +(defvar tramp-postfix-host-format nil ;Initialized when defining `tramp-syntax'! "String matching delimiter between host names and localnames. Used in `tramp-make-tramp-file-name'.") (defun tramp-build-postfix-host-regexp () (regexp-quote tramp-postfix-host-format)) -(defvar tramp-postfix-host-regexp (tramp-build-postfix-host-regexp) +(defvar tramp-postfix-host-regexp nil ;Initialized when defining `tramp-syntax'! "Regexp matching delimiter between host names and localnames. Derived from `tramp-postfix-host-format'.") -(defconst tramp-localname-regexp ".*$" +(defconst tramp-localname-regexp "[^\n\r]*\\'" "Regexp matching localnames.") (defconst tramp-unknown-id-string "UNKNOWN" @@ -905,7 +965,7 @@ It is expected, that `tramp-syntax' has the proper value." "\\(?:" tramp-prefix-port-regexp tramp-port-regexp "\\)?" "\\)?")) (defvar tramp-remote-file-name-spec-regexp - (tramp-build-remote-file-name-spec-regexp) + nil ;Initialized when defining `tramp-syntax'! "Regular expression matching a Tramp file name between prefix and postfix.") (defun tramp-build-file-name-structure () @@ -921,7 +981,7 @@ See `tramp-file-name-structure'." "\\(" tramp-localname-regexp "\\)") 5 6 7 8 1)) -(defvar tramp-file-name-structure (tramp-build-file-name-structure) +(defvar tramp-file-name-structure nil ;Initialized when defining `tramp-syntax'! "List of six elements (REGEXP METHOD USER HOST FILE HOP), detailing \ the Tramp file name structure. @@ -956,6 +1016,13 @@ This regexp should match Tramp file names but no other file names. When calling `tramp-register-file-name-handlers', the initial value is overwritten by the car of `tramp-file-name-structure'.") +;;;###autoload +(defcustom tramp-ignored-file-name-regexp nil + "Regular expression matching file names that are not under Tramp’s control." + :version "27.1" + :group 'tramp + :type '(choice (const nil) regexp)) + (defconst tramp-completion-file-name-regexp-default (concat "\\`/\\(" @@ -1007,7 +1074,7 @@ See `tramp-file-name-structure' for more explanations.") (tramp-lookup-syntax tramp-completion-file-name-regexp-alist)) (defvar tramp-completion-file-name-regexp - (tramp-build-completion-file-name-regexp) + nil ;Initialized when defining `tramp-syntax'! "Regular expression matching file names handled by Tramp completion. This regexp should match partial Tramp file names only. @@ -1149,23 +1216,15 @@ means to use always cached values for the directory contents." ;;; Internal Variables: -(defvar tramp-current-method nil - "Connection method for this *tramp* buffer.") - -(defvar tramp-current-user nil - "Remote login name for this *tramp* buffer.") - -(defvar tramp-current-domain nil - "Remote domain name for this *tramp* buffer.") - -(defvar tramp-current-host nil - "Remote host for this *tramp* buffer.") - -(defvar tramp-current-port nil - "Remote port for this *tramp* buffer.") - (defvar tramp-current-connection nil - "Last connection timestamp.") + "Last connection timestamp. +It is a cons cell of the actual `tramp-file-name-structure', and +the (optional) timestamp of last activity on this connection.") + +(defvar tramp-password-save-function nil + "Password save function. +Will be called once the password has been verified by successful +authentication.") (defconst tramp-completion-file-name-handler-alist '((file-name-all-completions @@ -1177,7 +1236,6 @@ Operations not mentioned here will be handled by Tramp's file name handler functions, or the normal Emacs functions.") ;; Handlers for foreign methods, like FTP or SMB, shall be plugged here. -;;;###tramp-autoload (defvar tramp-foreign-file-name-handler-alist nil "Alist of elements (FUNCTION . HANDLER) for foreign methods handled specially. If (FUNCTION FILENAME) returns non-nil, then all I/O on that file is done by @@ -1216,6 +1274,7 @@ If nil, return `tramp-default-port'." (or (tramp-file-name-port vec) (tramp-get-method-parameter vec 'tramp-default-port))) +;; Comparision of file names is performed by `tramp-equal-remote'. (defun tramp-file-name-equal-p (vec1 vec2) "Check, whether VEC1 and VEC2 denote the same `tramp-file-name'." (and (tramp-file-name-p vec1) (tramp-file-name-p vec2) @@ -1246,22 +1305,24 @@ entry does not exist, return nil." "Return unquoted localname component of VEC." (tramp-compat-file-name-unquote (tramp-file-name-localname vec))) -;;;###tramp-autoload (defun tramp-tramp-file-p (name) "Return t if NAME is a string with Tramp file name syntax." - (and (stringp name) + (and tramp-mode (stringp name) ;; No "/:" and "/c:". This is not covered by `tramp-file-name-regexp'. (not (string-match-p (if (memq system-type '(cygwin windows-nt)) "^/[[:alpha:]]?:" "^/:") name)) + ;; Excluded file names. + (or (null tramp-ignored-file-name-regexp) + (not (string-match-p tramp-ignored-file-name-regexp name))) (string-match-p tramp-file-name-regexp name) t)) (defun tramp-find-method (method user host) "Return the right method string to use. This is METHOD, if non-nil. Otherwise, do a lookup in -`tramp-default-method-alist'." +`tramp-default-method-alist' and `tramp-default-method'." (when (and method (or (string-equal method "") (string-equal method tramp-default-method-marker))) @@ -1272,8 +1333,8 @@ This is METHOD, if non-nil. Otherwise, do a lookup in lmethod item) (while choices (setq item (pop choices)) - (when (and (string-match (or (nth 0 item) "") (or host "")) - (string-match (or (nth 1 item) "") (or user ""))) + (when (and (string-match-p (or (nth 0 item) "") (or host "")) + (string-match-p (or (nth 1 item) "") (or user ""))) (setq lmethod (nth 2 item)) (setq choices nil))) lmethod) @@ -1286,15 +1347,15 @@ This is METHOD, if non-nil. Otherwise, do a lookup in (defun tramp-find-user (method user host) "Return the right user string to use. This is USER, if non-nil. Otherwise, do a lookup in -`tramp-default-user-alist'." +`tramp-default-user-alist' and `tramp-default-user'." (let ((result (or user (let ((choices tramp-default-user-alist) luser item) (while choices (setq item (pop choices)) - (when (and (string-match (or (nth 0 item) "") (or method "")) - (string-match (or (nth 1 item) "") (or host ""))) + (when (and (string-match-p (or (nth 0 item) "") (or method "")) + (string-match-p (or (nth 1 item) "") (or host ""))) (setq luser (nth 2 item)) (setq choices nil))) luser) @@ -1306,18 +1367,24 @@ This is USER, if non-nil. Otherwise, do a lookup in (defun tramp-find-host (method user host) "Return the right host string to use. -This is HOST, if non-nil. Otherwise, it is `tramp-default-host'." - (or (and (> (length host) 0) host) - (let ((choices tramp-default-host-alist) - lhost item) - (while choices - (setq item (pop choices)) - (when (and (string-match (or (nth 0 item) "") (or method "")) - (string-match (or (nth 1 item) "") (or user ""))) - (setq lhost (nth 2 item)) - (setq choices nil))) - lhost) - tramp-default-host)) +This is HOST, if non-nil. Otherwise, do a lookup in +`tramp-default-host-alist' and `tramp-default-host'." + (let ((result + (or (and (> (length host) 0) host) + (let ((choices tramp-default-host-alist) + lhost item) + (while choices + (setq item (pop choices)) + (when (and (string-match-p (or (nth 0 item) "") (or method "")) + (string-match-p (or (nth 1 item) "") (or user ""))) + (setq lhost (nth 2 item)) + (setq choices nil))) + lhost) + tramp-default-host))) + ;; We must mark, whether a default value has been used. + (if (or (> (length host) 0) (null result)) + result + (propertize result 'tramp-default t)))) (defun tramp-dissect-file-name (name &optional nodefault) "Return a `tramp-file-name' structure of NAME, a remote file name. @@ -1329,7 +1396,7 @@ to their default values. For the other file name parts, no default values are used." (save-match-data (unless (tramp-tramp-file-p name) - (tramp-compat-user-error nil "Not a Tramp file name: \"%s\"" name)) + (tramp-user-error nil "Not a Tramp file name: \"%s\"" name)) (if (not (string-match (nth 0 tramp-file-name-structure) name)) (error "`tramp-file-name-structure' didn't match!") (let ((method (match-string (nth 1 tramp-file-name-structure) name)) @@ -1337,7 +1404,7 @@ default values are used." (host (match-string (nth 3 tramp-file-name-structure) name)) (localname (match-string (nth 4 tramp-file-name-structure) name)) (hop (match-string (nth 5 tramp-file-name-structure) name)) - domain port) + domain port v) (when user (when (string-match tramp-user-with-domain-regexp user) (setq domain (match-string 2 user) @@ -1353,13 +1420,56 @@ default values are used." (setq host (replace-match "" nil t host)))) (unless nodefault - (setq method (tramp-find-method method user host) - user (tramp-find-user method user host) - host (tramp-find-host method user host))) - - (make-tramp-file-name - :method method :user user :domain domain :host host :port port - :localname (or localname "") :hop hop))))) + (when hop + (setq v (tramp-dissect-hop-name hop) + hop (and hop (tramp-make-tramp-hop-name v)))) + (let ((tramp-default-host + (or (and v (not (string-match-p "%h" (tramp-file-name-host v))) + (tramp-file-name-host v)) + tramp-default-host))) + (setq method (tramp-find-method method user host) + user (tramp-find-user method user host) + host (tramp-find-host method user host) + hop + (and hop + (format-spec hop (format-spec-make ?h host ?u user)))))) + + ;; Return result. + (prog1 + (setq v (make-tramp-file-name + :method method :user user :domain domain :host host + :port port :localname localname :hop hop)) + ;; The method must be known. + (unless (or (tramp-completion-mode-p) + (string-equal method tramp-default-method-marker) + (assoc method tramp-methods)) + (tramp-user-error + v "Method `%s' is not known." method)) + ;; Only some methods from tramp-sh.el do support multi-hops. + (when (and + hop + (or (not (tramp-get-method-parameter v 'tramp-login-program)) + (tramp-get-method-parameter v 'tramp-copy-program))) + (tramp-user-error + v "Method `%s' is not supported for multi-hops." method))))))) + +(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." + (let ((v (tramp-dissect-file-name + (concat tramp-prefix-format + (replace-regexp-in-string + (concat tramp-postfix-hop-regexp "$") + tramp-postfix-host-format name)) + nodefault))) + ;; Only some methods from tramp-sh.el do support multi-hops. + (when (or (not (tramp-get-method-parameter v 'tramp-login-program)) + (tramp-get-method-parameter v 'tramp-copy-program)) + (tramp-user-error + v "Method `%s' is not supported for multi-hops." + (tramp-file-name-method v))) + ;; Return result. + v)) (defun tramp-buffer-name (vec) "A name for the connection buffer VEC." @@ -1370,33 +1480,75 @@ default values are used." (format "*tramp/%s %s@%s*" method user-domain host-port) (format "*tramp/%s %s*" method host-port)))) -(defun tramp-make-tramp-file-name - (method user domain host port localname &optional hop) - "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME. -When not nil, optional DOMAIN, PORT and HOP are used." - ;; Unless `tramp-syntax' is `simplified', we need a method. - (when (and (not (zerop (length tramp-postfix-method-format))) - (zerop (length method))) - (signal 'wrong-type-argument (list 'stringp method))) - (concat tramp-prefix-format hop - (unless (zerop (length tramp-postfix-method-format)) - (concat method tramp-postfix-method-format)) - user - (unless (zerop (length domain)) - (concat tramp-prefix-domain-format domain)) - (unless (zerop (length user)) - tramp-postfix-user-format) - (when host - (if (string-match tramp-ipv6-regexp host) - (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) - host)) - (unless (zerop (length port)) - (concat tramp-prefix-port-format port)) - tramp-postfix-host-format - (when localname localname))) +(defun tramp-make-tramp-file-name (&rest args) + "Construct a Tramp file name from ARGS. + +ARGS could have two different signatures. The first one is of +type (VEC &optional LOCALNAME HOP). +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)." + (let (method user domain host port localname hop) + (cond + ((tramp-file-name-p (car args)) + (setq method (tramp-file-name-method (car args)) + user (tramp-file-name-user (car args)) + domain (tramp-file-name-domain (car args)) + host (tramp-file-name-host (car args)) + port (tramp-file-name-port (car args)) + localname (tramp-file-name-localname (car args)) + 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))))) + + (t (setq method (nth 0 args) + user (nth 1 args) + domain (nth 2 args) + host (nth 3 args) + port (nth 4 args) + localname (nth 5 args) + hop (nth 6 args)))) + + ;; Unless `tramp-syntax' is `simplified', we need a method. + (when (and (not (zerop (length tramp-postfix-method-format))) + (zerop (length method))) + (signal 'wrong-type-argument (list #'stringp method))) + (concat tramp-prefix-format hop + (unless (zerop (length tramp-postfix-method-format)) + (concat method tramp-postfix-method-format)) + user + (unless (zerop (length domain)) + (concat tramp-prefix-domain-format domain)) + (unless (zerop (length user)) + tramp-postfix-user-format) + (when host + (if (string-match-p tramp-ipv6-regexp host) + (concat + tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) + host)) + (unless (zerop (length port)) + (concat tramp-prefix-port-format port)) + tramp-postfix-host-format + localname))) + +(defun tramp-make-tramp-hop-name (vec) + "Construct a Tramp hop name from VEC." + (replace-regexp-in-string + 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) - "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME. + "Construct a Tramp file name from METHOD, USER, HOST and LOCALNAME. It must not be a complete Tramp file name, but as long as there are necessary only. This function will be used in file name completion." (concat tramp-prefix-format @@ -1407,7 +1559,7 @@ necessary only. This function will be used in file name completion." (concat user tramp-postfix-user-format)) (unless (zerop (length host)) (concat - (if (string-match tramp-ipv6-regexp host) + (if (string-match-p tramp-ipv6-regexp host) (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) host) @@ -1423,15 +1575,8 @@ necessary only. This function will be used in file name completion." (tramp-set-connection-property vec "process-buffer" (tramp-get-connection-property vec "process-buffer" nil)) - (setq buffer-undo-list t) - (setq default-directory - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - "/")) + (setq buffer-undo-list t + default-directory (tramp-make-tramp-file-name vec 'noloc 'nohop)) (current-buffer)))) (defun tramp-get-connection-buffer (vec) @@ -1506,8 +1651,6 @@ The outline level is equal to the verbosity of the Tramp message." (get-buffer-create (tramp-debug-buffer-name vec)) (when (bobp) (setq buffer-undo-list t) - ;; So it does not get loaded while `outline-regexp' is let-bound. - (require 'outline) ;; 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". @@ -1517,7 +1660,9 @@ The outline level is equal to the verbosity of the Tramp message." (outline-regexp tramp-debug-outline-regexp)) (outline-mode)) (set (make-local-variable 'outline-regexp) tramp-debug-outline-regexp) - (set (make-local-variable 'outline-level) 'tramp-debug-outline-level)) + (set (make-local-variable 'outline-level) 'tramp-debug-outline-level) + ;; Do not edit the debug buffer. + (use-local-map special-mode-map)) (current-buffer))) (defsubst tramp-debug-message (vec fmt-string &rest arguments) @@ -1533,10 +1678,13 @@ ARGUMENTS to actually emit the message (if applicable)." ";; Emacs: %s Tramp: %s -*- mode: outline; -*-" emacs-version tramp-version)) (when (>= tramp-verbose 10) - (insert - (format - "\n;; Location: %s Git: %s" - (locate-library "tramp") (tramp-repository-get-version))))) + (let ((tramp-verbose 0)) + (insert + (format + "\n;; Location: %s Git: %s/%s" + (locate-library "tramp") + (or tramp-repository-branch "") + (or tramp-repository-version "")))))) (unless (bolp) (insert "\n")) ;; Timestamp. @@ -1554,22 +1702,23 @@ ARGUMENTS to actually emit the message (if applicable)." (setq fn (symbol-name btf)) (unless (and - (string-match "^tramp" fn) + (string-match-p "^tramp" fn) (not - (string-match - (concat - "^" - (regexp-opt - '("tramp-backtrace" - "tramp-compat-funcall" - "tramp-compat-user-error" - "tramp-condition-case-unless-debug" - "tramp-debug-message" - "tramp-error" - "tramp-error-with-buffer" - "tramp-message") - t) - "$") + (string-match-p + (eval-when-compile + (concat + "^" + (regexp-opt + '("tramp-backtrace" + "tramp-compat-funcall" + "tramp-debug-message" + "tramp-error" + "tramp-error-with-buffer" + "tramp-message" + "tramp-signal-hook-function" + "tramp-user-error") + t) + "$")) fn))) (setq fn nil))) (setq btn (1+ btn)))) @@ -1607,54 +1756,54 @@ control string and the remaining ARGUMENTS to actually emit the message (if applicable)." (ignore-errors (when (<= level tramp-verbose) - ;; Match data must be preserved! - (save-match-data - ;; Display only when there is a minimum level. - (when (and tramp-message-show-message (<= level 3)) - (apply 'message - (concat - (cond - ((= level 0) "") - ((= level 1) "") - ((= level 2) "Warning: ") - (t "Tramp: ")) - fmt-string) - arguments)) - ;; Log only when there is a minimum level. - (when (>= tramp-verbose 4) - ;; Translate proc to vec. - (when (processp vec-or-proc) - (let ((tramp-verbose 0)) - (setq vec-or-proc - (tramp-get-connection-property vec-or-proc "vector" nil)))) + ;; Display only when there is a minimum level. + (when (and tramp-message-show-message (<= level 3)) + (apply #'message + (concat + (cond + ((= level 0) "") + ((= level 1) "") + ((= level 2) "Warning: ") + (t "Tramp: ")) + fmt-string) + arguments)) + ;; Log only when there is a minimum level. + (when (>= tramp-verbose 4) + (let ((tramp-verbose 0)) ;; Append connection buffer for error messages. (when (= level 1) - (let ((tramp-verbose 0)) - (with-current-buffer (tramp-get-connection-buffer vec-or-proc) - (setq fmt-string (concat fmt-string "\n%s") - arguments (append arguments (list (buffer-string))))))) - ;; Do it. - (when (tramp-file-name-p vec-or-proc) - (apply 'tramp-debug-message - vec-or-proc - (concat (format "(%d) # " level) fmt-string) - arguments))))))) + (with-current-buffer + (if (processp vec-or-proc) + (process-buffer vec-or-proc) + (tramp-get-connection-buffer vec-or-proc)) + (setq fmt-string (concat fmt-string "\n%s") + arguments (append arguments (list (buffer-string)))))) + ;; Translate proc to vec. + (when (processp vec-or-proc) + (setq vec-or-proc (process-get vec-or-proc 'vector)))) + ;; Do it. + (when (tramp-file-name-p vec-or-proc) + (apply #'tramp-debug-message + vec-or-proc + (concat (format "(%d) # " level) fmt-string) + arguments)))))) (defsubst tramp-backtrace (&optional vec-or-proc) "Dump a backtrace into the debug buffer. If VEC-OR-PROC is nil, the buffer *debug tramp* is used. This function is meant for debugging purposes." - (if vec-or-proc - (tramp-message vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))) - (if (>= tramp-verbose 10) - (with-output-to-temp-buffer "*debug tramp*" (backtrace))))) + (when (>= tramp-verbose 10) + (if vec-or-proc + (tramp-message + vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))) + (with-output-to-temp-buffer "*debug tramp*" (backtrace))))) (defsubst tramp-error (vec-or-proc signal fmt-string &rest arguments) "Emit an error. VEC-OR-PROC identifies the connection to use, SIGNAL is the signal identifier to be raised, remaining arguments passed to `tramp-message'. Finally, signal SIGNAL is raised." - (let (tramp-message-show-message) + (let (tramp-message-show-message signal-hook-function) (tramp-backtrace vec-or-proc) (unless arguments ;; FMT-STRING could be just a file name, as in @@ -1685,7 +1834,7 @@ an input event arrives. The other arguments are passed to `tramp-error'." (and buf (with-current-buffer buf (tramp-dissect-file-name default-directory)))))) (unwind-protect - (apply 'tramp-error vec-or-proc signal fmt-string arguments) + (apply #'tramp-error vec-or-proc signal fmt-string arguments) ;; Save exit. (when (and buf tramp-message-show-message @@ -1697,7 +1846,7 @@ an input event arrives. The other arguments are passed to `tramp-error'." (let ((enable-recursive-minibuffers t)) ;; `tramp-error' does not show messages. So we must do it ;; ourselves. - (apply 'message fmt-string arguments) + (apply #'message fmt-string arguments) ;; Show buffer. (pop-to-buffer buf) (discard-input) @@ -1706,6 +1855,28 @@ an input event arrives. The other arguments are passed to `tramp-error'." (when (tramp-file-name-equal-p vec (car tramp-current-connection)) (setcdr tramp-current-connection (current-time))))))) +;; We must make it a defun, because it is used earlier already. +(defun tramp-user-error (vec-or-proc fmt-string &rest arguments) + "Signal a user error (or \"pilot error\")." + (unwind-protect + (apply #'tramp-error vec-or-proc 'user-error fmt-string arguments) + ;; Save exit. + (when (and tramp-message-show-message + (not (zerop tramp-verbose)) + ;; Do not show when flagged from outside. + (not (tramp-completion-mode-p)) + ;; Show only when Emacs has started already. + (current-message)) + (let ((enable-recursive-minibuffers t)) + ;; `tramp-error' does not show messages. So we must do it ourselves. + (apply #'message fmt-string arguments) + (discard-input) + (sit-for 30) + ;; Reset timestamp. It would be wrong after waiting for a while. + (when + (tramp-file-name-equal-p vec-or-proc (car tramp-current-connection)) + (setcdr tramp-current-connection (current-time))))))) + (defmacro tramp-with-demoted-errors (vec-or-proc format &rest body) "Execute BODY while redirecting the error message to `tramp-message'. BODY is executed like wrapped by `with-demoted-errors'. FORMAT @@ -1718,6 +1889,12 @@ the resulting error message." (progn ,@body) (error (tramp-message ,vec-or-proc 3 ,format ,err) nil)))) +;; This function provides traces in case of errors not triggered by +;; Tramp functions. +(defun tramp-signal-hook-function (error-symbol data) + "Funtion to be called via `signal-hook-function'." + (tramp-error (car tramp-current-connection) error-symbol "%s" data)) + (defmacro with-parsed-tramp-file-name (filename var &rest body) "Parse a Tramp filename and make components available in the body. @@ -1752,12 +1929,12 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', (put 'with-parsed-tramp-file-name 'edebug-form-spec '(form symbolp body)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>")) -(defun tramp-progress-reporter-update (reporter &optional value) +(defun tramp-progress-reporter-update (reporter &optional value suffix) "Report progress of an operation for Tramp." (let* ((parameters (cdr reporter)) (message (aref parameters 3))) - (when (string-match message (or (current-message) "")) - (progress-reporter-update reporter value)))) + (when (string-match-p message (or (current-message) "")) + (tramp-compat-progress-reporter-update reporter value suffix)))) (defmacro with-tramp-progress-reporter (vec level message &rest body) "Executes BODY, spinning a progress reporter with MESSAGE. @@ -1829,7 +2006,7 @@ letter into the file name. This function removes it." (save-match-data (funcall (if (tramp-compat-file-name-quoted-p name) - 'tramp-compat-file-name-quote 'identity) + #'tramp-compat-file-name-quote #'identity) (let ((name (tramp-compat-file-name-unquote name))) (if (string-match "\\`[a-zA-Z]:/" name) (replace-match "/" nil t name) @@ -1837,7 +2014,6 @@ letter into the file name. This function removes it." ;;; Config Manipulation Functions: -;;;###tramp-autoload (defun tramp-set-completion-function (method function-list) "Sets the list of completion functions for METHOD. FUNCTION-LIST is a list of entries of the form (FUNCTION FILE). @@ -1851,7 +2027,6 @@ Example: \"ssh\" \\='((tramp-parse-sconfig \"/etc/ssh_config\") (tramp-parse-sconfig \"~/.ssh/config\")))" - (let ((r function-list) (v function-list)) (setq tramp-completion-function-alist @@ -1866,13 +2041,13 @@ Example: (unless (and (functionp (nth 0 (car v))) (cond ;; Windows registry. - ((string-match "^HKEY_CURRENT_USER" (nth 1 (car v))) + ((string-match-p "^HKEY_CURRENT_USER" (nth 1 (car v))) (and (memq system-type '(cygwin windows-nt)) (zerop (tramp-call-process v "reg" nil nil nil "query" (nth 1 (car v)))))) ;; Zeroconf service type. - ((string-match + ((string-match-p "^_[[:alpha:]]+\\._[[:alpha:]]+$" (nth 1 (car v)))) ;; Configuration file. (t (file-exists-p (nth 1 (car v)))))) @@ -1889,82 +2064,13 @@ For definition of that list see `tramp-set-completion-function'." (append `(;; Default settings are taken into account. (tramp-parse-default-user-host ,method) + ;; Hits from auth-sources. + (tramp-parse-auth-sources ,method) ;; Hosts visited once shall be remembered. (tramp-parse-connection-properties ,method)) ;; The method related defaults. (cdr (assoc method tramp-completion-function-alist)))) -;;; Fontification of `read-file-name': - -(defvar tramp-rfn-eshadow-overlay) -(make-variable-buffer-local 'tramp-rfn-eshadow-overlay) - -(defun tramp-rfn-eshadow-setup-minibuffer () - "Set up a minibuffer for `file-name-shadow-mode'. -Adds another overlay hiding filename parts according to Tramp's -special handling of `substitute-in-file-name'." - (when minibuffer-completing-file-name - (setq tramp-rfn-eshadow-overlay - (make-overlay (minibuffer-prompt-end) (minibuffer-prompt-end))) - ;; Copy rfn-eshadow-overlay properties. - (let ((props (overlay-properties rfn-eshadow-overlay))) - (while props - ;; The `field' property prevents correct minibuffer - ;; completion; we exclude it. - (if (not (eq (car props) 'field)) - (overlay-put tramp-rfn-eshadow-overlay (pop props) (pop props)) - (pop props) (pop props)))))) - -(add-hook 'rfn-eshadow-setup-minibuffer-hook - 'tramp-rfn-eshadow-setup-minibuffer) -(add-hook 'tramp-unload-hook - (lambda () - (remove-hook 'rfn-eshadow-setup-minibuffer-hook - 'tramp-rfn-eshadow-setup-minibuffer))) - -(defun tramp-rfn-eshadow-update-overlay-regexp () - (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 -`file-name-shadow-mode'; the minibuffer should have already -been set up by `rfn-eshadow-setup-minibuffer'." - ;; In remote files name, there is a shadowing just for the local part. - (ignore-errors - (let ((end (or (overlay-end rfn-eshadow-overlay) - (minibuffer-prompt-end))) - ;; We do not want to send any remote command. - (non-essential t)) - (when (tramp-tramp-file-p (buffer-substring end (point-max))) - (save-excursion - (save-restriction - (narrow-to-region - (1+ (or (string-match - (tramp-rfn-eshadow-update-overlay-regexp) - (buffer-string) end) - end)) - (point-max)) - (let ((rfn-eshadow-overlay tramp-rfn-eshadow-overlay) - (rfn-eshadow-update-overlay-hook nil) - file-name-handler-alist) - (move-overlay rfn-eshadow-overlay (point-max) (point-max)) - (rfn-eshadow-update-overlay)))))))) - -(add-hook 'rfn-eshadow-update-overlay-hook - 'tramp-rfn-eshadow-update-overlay) -(add-hook 'tramp-unload-hook - (lambda () - (remove-hook 'rfn-eshadow-update-overlay-hook - 'tramp-rfn-eshadow-update-overlay))) - ;; Inodes don't exist for some file systems. Therefore we must ;; generate virtual ones. Used in `find-buffer-visiting'. The method ;; applied might be not so efficient (Ange-FTP uses hashes). But @@ -1986,26 +2092,12 @@ been set up by `rfn-eshadow-setup-minibuffer'." If the file modes of FILENAME cannot be determined, return the value of `default-file-modes', without execute permissions." (or (file-modes filename) - (logand (default-file-modes) (string-to-number "0666" 8)))) + (logand (default-file-modes) #o0666))) (defun tramp-replace-environment-variables (filename) "Replace environment variables in FILENAME. Return the string with the replaced variables." - (or (ignore-errors - ;; Optional arg has been introduced with Emacs 24.4. - (tramp-compat-funcall 'substitute-env-vars filename 'only-defined)) - ;; We need an own implementation. - (save-match-data - (let ((idx (string-match "$\\(\\w+\\)" filename))) - ;; `$' is coded as `$$'. - (when (and idx - (or (zerop idx) (not (eq ?$ (aref filename (1- idx))))) - (getenv (match-string 1 filename))) - (setq filename - (replace-match - (substitute-in-file-name (match-string 0 filename)) - t nil filename))) - filename)))) + (substitute-env-vars filename 'only-defined)) (defun tramp-find-file-name-coding-system-alist (filename tmpname) "Like `find-operation-coding-system' for Tramp filenames. @@ -2015,7 +2107,7 @@ expression, which matches more than the file name suffix, the coding system might not be determined. This function repairs it." (let (result) (dolist (elt file-coding-system-alist (nreverse result)) - (when (and (consp elt) (string-match (car elt) filename)) + (when (and (consp elt) (string-match-p (car elt) filename)) ;; We found a matching entry in `file-coding-system-alist'. ;; So we add a similar entry, but with the temporary file name ;; as regexp. @@ -2029,12 +2121,14 @@ pass to the OPERATION." `(tramp-file-name-handler tramp-vc-file-name-handler tramp-completion-file-name-handler + tramp-archive-file-name-handler cygwin-mount-name-hook-function cygwin-mount-map-drive-hook-function . ,(and (eq inhibit-file-name-operation operation) inhibit-file-name-handlers))) - (inhibit-file-name-operation operation)) + (inhibit-file-name-operation operation) + signal-hook-function) (apply operation args))) ;; We handle here all file primitives. Most of them have the file @@ -2046,7 +2140,11 @@ pass to the OPERATION." ;; function as well but regexp only. (defun tramp-file-name-for-operation (operation &rest args) "Return file name related to OPERATION file primitive. -ARGS are the arguments OPERATION has been called with." +ARGS are the arguments OPERATION has been called with. + +It does not always return a Tramp file name, for example if the +first argument of `expand-file-name' is absolute and not remote. +Must be handled by the callers." (cond ;; FILE resp DIRECTORY. ((member operation @@ -2062,7 +2160,7 @@ ARGS are the arguments OPERATION has been called with." 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 find-file-noselect get-file-buffer + 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 @@ -2071,26 +2169,32 @@ ARGS are the arguments OPERATION has been called with." ;; Emacs 26+ only. file-name-case-insensitive-p ;; Emacs 27+ only. - file-system-info)) + file-system-info + ;; Tramp internal magic file name function. + tramp-set-file-uid-gid)) (if (file-name-absolute-p (nth 0 args)) (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 - '(add-name-to-file copy-directory copy-file expand-file-name + '(add-name-to-file copy-directory copy-file file-equal-p file-in-directory-p file-name-all-completions file-name-completion - ;; Starting with Emacs 26.1, just the 2nd argument of - ;; `make-symbolic-link' matters. For backward - ;; compatibility, we still accept the first argument as - ;; file name to be checked. Handled properly in - ;; `tramp-handle-*-make-symbolic-link'. - file-newer-than-file-p make-symbolic-link rename-file)) - (save-match-data - (cond - ((tramp-tramp-file-p (nth 0 args)) (nth 0 args)) - ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) - (t default-directory)))) + file-newer-than-file-p rename-file)) + (cond + ((tramp-tramp-file-p (nth 0 args)) (nth 0 args)) + ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) + (t default-directory))) + ;; FILE DIRECTORY resp FILE1 FILE2. + ((eq operation 'expand-file-name) + (cond + ((file-name-absolute-p (nth 0 args)) (nth 0 args)) + ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) + (t default-directory))) ;; START END FILE. ((eq operation 'write-region) (if (file-name-absolute-p (nth 2 args)) @@ -2106,7 +2210,9 @@ ARGS are the arguments OPERATION has been called with." ((member operation '(process-file shell-command start-file-process ;; Emacs 26+ only. - make-nearby-temp-file temporary-file-directory)) + make-nearby-temp-file temporary-file-directory + ;; Emacs 27+ only. + exec-path make-process)) default-directory) ;; PROC. ((member operation @@ -2132,15 +2238,6 @@ ARGS are the arguments OPERATION has been called with." res (cdr elt)))) res))) -(defvar tramp-debug-on-error nil - "Like `debug-on-error' but used Tramp internal.") - -(defmacro tramp-condition-case-unless-debug - (var bodyform &rest handlers) - "Like `condition-case-unless-debug' but `tramp-debug-on-error'." - `(let ((debug-on-error tramp-debug-on-error)) - (condition-case-unless-debug ,var ,bodyform ,@handlers))) - ;; In Emacs, there is some concurrency due to timers. If a timer ;; interrupts Tramp and wishes to use the same connection buffer as ;; the "main" Emacs, then garbage might occur in the connection @@ -2172,100 +2269,96 @@ preventing reentrant calls of Tramp.") (defun tramp-file-name-handler (operation &rest args) "Invoke Tramp file name handler. Falls back to normal file name handler if no Tramp file name handler exists." - (let ((filename (apply 'tramp-file-name-for-operation operation args))) - (if (and tramp-mode (tramp-tramp-file-p filename)) + (let ((filename (apply #'tramp-file-name-for-operation operation args)) + ;; `file-remote-p' is called for everything, even for symbolic + ;; links which look remote. We don't want to get an error. + (non-essential (or non-essential (eq operation 'file-remote-p)))) + (if (tramp-tramp-file-p filename) (save-match-data (setq filename (tramp-replace-environment-variables filename)) (with-parsed-tramp-file-name filename nil - (let ((completion (tramp-completion-mode-p)) + (let ((current-connection tramp-current-connection) (foreign (tramp-find-foreign-file-name-handler filename operation)) + (signal-hook-function #'tramp-signal-hook-function) result) + ;; Set `tramp-current-connection'. + (unless + (tramp-file-name-equal-p v (car tramp-current-connection)) + (setq tramp-current-connection (list v))) + ;; Call the backend function. - (if foreign - (tramp-condition-case-unless-debug err - (let ((sf (symbol-function foreign))) - ;; Some packages set the default directory to a - ;; remote path, before respective Tramp packages - ;; are already loaded. This results in - ;; recursive loading. Therefore, we load the - ;; Tramp packages locally. - (when (autoloadp sf) - (let ((default-directory - (tramp-compat-temporary-file-directory))) - (load (cadr sf) 'noerror 'nomessage))) - ;; If `non-essential' is non-nil, Tramp shall - ;; not open a new connection. - ;; If Tramp detects that it shouldn't continue - ;; to work, it throws the `suppress' event. - ;; This could happen for example, when Tramp - ;; tries to open the same connection twice in a - ;; short time frame. - ;; In both cases, we try the default handler then. - (setq result - (catch 'non-essential - (catch 'suppress - (when (and tramp-locked (not tramp-locker)) - (setq tramp-locked nil) - (tramp-error - (car-safe tramp-current-connection) - 'file-error - "Forbidden reentrant call of Tramp")) - (let ((tl tramp-locked)) - (setq tramp-locked t) - (unwind-protect - (let ((tramp-locker t)) - (apply foreign operation args)) - (setq tramp-locked tl)))))) - (cond - ((eq result 'non-essential) - (tramp-message - v 5 "Non-essential received in operation %s" - (cons operation args)) - (tramp-run-real-handler operation args)) - ((eq result 'suppress) - (let (tramp-message-show-message) + (unwind-protect + (if foreign + (let ((sf (symbol-function foreign))) + ;; Some packages set the default directory to + ;; a remote path, before respective Tramp + ;; packages are already loaded. This results + ;; in recursive loading. Therefore, we load + ;; the Tramp packages locally. + (when (autoloadp sf) + ;; FIXME: Not clear why we need these bindings here. + ;; The explanation above is not convincing and + ;; the bug#9114 for which it was added doesn't + ;; clarify the core of the problem. + (let ((default-directory + (tramp-compat-temporary-file-directory)) + file-name-handler-alist) + (autoload-do-load sf foreign))) + ;; (tramp-message + ;; v 4 "Running `%s'..." (cons operation args)) + ;; If `non-essential' is non-nil, Tramp shall + ;; not open a new connection. + ;; If Tramp detects that it shouldn't continue + ;; to work, it throws the `suppress' event. + ;; This could happen for example, when Tramp + ;; tries to open the same connection twice in + ;; a short time frame. + ;; In both cases, we try the default handler then. + (setq result + (catch 'non-essential + (catch 'suppress + (when (and tramp-locked (not tramp-locker)) + (setq tramp-locked nil) + (tramp-error + v 'file-error + "Forbidden reentrant call of Tramp")) + (let ((tl tramp-locked)) + (setq tramp-locked t) + (unwind-protect + (let ((tramp-locker t)) + (apply foreign operation args)) + (setq tramp-locked tl)))))) + ;; (tramp-message + ;; v 4 "Running `%s'...`%s'" (cons operation args) result) + (cond + ((eq result 'non-essential) (tramp-message - v 1 "Suppress received in operation %s" + v 5 "Non-essential received in operation %s" (cons operation args)) - (tramp-cleanup-connection v t) - (tramp-run-real-handler operation args))) - (t result))) - - ;; Trace that somebody has interrupted the operation. - ((debug quit) - (let (tramp-message-show-message) - (tramp-message - v 1 "Interrupt received in operation %s" - (cons operation args))) - ;; Propagate the quit signal. - (signal (car err) (cdr err))) - - ;; When we are in completion mode, some failed - ;; operations shall return at least a default - ;; value in order to give the user a chance to - ;; correct the file name in the minibuffer. - ;; In order to get a full backtrace, one could apply - ;; (setq tramp-debug-on-error t) - (error - (cond - ((and completion (zerop (length localname)) - (memq operation '(file-exists-p file-directory-p))) - t) - ((and completion (zerop (length localname)) - (memq operation - '(expand-file-name file-name-as-directory))) - filename) - ;; Propagate the error. - (t (signal (car err) (cdr err)))))) - - ;; Nothing to do for us. However, since we are in - ;; `tramp-mode', we must suppress the volume letter on - ;; MS Windows. - (setq result (tramp-run-real-handler operation args)) - (if (stringp result) - (tramp-drop-volume-letter result) - result))))) + (tramp-run-real-handler operation args)) + ((eq result 'suppress) + (let (tramp-message-show-message) + (tramp-message + v 1 "Suppress received in operation %s" + (cons operation args)) + (tramp-cleanup-connection v t) + (tramp-run-real-handler operation args))) + (t result))) + + ;; Nothing to do for us. However, since we are in + ;; `tramp-mode', we must suppress the volume + ;; letter on MS Windows. + (setq result (tramp-run-real-handler operation args)) + (if (stringp result) + (tramp-drop-volume-letter result) + result)) + + ;; Reset `tramp-current-connection'. + (unless + (tramp-file-name-equal-p + (car current-connection) (car tramp-current-connection)) + (setq tramp-current-connection current-connection)))))) ;; When `tramp-mode' is not enabled, or the file name is quoted, ;; we don't do anything. @@ -2282,10 +2375,10 @@ Falls back to normal file name handler if no Tramp file name handler exists." ;;;###autoload (progn (defun tramp-autoload-file-name-handler (operation &rest args) "Load Tramp file name handler, and perform OPERATION." + (tramp-unload-file-name-handlers) (if tramp-mode (let ((default-directory temporary-file-directory)) - (load "tramp" 'noerror 'nomessage)) - (tramp-unload-file-name-handlers)) + (load "tramp" 'noerror 'nomessage))) (apply operation args))) ;; `tramp-autoload-file-name-handler' must be registered before @@ -2312,44 +2405,47 @@ remote file names." "^%s$" (regexp-opt (mapcar - 'file-name-sans-extension + #'file-name-sans-extension (directory-files dir nil "^tramp.+\\.elc?$")) 'paren)))) (mapatoms (lambda (atom) (when (and (functionp atom) (autoloadp (symbol-function atom)) - (string-match files-regexp (cadr (symbol-function atom)))) + (string-match-p files-regexp (cadr (symbol-function atom)))) (ignore-errors (setf (cadr (symbol-function atom)) (expand-file-name (cadr (symbol-function atom)) dir)))))))) -(eval-after-load 'tramp (tramp-use-absolute-autoload-file-names)) +(tramp--with-startup (tramp-use-absolute-autoload-file-names)) (defun tramp-register-file-name-handlers () "Add Tramp file name handlers to `file-name-handler-alist'." ;; Remove autoloaded handlers from file name handler alist. Useful, ;; if `tramp-syntax' has been changed. - (dolist (fnh '(tramp-file-name-handler - tramp-completion-file-name-handler - tramp-autoload-file-name-handler)) - (let ((a1 (rassq fnh file-name-handler-alist))) - (setq file-name-handler-alist (delq a1 file-name-handler-alist)))) + (tramp-unload-file-name-handlers) ;; Add the handlers. We do not add anything to the `operations' - ;; property of `tramp-file-name-handler', this shall be done by the + ;; property of `tramp-file-name-handler' and + ;; `tramp-archive-file-name-handler', this shall be done by the ;; respective foreign handlers. (add-to-list 'file-name-handler-alist - (cons tramp-file-name-regexp 'tramp-file-name-handler)) + (cons tramp-file-name-regexp #'tramp-file-name-handler)) (put 'tramp-file-name-handler 'safe-magic t) (add-to-list 'file-name-handler-alist (cons tramp-completion-file-name-regexp - 'tramp-completion-file-name-handler)) + #'tramp-completion-file-name-handler)) (put 'tramp-completion-file-name-handler 'safe-magic t) ;; Mark `operations' the handler is responsible for. (put 'tramp-completion-file-name-handler 'operations - (mapcar 'car tramp-completion-file-name-handler-alist)) + (mapcar #'car tramp-completion-file-name-handler-alist)) + + (when (bound-and-true-p tramp-archive-enabled) + (add-to-list 'file-name-handler-alist + (cons tramp-archive-file-name-regexp + #'tramp-archive-file-name-handler)) + (put 'tramp-archive-file-name-handler 'safe-magic t)) ;; If jka-compr or epa-file are already loaded, move them to the ;; front of `file-name-handler-alist'. @@ -2359,10 +2455,9 @@ remote file names." (setq file-name-handler-alist (cons entry (delete entry file-name-handler-alist))))))) -(eval-after-load 'tramp (tramp-register-file-name-handlers)) +(tramp--with-startup (tramp-register-file-name-handlers)) -;;;###tramp-autoload -(progn (defun tramp-register-foreign-file-name-handler +(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. @@ -2376,8 +2471,8 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." (append (get 'tramp-file-name-handler 'operations) (mapcar - 'car - (symbol-value (intern (concat (symbol-name handler) "-alist"))))))))) + #'car + (symbol-value (intern (concat (symbol-name handler) "-alist")))))))) (defun tramp-exists-file-name-handler (operation &rest args) "Check, whether OPERATION runs a file name handler." @@ -2402,13 +2497,12 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." ;;;###autoload (progn (defun tramp-unload-file-name-handlers () "Unload Tramp file name handlers from `file-name-handler-alist'." - (dolist (fnh '(tramp-file-name-handler - tramp-completion-file-name-handler - tramp-autoload-file-name-handler)) - (let ((a1 (rassq fnh file-name-handler-alist))) - (setq file-name-handler-alist (delq a1 file-name-handler-alist)))))) + (dolist (fnh file-name-handler-alist) + (when (and (symbolp (cdr fnh)) + (string-prefix-p "tramp-" (symbol-name (cdr fnh)))) + (setq file-name-handler-alist (delq fnh file-name-handler-alist)))))) -(add-hook 'tramp-unload-hook 'tramp-unload-file-name-handlers) +(add-hook 'tramp-unload-hook #'tramp-unload-file-name-handlers) ;;; File name handler functions for completion mode: @@ -2442,7 +2536,6 @@ not in completion mode." ;; completions. (defun tramp-completion-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for partial Tramp files." - (let ((fullname (tramp-drop-volume-letter (expand-file-name filename directory))) hop result result1) @@ -2465,7 +2558,6 @@ not in completion mode." (host (tramp-file-name-host elt)) (localname (tramp-file-name-localname elt)) (m (tramp-find-method method user host)) - (tramp-current-user user) ; see `tramp-parse-passwd' all-user-hosts) (unless localname ;; Nothing to complete. @@ -2515,7 +2607,7 @@ not in completion mode." "Like `file-name-completion' for Tramp files." (try-completion filename - (mapcar 'list (file-name-all-completions filename directory)) + (mapcar #'list (file-name-all-completions filename directory)) (when (and predicate (tramp-connectable-p (expand-file-name filename directory))) (lambda (x) (funcall predicate (expand-file-name (car x) directory)))))) @@ -2540,7 +2632,6 @@ not in completion mode." (defun tramp-completion-dissect-file-name (name) "Returns a list of `tramp-file-name' structures. They are collected by `tramp-completion-dissect-file-name1'." - (let* ((x-nil "\\|\\(\\)") (tramp-completion-ipv6-regexp (format @@ -2615,7 +2706,6 @@ They are collected by `tramp-completion-dissect-file-name1'." "Returns a `tramp-file-name' structure matching STRUCTURE. The structure consists of remote method, remote user, remote host and localname (filename on remote host)." - (save-match-data (when (string-match (nth 0 structure) name) (make-tramp-file-name @@ -2633,9 +2723,9 @@ remote host and localname (filename on remote host)." (mapcar (lambda (method) (and method - (string-match (concat "^" (regexp-quote partial-method)) method) + (string-match-p (concat "^" (regexp-quote partial-method)) method) (tramp-completion-make-tramp-file-name method nil nil nil))) - (mapcar 'car tramp-methods))) + (mapcar #'car tramp-methods))) ;; Compares partial user and host names with possible completions. (defun tramp-get-completion-user-host @@ -2646,7 +2736,7 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." ((and partial-user partial-host) (if (and host - (string-match (concat "^" (regexp-quote partial-host)) host) + (string-match-p (concat "^" (regexp-quote partial-host)) host) (string-equal partial-user (or user partial-user))) (setq user partial-user) (setq user nil @@ -2655,13 +2745,15 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." (partial-user (setq host nil) (unless - (and user (string-match (concat "^" (regexp-quote partial-user)) user)) + (and user + (string-match-p (concat "^" (regexp-quote partial-user)) user)) (setq user nil))) (partial-host (setq user nil) (unless - (and host (string-match (concat "^" (regexp-quote partial-host)) host)) + (and host + (string-match-p (concat "^" (regexp-quote partial-host)) host)) (setq host nil))) (t (setq user nil @@ -2676,15 +2768,33 @@ This function is added always in `tramp-get-completion-function' for all methods. Resulting data are derived from default settings." `((,(tramp-find-user method nil nil) ,(tramp-find-host method nil nil)))) +(defcustom tramp-completion-use-auth-sources auth-source-do-cache + "Whether to use `auth-source-search' for completion of user and host names. +This could be disturbing, if it requires a password / passphrase, +as for \"~/.authinfo.gpg\"." + :group 'tramp + :version "27.1" + :type 'boolean) + +(defun tramp-parse-auth-sources (method) + "Return a list of (user host) tuples allowed to access for METHOD. +This function is added always in `tramp-get-completion-function' +for all methods. Resulting data are derived from default settings." + (and tramp-completion-use-auth-sources + (mapcar + (lambda (x) `(,(plist-get x :user) ,(plist-get x :host))) + (auth-source-search + :port method :require '(:port) :max most-positive-fixnum)))) + ;; Generic function. -(defun tramp-parse-group (regexp match-level skip-regexp) +(defun tramp-parse-group (regexp match-level skip-chars) "Return a (user host) tuple allowed to access. User is always nil." (let (result) (when (re-search-forward regexp (point-at-eol) t) (setq result (list nil (match-string match-level)))) (or - (> (skip-chars-forward skip-regexp) 0) + (> (skip-chars-forward skip-chars) 0) (forward-line 1)) result)) @@ -2701,11 +2811,10 @@ User is always nil." (goto-char (point-min)) (cl-loop while (not (eobp)) collect (funcall function)))))) -;;;###tramp-autoload (defun tramp-parse-rhosts (filename) "Return a list of (user host) tuples allowed to access. Either user or host may be nil." - (tramp-parse-file filename 'tramp-parse-rhosts-group)) + (tramp-parse-file filename #'tramp-parse-rhosts-group)) (defun tramp-parse-rhosts-group () "Return a (user host) tuple allowed to access. @@ -2720,22 +2829,20 @@ Either user or host may be nil." (forward-line 1) result)) -;;;###tramp-autoload (defun tramp-parse-shosts (filename) "Return a list of (user host) tuples allowed to access. User is always nil." - (tramp-parse-file filename 'tramp-parse-shosts-group)) + (tramp-parse-file filename #'tramp-parse-shosts-group)) (defun tramp-parse-shosts-group () "Return a (user host) tuple allowed to access. User is always nil." (tramp-parse-group (concat "^\\(" tramp-host-regexp "\\)") 1 ",")) -;;;###tramp-autoload (defun tramp-parse-sconfig (filename) "Return a list of (user host) tuples allowed to access. User is always nil." - (tramp-parse-file filename 'tramp-parse-sconfig-group)) + (tramp-parse-file filename #'tramp-parse-sconfig-group)) (defun tramp-parse-sconfig-group () "Return a (user host) tuple allowed to access. @@ -2743,7 +2850,7 @@ User is always nil." (tramp-parse-group (concat "\\(?:^[ \t]*Host\\)" "\\|" "\\(?:^.+\\)" "\\|" "\\(" tramp-host-regexp "\\)") - 1 "[ \t]+")) + 1 " \t")) ;; Generic function. (defun tramp-parse-shostkeys-sknownhosts (dirname regexp) @@ -2758,14 +2865,12 @@ User is always nil." when (and (not (string-match "^\\.\\.?$" f)) (string-match regexp f)) collect (list nil (match-string 1 f))))) -;;;###tramp-autoload (defun tramp-parse-shostkeys (dirname) "Return a list of (user host) tuples allowed to access. User is always nil." (tramp-parse-shostkeys-sknownhosts dirname (concat "^key_[0-9]+_\\(" tramp-host-regexp "\\)\\.pub$"))) -;;;###tramp-autoload (defun tramp-parse-sknownhosts (dirname) "Return a list of (user host) tuples allowed to access. User is always nil." @@ -2773,11 +2878,10 @@ User is always nil." dirname (concat "^\\(" tramp-host-regexp "\\)\\.ssh-\\(dss\\|rsa\\)\\.pub$"))) -;;;###tramp-autoload (defun tramp-parse-hosts (filename) "Return a list of (user host) tuples allowed to access. User is always nil." - (tramp-parse-file filename 'tramp-parse-hosts-group)) + (tramp-parse-file filename #'tramp-parse-hosts-group)) (defun tramp-parse-hosts-group () "Return a (user host) tuple allowed to access. @@ -2785,7 +2889,6 @@ User is always nil." (tramp-parse-group (concat "^\\(" tramp-ipv6-regexp "\\|" tramp-host-regexp "\\)") 1 " \t")) -;;;###tramp-autoload (defun tramp-parse-passwd (filename) "Return a list of (user host) tuples allowed to access. Host is always \"localhost\"." @@ -2796,7 +2899,7 @@ Host is always \"localhost\"." (goto-char (point-min)) (cl-loop while (not (eobp)) collect (tramp-parse-etc-group-group)))) - (tramp-parse-file filename 'tramp-parse-passwd-group)))) + (tramp-parse-file filename #'tramp-parse-passwd-group)))) (defun tramp-parse-passwd-group () "Return a (user host) tuple allowed to access. @@ -2808,7 +2911,6 @@ Host is always \"localhost\"." (forward-line 1) result)) -;;;###tramp-autoload (defun tramp-parse-etc-group (filename) "Return a list of (group host) tuples allowed to access. Host is always \"localhost\"." @@ -2819,7 +2921,7 @@ Host is always \"localhost\"." (goto-char (point-min)) (cl-loop while (not (eobp)) collect (tramp-parse-etc-group-group)))) - (tramp-parse-file filename 'tramp-parse-etc-group-group)))) + (tramp-parse-file filename #'tramp-parse-etc-group-group)))) (defun tramp-parse-etc-group-group () "Return a (group host) tuple allowed to access. @@ -2831,26 +2933,18 @@ Host is always \"localhost\"." (forward-line 1) result)) -;;;###tramp-autoload (defun tramp-parse-netrc (filename) "Return a list of (user host) tuples allowed to access. User may be nil." - (tramp-parse-file filename 'tramp-parse-netrc-group)) - -(defun tramp-parse-netrc-group () - "Return a (user host) tuple allowed to access. -User may be nil." - (let ((result) - (regexp - (concat - "^[ \t]*machine[ \t]+" "\\(" tramp-host-regexp "\\)" - "\\([ \t]+login[ \t]+" "\\(" tramp-user-regexp "\\)" "\\)?"))) - (when (re-search-forward regexp (point-at-eol) t) - (setq result (list (match-string 3) (match-string 1)))) - (forward-line 1) - result)) + ;; The declaration is not sufficient at runtime, because netrc.el is + ;; not autoloaded. + (autoload 'netrc-parse "netrc") + (mapcar + (lambda (item) + (and (assoc "machine" item) + `(,(cdr (assoc "login" item)) ,(cdr (assoc "machine" item))))) + (netrc-parse filename))) -;;;###tramp-autoload (defun tramp-parse-putty (registry-or-dirname) "Return a list of (user host) tuples allowed to access. User is always nil." @@ -2884,6 +2978,13 @@ User is always nil." (defvar tramp-handle-write-region-hook nil "Normal hook to be run at the end of `tramp-*-handle-write-region'.") +(defun tramp-handle-access-file (filename string) + "Like `access-file' for Tramp files." + (unless (file-readable-p filename) + (tramp-error + (tramp-dissect-file-name filename) tramp-file-missing + "%s: No such file or directory %s" string filename))) + (defun tramp-handle-add-name-to-file (filename newname &optional ok-if-already-exists) "Like `add-name-to-file' for Tramp files." @@ -2905,8 +3006,8 @@ User is always nil." localname))))) (tramp-error v 'file-already-exists newname) (delete-file newname))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (copy-file filename newname 'ok-if-already-exists 'keep-time 'preserve-uid-gid 'preserve-permissions))) @@ -2932,10 +3033,10 @@ User is always nil." (while temp (setq item (directory-file-name (pop temp))) - (when (or (null match) (string-match match item)) + (when (or (null match) (string-match-p match item)) (push (if full (concat directory item) item) result))) - (if nosort result (sort result 'string<))))) + (if nosort result (sort result #'string<))))) (defun tramp-handle-directory-files-and-attributes (directory &optional full match nosort id-format) @@ -2950,22 +3051,51 @@ User is always nil." "Like `dired-uncache' for Tramp files." (with-parsed-tramp-file-name (if (file-directory-p dir) dir (file-name-directory dir)) nil - (tramp-flush-directory-property v localname))) + (tramp-flush-directory-properties v localname))) + +(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 "/". + (setq dir (or dir default-directory "/")) + ;; Handle empty NAME. + (when (zerop (length name)) (setq name ".")) + ;; Unless NAME is absolute, concat DIR and NAME. + (unless (file-name-absolute-p name) + (setq name (concat (file-name-as-directory dir) name))) + ;; If NAME is not a Tramp file, run the real handler. + (if (not (tramp-tramp-file-p name)) + (tramp-run-real-handler #'expand-file-name (list name nil)) + ;; Dissect NAME. + (with-parsed-tramp-file-name name nil + (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) + (setq localname (concat "/" localname))) + ;; Do normal `expand-file-name' (this does "/./" and "/../"). + ;; `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)))))))) (defun tramp-handle-file-accessible-directory-p (filename) "Like `file-accessible-directory-p' for Tramp files." (and (file-directory-p filename) (file-readable-p filename))) +(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)) + (defun tramp-handle-file-equal-p (filename1 filename2) "Like `file-equalp-p' for Tramp files." ;; Native `file-equalp-p' calls `file-truename', which requires a ;; remote connection. This can be avoided, if FILENAME1 and ;; FILENAME2 are not located on the same remote host. - (when (string-equal - (file-remote-p (expand-file-name filename1)) - (file-remote-p (expand-file-name filename2))) - (tramp-run-real-handler 'file-equal-p (list filename1 filename2)))) + (when (tramp-equal-remote + (expand-file-name filename1) (expand-file-name filename2)) + (tramp-run-real-handler #'file-equal-p (list filename1 filename2)))) (defun tramp-handle-file-exists-p (filename) "Like `file-exists-p' for Tramp files." @@ -2976,10 +3106,20 @@ User is always nil." ;; Native `file-in-directory-p' calls `file-truename', which ;; requires a remote connection. This can be avoided, if FILENAME ;; and DIRECTORY are not located on the same remote host. - (when (string-equal - (file-remote-p (expand-file-name filename)) - (file-remote-p (expand-file-name directory))) - (tramp-run-real-handler 'file-in-directory-p (list filename directory)))) + (when (tramp-equal-remote + (expand-file-name filename) (expand-file-name directory)) + (tramp-run-real-handler #'file-in-directory-p (list filename directory)))) + +(defun tramp-handle-file-local-copy (filename) + "Like `file-local-copy' for Tramp files." + (with-parsed-tramp-file-name filename nil + (unless (file-exists-p filename) + (tramp-error + v tramp-file-missing + "Cannot make local copy of non-existing file `%s'" filename)) + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) + tmpfile))) (defun tramp-handle-file-modes (filename) "Like `file-modes' for Tramp files." @@ -2997,17 +3137,11 @@ User is always nil." ;; Run the command on the localname portion only unless we are in ;; completion mode. (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-domain v) - (tramp-file-name-host v) - (tramp-file-name-port v) - (if (and (zerop (length (tramp-file-name-localname v))) - (not (tramp-connectable-p file))) - "" - (tramp-run-real-handler - 'file-name-as-directory (list (or (tramp-file-name-localname v) "")))) - (tramp-file-name-hop v)))) + v (or (and (zerop (length (tramp-file-name-localname v))) + (not (tramp-connectable-p file))) + (tramp-run-real-handler + #'file-name-as-directory + (list (tramp-file-name-localname v))))))) (defun tramp-handle-file-name-case-insensitive-p (filename) "Like `file-name-case-insensitive-p' for Tramp files." @@ -3034,8 +3168,8 @@ User is always nil." ;; Check, whether we find an existing file with ;; lower case letters. This avoids us to create a ;; temporary file. - (while (and (string-match - "[a-z]" (file-remote-p candidate 'localname)) + (while (and (string-match-p + "[a-z]" (tramp-compat-file-local-name candidate)) (not (file-exists-p candidate))) (setq candidate (directory-file-name @@ -3045,8 +3179,8 @@ User is always nil." ;; to Emacs 26+ like `file-name-case-insensitive-p', ;; so there is no compatibility problem calling it. (unless - (string-match - "[a-z]" (file-remote-p candidate 'localname)) + (string-match-p + "[a-z]" (tramp-compat-file-local-name candidate)) (setq tmpfile (let ((default-directory (file-name-directory filename))) @@ -3059,27 +3193,23 @@ User is always nil." (file-exists-p (concat (file-remote-p candidate) - (upcase (file-remote-p candidate 'localname)))) + (upcase (tramp-compat-file-local-name candidate)))) ;; Cleanup. (when tmpfile (delete-file tmpfile))))))))))) (defun tramp-handle-file-name-completion (filename directory &optional predicate) "Like `file-name-completion' for Tramp files." - (unless (tramp-tramp-file-p directory) - (error - "tramp-handle-file-name-completion invoked on non-tramp directory `%s'" - directory)) (let (hits-ignored-extensions) (or (try-completion filename (file-name-all-completions filename directory) (lambda (x) - (when (funcall (or predicate 'identity) (expand-file-name x directory)) + (when (funcall (or predicate #'identity) (expand-file-name x directory)) (not (and completion-ignored-extensions - (string-match + (string-match-p (concat (regexp-opt completion-ignored-extensions 'paren) "$") x) ;; We remember the hit. (push x hits-ignored-extensions)))))) @@ -3090,24 +3220,19 @@ User is always nil." "Like `file-name-directory' but aware of Tramp files." ;; Everything except the last filename thing is the directory. We ;; cannot apply `with-parsed-tramp-file-name', because this expands - ;; the remote file name parts. This is a problem when we are in - ;; file name completion. + ;; the remote file name parts. (let ((v (tramp-dissect-file-name file t))) - ;; Run the command on the localname portion only. + ;; Run the command on the localname portion only. If this returns + ;; nil, mark also the localname part of `v' as nil. (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-domain v) - (tramp-file-name-host v) - (tramp-file-name-port v) - (tramp-run-real-handler - 'file-name-directory (list (or (tramp-file-name-localname v) ""))) - (tramp-file-name-hop v)))) + v (or (tramp-run-real-handler + #'file-name-directory (list (tramp-file-name-localname v))) + 'noloc)))) (defun tramp-handle-file-name-nondirectory (file) "Like `file-name-nondirectory' but aware of Tramp files." (with-parsed-tramp-file-name file nil - (tramp-run-real-handler 'file-name-nondirectory (list localname)))) + (tramp-run-real-handler #'file-name-nondirectory (list localname)))) (defun tramp-handle-file-newer-than-file-p (file1 file2) "Like `file-newer-than-file-p' for Tramp files." @@ -3141,13 +3266,13 @@ User is always nil." (and (or (not connected) c) (cond ((eq identification 'method) method) - ;; Domain and port are appended. + ;; Domain and port are appended to user and host, + ;; respectively. ((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) - (t (tramp-make-tramp-file-name - method user domain host port "" hop))))))))) + (t (tramp-make-tramp-file-name v 'noloc))))))))) (defun tramp-handle-file-selinux-context (_filename) "Like `file-selinux-context' for Tramp files." @@ -3164,7 +3289,7 @@ User is always nil." ;; Preserve trailing "/". (funcall (if (string-equal (file-name-nondirectory filename) "") - 'file-name-as-directory 'identity) + #'file-name-as-directory #'identity) (let ((result (expand-file-name filename)) (numchase 0) ;; Don't make the following value larger than necessary. @@ -3174,30 +3299,44 @@ User is always nil." (numchase-limit 20) symlink-target) (with-parsed-tramp-file-name result v1 - (with-tramp-file-property v1 v1-localname "file-truename" - (while (and (setq symlink-target (file-symlink-p result)) - (< numchase numchase-limit)) - (setq numchase (1+ numchase) - result - (with-parsed-tramp-file-name (expand-file-name result) v2 - (tramp-make-tramp-file-name - v2-method v2-user v2-domain v2-host v2-port - (funcall - (if (tramp-compat-file-name-quoted-p v2-localname) - 'tramp-compat-file-name-quote 'identity) - - (if (stringp symlink-target) - (if (file-remote-p symlink-target) - (let (file-name-handler-alist) - (tramp-compat-file-name-quote symlink-target)) - (expand-file-name - symlink-target (file-name-directory v2-localname))) - v2-localname))))) - (when (>= numchase numchase-limit) - (tramp-error - v1 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit))) - (directory-file-name result)))))) + ;; We cache only the localname. + (tramp-make-tramp-file-name + v1 + (with-tramp-file-property v1 v1-localname "file-truename" + (while (and (setq symlink-target (file-symlink-p result)) + (< numchase numchase-limit)) + (setq numchase (1+ numchase) + result + (with-parsed-tramp-file-name (expand-file-name result) v2 + (tramp-make-tramp-file-name + v2 + (funcall + (if (tramp-compat-file-name-quoted-p v2-localname) + #'tramp-compat-file-name-quote #'identity) + + (if (stringp symlink-target) + (if (file-remote-p symlink-target) + (let (file-name-handler-alist) + (tramp-compat-file-name-quote symlink-target)) + (expand-file-name + symlink-target (file-name-directory v2-localname))) + v2-localname)) + 'nohop))) + (when (>= numchase numchase-limit) + (tramp-error + v1 'file-error + "Maximum number (%d) of symlinks exceeded" numchase-limit))) + (tramp-compat-file-local-name (directory-file-name result)))))))) + +(defun tramp-handle-file-writable-p (filename) + "Like `file-writable-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-writable-p" + (if (file-exists-p filename) + (tramp-check-cached-permissions v ?w) + ;; If file doesn't exist, check if directory is writable. + (and (file-directory-p (file-name-directory filename)) + (file-writable-p (file-name-directory filename))))))) (defun tramp-handle-find-backup-file-name (filename) "Like `find-backup-file-name' for Tramp files." @@ -3211,12 +3350,11 @@ User is always nil." (if (and (stringp (cdr x)) (file-name-absolute-p (cdr x)) (not (tramp-tramp-file-p (cdr x)))) - (tramp-make-tramp-file-name - method user domain host port (cdr x) hop) + (tramp-make-tramp-file-name v (cdr x)) (cdr x)))) tramp-backup-directory-alist) backup-directory-alist))) - (tramp-run-real-handler 'find-backup-file-name (list filename))))) + (tramp-run-real-handler #'find-backup-file-name (list filename))))) (defun tramp-handle-insert-directory (filename switches &optional wildcard full-directory-p) @@ -3226,16 +3364,20 @@ User is always nil." (when (and (zerop (length (file-name-nondirectory filename))) (not full-directory-p)) (setq switches (concat switches "F"))) + ;; Check, whether directory is accessible. + (unless wildcard + (access-file filename "Reading directory")) (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-progress-reporter v 0 (format "Opening directory %s" filename) - (require 'ls-lisp) (let (ls-lisp-use-insert-directory-program start) + ;; Silence byte compiler. + ls-lisp-use-insert-directory-program (tramp-run-real-handler - 'insert-directory + #'insert-directory (list filename switches wildcard full-directory-p)) ;; `ls-lisp' always returns full listings. We must remove ;; superfluous parts. - (unless (string-match "l" switches) + (unless (string-match-p "l" switches) (save-excursion (goto-char (point-min)) (while (setq start @@ -3245,7 +3387,7 @@ User is always nil." start (or (text-property-any start (point-at-eol) 'dired-filename t) (point-at-eol))) - (if (= (point-at-bol) (point-at-eol)) + (if (= (point-at-bol) (point-at-eol)) ;; Empty line. (delete-region (point) (progn (forward-line) (point))) (forward-line))))))))) @@ -3273,7 +3415,7 @@ User is always nil." ;; run directly. (setq result (tramp-run-real-handler - 'insert-file-contents + #'insert-file-contents (list localname visit beg end replace))) ;; When we shall insert only a part of the file, we @@ -3317,7 +3459,7 @@ User is always nil." ((stringp remote-copy) (file-local-copy (tramp-make-tramp-file-name - method user domain host port remote-copy))) + v remote-copy 'nohop))) ((stringp tramp-temp-buffer-file-name) (copy-file filename tramp-temp-buffer-file-name 'ok) @@ -3327,7 +3469,7 @@ User is always nil." ;; When the file is not readable for the owner, it ;; cannot be inserted, even if it is readable for the ;; group or for everybody. - (set-file-modes local-copy (string-to-number "0600" 8)) + (set-file-modes local-copy #o0600) (when (and (null remote-copy) (tramp-get-method-parameter @@ -3361,9 +3503,7 @@ User is always nil." (or remote-copy (null tramp-temp-buffer-file-name))) (delete-file local-copy)) (when (stringp remote-copy) - (delete-file - (tramp-make-tramp-file-name - method user domain host port remote-copy))))) + (delete-file (tramp-make-tramp-file-name v remote-copy 'nohop))))) ;; Result. (list (expand-file-name filename) @@ -3381,14 +3521,13 @@ User is always nil." ;; The first condition is always true for absolute file names. ;; Included for safety's sake. (unless (or (file-name-directory file) - (string-match "\\.elc?\\'" file)) + (string-match-p "\\.elc?\\'" file)) (tramp-error v 'file-error "File `%s' does not include a `.el' or `.elc' suffix" file))) - (unless noerror - (when (not (file-exists-p file)) - (tramp-error - v tramp-file-missing "Cannot load nonexistent file `%s'" file))) + (unless (or noerror (file-exists-p file)) + (tramp-error + v tramp-file-missing "Cannot load nonexistent file `%s'" file)) (if (not (file-exists-p file)) nil (let ((tramp-message-show-message (not nomessage))) @@ -3411,23 +3550,13 @@ support symbolic links." ;; 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)))) + #'make-symbolic-link (list target linkname ok-if-already-exists)))) (defun tramp-handle-shell-command (command &optional output-buffer error-buffer) "Like `shell-command' for Tramp files." - (let* ((asynchronous (string-match "[ \t]*&[ \t]*\\'" command)) - ;; We cannot use `shell-file-name' and `shell-command-switch', - ;; they are variables of the local host. - (args (append - (cons - (tramp-get-method-parameter - (tramp-dissect-file-name default-directory) - 'tramp-remote-shell) - (tramp-get-method-parameter - (tramp-dissect-file-name default-directory) - 'tramp-remote-shell-args)) - (list (substring command 0 asynchronous)))) + (let* ((asynchronous (string-match-p "[ \t]*&[ \t]*\\'" command)) + (command (substring command 0 asynchronous)) current-buffer-p (output-buffer (cond @@ -3444,19 +3573,48 @@ support symbolic links." (cond ((bufferp error-buffer) error-buffer) ((stringp error-buffer) (get-buffer-create error-buffer)))) - (buffer - (if (and (not asynchronous) error-buffer) - (with-parsed-tramp-file-name default-directory nil - (list output-buffer (tramp-make-tramp-temp-file v))) - output-buffer)) - (p (get-buffer-process output-buffer))) - - ;; Check whether there is another process running. Tramp does not - ;; support 2 (asynchronous) processes in parallel. + (bname (buffer-name output-buffer)) + (p (get-buffer-process output-buffer)) + buffer) + + ;; The following code is taken from `shell-command', slightly + ;; adapted. Shouldn't it be factored out? (when p - (if (yes-or-no-p "A command is running. Kill it? ") - (ignore-errors (kill-process p)) - (tramp-compat-user-error p "Shell command in progress"))) + (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 p) + (tramp-user-error p "Shell command in progress"))) + ((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 output-buffer (generate-new-buffer bname)) + (tramp-user-error p "Shell command in progress"))) + ((eq async-shell-command-buffer 'new-buffer) + ;; It will create a new buffer. + (setq output-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 output-buffer + (rename-uniquely)) + (setq output-buffer (get-buffer-create bname))) + (tramp-user-error p "Shell command in progress"))) + ((eq async-shell-command-buffer 'rename-buffer) + ;; It will rename the buffer. + (with-current-buffer output-buffer + (rename-uniquely)) + (setq output-buffer (get-buffer-create bname))))) + + (setq buffer (if (and (not asynchronous) error-buffer) + (with-parsed-tramp-file-name default-directory nil + (list output-buffer (tramp-make-tramp-temp-file v))) + output-buffer)) (if current-buffer-p (progn @@ -3467,20 +3625,29 @@ support symbolic links." (erase-buffer))) (if (and (not current-buffer-p) (integerp asynchronous)) - (prog1 - ;; Run the process. - (setq p (apply 'start-file-process "*Async Shell*" buffer args)) - ;; Display output. - (with-current-buffer output-buffer - (display-buffer output-buffer '(nil (allow-no-window . t))) - (setq mode-line-process '(":%s")) - (shell-mode) - (set-process-sentinel p 'shell-command-sentinel) - (set-process-filter p 'comint-output-filter))) + (let ((tramp-remote-process-environment + ;; `async-shell-command-width' has been introduced with + ;; Emacs 27.1. + (if (natnump (bound-and-true-p async-shell-command-width)) + (cons (format "COLUMNS=%d" + (bound-and-true-p async-shell-command-width)) + tramp-remote-process-environment) + tramp-remote-process-environment))) + (prog1 + ;; Run the process. + (setq p (start-file-process-shell-command + (buffer-name output-buffer) buffer command)) + ;; Display output. + (with-current-buffer output-buffer + (display-buffer output-buffer '(nil (allow-no-window . t))) + (setq mode-line-process '(":%s")) + (shell-mode) + (set-process-sentinel p #'shell-command-sentinel) + (set-process-filter p #'comint-output-filter)))) (prog1 ;; Run the process. - (apply 'process-file (car args) nil buffer nil (cdr args)) + (process-file-shell-command command nil buffer nil) ;; Insert error messages if they were separated. (when (listp buffer) (with-current-buffer error-buffer @@ -3498,6 +3665,17 @@ support symbolic links." (when (with-current-buffer output-buffer (> (point-max) (point-min))) (display-message-or-buffer output-buffer))))))) +(defun tramp-handle-start-file-process (name buffer program &rest args) + "Like `start-file-process' for Tramp files." + ;; `make-process' knows the `:file-error' argument since Emacs 27.1. + (tramp-file-name-handler + 'make-process + :name name + :buffer buffer + :command (and program (cons program args)) + :noquery nil + :file-handler t)) + (defun tramp-handle-substitute-in-file-name (filename) "Like `substitute-in-file-name' for Tramp files. \"//\" and \"/~\" substitute only in the local filename part." @@ -3507,17 +3685,34 @@ support symbolic links." ;; First, we must replace environment variables. (setq filename (tramp-replace-environment-variables filename)) (with-parsed-tramp-file-name filename nil - ;; Ignore in LOCALNAME everything before "//" or "/~". - (when (and (stringp localname) (string-match ".+?/\\(/\\|~\\)" localname)) - (setq filename - (concat (file-remote-p filename) - (replace-match "\\1" nil nil localname))) - ;; "/m:h:~" does not work for completion. We use "/m:h:~/". - (when (string-match "~$" filename) - (setq filename (concat filename "/")))) - ;; We do not want to replace environment variables, again. + ;; We do not want to replace environment variables, again. "//" + ;; has a special meaning at the beginning of a file name on + ;; Cygwin and MS-Windows, we must remove it. (let (process-environment) - (tramp-run-real-handler 'substitute-in-file-name (list filename)))))) + ;; Ignore in LOCALNAME everything before "//" or "/~". + (when (stringp localname) + (if (string-match "//\\(/\\|~\\)" localname) + (setq filename + (replace-regexp-in-string + "\\`/+" "/" (substitute-in-file-name localname))) + (setq filename + (concat (file-remote-p filename) + (replace-regexp-in-string + "\\`/+" "/" + ;; We must disable cygwin-mount file name + ;; handlers and alike. + (tramp-run-real-handler + #'substitute-in-file-name (list localname)))))))) + ;; "/m:h:~" does not work for completion. We use "/m:h:~/". + (if (and (stringp localname) (string-equal "~" localname)) + (concat filename "/") + filename)))) + +(defconst tramp-time-dont-know '(0 0 0 1000) + "An invalid time value, used as \"Don’t know\" value.") + +(defconst tramp-time-doesnt-exist '(-1 65535) + "An invalid time value, used as \"Doesn’t exist\" value.") (defun tramp-handle-set-visited-file-modtime (&optional time-list) "Like `set-visited-file-modtime' for Tramp files." @@ -3526,14 +3721,12 @@ support symbolic links." (buffer-name))) (unless time-list (let ((remote-file-name-inhibit-cache t)) - ;; '(-1 65535) means file doesn't exists yet. (setq time-list (or (tramp-compat-file-attribute-modification-time (file-attributes (buffer-file-name))) - '(-1 65535))))) - ;; We use '(0 0) as a don't-know value. - (unless (equal time-list '(0 0)) - (tramp-run-real-handler 'set-visited-file-modtime (list time-list)))) + tramp-time-doesnt-exist)))) + (unless (tramp-compat-time-equal-p time-list tramp-time-dont-know) + (tramp-run-real-handler #'set-visited-file-modtime (list time-list)))) (defun tramp-handle-verify-visited-file-modtime (&optional buf) "Like `verify-visited-file-modtime' for Tramp files. @@ -3551,34 +3744,81 @@ of." (eq (visited-file-modtime) 0) (not (file-remote-p f nil 'connected))) t - (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)) - (mt (visited-file-modtime))) - - (cond - ;; File exists, and has a known modtime. - ((and attr (not (equal modtime '(0 0)))) - (< (abs (tramp-time-diff - modtime - ;; For compatibility, deal with both the old - ;; (HIGH . LOW) and the new (HIGH LOW) return - ;; values of `visited-file-modtime'. - (if (atom (cdr mt)) - (list (car mt) (cdr mt)) - mt))) - 2)) - ;; Modtime has the don't know value. - (attr t) - ;; If file does not exist, say it is not modified if and - ;; only if that agrees with the buffer's record. - (t (equal mt '(-1 65535)))))))))) + (let* ((remote-file-name-inhibit-cache t) + (attr (file-attributes f)) + (modtime (tramp-compat-file-attribute-modification-time attr)) + (mt (visited-file-modtime))) + (cond + ;; File exists, and has a known modtime. + ((and attr + (not (tramp-compat-time-equal-p modtime tramp-time-dont-know))) + (< (abs (tramp-time-diff modtime mt)) 2)) + ;; Modtime has the don't know value. + (attr t) + ;; If file does not exist, say it is not modified if and + ;; only if that agrees with the buffer's record. + (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist)))))))) + +(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)) + (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 ((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 + ;; modtime data to be clobbered from the temp file. We call + ;; `set-visited-file-modtime' ourselves later on. + (tramp-run-real-handler + #'write-region (list start end tmpfile append 'no-message lockname)) + (condition-case nil + (rename-file tmpfile filename 'ok-if-already-exists) + (error + (delete-file tmpfile) + (tramp-error + v 'file-error "Couldn't write region to `%s'" filename)))) + + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + + ;; Set file modification time. + (when (or (eq visit t) (stringp visit)) + (set-visited-file-modtime + (tramp-compat-file-attribute-modification-time + (file-attributes filename)))) + + ;; The end. + (when (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) + (tramp-message v 0 "Wrote %s" filename)) + (run-hooks 'tramp-handle-write-region-hook))) + +;; This is used in tramp-sh.el and tramp-sudoedit.el. +(defconst tramp-stat-marker "/////" + "Marker in stat commands for file attributes.") + +(defconst tramp-stat-quoted-marker "\\/\\/\\/\\/\\/" + "Quoted marker in stat commands for file attributes.") + +;; This is used in tramp-gvfs.el and tramp-sh.el. +(defconst tramp-gio-events + '("attribute-changed" "changed" "changes-done-hint" + "created" "deleted" "moved" "pre-unmount" "unmounted") + "List of events \"gio monitor\" could send.") + +;; This is the default handler. tramp-gvfs.el and tramp-sh.el have +;; their own one. (defun tramp-handle-file-notify-add-watch (filename _flags _callback) "Like `file-notify-add-watch' for Tramp files." - ;; This is the default handler. tramp-gvfs.el and tramp-sh.el have - ;; their own one. (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil (tramp-error @@ -3589,6 +3829,8 @@ of." ;; The descriptor must be a process object. (unless (processp proc) (tramp-error proc 'file-notify-error "Not a valid descriptor %S" proc)) + ;; There might be pending output. + (while (tramp-accept-process-output proc 0)) (tramp-message proc 6 "Kill %S" proc) (delete-process proc)) @@ -3602,6 +3844,12 @@ of." (concat (file-remote-p default-directory) (process-get proc 'watch-name)))))) +(defun tramp-file-notify-process-sentinel (proc event) + "Call `file-notify-rm-watch'." + (unless (process-live-p proc) + (tramp-message proc 5 "Sentinel called: `%S' `%s'" proc event) + (tramp-compat-funcall 'file-notify-rm-watch proc))) + ;;; Functions for establishing connection: ;; The following functions are actions to be taken when seeing certain @@ -3610,17 +3858,17 @@ of." (defun tramp-action-login (_proc vec) "Send the login name." - (when (not (stringp tramp-current-user)) - (setq tramp-current-user - (with-tramp-connection-property vec "login-as" - (save-window-excursion - (let ((enable-recursive-minibuffers t)) - (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 3 "Sending login name `%s'" tramp-current-user) - (tramp-send-string vec (concat tramp-current-user tramp-local-end-of-line))) + (let ((user (or (tramp-file-name-user vec) + (with-tramp-connection-property vec "login-as" + (save-window-excursion + (let ((enable-recursive-minibuffers t)) + (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 3 "Sending login name `%s'" user) + (tramp-send-string vec (concat user tramp-local-end-of-line))) + t) (defun tramp-action-password (proc vec) "Query the user for a password." @@ -3636,11 +3884,12 @@ of." (tramp-check-for-regexp proc tramp-password-prompt-regexp) (tramp-message vec 3 "Sending %s" (match-string 1)) ;; We don't call `tramp-send-string' in order to hide the - ;; password from the debug buffer. + ;; password from the debug buffer and the traces. (process-send-string proc (concat (tramp-read-passwd proc) tramp-local-end-of-line)) ;; Hide password prompt. - (narrow-to-region (point-max) (point-max))))) + (narrow-to-region (point-max) (point-max)))) + t) (defun tramp-action-succeed (_proc _vec) "Signal success in finding shell prompt." @@ -3657,13 +3906,14 @@ Send \"yes\" to remote process on confirmation, abort otherwise. See also `tramp-action-yn'." (save-window-excursion (let ((enable-recursive-minibuffers t)) - (save-match-data (pop-to-buffer (tramp-get-connection-buffer vec))) + (pop-to-buffer (tramp-get-connection-buffer vec)) (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-send-string vec (concat "yes" tramp-local-end-of-line))))) + (tramp-send-string vec (concat "yes" tramp-local-end-of-line)))) + t) (defun tramp-action-yn (proc vec) "Ask the user for confirmation using `y-or-n-p'. @@ -3671,13 +3921,14 @@ Send \"y\" to remote process on confirmation, abort otherwise. See also `tramp-action-yesno'." (save-window-excursion (let ((enable-recursive-minibuffers t)) - (save-match-data (pop-to-buffer (tramp-get-connection-buffer vec))) + (pop-to-buffer (tramp-get-connection-buffer vec)) (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-send-string vec (concat "y" tramp-local-end-of-line))))) + (tramp-send-string vec (concat "y" tramp-local-end-of-line)))) + t) (defun tramp-action-terminal (_proc vec) "Tell the remote host which terminal type to use. @@ -3685,7 +3936,8 @@ 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-send-string vec (concat tramp-terminal-type tramp-local-end-of-line))) + (tramp-send-string vec (concat tramp-terminal-type tramp-local-end-of-line)) + t) (defun tramp-action-process-alive (proc _vec) "Check, whether a process has finished." @@ -3695,14 +3947,14 @@ The terminal type can be configured with `tramp-terminal-type'." (defun tramp-action-out-of-band (proc vec) "Check, whether an out-of-band copy has finished." ;; There might be pending output for the exit status. - (tramp-accept-process-output proc 0.1) + (while (tramp-accept-process-output proc 0)) (cond ((and (not (process-live-p proc)) (zerop (process-exit-status proc))) (tramp-message vec 3 "Process has finished.") (throw 'tramp-action 'ok)) ((or (and (memq (process-status proc) '(stop exit)) (not (zerop (process-exit-status proc)))) - (memq (process-status proc) '(signal))) + (eq (process-status proc) 'signal)) ;; `scp' could have copied correctly, but set modes could have failed. ;; This can be ignored. (with-current-buffer (process-buffer proc) @@ -3719,13 +3971,14 @@ The terminal type can be configured with `tramp-terminal-type'." ;;; Functions for processing the actions: (defun tramp-process-one-action (proc vec actions) - "Wait for output from the shell and perform one action." + "Wait for output from the shell and perform one action. +See `tramp-process-actions' for the format of ACTIONS." (let ((case-fold-search t) found todo item pattern action) (while (not found) ;; Reread output once all actions have been performed. ;; Obviously, the output was not complete. - (tramp-accept-process-output proc 1) + (while (tramp-accept-process-output proc 0)) (setq todo actions) (while todo (setq item (pop todo)) @@ -3742,14 +3995,32 @@ The terminal type can be configured with `tramp-terminal-type'." "Perform ACTIONS until success or TIMEOUT. PROC and VEC indicate the remote connection to be used. POS, if set, is the starting point of the region to be deleted in the -connection buffer." +connection buffer. + +ACTIONS is a list of (PATTERN ACTION). The PATTERN should be a +symbol, a variable. The value of this variable gives the regular +expression to search for. Note that the regexp must match at the +end of the buffer, \"\\'\" is implicitly appended to it. + +The ACTION should also be a symbol, but a function. When the +corresponding PATTERN matches, the ACTION function is called. + +An ACTION function has two arguments (PROC VEC). If it returns +nil, nothing has been done, and the next action shall be called. +A non-nil return value indicates that the process output has been +consumed, and new output shall be retrieved, before starting to +process all ACTIONs, again. The same happens after calling the +last ACTION. + +If an action determines, that all processing has been done (e.g., +because the shell prompt has been detected), it shall throw a +result. The symbol `ok' means that all ACTIONs have been +performed successfully. Any other value means an error." ;; Enable `auth-source', unless "emacs -Q" has been called. We must - ;; use `tramp-current-*' variables in case we have several hops. + ;; use the "password-vector" property in case we have several hops. (tramp-set-connection-property - (make-tramp-file-name - :method tramp-current-method :user tramp-current-user - :domain tramp-current-domain :host tramp-current-host - :port tramp-current-port) + (tramp-get-connection-property + proc "password-vector" (process-get proc 'vector)) "first-password-request" tramp-cache-read-persistent-data) (save-restriction (with-tramp-progress-reporter @@ -3768,7 +4039,11 @@ connection buffer." (with-current-buffer (tramp-get-connection-buffer vec) (widen) (tramp-message vec 6 "\n%s" (buffer-string))) - (unless (eq exit 'ok) + (if (eq exit 'ok) + (ignore-errors + (and (functionp tramp-password-save-function) + (funcall tramp-password-save-function))) + ;; Not successful. (tramp-clear-passwd vec) (delete-process proc) (tramp-error-with-buffer @@ -3781,9 +4056,10 @@ connection buffer." (tramp-get-connection-buffer vec))) ((eq exit 'process-died) (substitute-command-keys - (concat - "Tramp failed to connect. If this happens repeatedly, try\n" - " `\\[tramp-cleanup-this-connection]'"))) + (eval-when-compile + (concat + "Tramp failed to connect. If this happens repeatedly, try\n" + " `\\[tramp-cleanup-this-connection]'")))) ((eq exit 'timeout) (format-message "Timeout reached, see buffer `%s' for details" @@ -3791,28 +4067,26 @@ connection buffer." (t "Login failed"))))) (when (numberp pos) (with-current-buffer (tramp-get-connection-buffer vec) - (let (buffer-read-only) (delete-region pos (point)))))))) + (let ((inhibit-read-only t)) (delete-region pos (point)))))))) ;;; Utility functions: -(defun tramp-accept-process-output (proc timeout) +(defun tramp-accept-process-output (proc &optional timeout) "Like `accept-process-output' for Tramp processes. This is needed in order to hide `last-coding-system-used', which is set for process communication also." (with-current-buffer (process-buffer proc) - (let (buffer-read-only last-coding-system-used - ;; We do not want to run timers. - timer-list timer-idle-list) - ;; Under Windows XP, `accept-process-output' doesn't return - ;; sometimes. So we add an additional timeout. JUST-THIS-ONE - ;; is set due to Bug#12145. It is an integer, in order to avoid - ;; running timers as well. + (let ((inhibit-read-only t) + last-coding-system-used + result) + ;; JUST-THIS-ONE is set due to Bug#12145. (tramp-message - proc 10 "%s %s %s\n%s" - proc (process-status proc) - (with-timeout (timeout) - (accept-process-output proc timeout nil 0)) - (buffer-string))))) + proc 10 "%s %s %s %s\n%s" + proc timeout (process-status proc) + (with-local-quit + (setq result (accept-process-output proc timeout nil t))) + (buffer-string)) + result))) (defun tramp-check-for-regexp (proc regexp) "Check, whether REGEXP is contained in process buffer of PROC. @@ -3855,31 +4129,34 @@ Erase echoed commands if exists." Expects the output of PROC to be sent to the current buffer. Returns the string that matched, or nil. Waits indefinitely if TIMEOUT is nil." - (with-current-buffer (process-buffer proc) - (let ((found (tramp-check-for-regexp proc regexp))) - (cond (timeout - (with-timeout (timeout) - (while (not found) - (tramp-accept-process-output proc 1) - (unless (process-live-p proc) - (tramp-error-with-buffer - nil proc 'file-error "Process has died")) - (setq found (tramp-check-for-regexp proc regexp))))) - (t + (let ((found (tramp-check-for-regexp proc regexp))) + (cond (timeout + (with-timeout (timeout) (while (not found) - (tramp-accept-process-output proc 1) + (tramp-accept-process-output proc) (unless (process-live-p proc) (tramp-error-with-buffer nil proc 'file-error "Process has died")) (setq found (tramp-check-for-regexp proc regexp))))) - (tramp-message proc 6 "\n%s" (buffer-string)) - (when (not found) - (if timeout - (tramp-error - proc 'file-error "[[Regexp `%s' not found in %d secs]]" - regexp timeout) - (tramp-error proc 'file-error "[[Regexp `%s' not found]]" regexp))) - found))) + (t + (while (not found) + (tramp-accept-process-output proc) + (unless (process-live-p proc) + (tramp-error-with-buffer + nil proc 'file-error "Process has died")) + (setq found (tramp-check-for-regexp proc regexp))))) + ;; 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)))) + (unless found + (if timeout + (tramp-error + proc 'file-error "[[Regexp `%s' not found in %d secs]]" + regexp timeout) + (tramp-error proc 'file-error "[[Regexp `%s' not found]]" regexp))) + found)) ;; It seems that Tru64 Unix does not like it if long strings are sent ;; to it in one go. (This happens when sending the Perl @@ -3901,26 +4178,40 @@ the remote host use line-endings as defined in the variable (with-current-buffer (tramp-get-connection-buffer vec) ;; Clean up the buffer. We cannot call `erase-buffer' because ;; narrowing might be in effect. - (let (buffer-read-only) (delete-region (point-min) (point-max))) + (let ((inhibit-read-only t)) (delete-region (point-min) (point-max))) ;; Replace "\n" by `tramp-rsh-end-of-line'. (setq string (mapconcat - 'identity (split-string string "\n") tramp-rsh-end-of-line)) - (unless (or (string= string "") + #'identity (split-string string "\n") tramp-rsh-end-of-line)) + (unless (or (string-empty-p string) (string-equal (substring string -1) tramp-rsh-end-of-line)) (setq string (concat string tramp-rsh-end-of-line))) ;; Send the string. - (if (and chunksize (not (zerop chunksize))) - (let ((pos 0) - (end (length string))) - (while (< pos end) - (tramp-message - vec 10 "Sending chunk from %s to %s" - pos (min (+ pos chunksize) end)) - (process-send-string - p (substring string pos (min (+ pos chunksize) end))) - (setq pos (+ pos chunksize)))) - (process-send-string p string))))) + (with-local-quit + (if (and chunksize (not (zerop chunksize))) + (let ((pos 0) + (end (length string))) + (while (< pos end) + (tramp-message + vec 10 "Sending chunk from %s to %s" + pos (min (+ pos chunksize) end)) + (process-send-string + p (substring string pos (min (+ pos chunksize) end))) + (setq pos (+ pos chunksize)))) + (process-send-string p string)))))) + +(defun tramp-process-sentinel (proc event) + "Flush file caches and remove shell prompt." + (unless (process-live-p proc) + (let ((vec (process-get proc 'vector)) + (prompt (tramp-get-connection-property proc "prompt" nil))) + (when vec + (tramp-message vec 5 "Sentinel called: `%S' `%s'" proc event) + (tramp-flush-connection-properties proc) + (tramp-flush-directory-properties vec "")) + (goto-char (point-max)) + (when (and prompt (re-search-backward (regexp-quote prompt) nil t)) + (delete-region (point) (point-max)))))) (defun tramp-get-inode (vec) "Returns the virtual inode number. @@ -3934,6 +4225,7 @@ If it doesn't exist, generate a new one." (with-tramp-connection-property (tramp-get-connection-process vec) "device" (cons -1 (setq tramp-devices (1+ tramp-devices))))) +;; Comparision of vectors is performed by `tramp-file-name-equal-p'. (defun tramp-equal-remote (file1 file2) "Check, whether the remote parts of FILE1 and FILE2 are identical. The check depends on method, user and host name of the files. If @@ -3943,16 +4235,17 @@ account. Example: - (tramp-equal-remote \"/ssh::/etc\" \"/<your host name>:/home\") + (tramp-equal-remote \"/ssh::/etc\" \"/-:<your host name>:/home\") would yield t. On the other hand, the following check results in nil: - (tramp-equal-remote \"/sudo::/etc\" \"/su::/etc\")" - (and (tramp-tramp-file-p file1) - (tramp-tramp-file-p file2) - (string-equal (file-remote-p file1) (file-remote-p file2)))) + (tramp-equal-remote \"/sudo::/etc\" \"/su::/etc\") + +If both files are local, the function returns t." + (or (and (null (file-remote-p file1)) (null (file-remote-p file2))) + (and (tramp-tramp-file-p file1) (tramp-tramp-file-p file2) + (string-equal (file-remote-p file1) (file-remote-p file2))))) -;;;###tramp-autoload (defun tramp-mode-string-to-int (mode-string) "Converts a ten-letter `drwxrwxrwx'-style mode string into mode bits." (let* (case-fold-search @@ -3966,53 +4259,52 @@ would yield t. On the other hand, the following check results in nil: (other-read (aref mode-chars 7)) (other-write (aref mode-chars 8)) (other-execute-or-sticky (aref mode-chars 9))) - (save-match-data - (logior - (cond - ((char-equal owner-read ?r) (string-to-number "00400" 8)) - ((char-equal owner-read ?-) 0) - (t (error "Second char `%c' must be one of `r-'" owner-read))) - (cond - ((char-equal owner-write ?w) (string-to-number "00200" 8)) - ((char-equal owner-write ?-) 0) - (t (error "Third char `%c' must be one of `w-'" owner-write))) - (cond - ((char-equal owner-execute-or-setid ?x) (string-to-number "00100" 8)) - ((char-equal owner-execute-or-setid ?S) (string-to-number "04000" 8)) - ((char-equal owner-execute-or-setid ?s) (string-to-number "04100" 8)) - ((char-equal owner-execute-or-setid ?-) 0) - (t (error "Fourth char `%c' must be one of `xsS-'" - owner-execute-or-setid))) - (cond - ((char-equal group-read ?r) (string-to-number "00040" 8)) - ((char-equal group-read ?-) 0) - (t (error "Fifth char `%c' must be one of `r-'" group-read))) - (cond - ((char-equal group-write ?w) (string-to-number "00020" 8)) - ((char-equal group-write ?-) 0) - (t (error "Sixth char `%c' must be one of `w-'" group-write))) - (cond - ((char-equal group-execute-or-setid ?x) (string-to-number "00010" 8)) - ((char-equal group-execute-or-setid ?S) (string-to-number "02000" 8)) - ((char-equal group-execute-or-setid ?s) (string-to-number "02010" 8)) - ((char-equal group-execute-or-setid ?-) 0) - (t (error "Seventh char `%c' must be one of `xsS-'" - group-execute-or-setid))) - (cond - ((char-equal other-read ?r) (string-to-number "00004" 8)) - ((char-equal other-read ?-) 0) - (t (error "Eighth char `%c' must be one of `r-'" other-read))) - (cond - ((char-equal other-write ?w) (string-to-number "00002" 8)) - ((char-equal other-write ?-) 0) - (t (error "Ninth char `%c' must be one of `w-'" other-write))) - (cond - ((char-equal other-execute-or-sticky ?x) (string-to-number "00001" 8)) - ((char-equal other-execute-or-sticky ?T) (string-to-number "01000" 8)) - ((char-equal other-execute-or-sticky ?t) (string-to-number "01001" 8)) - ((char-equal other-execute-or-sticky ?-) 0) - (t (error "Tenth char `%c' must be one of `xtT-'" - other-execute-or-sticky))))))) + (logior + (cond + ((char-equal owner-read ?r) #o0400) + ((char-equal owner-read ?-) 0) + (t (error "Second char `%c' must be one of `r-'" owner-read))) + (cond + ((char-equal owner-write ?w) #o0200) + ((char-equal owner-write ?-) 0) + (t (error "Third char `%c' must be one of `w-'" owner-write))) + (cond + ((char-equal owner-execute-or-setid ?x) #o0100) + ((char-equal owner-execute-or-setid ?S) #o4000) + ((char-equal owner-execute-or-setid ?s) #o4100) + ((char-equal owner-execute-or-setid ?-) 0) + (t (error "Fourth char `%c' must be one of `xsS-'" + owner-execute-or-setid))) + (cond + ((char-equal group-read ?r) #o0040) + ((char-equal group-read ?-) 0) + (t (error "Fifth char `%c' must be one of `r-'" group-read))) + (cond + ((char-equal group-write ?w) #o0020) + ((char-equal group-write ?-) 0) + (t (error "Sixth char `%c' must be one of `w-'" group-write))) + (cond + ((char-equal group-execute-or-setid ?x) #o0010) + ((char-equal group-execute-or-setid ?S) #o2000) + ((char-equal group-execute-or-setid ?s) #o2010) + ((char-equal group-execute-or-setid ?-) 0) + (t (error "Seventh char `%c' must be one of `xsS-'" + group-execute-or-setid))) + (cond + ((char-equal other-read ?r) #o0004) + ((char-equal other-read ?-) 0) + (t (error "Eighth char `%c' must be one of `r-'" other-read))) + (cond + ((char-equal other-write ?w) #o0002) + ((char-equal other-write ?-) 0) + (t (error "Ninth char `%c' must be one of `w-'" other-write))) + (cond + ((char-equal other-execute-or-sticky ?x) #o0001) + ((char-equal other-execute-or-sticky ?T) #o1000) + ((char-equal other-execute-or-sticky ?t) #o1001) + ((char-equal other-execute-or-sticky ?-) 0) + (t (error "Tenth char `%c' must be one of `xtT-'" + other-execute-or-sticky)))))) (defconst tramp-file-mode-type-map '((0 . "-") ; Normal file (SVID-v2 and XPG2) @@ -4033,17 +4325,16 @@ would yield t. On the other hand, the following check results in nil: "A list of file types returned from the `stat' system call. This is used to map a mode number to a permission string.") -;;;###tramp-autoload (defun tramp-file-mode-from-int (mode) "Turn an integer representing a file mode into an ls(1)-like string." (let ((type (cdr - (assoc (logand (lsh mode -12) 15) tramp-file-mode-type-map))) - (user (logand (lsh mode -6) 7)) - (group (logand (lsh mode -3) 7)) - (other (logand (lsh mode -0) 7)) - (suid (> (logand (lsh mode -9) 4) 0)) - (sgid (> (logand (lsh mode -9) 2) 0)) - (sticky (> (logand (lsh mode -9) 1) 0))) + (assoc (logand (ash mode -12) 15) tramp-file-mode-type-map))) + (user (logand (ash mode -6) 7)) + (group (logand (ash mode -3) 7)) + (other (logand (ash mode -0) 7)) + (suid (> (logand (ash mode -9) 4) 0)) + (sgid (> (logand (ash mode -9) 2) 0)) + (sticky (> (logand (ash mode -9) 1) 0))) (setq user (tramp-file-mode-permissions user suid "s")) (setq group (tramp-file-mode-permissions group sgid "s")) (setq other (tramp-file-mode-permissions other sticky "t")) @@ -4061,20 +4352,51 @@ This is used internally by `tramp-file-mode-from-int'." (and suid (upcase suid-text)) ; suid, !execute (and x "x") "-")))) ; !suid -;;;###tramp-autoload +;; This is a Tramp internal function. A general `set-file-uid-gid' +;; outside Tramp is not needed, I believe. +(defun tramp-set-file-uid-gid (filename &optional uid gid) + "Set the ownership for FILENAME. +If UID and GID are provided, these values are used; otherwise uid +and gid of the corresponding remote or local user is taken, +depending whether FILENAME is remote or local. Both parameters +must be non-negative integers. +The setgid bit of the upper directory is respected. +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))))) + + (let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid))) + (if handler + (funcall handler #'tramp-set-file-uid-gid filename uid gid) + ;; On W32 systems, "chown" does not work. + (unless (memq system-type '(ms-dos windows-nt)) + (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer))) + (gid (or (and (natnump gid) gid) (tramp-get-local-gid 'integer)))) + (tramp-call-process + nil "chown" nil nil nil (format "%d:%d" uid gid) + (tramp-unquote-shell-quote-argument filename))))))) + (defun tramp-get-local-uid (id-format) "The uid of the local user, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." - (if (equal id-format 'integer) (user-uid) (user-login-name))) + ;; We use key nil for local connection properties. + (with-tramp-connection-property nil (format "uid-%s" id-format) + (if (equal id-format 'integer) (user-uid) (user-login-name)))) -;;;###tramp-autoload (defun tramp-get-local-gid (id-format) "The gid of the local user, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." - ;; `group-gid' has been introduced with Emacs 24.4. - (if (and (fboundp 'group-gid) (equal id-format 'integer)) - (tramp-compat-funcall 'group-gid) - (tramp-compat-file-attribute-group-id (file-attributes "~/" id-format)))) + ;; We use key nil for local connection properties. + (with-tramp-connection-property nil (format "gid-%s" id-format) + (cond + ((equal id-format 'integer) (group-gid)) + ;; `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)))))) (defun tramp-get-local-locale (&optional vec) "Determine locale, supporting UTF8 if possible. @@ -4089,8 +4411,9 @@ VEC is used for tracing." nil "locale" nil t nil "-a")))) (while candidates (goto-char (point-min)) - (if (string-match (format "^%s\r?$" (regexp-quote (car candidates))) - (buffer-string)) + (if (string-match-p + (format "^%s\r?$" (regexp-quote (car candidates))) + (buffer-string)) (setq locale (car candidates) candidates nil) (setq candidates (cdr candidates)))))) @@ -4098,7 +4421,6 @@ VEC is used for tracing." (when vec (tramp-message vec 7 "locale %s" (or locale "C"))) (or locale "C")))) -;;;###tramp-autoload (defun tramp-check-cached-permissions (vec access) "Check `file-attributes' caches for VEC. Return t if according to the cache access type ACCESS is known to @@ -4119,15 +4441,7 @@ be granted." vec (tramp-file-name-localname vec) (concat "file-attributes-" suffix) nil) (file-attributes - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - (tramp-file-name-localname vec) - (tramp-file-name-hop vec)) - (intern suffix)))) + (tramp-make-tramp-file-name vec) (intern suffix)))) (remote-uid (tramp-get-connection-property vec (concat "uid-" suffix) nil)) @@ -4167,14 +4481,14 @@ be granted." (tramp-compat-file-attribute-group-id file-attr)))))))))))) -;;;###tramp-autoload (defun tramp-local-host-p (vec) - "Return t if this points to the local host, nil otherwise." + "Return t if this points to the local host, nil otherwise. +This handles also chrooted environments, which are not regarded as local." (let ((host (tramp-file-name-host vec)) (port (tramp-file-name-port vec))) (and - (stringp host) - (string-match tramp-local-host-regexp host) + (stringp tramp-local-host-regexp) (stringp host) + (string-match-p tramp-local-host-regexp host) ;; A port is an indication for an ssh tunnel or alike. (null port) ;; The method shall be applied to one of the shell file name @@ -4184,11 +4498,7 @@ be granted." ;; The local temp directory must be writable for the other user. (file-writable-p (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - host port - (tramp-compat-temporary-file-directory))) + vec (tramp-compat-temporary-file-directory) 'nohop)) ;; On some systems, chown runs only for root. (or (zerop (user-uid)) ;; This is defined in tramp-sh.el. Let's assume this is @@ -4198,20 +4508,14 @@ be granted." (defun tramp-get-remote-tmpdir (vec) "Return directory for temporary files on the remote host identified by VEC." (with-tramp-connection-property vec "tmpdir" - (let ((dir (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp") - (tramp-file-name-hop vec)))) + (let ((dir + (tramp-make-tramp-file-name + vec (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp")))) (or (and (file-directory-p dir) (file-writable-p dir) - (file-remote-p dir 'localname)) + (tramp-compat-file-local-name dir)) (tramp-error vec 'file-error "Directory %s not accessible" dir)) dir))) -;;;###tramp-autoload (defun tramp-make-tramp-temp-file (vec) "Create a temporary file on the remote host identified by VEC. Return the local name of the temporary file." @@ -4228,7 +4532,7 @@ Return the local name of the temporary file." (setq result nil) ;; This creates the file by side effect. (set-file-times result) - (set-file-modes result (string-to-number "0700" 8)))) + (set-file-modes result #o0700))) ;; Return the local part. (with-parsed-tramp-file-name result nil localname))) @@ -4238,11 +4542,11 @@ Return the local name of the temporary file." (when (stringp tramp-temp-buffer-file-name) (ignore-errors (delete-file tramp-temp-buffer-file-name)))) -(add-hook 'kill-buffer-hook 'tramp-delete-temp-file-function) +(add-hook 'kill-buffer-hook #'tramp-delete-temp-file-function) (add-hook 'tramp-unload-hook (lambda () (remove-hook 'kill-buffer-hook - 'tramp-delete-temp-file-function))) + #'tramp-delete-temp-file-function))) (defun tramp-handle-make-auto-save-file-name () "Like `make-auto-save-file-name' for Tramp files. @@ -4278,7 +4582,7 @@ this file, if that variable is non-nil." (tramp-compat-file-name-unquote (buffer-file-name))) tramp-auto-save-directory)))) ;; Run plain `make-auto-save-file-name'. - (tramp-run-real-handler 'make-auto-save-file-name nil))) + (tramp-run-real-handler #'make-auto-save-file-name nil))) (defun tramp-subst-strs-in-string (alist string) "Replace all occurrences of the string FROM with TO in STRING. @@ -4317,22 +4621,19 @@ ALIST is of the form ((FROM . TO) ...)." It always returns a return code. The Lisp error raised when PROGRAM is nil is trapped also, returning 1. Furthermore, traces are written with verbosity of 6." - (let ((default-directory (tramp-compat-temporary-file-directory)) - (v (or vec - (make-tramp-file-name - :method tramp-current-method :user tramp-current-user - :domain tramp-current-domain :host tramp-current-host - :port tramp-current-port))) + (let ((default-directory (tramp-compat-temporary-file-directory)) + (process-environment (default-toplevel-value 'process-environment)) (destination (if (eq destination t) (current-buffer) destination)) + (vec (or vec (car tramp-current-connection))) output error result) (tramp-message - v 6 "`%s %s' %s %s" - program (mapconcat 'identity args " ") infile destination) + vec 6 "`%s %s' %s %s" + program (string-join args " ") infile destination) (condition-case err (with-temp-buffer (setq result (apply - 'call-process program infile (or destination t) display args)) + #'call-process program infile (or destination t) display args)) ;; `result' could also be an error string. (when (stringp result) (setq error result @@ -4344,8 +4645,8 @@ are written with verbosity of 6." (setq error (error-message-string err) result 1))) (if (zerop (length error)) - (tramp-message v 6 "%d\n%s" result output) - (tramp-message v 6 "%d\n%s\n%s" result output error)) + (tramp-message vec 6 "%d\n%s" result output) + (tramp-message vec 6 "%d\n%s\n%s" result output error)) result)) (defun tramp-call-process-region @@ -4354,55 +4655,77 @@ are written with verbosity of 6." It always returns a return code. The Lisp error raised when PROGRAM is nil is trapped also, returning 1. Furthermore, traces are written with verbosity of 6." - (let ((default-directory (tramp-compat-temporary-file-directory)) - (v (or vec - (make-tramp-file-name - :method tramp-current-method :user tramp-current-user - :domain tramp-current-domain :host tramp-current-host - :port tramp-current-port))) + (let ((default-directory (tramp-compat-temporary-file-directory)) + (process-environment (default-toplevel-value 'process-environment)) (buffer (if (eq buffer t) (current-buffer) buffer)) result) (tramp-message - v 6 "`%s %s' %s %s %s %s" - program (mapconcat 'identity args " ") start end delete buffer) + vec 6 "`%s %s' %s %s %s %s" + program (string-join args " ") start end delete buffer) (condition-case err (progn (setq result (apply - 'call-process-region + #'call-process-region start end program delete buffer display args)) ;; `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 v 6 "%d" result) - (tramp-message v 6 "%d\n%s" result (buffer-string))))) + (tramp-message vec 6 "%d" result) + (tramp-message vec 6 "%d\n%s" result (buffer-string))))) (error (setq result 1) - (tramp-message v 6 "%d\n%s" result (error-message-string err)))) + (tramp-message vec 6 "%d\n%s" result (error-message-string err)))) + result)) + +(defun tramp-process-lines + (vec program &rest args) + "Calls `process-lines' on the local host. +If an error occurs, it returns nil. Traces are written with +verbosity of 6." + (let ((default-directory (tramp-compat-temporary-file-directory)) + (process-environment (default-toplevel-value 'process-environment)) + (vec (or vec (car tramp-current-connection))) + result) + (if args + (tramp-message vec 6 "%s %s" program (string-join args " ")) + (tramp-message vec 6 "%s" program)) + (setq result + (condition-case err + (apply #'process-lines program args) + (error + (tramp-error vec (car err) (cdr err))))) + (tramp-message vec 6 "%s" result) result)) -;;;###tramp-autoload (defun tramp-read-passwd (proc &optional prompt) "Read a password from user (compat function). Consults the auth-source package. Invokes `password-read' if available, `read-passwd' else." (let* ((case-fold-search t) (key (tramp-make-tramp-file-name - tramp-current-method tramp-current-user tramp-current-domain - tramp-current-host tramp-current-port "")) + ;; 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)) (pw-prompt (or prompt (with-current-buffer (process-buffer proc) (tramp-check-for-regexp proc tramp-password-prompt-regexp) (format "%s for %s " (capitalize (match-string 1)) key)))) + (auth-source-creation-prompts `((secret . ,pw-prompt))) ;; 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. @@ -4411,82 +4734,69 @@ Invokes `password-read' if available, `read-passwd' else." v "first-password-request" nil) ;; Try with Tramp's current method. (setq auth-info - (auth-source-search - :max 1 - (and tramp-current-user :user) - (if tramp-current-domain - (format - "%s%s%s" - tramp-current-user tramp-prefix-domain-format - tramp-current-domain) - tramp-current-user) - :host - (if tramp-current-port - (format - "%s%s%s" - tramp-current-host tramp-prefix-port-format - tramp-current-port) - tramp-current-host) - :port tramp-current-method - :require - (cons - :secret (and tramp-current-user '(:user)))) - auth-passwd (plist-get - (nth 0 auth-info) :secret) - auth-passwd (if (functionp auth-passwd) - (funcall auth-passwd) - auth-passwd)))) + (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. - (let ((password (password-read pw-prompt key))) - (password-cache-add key password) - password) - ;; Else, get the password interactively. + (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)) + (tramp-set-connection-property v "first-password-request" nil))) + ;; Reenable the timers. (with-timeout-unsuspend stimers)))) -;;;###tramp-autoload (defun tramp-clear-passwd (vec) "Clear password cache for connection related to VEC." (let ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (domain (tramp-file-name-domain vec)) (user-domain (tramp-file-name-user-domain vec)) - (host (tramp-file-name-host vec)) - (port (tramp-file-name-port vec)) (host-port (tramp-file-name-host-port vec)) (hop (tramp-file-name-hop vec))) (when hop ;; Clear also the passwords of the hops. - (tramp-clear-passwd - (tramp-dissect-file-name - (concat - tramp-prefix-format - (replace-regexp-in-string - (concat tramp-postfix-hop-regexp "$") - tramp-postfix-host-format hop))))) + (tramp-clear-passwd (tramp-dissect-hop-name hop))) (auth-source-forget `(:max 1 ,(and user-domain :user) ,user-domain :host ,host-port :port ,method)) - (password-cache-remove - (tramp-make-tramp-file-name method user domain host port "")))) - -;; Snarfed code from time-date.el. - -(defconst tramp-half-a-year '(241 17024) -"Evaluated by \"(days-to-time 183)\".") + (password-cache-remove (tramp-make-tramp-file-name vec 'noloc 'nohop)))) -;;;###tramp-autoload (defun tramp-time-diff (t1 t2) "Return the difference between the two times, in seconds. T1 and T2 are time values (as returned by `current-time' for example)." - ;; Starting with Emacs 25.1, we could change this to use `time-subtract'. - (float-time (tramp-compat-funcall 'subtract-time t1 t2))) + (float-time (time-subtract t1 t2))) (defun tramp-unquote-shell-quote-argument (s) - "Remove quotation prefix \"/:\" from string S, and quote it then for shell." - (shell-quote-argument (tramp-compat-file-name-unquote s))) + "Remove quotation prefix \"/:\" from string S, and quote it then for shell. +Suppress `shell-file-name'. This is needed on w32 systems, which +would use a wrong quoting for local file names. See `w32-shell-name'." + (let (shell-file-name) + (shell-quote-argument (tramp-compat-file-name-unquote s)))) ;; Currently (as of Emacs 20.5), the function `shell-quote-argument' ;; does not deal well with newline characters. Newline is replaced by @@ -4509,7 +4819,6 @@ T1 and T2 are time values (as returned by `current-time' for example)." ;; ;; Thanks to Mario DeWeerd for the hint that it is sufficient for this ;; function to work with Bourne-like shells. -;;;###tramp-autoload (defun tramp-shell-quote-argument (s) "Similar to `shell-quote-argument', but groks newlines. Only works for Bourne-like shells." @@ -4541,82 +4850,46 @@ Only works for Bourne-like shells." pid) ;; If it's a Tramp process, send the INT signal remotely. (when (and (processp proc) (setq pid (process-get proc 'remote-pid))) - (if (not (process-live-p proc)) + (if (not (process-live-p proc)) (tramp-error proc 'error "Process %s is not active" proc) (tramp-message proc 5 "Interrupt process %s with pid %s" proc pid) ;; This is for tramp-sh.el. Other backends do not support this (yet). (tramp-compat-funcall 'tramp-send-command - (tramp-get-connection-property proc "vector" nil) - (format "kill -2 %d" pid)) + (process-get proc 'vector) + (format "kill -2 -%d" pid)) ;; Wait, until the process has disappeared. If it doesn't, ;; fall back to the default implementation. - (with-timeout (1 (ignore)) - (while (process-live-p proc) - ;; We cannot run `tramp-accept-process-output', it blocks timers. - (accept-process-output proc 0.1)) - ;; Report success. - proc))))) + (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)))) - -;;; Integration of eshell.el: - -;; eshell.el keeps the path in `eshell-path-env'. We must change it -;; when `default-directory' points to another host. -(defun tramp-eshell-directory-change () - "Set `eshell-path-env' to $PATH of the host related to `default-directory'." - (setq eshell-path-env - (if (tramp-tramp-file-p default-directory) - (with-parsed-tramp-file-name default-directory nil - (mapconcat - 'identity - (or - ;; When `tramp-own-remote-path' is in `tramp-remote-path', - ;; the remote path is only set in the session cache. - ;; Use `path-separator' as it does eshell. - (tramp-get-connection-property - (tramp-get-connection-process v) "remote-path" nil) - (tramp-get-connection-property v "remote-path" nil)) - path-separator)) - (getenv "PATH")))) - -(eval-after-load "esh-util" - '(progn - (add-hook 'eshell-mode-hook - 'tramp-eshell-directory-change) - (add-hook 'eshell-directory-change-hook - 'tramp-eshell-directory-change) - (add-hook 'tramp-unload-hook - (lambda () - (remove-hook 'eshell-mode-hook - 'tramp-eshell-directory-change) - (remove-hook 'eshell-directory-change-hook - 'tramp-eshell-directory-change))))) + (remove-hook 'interrupt-process-functions #'tramp-interrupt-process)))) ;; Checklist for `tramp-unload-hook' ;; - Unload all `tramp-*' packages ;; - Reset `file-name-handler-alist' ;; - Cleanup hooks where Tramp functions are in -;; - Cleanup advised functions ;; - Cleanup autoloads ;;;###autoload (defun tramp-unload-tramp () "Discard Tramp from loading remote files." (interactive) - ;; ange-ftp settings must be enabled. + ;; ange-ftp settings must be re-enabled. (tramp-compat-funcall 'tramp-ftp-enable-ange-ftp) ;; Maybe it's not loaded yet. (ignore-errors (unload-feature 'tramp 'force))) (provide 'tramp) +(run-hooks 'tramp--startup-hook) +(setq tramp--startup-hook nil) + ;;; TODO: ;; ;; * Avoid screen blanking when hitting `g' in dired. (Eli Tziperman) @@ -4639,6 +4912,12 @@ Only works for Bourne-like shells." ;; and friends, for most of the handlers this is the major ;; difference between the different backends. Other handlers but ;; *-process-file would profit from this as well. +;; +;; * Get rid of `shell-command'. In its primary implementation, it +;; uses `process-file-shell-command' and +;; `start-file-process-shell-command', which is sufficient due to +;; connection-local `shell-file-name'. + ;;; tramp.el ends here diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 81d80d0a5a7..9fe848dbbe2 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -7,7 +7,6 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.3.5.26.3 ;; This file is part of GNU Emacs. @@ -26,39 +25,49 @@ ;;; Code: -;; In the Tramp GIT repository, the version number and the bug report -;; address are auto-frobbed from configure.ac, so you should edit that -;; file and run "autoconf && ./configure" to change them. Emacs -;; version check is defined in macro AC_EMACS_INFO of aclocal.m4; -;; should be changed only there. +;; In the Tramp GIT, the version number is auto-frobbed from tramp.el, +;; and the bug report address is auto-frobbed from configure.ac. +;; Emacs version check is defined in macro AC_EMACS_INFO of +;; aclocal.m4; should be changed only there. ;;;###tramp-autoload -(defconst tramp-version "2.3.5.26.3" +(defconst tramp-version "2.4.3-pre" "This version of Tramp.") ;;;###tramp-autoload (defconst tramp-bug-report-address "tramp-devel@gnu.org" "Email address to send bug reports to.") -(defun tramp-repository-get-version () - "Try to return as a string the repository revision of the Tramp sources." - (let ((dir (locate-dominating-file (locate-library "tramp") ".git"))) - (when dir - (with-temp-buffer - (let ((default-directory (file-name-as-directory dir))) - (and (zerop - (ignore-errors - (call-process "git" nil '(t nil) nil "rev-parse" "HEAD"))) - (not (zerop (buffer-size))) - (replace-regexp-in-string "\n" "" (buffer-string)))))))) +(defconst tramp-repository-branch + (ignore-errors + ;; Suppress message from `emacs-repository-get-branch'. We must + ;; also handle out-of-tree builds. + (let ((inhibit-message t) + (dir (or (locate-dominating-file (locate-library "tramp") ".git") + source-directory))) + ;; `emacs-repository-get-branch' has been introduced with Emacs 27.1. + (with-no-warnings + (and (stringp dir) (file-directory-p dir) + (emacs-repository-get-branch dir))))) + "The repository branch of the Tramp sources.") + +(defconst tramp-repository-version + (ignore-errors + ;; Suppress message from `emacs-repository-get-version'. We must + ;; also handle out-of-tree builds. + (let ((inhibit-message t) + (dir (or (locate-dominating-file (locate-library "tramp") ".git") + source-directory))) + (and (stringp dir) (file-directory-p dir) + (emacs-repository-get-version dir)))) + "The repository revision of the Tramp sources.") ;; Check for Emacs version. -(let ((x (if (>= emacs-major-version 24) - "ok" - (format "Tramp 2.3.5.26.3 is not fit for %s" - (when (string-match "^.*$" (emacs-version)) - (match-string 0 (emacs-version))))))) - (unless (string-match "\\`ok\\'" x) (error "%s" x))) +(let ((x (if (not (string-lessp emacs-version "24.4")) + "ok" + (format "Tramp 2.4.3-pre is not fit for %s" + (replace-regexp-in-string "\n" "" (emacs-version)))))) + (unless (string-equal "ok" x) (error "%s" x))) ;; Tramp versions integrated into Emacs. If a user option declares a ;; `:package-version' which doesn't belong to an integrated Tramp diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el index 40df23e174a..e297b9d6108 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el @@ -342,7 +342,7 @@ Please submit bug reports and other feedback to the author, Neil W. Van Dyke (mapconcat (lambda (c) (let ((s (char-to-string c))) (cond ((string= s " ") "+") - ((string-match "[a-zA-Z_.-/]" s) s) + ((string-match "[a-zA-Z_./~-]" s) s) (t (upcase (format "%%%02x" c)))))) (encode-coding-string str 'utf-8) "")) diff --git a/lisp/net/zeroconf.el b/lisp/net/zeroconf.el index 8c58bcc41a9..36643a828eb 100644 --- a/lisp/net/zeroconf.el +++ b/lisp/net/zeroconf.el @@ -382,6 +382,8 @@ TYPE. The resulting list has the format ;; `zeroconf-services-hash'. (gethash (concat name "/" type) zeroconf-services-hash nil)) +(defvar dbus-debug) + (defun zeroconf-resolve-service (service) "Return all service attributes SERVICE as list. NAME must be a string. The service must be of service type @@ -526,22 +528,27 @@ DOMAIN is nil, the local domain is used." zeroconf-avahi-current-domain zeroconf-avahi-flags-unspec)))) +(defvar zeroconf-service-type-browser-handler-running nil + "Prevent infinite recursion in `zeroconf-service-type-browser-handler'.") + (defun zeroconf-service-type-browser-handler (&rest val) "Registered service type browser handler at the Avahi daemon." - (when zeroconf-debug - (message "zeroconf-service-type-browser-handler: %s %S" - (dbus-event-member-name last-input-event) val)) - (cond - ((string-equal (dbus-event-member-name last-input-event) "ItemNew") - ;; Parameters: (interface protocol type domain flags) - ;; Register a service browser. - (let ((object-path (zeroconf-register-service-browser (nth 2 val)))) - ;; Register the signals. - (dolist (member '("ItemNew" "ItemRemove" "Failure")) - (dbus-register-signal - :system zeroconf-service-avahi object-path - zeroconf-interface-avahi-service-browser member - 'zeroconf-service-browser-handler)))))) + (unless zeroconf-service-type-browser-handler-running + (let ((zeroconf-service-type-browser-handler-running t)) + (when zeroconf-debug + (message "zeroconf-service-type-browser-handler: %s %S" + (dbus-event-member-name last-input-event) val)) + (cond + ((string-equal (dbus-event-member-name last-input-event) "ItemNew") + ;; Parameters: (interface protocol type domain flags) + ;; Register a service browser. + (let ((object-path (zeroconf-register-service-browser (nth 2 val)))) + ;; Register the signals. + (dolist (member '("ItemNew" "ItemRemove" "Failure")) + (dbus-register-signal + :system zeroconf-service-avahi object-path + zeroconf-interface-avahi-service-browser member + 'zeroconf-service-browser-handler)))))))) (defun zeroconf-register-service-browser (type) "Register a service browser at the Avahi daemon." diff --git a/lisp/newcomment.el b/lisp/newcomment.el index 335cbdd3366..ac706b949ba 100644 --- a/lisp/newcomment.el +++ b/lisp/newcomment.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. ;; Author: code extracted from Emacs-20's simple.el -;; Maintainer: Stefan Monnier <monnier@iro.umontreal.ca> +;; Maintainer: Stefan Monnier <monnier@gnu.org> ;; Keywords: comment uncomment ;; Package: emacs @@ -159,6 +159,14 @@ The function has no args. Applicable at least in modes for languages like fixed-format Fortran where comments always start in column zero.") +(defvar-local comment-combine-change-calls t + "If non-nil (the default), use `combine-change-calls' around + calls of `comment-region-function' and + `uncomment-region-function'. This Substitutes a single call to + each of the hooks `before-change-functions' and + `after-change-functions' in place of those hooks being called + for each individual buffer change.") + (defvar comment-region-function 'comment-region-default "Function to comment a region. Its args are the same as those of `comment-region', but BEG and END are @@ -527,7 +535,7 @@ Ensure that `comment-normalize-vars' has been called before you use this." ;; comment-search-backward is only used to find the comment-column (in ;; comment-set-column) and to find the comment-start string (via ;; comment-beginning) in indent-new-comment-line, it should be harmless. - (if (not (re-search-backward comment-start-skip limit t)) + (if (not (re-search-backward comment-start-skip limit 'move)) (unless noerror (error "No comment")) (beginning-of-line) (let* ((end (match-end 0)) @@ -898,7 +906,7 @@ comment delimiters." (save-excursion (funcall uncomment-region-function beg end arg)))) -(defun uncomment-region-default (beg end &optional arg) +(defun uncomment-region-default-1 (beg end &optional arg) "Uncomment each line in the BEG .. END region. The numeric prefix ARG can specify a number of chars to remove from the comment delimiters. @@ -993,9 +1001,26 @@ This function is the default value of `uncomment-region-function'." (re-search-forward sre (line-end-position) t)) (replace-match "" t t nil (if (match-end 2) 2 1))))) ;; Go to the end for the next comment. - (goto-char (point-max)))))) + (goto-char (point-max))) + ;; Remove any obtrusive spaces left preceding a tab at `spt'. + (when (and (eq (char-after spt) ?\t) (eq (char-before spt) ? ) + (> tab-width 0)) + (save-excursion + (goto-char spt) + (let* ((fcol (current-column)) + (slim (- (point) (mod fcol tab-width)))) + (delete-char (- (skip-chars-backward " " slim))))))))) (set-marker end nil)) +(defun uncomment-region-default (beg end &optional arg) + "Uncomment each line in the BEG .. END region. +The numeric prefix ARG can specify a number of chars to remove from the +comment markers." + (if comment-combine-change-calls + (combine-change-calls beg end (uncomment-region-default-1 beg end arg)) + (uncomment-region-default-1 beg end arg))) + + (defun comment-make-bol-ws (len) "Make a white-space string of width LEN for use at BOL. When `indent-tabs-mode' is non-nil, tab characters will be used." @@ -1192,7 +1217,7 @@ changed with `comment-style'." ;; FIXME: maybe we should call uncomment depending on ARG. (funcall comment-region-function beg end arg))) -(defun comment-region-default (beg end &optional arg) +(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)) @@ -1261,6 +1286,11 @@ changed with `comment-style'." lines indent)))))) +(defun comment-region-default (beg end &optional arg) + (if comment-combine-change-calls + (combine-change-calls beg end (comment-region-default-1 beg end arg)) + (comment-region-default-1 beg end arg))) + ;;;###autoload (defun comment-box (beg end &optional arg) "Comment out the BEG .. END region, putting it inside a box. diff --git a/lisp/notifications.el b/lisp/notifications.el index baab00a0e5a..1d250e2d920 100644 --- a/lisp/notifications.el +++ b/lisp/notifications.el @@ -232,8 +232,8 @@ of another `notifications-notify' call." (add-to-list 'hints `(:dict-entry "urgency" (:variant :byte ,(pcase urgency - (`low 0) - (`critical 2) + ('low 0) + ('critical 2) (_ 1)))) t)) (when category (add-to-list 'hints `(:dict-entry diff --git a/lisp/novice.el b/lisp/novice.el index e4aa2eeef4c..3da4e25810a 100644 --- a/lisp/novice.el +++ b/lisp/novice.el @@ -35,9 +35,6 @@ ;; and the keys are returned by (this-command-keys). ;;;###autoload -(define-obsolete-variable-alias 'disabled-command-hook - 'disabled-command-function "22.1") -;;;###autoload (defvar disabled-command-function 'disabled-command-function "Function to call to handle disabled commands. If nil, the feature is disabled, i.e., all commands work normally.") diff --git a/lisp/nxml/nxml-maint.el b/lisp/nxml/nxml-maint.el index 2570e51af51..c524567a5b2 100644 --- a/lisp/nxml/nxml-maint.el +++ b/lisp/nxml/nxml-maint.el @@ -34,10 +34,10 @@ (let (lst head) (with-current-buffer (find-file-noselect file) (goto-char (point-min)) - (while (re-search-forward "^ *\\([a-FA-F0-9]\\{2\\}\\)[ \t]+" nil t) + (while (re-search-forward "^ *\\([[:xdigit:]]\\{2\\}\\)[ \t]+" nil t) (let ((row (match-string 1)) (eol (line-end-position))) - (while (re-search-forward "\\([a-FA-F0-9]\\{2\\}\\)-\\([a-FA-F0-9]\\{2\\}\\)\\|\\([a-FA-F0-9]\\{2\\}\\)" eol t) + (while (re-search-forward "\\([[:xdigit:]]\\{2\\}\\)-\\([[:xdigit:]]\\{2\\}\\)\\|\\([[:xdigit:]]\\{2\\}\\)" eol t) (setq lst (cons (if (match-beginning 3) (concat "#x" row (match-string 3)) diff --git a/lisp/nxml/nxml-mode.el b/lisp/nxml/nxml-mode.el index ab035b927ee..623a6666627 100644 --- a/lisp/nxml/nxml-mode.el +++ b/lisp/nxml/nxml-mode.el @@ -56,8 +56,9 @@ The glyph is displayed in face `nxml-glyph'." :group 'nxml :type 'boolean) -(defcustom nxml-sexp-element-flag nil +(defcustom nxml-sexp-element-flag t "Non-nil means sexp commands treat an element as a single expression." + :version "27.1" ; nil -> t :group 'nxml :type 'boolean) @@ -423,6 +424,15 @@ reference.") (when rng-validate-mode (rng-validate-while-idle (current-buffer))))) +(defvar nxml-prolog-end) ;; nxml-rap.el + +(defun nxml-syntax-propertize (start end) + "Syntactic keywords for `nxml-mode'." + ;; Like `sgml-syntax-propertize', but rescan prolog if needed. + (when (< start nxml-prolog-end) + (nxml-scan-prolog)) + (sgml-syntax-propertize start end)) + (defvar tildify-space-string) (defvar tildify-foreach-region-function) @@ -471,11 +481,10 @@ The Emacs commands that normally operate on balanced expressions will operate on XML markup items. Thus \\[forward-sexp] will move forward across one markup item; \\[backward-sexp] will move backward across one markup item; \\[kill-sexp] will kill the following markup item; -\\[mark-sexp] will mark the following markup item. By default, each -tag each treated as a single markup item; to make the complete element -be treated as a single markup item, set the variable -`nxml-sexp-element-flag' to t. For more details, see the function -`nxml-forward-balanced-item'. +\\[mark-sexp] will mark the following markup item. By default, the +complete element is treated as a single markup item; to make each tag be +treated as a separate markup item, set the variable `nxml-sexp-element-flag' +to nil. For more details, see the function `nxml-forward-balanced-item'. \\[nxml-backward-up-element] and \\[nxml-down-element] move up and down the element structure. @@ -493,7 +502,7 @@ Many aspects this mode can be customized using ;; FIXME: Use the fact that we're parsing the document already ;; rather than using regex-based filtering. (setq-local tildify-foreach-region-function - (apply-partially #'tildify-foreach-ignore-environments + (apply-partially 'tildify-foreach-ignore-environments '(("<! *--" . "-- *>") ("<" . ">")))) (setq-local mode-line-process '((nxml-degraded "/degraded"))) ;; We'll determine the fill prefix ourselves @@ -518,19 +527,16 @@ Many aspects this mode can be customized using (nxml-with-invisible-motion (nxml-scan-prolog))))) (setq-local syntax-ppss-table sgml-tag-syntax-table) - (setq-local syntax-propertize-function #'sgml-syntax-propertize) + (setq-local syntax-propertize-function #'nxml-syntax-propertize) (add-hook 'change-major-mode-hook #'nxml-cleanup nil t) - ;; Emacs 23 handles the encoding attribute on the xml declaration - ;; transparently to nxml-mode, so there is no longer a need for the below - ;; hook. The hook also had the drawback of overriding explicit user - ;; instruction to save as some encoding other than utf-8. - ;;(add-hook 'write-contents-hooks #'nxml-prepare-to-save) (when (not (and (buffer-file-name) (file-exists-p (buffer-file-name)))) (when (and nxml-default-buffer-file-coding-system (not (local-variable-p 'buffer-file-coding-system))) (setq buffer-file-coding-system nxml-default-buffer-file-coding-system)) - (when nxml-auto-insert-xml-declaration-flag + ;; When starting a new file, insert the XML declaraction. + (when (and nxml-auto-insert-xml-declaration-flag + (zerop (buffer-size))) (nxml-insert-xml-declaration))) (setq font-lock-defaults @@ -540,7 +546,9 @@ Many aspects this mode can be customized using nil ; no special syntax table (font-lock-extend-region-functions . (nxml-extend-region)) (jit-lock-contextually . t) - (font-lock-unfontify-region-function . nxml-unfontify-region))) + (font-lock-unfontify-region-function . nxml-unfontify-region) + (font-lock-syntactic-face-function + . sgml-font-lock-syntactic-face))) (with-demoted-errors (rng-nxml-mode-init))) @@ -1510,17 +1518,18 @@ With ARG, do it that many times. Negative arg -N means move backward across N balanced expressions. This is the equivalent of `forward-sexp' for XML. -An element contains as items strings with no markup, tags, processing -instructions, comments, CDATA sections, entity references and -characters references. However, if the variable -`nxml-sexp-element-flag' is non-nil, then an element is treated as a -single markup item. A start-tag contains an element name followed by -one or more attributes. An end-tag contains just an element name. -An attribute value literals contains strings with no markup, entity -references and character references. A processing instruction -consists of a target and a content string. A comment or a CDATA -section contains a single string. An entity reference contains a -single name. A character reference contains a character number." +An element is by default treated as a single markup item. +However, if the variable `nxml-sexp-element-flag' is nil, then an +element contains as items strings with no markup, tags, +processing instructions, comments, CDATA sections, entity +references and character references. A start-tag contains an +element name followed by one or more attributes. An end-tag +contains just an element name. An attribute value literals +contains strings with no markup, entity references and character +references. A processing instruction consists of a target and a +content string. A comment or a CDATA section contains a single +string. An entity reference contains a single name. A character +reference contains a character number." (interactive "^p") (or arg (setq arg 1)) (cond ((> arg 0) diff --git a/lisp/nxml/nxml-rap.el b/lisp/nxml/nxml-rap.el index 21dbaded25a..cf34119c2c0 100644 --- a/lisp/nxml/nxml-rap.el +++ b/lisp/nxml/nxml-rap.el @@ -108,7 +108,6 @@ Return nil if the character at POS is not inside." (setq nxml-prolog-regions (xmltok-forward-prolog)) (setq nxml-prolog-end (point)))) - ;;; Random access parsing (defun nxml-token-after () diff --git a/lisp/nxml/rng-cmpct.el b/lisp/nxml/rng-cmpct.el index d36f9d92f26..60c871990e1 100644 --- a/lisp/nxml/rng-cmpct.el +++ b/lisp/nxml/rng-cmpct.el @@ -369,7 +369,7 @@ OVERRIDE is either nil, require or t." (and pos (rng-c-error "Nul character found (binary file?)"))) (let ((offset 0)) - (while (re-search-forward "\\\\x+{\\([0-9a-fA-F]+\\)}" + (while (re-search-forward "\\\\x+{\\([[:xdigit:]]+\\)}" (point-max) t) (let* ((ch (decode-char 'ucs (string-to-number (match-string 1) 16)))) diff --git a/lisp/nxml/rng-loc.el b/lisp/nxml/rng-loc.el index 89b58e38b06..db4f6e48284 100644 --- a/lisp/nxml/rng-loc.el +++ b/lisp/nxml/rng-loc.el @@ -407,7 +407,7 @@ or nil." "Return a list of rules for the schema locating file FILE." (setq file (expand-file-name file)) (let ((cached (assoc file rng-schema-locating-file-alist)) - (mtime (nth 5 (file-attributes file))) + (mtime (file-attribute-modification-time (file-attributes file))) parsed) (cond ((not mtime) (when cached diff --git a/lisp/nxml/rng-maint.el b/lisp/nxml/rng-maint.el index da4567daf6e..56fbf12eda9 100644 --- a/lisp/nxml/rng-maint.el +++ b/lisp/nxml/rng-maint.el @@ -226,11 +226,9 @@ (defun rng-time-function (function &rest args) (let* ((start (current-time)) - (val (apply function args)) - (end (current-time))) + (val (apply function args))) (message "%s ran in %g seconds" - function - (float-time (time-subtract end start))) + function (float-time (time-since start))) val)) (defun rng-time-tokenize-buffer () diff --git a/lisp/nxml/rng-nxml.el b/lisp/nxml/rng-nxml.el index c110937b34b..05b59316d13 100644 --- a/lisp/nxml/rng-nxml.el +++ b/lisp/nxml/rng-nxml.el @@ -160,7 +160,7 @@ Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil." (and rng-collecting-text (rng-flush-text)) (let ((target-names (rng-match-possible-start-tag-names))) `(,(1+ lt-pos) - ,(save-excursion (skip-chars-forward "[[:alnum:]_.-:]") (point)) + ,(save-excursion (skip-chars-forward "-[:alnum:]_.:") (point)) ,(apply-partially #'rng-complete-qname-function target-names nil extra-strings) :exit-function @@ -207,7 +207,7 @@ Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil." (cdar rng-open-elements)) (cdar rng-open-elements)))) `(,(+ (match-beginning 0) 2) - ,(save-excursion (skip-chars-forward "[[:alnum:]_.-:]") (point)) + ,(save-excursion (skip-chars-forward "-[:alnum:]_.:") (point)) ,(list start-tag-name) ;Sole completion candidate. :exit-function ,(lambda (_completion status) @@ -247,7 +247,7 @@ Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil." "xmlns")) rng-undeclared-prefixes))) `(,attribute-start - ,(save-excursion (skip-chars-forward "[[:alnum:]_.-:]") (point)) + ,(save-excursion (skip-chars-forward "-[:alnum:]_.:") (point)) ,(apply-partially #'rng-complete-qname-function target-names t extra-strings) :exit-function diff --git a/lisp/nxml/rng-uri.el b/lisp/nxml/rng-uri.el index 0e458cfd2f4..5a67cc7f145 100644 --- a/lisp/nxml/rng-uri.el +++ b/lisp/nxml/rng-uri.el @@ -30,9 +30,10 @@ Multibyte characters are left as is. Use `rng-uri-escape-multibyte' to escape them using %HH." (setq f (expand-file-name f)) (let ((url - (replace-regexp-in-string "[\000-\032\177<>#%\"{}|\\^[]`%?;]" - 'rng-percent-encode - f))) + ;; FIXME. Explain why the pattern doesn't also have "!$&'()*+,/:@=". + ;; See Internet RFC 3986 section 2.2. + (replace-regexp-in-string "[]\0-\s\"#%;<>?[\\^`{|}\177]" + 'rng-percent-encode f))) (concat "file:" (if (and (> (length url) 0) (= (aref url 0) ?/)) @@ -42,7 +43,7 @@ escape them using %HH." (defun rng-uri-escape-multibyte (uri) "Escape multibyte characters in URI." - (replace-regexp-in-string "[:nonascii:]" + (replace-regexp-in-string "[[:nonascii:]]" 'rng-percent-encode (encode-coding-string uri 'utf-8))) @@ -67,7 +68,7 @@ Signal an error if URI is not a valid file URL." ;; pattern is either nil or match or replace (defun rng-uri-file-name-1 (uri pattern) - (unless (string-match "\\`\\(?:[^%]\\|%[0-9a-fA-F]{2}\\)*\\'" uri) + (unless (string-match "\\`\\(?:[^%]\\|%[[:xdigit:]]{2}\\)*\\'" uri) (rng-uri-error "Bad escapes in URI `%s'" uri)) (setq uri (rng-uri-unescape-multibyte uri)) (let* ((components @@ -298,7 +299,7 @@ Both FULL and BASE must be absolute URIs." (mapconcat 'identity segments "/"))) (defun rng-uri-unescape-multibyte (str) - (replace-regexp-in-string "\\(?:%[89a-fA-F][0-9a-fA-F]\\)+" + (replace-regexp-in-string "\\(?:%[89a-fA-F][[:xdigit:]]\\)+" 'rng-multibyte-percent-decode str)) @@ -309,7 +310,7 @@ Both FULL and BASE must be absolute URIs." 'utf-8)) (defun rng-uri-unescape-unibyte (str) - (replace-regexp-in-string "%[0-7][0-9a-fA-F]" + (replace-regexp-in-string "%[0-7][[:xdigit:]]" (lambda (h) (string-to-number (substring h 1) 16)) str @@ -317,7 +318,7 @@ Both FULL and BASE must be absolute URIs." t)) (defun rng-uri-unescape-unibyte-match (str) - (replace-regexp-in-string "%[0-7][0-9a-fA-F]\\|[^%]" + (replace-regexp-in-string "%[0-7][[:xdigit:]]\\|[^%]" (lambda (match) (if (string= match "*") "\\([^/]*\\)" @@ -332,7 +333,7 @@ Both FULL and BASE must be absolute URIs." (defun rng-uri-unescape-unibyte-replace (str next-match-index) (replace-regexp-in-string - "%[0-7][0-9a-fA-F]\\|[^%]" + "%[0-7][[:xdigit:]]\\|[^%]" (lambda (match) (if (string= match "*") (let ((n next-match-index)) diff --git a/lisp/nxml/rng-xsd.el b/lisp/nxml/rng-xsd.el index 6cd1688fe46..582d08e149f 100644 --- a/lisp/nxml/rng-xsd.el +++ b/lisp/nxml/rng-xsd.el @@ -330,7 +330,7 @@ trailing digits. For example, -0021.0430 would be represented by [-1 (match-string 1 string))) (defun rng-xsd-convert-hex-binary (string) - (and (string-match "\\`[ \r\n\t]*\\(\\(?:[0-9A-Fa-f][0-9A-Fa-f]\\)*\\)[ \r\n\t]*\\'" + (and (string-match "\\`[ \r\n\t]*\\(\\(?:[[:xdigit:]][[:xdigit:]]\\)*\\)[ \r\n\t]*\\'" string) (downcase (match-string 1 string)))) @@ -360,7 +360,7 @@ trailing digits. For example, -0021.0430 would be represented by [-1 n))) (defun rng-xsd-convert-any-uri (string) - (and (string-match "\\`\\(?:[^%]\\|%[0-9a-fA-F][0-9a-fA-F]\\)?*\\'" string) + (and (string-match "\\`\\(?:[^%]\\|%[[:xdigit:]][[:xdigit:]]\\)*\\'" string) (string-match "\\`[^#]*\\(?:#[^#]*\\)?\\'" string) (string-match "\\`\\(?:[a-zA-Z][-+.A-Za-z0-9]*:.+\\|[^:]*\\(?:[#/?].*\\)?\\)\\'" string) string)) diff --git a/lisp/nxml/xmltok.el b/lisp/nxml/xmltok.el index afa33e064f3..3cab5ed9b7b 100644 --- a/lisp/nxml/xmltok.el +++ b/lisp/nxml/xmltok.el @@ -413,7 +413,7 @@ and VALUE-END, otherwise a STRING giving the value." (xmltok-g decimal-ref-close ";") opt)) (hex-ref (xmltok+ "x" open - (xmltok-g hex "[0-9a-fA-F]" +) + (xmltok-g hex "[[:xdigit:]]" +) (xmltok-g hex-ref-close ";") opt close opt)) (char-ref diff --git a/lisp/nxml/xsd-regexp.el b/lisp/nxml/xsd-regexp.el index 7ae169c19c6..c002e6fd9fb 100644 --- a/lisp/nxml/xsd-regexp.el +++ b/lisp/nxml/xsd-regexp.el @@ -702,7 +702,7 @@ Code is inserted into the current buffer." (with-current-buffer (find-file-noselect file) (goto-char (point-min)) (mapc (lambda (x) (put x 'xsdre-ranges nil)) xsdre-gen-categories) - (while (re-search-forward "^\\([0-9A-Fa-f]*\\);[^;]*;\\([A-Z][a-z]\\);" + (while (re-search-forward "^\\([[:xdigit:]]*\\);[^;]*;\\([A-Z][a-z]\\);" nil t) (let* ((sym (intern (match-string-no-properties 2))) diff --git a/lisp/obsolete/assoc.el b/lisp/obsolete/assoc.el index a601733799f..926e60516ed 100644 --- a/lisp/obsolete/assoc.el +++ b/lisp/obsolete/assoc.el @@ -27,7 +27,6 @@ ;; fetching off key-value pairs in association lists. ;;; Code: -(eval-when-compile (require 'cl)) (defun asort (alist-symbol key) "Move a specified key-value pair to the head of an alist. diff --git a/lisp/obsolete/cc-compat.el b/lisp/obsolete/cc-compat.el index bbacd121135..8e9d9e72625 100644 --- a/lisp/obsolete/cc-compat.el +++ b/lisp/obsolete/cc-compat.el @@ -59,21 +59,21 @@ ;; In case c-mode.el isn't loaded (defvar c-indent-level 2 - "*Indentation of C statements with respect to containing block.") + "Indentation of C statements with respect to containing block.") ;;;###autoload(put 'c-indent-level 'safe-local-variable 'integerp) (defvar c-brace-imaginary-offset 0 - "*Imagined indentation of a C open brace that actually follows a statement.") + "Imagined indentation of a C open brace that actually follows a statement.") (defvar c-brace-offset 0 - "*Extra indentation for braces, compared with other text in same context.") + "Extra indentation for braces, compared with other text in same context.") (defvar c-argdecl-indent 5 - "*Indentation level of declarations of C function arguments.") + "Indentation level of declarations of C function arguments.") (defvar c-label-offset -2 - "*Offset of C label lines and case statements relative to usual indentation.") + "Offset of C label lines and case statements relative to usual indentation.") (defvar c-continued-statement-offset 2 - "*Extra indent for lines not starting new statements.") + "Extra indent for lines not starting new statements.") (defvar c-continued-brace-offset 0 - "*Extra indent for substatements that start with open-braces. + "Extra indent for substatements that start with open-braces. This is in addition to c-continued-statement-offset.") diff --git a/lisp/obsolete/cl-compat.el b/lisp/obsolete/cl-compat.el index b2735826ce1..7882705fe9f 100644 --- a/lisp/obsolete/cl-compat.el +++ b/lisp/obsolete/cl-compat.el @@ -142,7 +142,7 @@ (Values (mapcar* 'list newsyms oldforms) newsyms))) (defun zip-lists (evens odds) - (mapcan 'list evens odds)) + (cl-mapcan 'list evens odds)) (defun unzip-lists (list) (let ((e nil) (o nil)) diff --git a/lisp/obsolete/complete.el b/lisp/obsolete/complete.el index da73840c73a..173a4619caa 100644 --- a/lisp/obsolete/complete.el +++ b/lisp/obsolete/complete.el @@ -191,7 +191,6 @@ If nil, means use the colon-separated path in the variable $INCPATH instead." ;;;###autoload (define-minor-mode partial-completion-mode "Toggle Partial Completion mode. -With prefix ARG, turn Partial Completion mode on if ARG is positive. When Partial Completion mode is enabled, TAB (or M-TAB if `PC-meta-flag' is nil) is enhanced so that if some string is divided into words and each word is @@ -833,9 +832,12 @@ GOTO-END is non-nil, however, it instead replaces up to END." ;; ;; Note that choose-completion-string-functions ;; plays around with point. - (setq completion-base-size (if dirname - dirlength - (- beg prompt-end)))))) + (with-suppressed-warnings ((obsolete + completion-base-size)) + (setq completion-base-size + (if dirname + dirlength + (- beg prompt-end))))))) (PC-temp-minibuffer-message " [Next char not unique]")) ;; Expansion of filenames is not reversible, ;; so just keep the prefix. diff --git a/lisp/obsolete/crisp.el b/lisp/obsolete/crisp.el index 239c7e19960..832820b0a57 100644 --- a/lisp/obsolete/crisp.el +++ b/lisp/obsolete/crisp.el @@ -353,10 +353,7 @@ normal CRiSP binding) and when it is nil M-x will run ;;;###autoload (define-minor-mode crisp-mode - "Toggle CRiSP/Brief emulation (CRiSP mode). -With a prefix argument ARG, enable CRiSP mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "Toggle CRiSP/Brief emulation (CRiSP mode)." :keymap crisp-mode-map :lighter crisp-mode-mode-line-string (when crisp-mode @@ -379,10 +376,6 @@ if ARG is omitted or nil." ;;;###autoload (defalias 'brief-mode 'crisp-mode) -;; Interaction with other packages. -(put 'crisp-home 'CUA 'move) -(put 'crisp-end 'CUA 'move) - (run-hooks 'crisp-load-hook) (provide 'crisp) diff --git a/lisp/obsolete/fast-lock.el b/lisp/obsolete/fast-lock.el index d660e5506c3..9ae6d91bde8 100644 --- a/lisp/obsolete/fast-lock.el +++ b/lisp/obsolete/fast-lock.el @@ -161,7 +161,7 @@ ;; - XEmacs: Add `font-lock-value-in-major-mode' if necessary ;; - Removed `fast-lock-submit-bug-report' and bade farewell ;; 3.11--3.12: -;; - Added Custom support (Hrvoje Niksic help) +;; - Added Custom support (Hrvoje Nikšić help) ;; - Made `save-buffer-state' wrap `inhibit-point-motion-hooks' ;; - Made `fast-lock-cache-data' simplify calls of `font-lock-compile-keywords' ;; 3.12--3.13: @@ -190,10 +190,6 @@ (defvar font-lock-face-list) (eval-when-compile - ;; - ;; We don't do this at the top-level as we only use non-autoloaded macros. - (require 'cl) - ;; ;; We use this to preserve or protect things when modifying text properties. (defmacro save-buffer-state (varlist &rest body) "Bind variables according to VARLIST and eval BODY restoring buffer state." @@ -218,23 +214,6 @@ (setq faces (cdr faces)))) faces))))) -;;(defun fast-lock-submit-bug-report () -;; "Submit via mail a bug report on fast-lock.el." -;; (interactive) -;; (let ((reporter-prompt-for-summary-p t)) -;; (reporter-submit-bug-report "simon@gnu.org" "fast-lock 3.14" -;; '(fast-lock-cache-directories fast-lock-minimum-size -;; fast-lock-save-others fast-lock-save-events fast-lock-save-faces -;; fast-lock-verbose) -;; nil nil -;; (concat "Hi Si., -;; -;;I want to report a bug. I've read the `Bugs' section of `Info' on Emacs, so I -;;know how to make a clear and unambiguous report. To reproduce the bug: -;; -;;Start a fresh editor via `" invocation-name " -no-init-file -no-site-file'. -;;In the `*scratch*' buffer, evaluate:")))) - (defgroup fast-lock nil "Font Lock support mode to cache fontification." :load 'fast-lock @@ -445,7 +424,8 @@ See `fast-lock-mode'." ;; Only save if user's restrictions are satisfied. (and min-size (>= (buffer-size) min-size)) (or fast-lock-save-others - (eq (user-uid) (nth 2 (file-attributes buffer-file-name)))) + (eq (user-uid) (file-attribute-user-id + (file-attributes buffer-file-name)))) ;; ;; Only save if there are `face' properties to save. (text-property-not-all (point-min) (point-max) 'face nil)) diff --git a/lisp/obsolete/info-edit.el b/lisp/obsolete/info-edit.el new file mode 100644 index 00000000000..b64e84003fc --- /dev/null +++ b/lisp/obsolete/info-edit.el @@ -0,0 +1,83 @@ +;; info-edit.el --- Editing info files -*- lexical-binding:t -*- + +;; Copyright (C) 1985-1986, 1992-2019 Free Software Foundation, Inc. + +;; Maintainer: emacs-devel@gnu.org +;; Keywords: help +;; Obsolete-since: 24.4 + +;; 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 'info) + +(defvar Info-edit-mode-hook nil + "Hook run when `Info-edit-mode' is activated.") + +(make-obsolete-variable 'Info-edit-mode-hook + "editing Info nodes by hand is not recommended." "24.4") + +(define-obsolete-variable-alias 'Info-edit-map 'Info-edit-mode-map "24.1") +(defvar Info-edit-mode-map (let ((map (make-sparse-keymap))) + (set-keymap-parent map text-mode-map) + (define-key map "\C-c\C-c" 'Info-cease-edit) + map) + "Local keymap used within `e' command of Info.") + +(make-obsolete-variable 'Info-edit-mode-map + "editing Info nodes by hand is not recommended." + "24.4") + +;; Info-edit mode is suitable only for specially formatted data. +(put 'Info-edit-mode 'mode-class 'special) + +(define-derived-mode Info-edit-mode text-mode "Info Edit" + "Major mode for editing the contents of an Info node. +Like text mode with the addition of `Info-cease-edit' +which returns to Info mode for browsing." + (setq buffer-read-only nil) + (force-mode-line-update) + (buffer-enable-undo (current-buffer))) + +(defun Info-edit () + "Edit the contents of this Info node." + (interactive) + (Info-edit-mode) + (message "%s" (substitute-command-keys + "Editing: Type \\<Info-edit-mode-map>\\[Info-cease-edit] to return to info"))) + +(put 'Info-edit 'disabled "Editing Info nodes by hand is not recommended. +This feature will be removed in future.") + +(defun Info-cease-edit () + "Finish editing Info node; switch back to Info proper." + (interactive) + ;; Do this first, so nothing has changed if user C-g's at query. + (and (buffer-modified-p) + (y-or-n-p "Save the file? ") + (save-buffer)) + (Info-mode) + (force-mode-line-update) + (and (marker-position Info-tag-table-marker) + (buffer-modified-p) + (message "Tags may have changed. Use Info-tagify if necessary"))) + +(provide 'info-edit) + +;;; info-edit.el ends here diff --git a/lisp/obsolete/iswitchb.el b/lisp/obsolete/iswitchb.el index 888c0af8f90..ad2067fdef7 100644 --- a/lisp/obsolete/iswitchb.el +++ b/lisp/obsolete/iswitchb.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1996-1997, 2000-2019 Free Software Foundation, Inc. ;; Author: Stephen Eglen <stephen@gnu.org> -;; Maintainer: Stephen Eglen <stephen@gnu.org> ;; Keywords: completion convenience ;; Obsolete-since: 24.4 @@ -353,8 +352,6 @@ See also `iswitchb-newbuffer'." :type 'boolean :group 'iswitchb) -(define-obsolete-variable-alias 'iswitchb-use-fonts 'iswitchb-use-faces "22.1") - (defcustom iswitchb-use-faces t "Non-nil means use font-lock faces for showing first match." :type 'boolean @@ -1247,7 +1244,7 @@ Modified from `icomplete-completions'." (if (and iswitchb-use-faces comps) (progn - (setq first (car comps)) + (setq first (copy-sequence (car comps))) (setq first (format "%s" first)) (put-text-property 0 (length first) 'face (if (= (length comps) 1) @@ -1419,9 +1416,6 @@ See the variable `iswitchb-case' for details." ;;;###autoload (define-minor-mode iswitchb-mode "Toggle Iswitchb mode. -With a prefix argument ARG, enable Iswitchb mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Iswitchb mode is a global minor mode that enables switching between buffers using substrings. See `iswitchb' for details." diff --git a/lisp/obsolete/lazy-lock.el b/lisp/obsolete/lazy-lock.el index 364c2d3200d..44f8528b201 100644 --- a/lisp/obsolete/lazy-lock.el +++ b/lisp/obsolete/lazy-lock.el @@ -267,11 +267,9 @@ ;;; Code: (require 'font-lock) +(eval-when-compile (require 'cl-lib)) (eval-when-compile - ;; We don't do this at the top-level as we only use non-autoloaded macros. - (require 'cl) - ;; ;; We use this to preserve or protect things when modifying text properties. (defmacro save-buffer-state (varlist &rest body) "Bind variables according to VARLIST and eval BODY restoring buffer state." @@ -977,7 +975,7 @@ verbosity is controlled via the variable `lazy-lock-stealth-verbose'." (while (setq beg (text-property-any beg (point-max) 'lazy-lock t)) (setq next (or (text-property-any beg (point-max) 'lazy-lock nil) (point-max))) - (incf size (- next beg)) + (cl-incf size (- next beg)) (setq beg next)) ;; Float because using integer multiplication will frequently overflow. (truncate (* (/ (float size) (point-max)) 100))))) diff --git a/lisp/obsolete/levents.el b/lisp/obsolete/levents.el index a2a50119c8a..714b3fbb761 100644 --- a/lisp/obsolete/levents.el +++ b/lisp/obsolete/levents.el @@ -145,7 +145,7 @@ It will be the next event read after all pending events." The value is an ASCII printing character (not upper case) or a symbol." (if (symbolp event) (car (get event 'event-symbol-elements)) - (let ((base (logand event (1- (lsh 1 18))))) + (let ((base (logand event (1- (ash 1 18))))) (downcase (if (< base 32) (logior base 64) base))))) (defun event-object (event) diff --git a/lisp/obsolete/longlines.el b/lisp/obsolete/longlines.el index a35947bd613..30c6f35e7b1 100644 --- a/lisp/obsolete/longlines.el +++ b/lisp/obsolete/longlines.el @@ -5,7 +5,7 @@ ;; Authors: Kai Grossjohann <Kai.Grossjohann@CS.Uni-Dortmund.DE> ;; Alex Schroeder <alex@gnu.org> ;; Chong Yidong <cyd@stupidchicken.com> -;; Maintainer: Chong Yidong <cyd@stupidchicken.com> +;; Maintainer: emacs-devel@gnu.org ;; Obsolete-since: 24.4 ;; Keywords: convenience, wp @@ -97,9 +97,6 @@ This is used when `longlines-show-hard-newlines' is on." ;;;###autoload (define-minor-mode longlines-mode "Toggle Long Lines mode in this buffer. -With a prefix argument ARG, enable Long Lines mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. When Long Lines mode is enabled, long lines are wrapped if they extend beyond `fill-column'. The soft newlines used for line diff --git a/lisp/obsolete/mailpost.el b/lisp/obsolete/mailpost.el index eebaa34de10..2f74faf1d6c 100644 --- a/lisp/obsolete/mailpost.el +++ b/lisp/obsolete/mailpost.el @@ -54,10 +54,10 @@ site-init." (while (and (re-search-forward "\n\n\n*" delimline t) (< (point) delimline)) (replace-match "\n")) - ;; Find and handle any FCC fields. + ;; Find and handle any Fcc fields. (let ((case-fold-search t)) (goto-char (point-min)) - (if (re-search-forward "^FCC:" delimline t) + (if (re-search-forward "^Fcc:" delimline t) (mail-do-fcc delimline)) ;; If there is a From and no Sender, put it a Sender. (goto-char (point-min)) diff --git a/lisp/progmodes/mantemp.el b/lisp/obsolete/mantemp.el index 9beeb4aae62..ad638422c2b 100644 --- a/lisp/progmodes/mantemp.el +++ b/lisp/obsolete/mantemp.el @@ -5,6 +5,7 @@ ;; Author: Tom Houlder <thoulder@icor.fr> ;; Created: 10 Dec 1996 ;; Keywords: g++, templates +;; Obsolete-since: 27.1 ;; This file is part of GNU Emacs. @@ -23,6 +24,9 @@ ;;; Commentary: +;; This file is obsolete. For more information, see: +;; https://debbugs.gnu.org/34789 + ;; The following is a typical error message from g++ using STL (here ;; with split lines): ;; @@ -89,7 +93,7 @@ (save-excursion (goto-char (point-min)) (message "Removing comments") - (while (re-search-forward "^[A-z.()+0-9: ]*`\\|'.*$" nil t) + (while (re-search-forward "^[a-zA-Z.()+0-9: ]*`\\|'.*$" nil t) (replace-match "")))) (defun mantemp-remove-memfuncs () @@ -99,14 +103,14 @@ (goto-char (point-min)) (message "Removing member function extensions") (while (re-search-forward - "^[A-z :&*<>~=,0-9+]*>::operator " nil t nil) + "^[a-zA-Z :&*<>~=,0-9+]*>::operator " nil t nil) (progn (backward-char 11) (delete-region (point) (line-end-position)))) ;; Remove other member function extensions. (goto-char (point-min)) (message "Removing member function extensions") - (while (re-search-forward "^[A-z :&*<>~=,0-9+]*>::" nil t nil) + (while (re-search-forward "^[a-zA-Z :&*<>~=,0-9+]*>::" nil t nil) (progn (backward-char 2) (delete-region (point) (line-end-position)))))) @@ -154,7 +158,7 @@ the lines." (goto-char (point-min)) (message "Inserting 'template' for functions") (while (re-search-forward - "^template class [A-z :&*<>~=,0-9+!]*(" nil t nil) + "^template class [a-zA-Z :&*<>~=,0-9+!]*(" nil t nil) (progn (beginning-of-line) (forward-word-strictly 1) diff --git a/lisp/obsolete/mouse-sel.el b/lisp/obsolete/mouse-sel.el index 0a19fc0a961..b8dd9e6fa73 100644 --- a/lisp/obsolete/mouse-sel.el +++ b/lisp/obsolete/mouse-sel.el @@ -135,9 +135,6 @@ (require 'mouse) (require 'thingatpt) -(eval-when-compile - (require 'cl)) - ;;=== User Variables ====================================================== (defgroup mouse-sel nil @@ -197,9 +194,6 @@ If nil, point will always be placed at the beginning of the region." ;;;###autoload (define-minor-mode mouse-sel-mode "Toggle Mouse Sel mode. -With a prefix argument ARG, enable Mouse Sel mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Mouse Sel mode is a global minor mode. When enabled, mouse selection is enhanced in various ways: diff --git a/lisp/obsolete/old-whitespace.el b/lisp/obsolete/old-whitespace.el index 591f018907a..c8daa572bf2 100644 --- a/lisp/obsolete/old-whitespace.el +++ b/lisp/obsolete/old-whitespace.el @@ -747,7 +747,6 @@ If timer is not set, then set it to scan the files in ;;;###autoload (define-minor-mode whitespace-global-mode "Toggle using Whitespace mode in new buffers. -With ARG, turn the mode on if ARG is positive, otherwise turn it off. When this mode is active, `whitespace-buffer' is added to `find-file-hook' and `kill-buffer-hook'." diff --git a/lisp/obsolete/options.el b/lisp/obsolete/options.el deleted file mode 100644 index eb3fb2aa4f3..00000000000 --- a/lisp/obsolete/options.el +++ /dev/null @@ -1,140 +0,0 @@ -;;; options.el --- edit Options command for Emacs - -;; Copyright (C) 1985, 2001-2019 Free Software Foundation, Inc. - -;; Maintainer: emacs-devel@gnu.org -;; Obsolete-since: 22.1 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This code provides functions to list and edit the values of all global -;; option variables known to loaded Emacs Lisp code. There are two entry -;; points, `list-options' and `edit' options'. The latter enters a major -;; mode specifically for editing option values. Do `M-x describe-mode' in -;; that context for more details. - -;; The customization buffer feature is intended to make this obsolete. - -;;; Code: - -;;;###autoload -(defun list-options () - "Display a list of Emacs user options, with values and documentation. -It is now better to use Customize instead." - (interactive) - (with-output-to-temp-buffer "*List Options*" - (let (vars) - (princ "This facility is obsolete; we recommend using M-x customize instead.") - - (mapatoms (function (lambda (sym) - (if (custom-variable-p sym) - (setq vars (cons sym vars)))))) - (setq vars (sort vars 'string-lessp)) - (while vars - (let ((sym (car vars))) - (when (boundp sym) - (princ ";; ") - (prin1 sym) - (princ ":\n\t") - (prin1 (symbol-value sym)) - (terpri) - (princ (substitute-command-keys - (documentation-property sym 'variable-documentation))) - (princ "\n;;\n")) - (setq vars (cdr vars)))) - (with-current-buffer "*List Options*" - (Edit-options-mode) - (setq buffer-read-only t))))) - -;;;###autoload -(defun edit-options () - "Edit a list of Emacs user option values. -Selects a buffer containing such a list, -in which there are commands to set the option values. -Type \\[describe-mode] in that buffer for a list of commands. - -The Custom feature is intended to make this obsolete." - (interactive) - (list-options) - (pop-to-buffer "*List Options*")) - -(defvar Edit-options-mode-map - (let ((map (make-keymap))) - (define-key map "s" 'Edit-options-set) - (define-key map "x" 'Edit-options-toggle) - (define-key map "1" 'Edit-options-t) - (define-key map "0" 'Edit-options-nil) - (define-key map "p" 'backward-paragraph) - (define-key map " " 'forward-paragraph) - (define-key map "n" 'forward-paragraph) - map) - "") - -;; Edit Options mode is suitable only for specially formatted data. -(put 'Edit-options-mode 'mode-class 'special) - -(define-derived-mode Edit-options-mode emacs-lisp-mode "Options" - "\\<Edit-options-mode-map>\ -Major mode for editing Emacs user option settings. -Special commands are: -\\[Edit-options-set] -- set variable point points at. New value read using minibuffer. -\\[Edit-options-toggle] -- toggle variable, t -> nil, nil -> t. -\\[Edit-options-t] -- set variable to t. -\\[Edit-options-nil] -- set variable to nil. -Changed values made by these commands take effect immediately. - -Each variable description is a paragraph. -For convenience, the characters \\[backward-paragraph] and \\[forward-paragraph] move back and forward by paragraphs." - (setq-local paragraph-separate "[^\^@-\^?]") - (setq-local paragraph-start "\t") - (setq-local truncate-lines t)) - -(defun Edit-options-set () (interactive) - (Edit-options-modify - (lambda (var) (eval-minibuffer (concat "New " (symbol-name var) ": "))))) - -(defun Edit-options-toggle () (interactive) - (Edit-options-modify (lambda (var) (not (symbol-value var))))) - -(defun Edit-options-t () (interactive) - (Edit-options-modify (lambda (var) t))) - -(defun Edit-options-nil () (interactive) - (Edit-options-modify (lambda (var) nil))) - -(defun Edit-options-modify (modfun) - (save-excursion - (let ((buffer-read-only nil) var pos) - (re-search-backward "^;; \\|\\`") - (forward-char 3) - (setq pos (point)) - (save-restriction - (narrow-to-region pos (progn (end-of-line) (1- (point)))) - (goto-char pos) - (setq var (read (current-buffer)))) - (goto-char pos) - (forward-line 1) - (forward-char 1) - (save-excursion - (set var (funcall modfun var))) - (kill-sexp 1) - (prin1 (symbol-value var) (current-buffer))))) - -(provide 'options) - -;;; options.el ends here diff --git a/lisp/obsolete/otodo-mode.el b/lisp/obsolete/otodo-mode.el index 7e9cc231d3a..7a0adc81a97 100644 --- a/lisp/obsolete/otodo-mode.el +++ b/lisp/obsolete/otodo-mode.el @@ -925,8 +925,9 @@ If INCLUDE-SEP is non-nil, return point after the separator." "Major mode for editing TODO lists." (easy-menu-add todo-menu)) -(defvar date) -(defvar entry) +(with-suppressed-warnings ((lexical date entry)) + (defvar date) + (defvar entry)) ;; t-c should be used from diary code, which requires calendar. (declare-function calendar-current-date "calendar" (&optional offset)) diff --git a/lisp/obsolete/pgg-gpg.el b/lisp/obsolete/pgg-gpg.el index 1dfd3e672bc..6a901fbef3e 100644 --- a/lisp/obsolete/pgg-gpg.el +++ b/lisp/obsolete/pgg-gpg.el @@ -27,8 +27,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'pgg) @@ -303,7 +302,7 @@ passphrase cache or user." (defun pgg-gpg-select-matching-key (message-keys secret-keys) "Choose a key from MESSAGE-KEYS that matches one of the keys in SECRET-KEYS." - (loop for message-key in message-keys + (cl-loop for message-key in message-keys for message-key-id = (and (equal (car message-key) 1) (cdr (assq 'key-identifier (cdr message-key)))) diff --git a/lisp/obsolete/pgg-parse.el b/lisp/obsolete/pgg-parse.el index ba39cc2ad63..cdff9acba9c 100644 --- a/lisp/obsolete/pgg-parse.el +++ b/lisp/obsolete/pgg-parse.el @@ -35,10 +35,7 @@ ;;; Code: -(eval-when-compile - ;; For Emacs <22.2 and XEmacs. - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup pgg-parse () "OpenPGP packet parsing." @@ -119,17 +116,17 @@ ) (defmacro pgg-parse-time-field (bytes) - `(list (logior (lsh (car ,bytes) 8) + `(list (logior (ash (car ,bytes) 8) (nth 1 ,bytes)) - (logior (lsh (nth 2 ,bytes) 8) + (logior (ash (nth 2 ,bytes) 8) (nth 3 ,bytes)) 0)) (defmacro pgg-byte-after (&optional pos) - `(pgg-char-int (char-after ,(or pos `(point))))) + `(pgg-char-int (char-after ,(or pos '(point))))) (defmacro pgg-read-byte () - `(pgg-char-int (char-after (prog1 (point) (forward-char))))) + '(pgg-char-int (char-after (prog1 (point) (forward-char))))) (defmacro pgg-read-bytes-string (nbytes) `(buffer-substring @@ -187,21 +184,21 @@ (ccl-execute-on-string pgg-parse-crc24 h string) (format "%c%c%c" (logand (aref h 1) 255) - (logand (lsh (aref h 2) -8) 255) + (logand (ash (aref h 2) -8) 255) (logand (aref h 2) 255))))) (defmacro pgg-parse-length-type (c) `(cond ((< ,c 192) (cons ,c 1)) ((< ,c 224) - (cons (+ (lsh (- ,c 192) 8) + (cons (+ (ash (- ,c 192) 8) (pgg-byte-after (+ 2 (point))) 192) 2)) ((= ,c 255) - (cons (cons (logior (lsh (pgg-byte-after (+ 2 (point))) 8) + (cons (cons (logior (ash (pgg-byte-after (+ 2 (point))) 8) (pgg-byte-after (+ 3 (point)))) - (logior (lsh (pgg-byte-after (+ 4 (point))) 8) + (logior (ash (pgg-byte-after (+ 4 (point))) 8) (pgg-byte-after (+ 5 (point))))) 5)) (t;partial body length @@ -213,13 +210,13 @@ (if (zerop (logand 64 ptag));Old format (progn (setq length-type (logand ptag 3) - length-type (if (= 3 length-type) 0 (lsh 1 length-type)) - content-tag (logand 15 (lsh ptag -2)) + length-type (if (= 3 length-type) 0 (ash 1 length-type)) + content-tag (logand 15 (ash ptag -2)) packet-bytes 0 header-bytes (1+ length-type)) (dotimes (i length-type) (setq packet-bytes - (logior (lsh packet-bytes 8) + (logior (ash packet-bytes 8) (pgg-byte-after (+ 1 i (point))))))) (setq content-tag (logand 63 ptag) length-type (pgg-parse-length-type @@ -229,7 +226,7 @@ (list content-tag packet-bytes header-bytes))) (defun pgg-parse-packet (ptag) - (case (car ptag) + (cl-case (car ptag) (1 ;Public-Key Encrypted Session Key Packet (pgg-parse-public-key-encrypted-session-key-packet ptag)) (2 ;Signature Packet @@ -282,7 +279,7 @@ (1+ (cdr length-type))))) (defun pgg-parse-signature-subpacket (ptag) - (case (car ptag) + (cl-case (car ptag) (2 ;signature creation time (cons 'creation-time (let ((bytes (pgg-read-bytes 4))) @@ -320,10 +317,10 @@ (let ((name-bytes (pgg-read-bytes 2)) (value-bytes (pgg-read-bytes 2))) (cons (pgg-read-bytes-string - (logior (lsh (car name-bytes) 8) + (logior (ash (car name-bytes) 8) (nth 1 name-bytes))) (pgg-read-bytes-string - (logior (lsh (car value-bytes) 8) + (logior (ash (car value-bytes) 8) (nth 1 value-bytes))))))) (21 ;preferred hash algorithms (cons 'preferred-hash-algorithm @@ -383,7 +380,7 @@ (pgg-set-alist result 'hash-algorithm (pgg-read-byte)) (when (>= 10000 (setq n (pgg-read-bytes 2) - n (logior (lsh (car n) 8) + n (logior (ash (car n) 8) (nth 1 n)))) (save-restriction (narrow-to-region (point)(+ n (point))) @@ -394,7 +391,7 @@ #'pgg-parse-signature-subpacket))) (goto-char (point-max)))) (when (>= 10000 (setq n (pgg-read-bytes 2) - n (logior (lsh (car n) 8) + n (logior (ash (car n) 8) (nth 1 n)))) (save-restriction (narrow-to-region (point)(+ n (point))) diff --git a/lisp/obsolete/pgg-pgp.el b/lisp/obsolete/pgg-pgp.el index 0627217f073..9e9a38d5447 100644 --- a/lisp/obsolete/pgg-pgp.el +++ b/lisp/obsolete/pgg-pgp.el @@ -25,8 +25,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'pgg) diff --git a/lisp/obsolete/pgg-pgp5.el b/lisp/obsolete/pgg-pgp5.el index eafa2742557..81199431458 100644 --- a/lisp/obsolete/pgg-pgp5.el +++ b/lisp/obsolete/pgg-pgp5.el @@ -25,8 +25,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'pgg) diff --git a/lisp/obsolete/pgg.el b/lisp/obsolete/pgg.el index 23bbedea28b..18b63fc3ee6 100644 --- a/lisp/obsolete/pgg.el +++ b/lisp/obsolete/pgg.el @@ -29,11 +29,7 @@ (require 'pgg-parse) (autoload 'run-at-time "timer") -;; Don't merge these two `eval-when-compile's. -(eval-when-compile - ;; For Emacs <22.2 and XEmacs. - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) - (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;;; @ utility functions ;;; @@ -258,7 +254,7 @@ regulate cache behavior." (defmacro pgg-convert-lbt-region (start end lbt) `(let ((pgg-conversion-end (set-marker (make-marker) ,end))) (goto-char ,start) - (case ,lbt + (cl-case ,lbt (CRLF (while (progn (end-of-line) @@ -576,7 +572,7 @@ within the region." (with-current-buffer (get-buffer-create pgg-output-buffer) (buffer-disable-undo) (erase-buffer) - (let ((proto (if (string-match "^[a-zA-Z\\+\\.\\\\-]+:" keyserver) + (let ((proto (if (string-match "^[a-zA-Z\\+.-]+:" keyserver) (substring keyserver 0 (1- (match-end 0)))))) (save-excursion (funcall pgg-insert-url-function diff --git a/lisp/obsolete/sregex.el b/lisp/obsolete/sregex.el index 32020d01c72..884cd3e4e45 100644 --- a/lisp/obsolete/sregex.el +++ b/lisp/obsolete/sregex.el @@ -240,7 +240,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; Compatibility code for when we didn't have shy-groups (defvar sregex--current-sregex nil) @@ -487,7 +487,7 @@ has one of the following forms: (concat "\\(?:" (regexp-quote exp) "\\)") (regexp-quote exp))) ((symbolp exp) - (ecase exp + (cl-ecase exp (any ".") (bol "^") (eol "$") diff --git a/lisp/net/starttls.el b/lisp/obsolete/starttls.el index 4087a562448..e0a09688f45 100644 --- a/lisp/net/starttls.el +++ b/lisp/obsolete/starttls.el @@ -6,6 +6,7 @@ ;; Author: Simon Josefsson <simon@josefsson.org> ;; Created: 1999/11/20 ;; Keywords: TLS, SSL, OpenSSL, GnuTLS, mail, news +;; Obsolete-since: 27.1 ;; This file is part of GNU Emacs. @@ -216,7 +217,7 @@ handshake, or nil on failure." starttls-success nil t)) (setq done-bad (re-search-forward starttls-failure nil t)))))) - (accept-process-output process 1 100) + (accept-process-output process 1.1) (sit-for 0.1)) (setq info (buffer-substring-no-properties old-max (point-max))) (delete-region old-max (point-max)) @@ -250,7 +251,7 @@ handshake, or nil on failure." (goto-char old-max) (not (setq done (re-search-forward starttls-connect nil t))))) - (accept-process-output process 0 100) + (accept-process-output process 0.1) (sit-for 0.1)) (if done (with-current-buffer buffer diff --git a/lisp/net/tls.el b/lisp/obsolete/tls.el index 83f7d18984b..d17ddad7ee5 100644 --- a/lisp/net/tls.el +++ b/lisp/obsolete/tls.el @@ -4,6 +4,7 @@ ;; Author: Simon Josefsson <simon@josefsson.org> ;; Keywords: comm, tls, gnutls, ssl +;; Obsolete-since: 27.1 ;; This file is part of GNU Emacs. diff --git a/lisp/obsolete/tpu-edt.el b/lisp/obsolete/tpu-edt.el index 6830f3ccf9b..0848135715e 100644 --- a/lisp/obsolete/tpu-edt.el +++ b/lisp/obsolete/tpu-edt.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1993-1995, 2000-2019 Free Software Foundation, Inc. ;; Author: Rob Riepel <riepel@networking.stanford.edu> -;; Maintainer: Rob Riepel <riepel@networking.stanford.edu> ;; Version: 4.5 ;; Keywords: emulations ;; Obsolete-since: 24.5 @@ -980,10 +979,7 @@ and the total number of lines in the buffer." ;;; ;;;###autoload (define-minor-mode tpu-edt-mode - "Toggle TPU/edt emulation on or off. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "Toggle TPU/edt emulation on or off." :global t :group 'tpu (if tpu-edt-mode (tpu-edt-on) (tpu-edt-off))) diff --git a/lisp/obsolete/tpu-extras.el b/lisp/obsolete/tpu-extras.el index cc048cd9240..8b5818dfca3 100644 --- a/lisp/obsolete/tpu-extras.el +++ b/lisp/obsolete/tpu-extras.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1993-1995, 2000-2019 Free Software Foundation, Inc. ;; Author: Rob Riepel <riepel@networking.stanford.edu> -;; Maintainer: Rob Riepel <riepel@networking.stanford.edu> ;; Keywords: emulations ;; Package: tpu-edt ;; Obsolete-since: 24.5 @@ -133,10 +132,7 @@ the previous line when starting from a line beginning." ;;;###autoload (define-minor-mode tpu-cursor-free-mode - "Minor mode to allow the cursor to move freely about the screen. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "Minor mode to allow the cursor to move freely about the screen." :init-value nil (if (not tpu-cursor-free-mode) (tpu-trim-line-ends)) diff --git a/lisp/obsolete/tpu-mapper.el b/lisp/obsolete/tpu-mapper.el index 60e0e49b8b4..a7aa0cb0d00 100644 --- a/lisp/obsolete/tpu-mapper.el +++ b/lisp/obsolete/tpu-mapper.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1993-1995, 2001-2019 Free Software Foundation, Inc. ;; Author: Rob Riepel <riepel@networking.stanford.edu> -;; Maintainer: Rob Riepel <riepel@networking.stanford.edu> ;; Keywords: emulations ;; Package: tpu-edt ;; Obsolete-since: 24.5 diff --git a/lisp/obsolete/vc-arch.el b/lisp/obsolete/vc-arch.el index 32e21613679..925289102c1 100644 --- a/lisp/obsolete/vc-arch.el +++ b/lisp/obsolete/vc-arch.el @@ -133,7 +133,8 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches." (file-error (insert (format "%s <%s> %s" (current-time-string) user-mail-address - (+ (nth 2 (current-time)) + (+ (% (car (encode-time nil 1000000)) + 1000000) (buffer-size))))))) (comment-region beg (point)))) @@ -304,8 +305,9 @@ Only the value `maybe' can be trusted :-(." ;; Buh? Unexpected format. 'edited (let ((ats (file-attributes file))) - (if (and (eq (nth 7 ats) (string-to-number (match-string 2))) - (equal (format-time-string "%s" (nth 5 ats)) + (if (and (eq (file-attribute-size ats) (string-to-number (match-string 2))) + (equal (format-time-string + "%s" (file-attribute-modification-time ats)) (match-string 1))) 'up-to-date 'edited))))))))) @@ -395,14 +397,14 @@ CALLBACK expects (ENTRIES &optional MORE-TO-COME); see (setq rev (replace-match (cdr rule) t nil rev)))) (format "Arch%c%s" (pcase (vc-state file) - ((or `up-to-date `needs-update) ?-) - (`added ?@) + ((or 'up-to-date 'needs-update) ?-) + ('added ?@) (_ ?:)) rev))) (defun vc-arch-diff3-rej-p (rej) (let ((attrs (file-attributes rej))) - (and attrs (< (nth 7 attrs) 60) + (and attrs (< (file-attribute-size attrs) 60) (with-temp-buffer (insert-file-contents rej) (goto-char (point-min)) diff --git a/lisp/obsolete/vi.el b/lisp/obsolete/vi.el index aee4f187685..df5ddfdbcf9 100644 --- a/lisp/obsolete/vi.el +++ b/lisp/obsolete/vi.el @@ -1386,7 +1386,7 @@ l(ines)." (interactive "p\nc") (cond ((char-equal region ?d) (mark-defun)) ((char-equal region ?s) (mark-sexp arg)) - ((char-equal region ?b) (mark-whole-buffer)) + ((char-equal region ?b) (with-no-warnings (mark-whole-buffer))) ((char-equal region ?p) (mark-paragraph)) ((char-equal region ?P) (mark-page arg)) ((char-equal region ?f) (c-mark-function)) diff --git a/lisp/obsolete/vip.el b/lisp/obsolete/vip.el index e0566cdb78c..9943fb2548b 100644 --- a/lisp/obsolete/vip.el +++ b/lisp/obsolete/vip.el @@ -1858,7 +1858,7 @@ STRING. Search will be forward if FORWARD, otherwise backward." (+ vip-use-register 32) (point) (+ (point) val)) (copy-to-register vip-use-register (point) (+ (point) val) nil)) (setq vip-use-register nil))) - (delete-backward-char val t))) + (with-no-warnings (delete-backward-char val t)))) ;; join lines. @@ -2187,19 +2187,19 @@ a token has type \(command, address, end-mark\) and value." ((looking-at "%") (forward-char 1) (setq ex-token-type "whole")) - ((looking-at "+") - (cond ((or (looking-at "+[-+]") (looking-at "+[\n|]")) + ((looking-at "\\+") + (cond ((looking-at "\\+[-+\n|]") (forward-char 1) (insert "1") (backward-char 1) (setq ex-token-type "plus")) - ((looking-at "+[0-9]") + ((looking-at "\\+[0-9]") (forward-char 1) (setq ex-token-type "plus")) (t (error "Badly formed address")))) ((looking-at "-") - (cond ((or (looking-at "-[-+]") (looking-at "-[\n|]")) + (cond ((looking-at "-[-+\n|]") (forward-char 1) (insert "1") (backward-char 1) @@ -2216,7 +2216,7 @@ a token has type \(command, address, end-mark\) and value." (while (and (not (eolp)) cont) ;;(re-search-forward "[^/]*/") (re-search-forward "[^/]*\\(/\\|\n\\)") - (if (not (vip-looking-back "[^\\\\]\\(\\\\\\\\\\)*\\\\/")) + (if (not (vip-looking-back "[^\\]\\(\\\\\\\\\\)*\\\\/")) (setq cont nil)))) (backward-char 1) (setq ex-token (buffer-substring (point) (mark))) @@ -2229,7 +2229,7 @@ a token has type \(command, address, end-mark\) and value." (while (and (not (eolp)) cont) ;;(re-search-forward "[^\\?]*\\?") (re-search-forward "[^\\?]*\\(\\?\\|\n\\)") - (if (not (vip-looking-back "[^\\\\]\\(\\\\\\\\\\)*\\\\\\?")) + (if (not (vip-looking-back "[^\\]\\(\\\\\\\\\\)*\\\\\\?")) (setq cont nil)) (backward-char 1) (if (not (looking-at "\n")) (forward-char 1)))) @@ -2325,7 +2325,7 @@ a token has type \(command, address, end-mark\) and value." (while (and (not (eolp)) cont) (re-search-forward "[^/]*\\(/\\|\n\\)") ;;(re-search-forward "[^/]*/") - (if (not (vip-looking-back "[^\\\\]\\(\\\\\\\\\\)*\\\\/")) + (if (not (vip-looking-back "[^\\]\\(\\\\\\\\\\)*\\\\/")) (setq cont nil)))) (setq ex-token (if (= (mark) (point)) "" @@ -2520,7 +2520,7 @@ a token has type \(command, address, end-mark\) and value." ex-variant t) (forward-char 2) (skip-chars-forward " \t"))) - (if (looking-at "+") + (if (looking-at "\\+") (progn (forward-char 1) (set-mark (point)) @@ -2979,9 +2979,10 @@ vip-s-string" (vip-change-mode-to-emacs) (condition-case conditions (progn - (if (string= tag "") - (find-tag ex-tag t) - (find-tag-other-window ex-tag)) + (with-suppressed-warnings ((obsolete find-tag find-tag-other-window)) + (if (string= tag "") + (find-tag ex-tag t) + (find-tag-other-window ex-tag))) (vip-change-mode-to-vi)) (error (vip-change-mode-to-vi) diff --git a/lisp/obsolete/ws-mode.el b/lisp/obsolete/ws-mode.el index 05dca959dad..16156106710 100644 --- a/lisp/obsolete/ws-mode.el +++ b/lisp/obsolete/ws-mode.el @@ -1,4 +1,4 @@ -;;; ws-mode.el --- WordStar emulation mode for GNU Emacs +;;; ws-mode.el --- WordStar emulation mode for GNU Emacs -*- lexical-binding: t -*- ;; Copyright (C) 1991, 2001-2019 Free Software Foundation, Inc. @@ -24,9 +24,20 @@ ;;; Commentary: -;; This emulates WordStar, with a major mode. +;; This provides emulation of WordStar with a minor mode. ;;; Code: + +(defgroup wordstar nil + "WordStar emulation within Emacs." + :prefix "wordstar-" + :prefix "ws-" + :group 'emulations) + +(defcustom wordstar-mode-lighter " WordStar" + "Lighter shown in the modeline for `wordstar' mode." + :type 'string) + (defvar wordstar-C-k-map (let ((map (make-keymap))) (define-key map " " ()) @@ -98,8 +109,7 @@ (define-key map "wh" 'split-window-right) (define-key map "wo" 'other-window) (define-key map "wv" 'split-window-below) - map) - "") + map)) (defvar wordstar-C-q-map (let ((map (make-keymap))) @@ -174,12 +184,9 @@ ;; wordstar-C-j-map not yet implemented (defvar wordstar-C-j-map nil) - -(put 'wordstar-mode 'mode-class 'special) - ;;;###autoload -(define-derived-mode wordstar-mode fundamental-mode "WordStar" - "Major mode with WordStar-like key bindings. +(define-minor-mode wordstar-mode + "Minor mode with WordStar-like key bindings. BUGS: - Help menus with WordStar commands (C-j just calls help-for-help) @@ -189,8 +196,18 @@ BUGS: - Search and replace (C-q a) is only available in forward direction No key bindings beginning with ESC are installed, they will work -Emacs-like.") +Emacs-like." + :group 'wordstar + :lighter wordstar-mode-lighter + :keymap wordstar-mode-map) + +(defun turn-on-wordstar-mode () + (when (and (not (minibufferp)) + (not wordstar-mode)) + (wordstar-mode 1))) +(define-globalized-minor-mode global-wordstar-mode wordstar-mode + turn-on-wordstar-mode) (defun wordstar-center-paragraph () "Center each line in the paragraph at or after point. @@ -254,7 +271,7 @@ the distance between the end of the text and `fill-column'." (defvar ws-search-string nil "String of last search in WordStar mode.") (defvar ws-search-direction t - "Direction of last search in WordStar mode. t if forward, nil if backward.") + "Direction of last search in WordStar mode. t if forward, nil if backward.") (defvar ws-last-cursorposition nil "Position before last search etc. in WordStar mode.") @@ -266,71 +283,12 @@ the distance between the end of the text and `fill-column'." ;; wordstar special functions: (defun ws-error (string) - "Report error of a WordStar special function. Error message is saved -in ws-last-errormessage for recovery with C-q w." + "Report error of a WordStar special function. +Error message is saved in `ws-last-errormessage' for recovery +with C-q w." (setq ws-last-errormessage string) (error string)) -(defun ws-set-marker-0 () - "In WordStar mode: Set marker 0 to current cursor position." - (interactive) - (setq ws-marker-0 (point-marker)) - (message "Marker 0 set")) - -(defun ws-set-marker-1 () - "In WordStar mode: Set marker 1 to current cursor position." - (interactive) - (setq ws-marker-1 (point-marker)) - (message "Marker 1 set")) - -(defun ws-set-marker-2 () - "In WordStar mode: Set marker 2 to current cursor position." - (interactive) - (setq ws-marker-2 (point-marker)) - (message "Marker 2 set")) - -(defun ws-set-marker-3 () - "In WordStar mode: Set marker 3 to current cursor position." - (interactive) - (setq ws-marker-3 (point-marker)) - (message "Marker 3 set")) - -(defun ws-set-marker-4 () - "In WordStar mode: Set marker 4 to current cursor position." - (interactive) - (setq ws-marker-4 (point-marker)) - (message "Marker 4 set")) - -(defun ws-set-marker-5 () - "In WordStar mode: Set marker 5 to current cursor position." - (interactive) - (setq ws-marker-5 (point-marker)) - (message "Marker 5 set")) - -(defun ws-set-marker-6 () - "In WordStar mode: Set marker 6 to current cursor position." - (interactive) - (setq ws-marker-6 (point-marker)) - (message "Marker 6 set")) - -(defun ws-set-marker-7 () - "In WordStar mode: Set marker 7 to current cursor position." - (interactive) - (setq ws-marker-7 (point-marker)) - (message "Marker 7 set")) - -(defun ws-set-marker-8 () - "In WordStar mode: Set marker 8 to current cursor position." - (interactive) - (setq ws-marker-8 (point-marker)) - (message "Marker 8 set")) - -(defun ws-set-marker-9 () - "In WordStar mode: Set marker 9 to current cursor position." - (interactive) - (setq ws-marker-9 (point-marker)) - (message "Marker 9 set")) - (defun ws-begin-block () "In WordStar mode: Set block begin marker to current cursor position." (interactive) @@ -358,7 +316,6 @@ in ws-last-errormessage for recovery with C-q w." (message "")) (message "Block markers not set"))) - (defun ws-indent-block () "In WordStar mode: Indent block (not yet implemented)." (interactive) @@ -373,7 +330,7 @@ in ws-last-errormessage for recovery with C-q w." (defun ws-print-block () "In WordStar mode: Print block." (interactive) - (message "Don't do this. Write block to a file (C-k w) and print this file.")) + (message "Don't do this. Write block to a file (C-k w) and print this file")) (defun ws-mark-word () "In WordStar mode: Mark current word as block." @@ -389,7 +346,7 @@ in ws-last-errormessage for recovery with C-q w." (defun ws-exdent-block () "I don't know what this (C-k u) should do." (interactive) - (ws-error "This won't be done -- not yet implemented.")) + (ws-error "This won't be done -- not yet implemented")) (defun ws-move-block () "In WordStar mode: Move block to current cursor position." @@ -430,96 +387,6 @@ in ws-last-errormessage for recovery with C-q w." (ws-block-end-marker "Block begin marker not set") (t "Block markers not set"))))) -(defun ws-find-marker-0 () - "In WordStar mode: Go to marker 0." - (interactive) - (if ws-marker-0 - (progn - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-0)) - (ws-error "Marker 0 not set"))) - -(defun ws-find-marker-1 () - "In WordStar mode: Go to marker 1." - (interactive) - (if ws-marker-1 - (progn - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-1)) - (ws-error "Marker 1 not set"))) - -(defun ws-find-marker-2 () - "In WordStar mode: Go to marker 2." - (interactive) - (if ws-marker-2 - (progn - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-2)) - (ws-error "Marker 2 not set"))) - -(defun ws-find-marker-3 () - "In WordStar mode: Go to marker 3." - (interactive) - (if ws-marker-3 - (progn - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-3)) - (ws-error "Marker 3 not set"))) - -(defun ws-find-marker-4 () - "In WordStar mode: Go to marker 4." - (interactive) - (if ws-marker-4 - (progn - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-4)) - (ws-error "Marker 4 not set"))) - -(defun ws-find-marker-5 () - "In WordStar mode: Go to marker 5." - (interactive) - (if ws-marker-5 - (progn - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-5)) - (ws-error "Marker 5 not set"))) - -(defun ws-find-marker-6 () - "In WordStar mode: Go to marker 6." - (interactive) - (if ws-marker-6 - (progn - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-6)) - (ws-error "Marker 6 not set"))) - -(defun ws-find-marker-7 () - "In WordStar mode: Go to marker 7." - (interactive) - (if ws-marker-7 - (progn - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-7)) - (ws-error "Marker 7 not set"))) - -(defun ws-find-marker-8 () - "In WordStar mode: Go to marker 8." - (interactive) - (if ws-marker-8 - (progn - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-8)) - (ws-error "Marker 8 not set"))) - -(defun ws-find-marker-9 () - "In WordStar mode: Go to marker 9." - (interactive) - (if ws-marker-9 - (progn - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-9)) - (ws-error "Marker 9 not set"))) - (defun ws-goto-block-begin () "In WordStar mode: Go to block begin marker." (interactive) @@ -560,16 +427,16 @@ in ws-last-errormessage for recovery with C-q w." "In WordStar mode: Undo and give message about undoing more changes." (interactive) (undo) - (message "Repeat C-q l to undo more changes.")) + (message "Repeat C-q l to undo more changes")) (defun ws-goto-last-cursorposition () - "In WordStar mode: " + "In WordStar mode: Go to position before last search." (interactive) (if ws-last-cursorposition (progn (setq ws-last-cursorposition (point-marker)) (goto-char ws-last-cursorposition)) - (ws-error "No last cursor position available."))) + (ws-error "No last cursor position available"))) (defun ws-last-error () "In WordStar mode: repeat last error message. @@ -577,7 +444,7 @@ This will only work for errors raised by WordStar mode functions." (interactive) (if ws-last-errormessage (message "%s" ws-last-errormessage) - (message "No WordStar error yet."))) + (message "No WordStar error yet"))) (defun ws-kill-eol () "In WordStar mode: Kill to end of line (like WordStar, not like Emacs)." @@ -587,8 +454,7 @@ This will only work for errors raised by WordStar mode functions." (kill-region p (point)))) (defun ws-kill-bol () - "In WordStar mode: Kill to beginning of line -\(like WordStar, not like Emacs)." + "In WordStar mode: Kill to beginning of line (like WordStar, not like Emacs)." (interactive) (let ((p (point))) (beginning-of-line) @@ -638,6 +504,36 @@ sWith: " ) (ws-block-end-marker "Block begin marker not set") (t "Block markers not set"))))) +(defmacro ws-set-marker (&rest indices) + (let (n forms) + (while indices + (setq n (pop indices)) + (push `(defun ,(intern (format "ws-set-marker-%d" n)) () + ,(format "In WordStar mode: Set marker %d to current cursor position" n) + (interactive) + (setq ,(intern (format "ws-marker-%d" n)) (point-marker)) + (message ,(format "Marker %d set" n))) + forms)) + `(progn ,@(nreverse forms)))) + +(ws-set-marker 0 1 2 3 4 5 6 7 8 9) + +(defmacro ws-find-marker (&rest indices) + (let (n forms) + (while indices + (setq n (pop indices)) + (push `(defun ,(intern (format "ws-find-marker-%d" n)) () + ,(format "In WordStar mode: Go to marker %d." n) + (interactive) + (if ,(intern (format "ws-marker-%d" n)) + (progn (setq ws-last-cursorposition (point-marker)) + (goto-char ,(intern (format "ws-marker-%d" n)))) + (ws-error ,(format "Marker %d not set" n)))) + forms)) + `(progn ,@(nreverse forms)))) + +(ws-find-marker 0 1 2 3 4 5 6 7 8 9) + (provide 'ws-mode) ;;; ws-mode.el ends here diff --git a/lisp/obsolete/xesam.el b/lisp/obsolete/xesam.el deleted file mode 100644 index 78c4c948c6e..00000000000 --- a/lisp/obsolete/xesam.el +++ /dev/null @@ -1,916 +0,0 @@ -;;; xesam.el --- Xesam interface to search engines. - -;; Copyright (C) 2008-2019 Free Software Foundation, Inc. - -;; Author: Michael Albinus <michael.albinus@gmx.de> -;; Keywords: tools, hypermedia -;; Obsolete-since: 24.4 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This file is obsolete. - -;; This package provides an interface to Xesam, a D-Bus based "eXtEnsible -;; Search And Metadata specification". It has been tested with -;; -;; xesam-glib 0.3.4, xesam-tools 0.6.1 -;; beagle 0.3.7, beagle-xesam 0.2 -;; strigi 0.5.11 - -;; The precondition for this package is a D-Bus aware Emacs. This is -;; configured per default, when Emacs is built on a machine running -;; D-Bus. Furthermore, there must be at least one search engine -;; running, which supports the Xesam interface. Beagle and strigi have -;; been tested; tracker, pinot and recoll are also said to support -;; Xesam. You can check the existence of such a search engine by -;; -;; (dbus-list-queued-owners :session "org.freedesktop.xesam.searcher") - -;; In order to start a search, you must load xesam.el: -;; -;; (require 'xesam) - -;; xesam.el supports two types of queries, which are explained *very* short: -;; -;; * Full text queries. Just search keys shall be given, like -;; -;; hello world -;; -;; A full text query in xesam.el is restricted to files. -;; -;; * Xesam End User Search Language queries. The Xesam query language -;; is described at <http://xesam.org/main/XesamUserSearchLanguage>, -;; which must be consulted for the whole features. -;; -;; A query string consists of search keys, collectors, selectors, -;; and phrases. Search keys are words like in a full text query: -;; -;; hello word -;; -;; A selector is a tuple <keyword><relation>. <keyword> can be any -;; predefined Xesam keyword, the most common keywords are "ext" -;; (file name extension), "format " (mime type), "tag" (user -;; keywords) and "type" (types of items, like "audio", "file", -;; "picture", "attachment"). <relation> is a comparison to a value, -;; which must be a string (relation ":" or "=") or number (relation -;; "<=", ">=", "<", ">"): -;; -;; type:attachment ext=el -;; -;; A collector is one of the items "AND", "and", "&&", "OR", "or", -;; "||", or "-". The default collector on multiple terms is "AND"; -;; "-" means "AND NOT". -;; -;; albinus -type:file -;; -;; A phrase is a string enclosed in quotes, with appended modifiers -;; (single letters). Examples of modifiers are "c" (case -;; sensitive), "C" (case insensitive), "e" (exact match), "r" -;; (regular expression): -;; -;; "Hello world"c - -;; You can customize, whether you want to apply a Xesam user query, or -;; a full text query. Note, that not every search engine supports -;; both query types. -;; -;; (setq xesam-query-type 'fulltext-query) -;; -;; Another option to be customized is the number of hits to be -;; presented at once. -;; -;; (setq xesam-hits-per-page 50) - -;; A search can be started by the command -;; -;; M-x xesam-search -;; -;; When several search engines are registered, the engine to be used -;; can be selected via minibuffer completion. Afterwards, the query -;; shall be entered in the minibuffer. - -;; Search results are presented in a new buffer. This buffer has the -;; major mode `xesam-mode', with the following keybindings: - -;; SPC `scroll-up' -;; DEL `scroll-down' -;; < `beginning-of-buffer' -;; > `end-of-buffer' -;; q `quit-window' -;; z `kill-this-buffer' -;; g `revert-buffer' - -;; The search results are represented by widgets. Navigation commands -;; are the usual widget navigation commands: - -;; TAB `widget-forward' -;; <backtab> `widget-backward' - -;; Applying RET, <down-mouse-1>, or <down-mouse-2> on a URL belonging -;; to the widget, brings up more details of the search hit. The way, -;; how this hit is presented, depends on the type of the hit. HTML -;; files are opened via `browse-url'. Local files are opened in a new -;; buffer, with highlighted search hits (highlighting can be toggled -;; by `xesam-minor-mode' in that buffer). - -;;; Code: - -(require 'dbus) - -;; Widgets are used to highlight the search results. -(require 'widget) -(require 'wid-edit) - -;; `run-at-time' is used in the signal handler. -(require 'timer) - -;; The default search field is "xesam:url". It must be inspected. -(require 'url) - -(defgroup xesam nil - "Xesam compatible interface to search engines." - :group 'extensions - :group 'comm - :version "23.1") - -(defcustom xesam-query-type 'user-query - "Xesam query language type." - :group 'xesam - :type '(choice - (const :tag "Xesam user query" user-query) - (const :tag "Xesam fulltext query" fulltext-query))) - -(defcustom xesam-hits-per-page 20 - "Number of search hits to be displayed in the result buffer." - :group 'xesam - :type 'integer) - -(defface xesam-mode-line '((t :inherit mode-line-emphasis)) - "Face to highlight mode line." - :group 'xesam) - -(defface xesam-highlight '((t :inherit match)) - "Face to highlight query entries. -It will be overlaid by `widget-documentation-face', so it shall -be different at least in one face property not set in that face." - :group 'xesam) - -(defvar xesam-debug nil - "Insert debug information in the help echo.") - -(defconst xesam-service-search "org.freedesktop.xesam.searcher" - "The D-Bus name used to talk to Xesam.") - -(defconst xesam-path-search "/org/freedesktop/xesam/searcher/main" - "The D-Bus object path used to talk to Xesam.") - -;; Methods: "NewSession", "SetProperty", "GetProperty", -;; "CloseSession", "NewSearch", "StartSearch", "GetHitCount", -;; "GetHits", "GetHitData", "CloseSearch" and "GetState". -;; Signals: "HitsAdded", "HitsRemoved", "HitsModified", "SearchDone" -;; and "StateChanged". -(defconst xesam-interface-search "org.freedesktop.xesam.Search" - "The D-Bus Xesam search interface.") - -(defconst xesam-all-fields - '("xesam:35mmEquivalent" "xesam:aimContactMedium" "xesam:aperture" - "xesam:aspectRatio" "xesam:attachmentEncoding" "xesam:attendee" - "xesam:audioBitrate" "xesam:audioChannels" "xesam:audioCodec" - "xesam:audioCodecType" "xesam:audioSampleFormat" "xesam:audioSampleRate" - "xesam:author" "xesam:bcc" "xesam:birthDate" "xesam:blogContactURL" - "xesam:cameraManufacturer" "xesam:cameraModel" "xesam:cc" "xesam:ccdWidth" - "xesam:cellPhoneNumber" "xesam:characterCount" "xesam:charset" - "xesam:colorCount" "xesam:colorSpace" "xesam:columnCount" "xesam:comment" - "xesam:commentCharacterCount" "xesam:conflicts" "xesam:contactMedium" - "xesam:contactName" "xesam:contactNick" "xesam:contactPhoto" - "xesam:contactURL" "xesam:contains" "xesam:contentKeyword" - "xesam:contentComment" "xesam:contentCreated" "xesam:contentModified" - "xesam:contentType" "xesam:contributor" "xesam:copyright" "xesam:creator" - "xesam:definesClass" "xesam:definesFunction" "xesam:definesGlobalVariable" - "xesam:deletionTime" "xesam:depends" "xesam:description" "xesam:device" - "xesam:disclaimer" "xesam:documentCategory" "xesam:duration" - "xesam:emailAddress" "xesam:eventEnd" "xesam:eventLocation" - "xesam:eventStart" "xesam:exposureBias" "xesam:exposureProgram" - "xesam:exposureTime" "xesam:faxPhoneNumber" "xesam:fileExtension" - "xesam:fileSystemType" "xesam:flashUsed" "xesam:focalLength" - "xesam:focusDistance" "xesam:formatSubtype" "xesam:frameCount" - "xesam:frameRate" "xesam:freeSpace" "xesam:gender" "xesam:generator" - "xesam:generatorOptions" "xesam:group" "xesam:hash" "xesam:hash" - "xesam:height" "xesam:homeEmailAddress" "xesam:homePhoneNumber" - "xesam:homePostalAddress" "xesam:homepageContactURL" - "xesam:horizontalResolution" "xesam:icqContactMedium" "xesam:id" - "xesam:imContactMedium" "xesam:interests" "xesam:interlaceMode" - "xesam:isEncrypted" "xesam:isImportant" "xesam:isInProgress" - "xesam:isPasswordProtected" "xesam:isRead" "xesam:isoEquivalent" - "xesam:jabberContactMedium" "xesam:keyword" "xesam:language" "xesam:legal" - "xesam:license" "xesam:licenseType" "xesam:lineCount" "xesam:links" - "xesam:mailingPostalAddress" "xesam:maintainer" "xesam:md5Hash" - "xesam:mediaCodec" "xesam:mediaCodecBitrate" "xesam:mediaCodecType" - "xesam:meteringMode" "xesam:mimeType" "xesam:mountPoint" - "xesam:msnContactMedium" "xesam:name" "xesam:occupiedSpace" - "xesam:orientation" "xesam:originalLocation" "xesam:owner" - "xesam:pageCount" "xesam:permissions" "xesam:phoneNumber" - "xesam:physicalAddress" "xesam:pixelFormat" "xesam:primaryRecipient" - "xesam:programmingLanguage" "xesam:rating" "xesam:receptionTime" - "xesam:recipient" "xesam:related" "xesam:remoteUser" "xesam:rowCount" - "xesam:sampleBitDepth" "xesam:sampleFormat" "xesam:secondaryRecipient" - "xesam:sha1Hash" "xesam:size" "xesam:skypeContactMedium" - "xesam:sourceCreated" "xesam:sourceModified" "xesam:storageSize" - "xesam:subject" "xesam:supercedes" "xesam:title" "xesam:to" - "xesam:totalSpace" "xesam:totalUncompressedSize" "xesam:url" - "xesam:usageIntensity" "xesam:userComment" "xesam:userKeyword" - "xesam:uuid" "xesam:version" "xesam:verticalResolution" - "xesam:videoBitrate" - "xesam:videoCodec" "xesam:videoCodecType" "xesam:whiteBalance" - "xesam:width" "xesam:wordCount" "xesam:workEmailAddress" - "xesam:workPhoneNumber" "xesam:workPostalAddress" - "xesam:yahooContactMedium") - "All fields from the Xesam Core Ontology. -This defconst can be used to check for a new search engine, which -fields are supported.") - -(defconst xesam-user-query - "<?xml version=\"1.0\" encoding=\"UTF-8\"?> -<request xmlns=\"http://freedesktop.org/standards/xesam/1.0/query\"> - <userQuery> - %s - </userQuery> -</request>" - "The Xesam user query XML.") - -(defconst xesam-fulltext-query - "<?xml version=\"1.0\" encoding=\"UTF-8\"?> -<request xmlns=\"http://freedesktop.org/standards/xesam/1.0/query\"> - <query content=\"xesam:Document\" source=\"xesam:File\"> - <fullText> - <string>%s</string> - </fullText> - </query> -</request>" - "The Xesam fulltext query XML.") - -(declare-function dbus-get-unique-name "dbusbind.c" (bus)) - -(defvar xesam-dbus-unique-names - (ignore-errors - (list (cons :system (dbus-get-unique-name :system)) - (cons :session (dbus-get-unique-name :session)))) - "The unique names, under which Emacs is registered at D-Bus.") - -(defun xesam-dbus-call-method (&rest args) - "Apply a D-Bus method call. -`dbus-call-method' is preferred, because it performs better. -If the target D-Bus service is owned by Emacs, this -is not applicable, and `dbus-call-method-non-blocking' must be -used instead. ARGS are identical to the argument list of both -functions." - (apply - ;; The first argument is the bus, the second argument the targt service. - (if (string-equal (cdr (assoc (car args) xesam-dbus-unique-names)) - (cadr args)) - 'dbus-call-method-non-blocking 'dbus-call-method) - args)) - -(defun xesam-get-property (engine property) - "Return the PROPERTY value of ENGINE." - ;; "GetProperty" returns a variant, so we must use the car. - (car (xesam-dbus-call-method - :session (car engine) xesam-path-search - xesam-interface-search "GetProperty" - (xesam-get-cached-property engine "session") property))) - -(defun xesam-set-property (engine property value) - "Set the PROPERTY of ENGINE to VALUE. -VALUE can be a string, a non-negative integer, a boolean -value (nil or t), or a list of them. It returns the new value of -PROPERTY in the search engine. This new value can be different -from VALUE, depending on what the search engine accepts." - ;; "SetProperty" returns a variant, so we must use the car. - (car (xesam-dbus-call-method - :session (car engine) xesam-path-search - xesam-interface-search "SetProperty" - (xesam-get-cached-property engine "session") property - ;; The value must be a variant. It can be only a string, an - ;; unsigned int, a boolean, or an array of them. So we need - ;; no type keyword; we let the type check to the search - ;; engine. - (list :variant value)))) - -(defvar xesam-minibuffer-vendor-history nil - "Interactive vendor history.") - -(defvar xesam-minibuffer-query-history nil - "Interactive query history.") - -;; Pacify byte compiler. -(defvar xesam-vendor nil) -(make-variable-buffer-local 'xesam-vendor) -(put 'xesam-vendor 'permanent-local t) - -(defvar xesam-engine nil) -(defvar xesam-search nil) -(defvar xesam-type nil) -(defvar xesam-query nil) -(defvar xesam-xml-string nil) -(defvar xesam-objects nil) -(defvar xesam-current nil) -(defvar xesam-count nil) -(defvar xesam-to nil) -(defvar xesam-notify-function nil) -(defvar xesam-refreshing nil) - - -;;; Search engines. - -(defvar xesam-search-engines nil - "List of available Xesam search engines. -Every entry is an association list, with a car denoting the -unique D-Bus service name of the engine. The rest of the entry -are cached associations of engine attributes, like the session -identifier, and the display name. Example: - - \(\(\":1.59\" - \(\"session\" . \"0t1214948020ut358230u0p2698r3912347765k3213849828\") - \(\"vendor.display\" . \"Tracker Xesam Service\")) - \(\":1.27\" - \(\"session\" . \"strigisession1369133069\") - \(\"vendor.display\" . \"Strigi Desktop Search\"))) - -A Xesam-compatible search engine is identified as a queued D-Bus -service of the known service `xesam-service-search'.") - -(defun xesam-get-cached-property (engine property) - "Return the PROPERTY value of ENGINE from the cache. -If PROPERTY is not existing, retrieve it from ENGINE first." - ;; If the property has not been cached yet, we retrieve it from the - ;; engine, and cache it. - (unless (assoc property engine) - (xesam-set-cached-property - engine property (xesam-get-property engine property))) - (cdr (assoc property engine))) - -(defun xesam-set-cached-property (engine property value) - "Set the PROPERTY of ENGINE to VALUE in the cache." - (setcdr engine (append (cdr engine) (list (cons property value))))) - -(defun xesam-delete-search-engine (&rest args) - "Remove service from `xesam-search-engines'." - (setq xesam-search-engines - (delete (assoc (car args) xesam-search-engines) xesam-search-engines))) - -(defvar dbus-debug) - -(defun xesam-search-engines () - "Return Xesam search engines, stored in `xesam-search-engines'. -The first search engine is the name owner of `xesam-service-search'. -If there is no registered search engine at all, the function returns nil." - (let ((services (dbus-ignore-errors - (dbus-list-queued-owners - :session xesam-service-search))) - engine vendor-id hit-fields) - (dolist (service services) - (unless (assoc-string service xesam-search-engines) - - ;; Open a new session, and add it to the search engines list. - (add-to-list 'xesam-search-engines (list service) 'append) - (setq engine (assoc service xesam-search-engines)) - - ;; Add the session string. - (xesam-set-cached-property - engine "session" - (xesam-dbus-call-method - :session service xesam-path-search - xesam-interface-search "NewSession")) - - ;; Unset the "search.live" property; we don't want to be - ;; informed by changed results. - (xesam-set-property engine "search.live" nil) - - ;; Check the vendor properties. - (setq vendor-id (xesam-get-property engine "vendor.id") - hit-fields (xesam-get-property engine "hit.fields")) - - ;; Usually, `hit.fields' shall describe supported fields. - ;; That is not the case now, so we set it ourselves. - ;; Hopefully, this will change later. - (setq hit-fields - (pcase (intern vendor-id) - (`Beagle - '("xesam:mimeType" "xesam:url")) - (`Strigi - '("xesam:author" "xesam:cc" "xesam:charset" - "xesam:contentType" "xesam:fileExtension" - "xesam:id" "xesam:lineCount" "xesam:links" - "xesam:mimeType" "xesam:name" "xesam:size" - "xesam:sourceModified" "xesam:subject" "xesam:to" - "xesam:url")) - (`TrackerXesamSession - '("xesam:relevancyRating" "xesam:url")) - (`Debbugs - '("xesam:keyword" "xesam:owner" "xesam:title" - "xesam:url" "xesam:sourceModified" "xesam:mimeType" - "debbugs:key")) - ;; xesam-tools yahoo service. - (_ '("xesam:contentModified" "xesam:mimeType" "xesam:summary" - "xesam:title" "xesam:url" "yahoo:displayUrl")))) - - (xesam-set-property engine "hit.fields" hit-fields) - (xesam-set-property engine "hit.fields.extended" '("xesam:snippet")) - - ;; Let us notify, when the search engine disappears. - (dbus-register-signal - :session dbus-service-dbus dbus-path-dbus - dbus-interface-dbus "NameOwnerChanged" - 'xesam-delete-search-engine service)))) - xesam-search-engines) - - -;;; Search buffers. - -(defvar xesam-mode-map - (let ((map (copy-keymap special-mode-map))) - (set-keymap-parent map widget-keymap) - map)) - -(define-derived-mode xesam-mode special-mode "Xesam" - "Major mode for presenting search results of a Xesam search. -In this mode, widgets represent the search results. - -\\{xesam-mode-map} -Turning on Xesam mode runs the normal hook `xesam-mode-hook'. It -can be used to set `xesam-notify-function', which must a search -engine specific, widget :notify function to visualize xesam:url." - (set (make-local-variable 'xesam-notify-function) nil) - ;; Maybe we implement something useful, later on. - (set (make-local-variable 'revert-buffer-function) 'ignore) - ;; `xesam-engine', `xesam-search', `xesam-type', `xesam-query', and - ;; `xesam-xml-string' will be set in `xesam-new-search'. - (set (make-local-variable 'xesam-engine) nil) - (set (make-local-variable 'xesam-search) nil) - (set (make-local-variable 'xesam-type) "") - (set (make-local-variable 'xesam-query) "") - (set (make-local-variable 'xesam-xml-string) "") - (set (make-local-variable 'xesam-objects) nil) - ;; `xesam-current' is the last hit put into the search buffer, - (set (make-local-variable 'xesam-current) 0) - ;; `xesam-count' is the number of hits reported by the search engine. - (set (make-local-variable 'xesam-count) 0) - ;; `xesam-to' is the upper hit number to be presented. - (set (make-local-variable 'xesam-to) xesam-hits-per-page) - ;; `xesam-notify-function' can be a search engine specific function - ;; to visualize xesam:url. It can be overwritten in `xesam-mode'. - (set (make-local-variable 'xesam-notify-function) nil) - ;; `xesam-refreshing' is an indicator, whether the buffer is just - ;; being updated. Needed, because `xesam-refresh-search-buffer' - ;; can be triggered by an event. - (set (make-local-variable 'xesam-refreshing) nil) - ;; Mode line position returns hit counters. - (set (make-local-variable 'mode-line-position) - (list '(-3 "%p%") - '(10 (:eval (format " (%d/%d)" xesam-current xesam-count))))) - ;; Header line contains the query string. - (set (make-local-variable 'header-line-format) - (list '(20 - (:eval - (list "Type: " - (propertize xesam-type 'face 'xesam-mode-line)))) - '(10 - (:eval - (list " Query: " - (propertize - xesam-query - 'face 'xesam-mode-line - 'help-echo (when xesam-debug xesam-xml-string))))))) - - (when (not (called-interactively-p 'interactive)) - ;; Initialize buffer. - (setq buffer-read-only t) - (let ((inhibit-read-only t)) - (erase-buffer)))) - -;; It doesn't make sense to call it interactively. -(put 'xesam-mode 'disabled t) - -;; The very first buffer created with `xesam-mode' does not have the -;; keymap etc. So we create a dummy buffer. Stupid. -(with-temp-buffer (xesam-mode)) - -(define-minor-mode xesam-minor-mode - "Toggle Xesam minor mode. -With a prefix argument ARG, enable Xesam minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. - -When Xesam minor mode is enabled, all text which matches a -previous Xesam query in this buffer is highlighted." - :group 'xesam - :init-value nil - :lighter " Xesam" - (when (local-variable-p 'xesam-query) - ;; Run only if the buffer is related to a Xesam search. - (save-excursion - (if xesam-minor-mode - ;; Highlight hits. - (let ((query-regexp (regexp-opt (split-string xesam-query nil t) t)) - (case-fold-search t)) - ;; I have no idea whether people will like setting - ;; `isearch-case-fold-search' and `query-regexp'. Maybe - ;; this shall be controlled by a custom option. - (unless isearch-case-fold-search (isearch-toggle-case-fold)) - (isearch-update-ring query-regexp t) - ;; Create overlays. - (goto-char (point-min)) - (while (re-search-forward query-regexp nil t) - (overlay-put - (make-overlay - (match-beginning 0) (match-end 0)) 'face 'xesam-highlight))) - ;; Remove overlays. - (dolist (ov (overlays-in (point-min) (point-max))) - (delete-overlay ov)))))) - -(defun xesam-buffer-name (service search) - "Return the buffer name where to present search results. -SERVICE is the D-Bus unique service name of the Xesam search engine. -SEARCH is the search identification in that engine. Both must be strings." - (format "*%s/%s*" service search)) - -(defun xesam-highlight-string (string) - "Highlight text enclosed by <b> and </b>. -Return propertized STRING." - (while (string-match "\\(.*\\)\\(<b>\\)\\(.*\\)\\(</b>\\)\\(.*\\)" string) - (setq string - (format - "%s%s%s" - (match-string 1 string) - (propertize (match-string 3 string) 'face 'xesam-highlight) - (match-string 5 string)))) - string) - -(defun xesam-refresh-entry (engine entry) - "Refreshes one entry in the search buffer." - (let* ((result (nth (1- xesam-current) xesam-objects)) - widget) - - ;; Create widget. - (setq widget (widget-convert 'link)) - (when xesam-debug - (widget-put widget :help-echo "")) - - ;; Take all results. - (dolist (field (xesam-get-cached-property engine "hit.fields")) - (when (cond - ((stringp (caar result)) (not (zerop (length (caar result))))) - ((numberp (caar result)) (not (zerop (caar result)))) - ((caar result) t)) - (when xesam-debug - (widget-put - widget :help-echo - (format "%s%s: %s\n" - (widget-get widget :help-echo) field (caar result)))) - (widget-put widget (intern (concat ":" field)) (caar result))) - (setq result (cdr result))) - - ;; Strigi doesn't return URLs in xesam:url. We must fix this. - (when - (not (url-type (url-generic-parse-url (widget-get widget :xesam:url)))) - (widget-put - widget :xesam:url (concat "file://" (widget-get widget :xesam:url)))) - - ;; Strigi returns xesam:size as string. We must fix this. - (when (and (widget-member widget :xesam:size) - (stringp (widget-get widget :xesam:size))) - (widget-put - widget :xesam:size (string-to-number (widget-get widget :xesam:url)))) - - ;; First line: :tag. - (cond - ((widget-member widget :xesam:title) - (widget-put widget :tag (widget-get widget :xesam:title))) - ((widget-member widget :xesam:subject) - (widget-put widget :tag (widget-get widget :xesam:subject))) - ((widget-member widget :xesam:mimeType) - (widget-put widget :tag (widget-get widget :xesam:mimeType))) - ((widget-member widget :xesam:name) - (widget-put widget :tag (widget-get widget :xesam:name)))) - - ;; Highlight the search items. - (when (widget-member widget :tag) - (widget-put - widget :tag (xesam-highlight-string (widget-get widget :tag)))) - - ;; Last Modified. - (when (and (widget-member widget :xesam:sourceModified) - (not - (zerop - (string-to-number (widget-get widget :xesam:sourceModified))))) - (widget-put - widget :tag - (format - "%s\nLast Modified: %s" - (or (widget-get widget :tag) "") - (format-time-string - "%d %B %Y, %T" - (seconds-to-time - (string-to-number (widget-get widget :xesam:sourceModified))))))) - - ;; Second line: :value. - (widget-put widget :value (widget-get widget :xesam:url)) - - (cond - ;; A search engine can set `xesam-notify-function' via - ;; `xesam-mode-hooks'. - (xesam-notify-function - (widget-put widget :notify xesam-notify-function)) - - ;; In case of HTML, we use a URL link. - ((and (widget-member widget :xesam:mimeType) - (string-equal "text/html" (widget-get widget :xesam:mimeType))) - (setcar widget 'url-link)) - - ;; For local files, we will open the file as default action. - ((string-match "file" - (url-type (url-generic-parse-url - (widget-get widget :xesam:url)))) - (widget-put - widget :notify - (lambda (widget &rest ignore) - (let ((query xesam-query)) - (find-file - (url-filename (url-generic-parse-url (widget-value widget)))) - (set (make-local-variable 'xesam-query) query) - (xesam-minor-mode 1)))) - (widget-put - widget :value - (url-filename (url-generic-parse-url (widget-get widget :xesam:url)))))) - - ;; Third line: :doc. - (cond - ((widget-member widget :xesam:summary) - (widget-put widget :doc (widget-get widget :xesam:summary))) - ((widget-member widget :xesam:snippet) - (widget-put widget :doc (widget-get widget :xesam:snippet)))) - - (when (widget-member widget :doc) - (with-temp-buffer - (insert - (xesam-highlight-string (widget-get widget :doc))) - (fill-region-as-paragraph (point-min) (point-max)) - (widget-put widget :doc (buffer-string))) - (widget-put widget :help-echo (widget-get widget :doc))) - - ;; Format the widget. - (widget-put - widget :format - (format "%d. %s%%[%%v%%]\n%s\n" xesam-current - (if (widget-member widget :tag) "%{%t%}\n" "") - (if (widget-member widget :doc) "%h" ""))) - - ;; Write widget. - (goto-char (point-max)) - (widget-default-create widget) - (set-buffer-modified-p nil) - (force-mode-line-update) - (redisplay))) - -(defun xesam-get-hits (engine search hits) - "Retrieve hits from ENGINE." - (with-current-buffer (xesam-buffer-name (car engine) search) - (setq xesam-objects - (append xesam-objects - (xesam-dbus-call-method - :session (car engine) xesam-path-search - xesam-interface-search "GetHits" search hits))))) - -(defun xesam-refresh-search-buffer (engine search) - "Refreshes the buffer, presenting results of SEARCH." - (with-current-buffer (xesam-buffer-name (car engine) search) - ;; Work only if nobody else is here. - (unless (or xesam-refreshing (>= xesam-current xesam-to)) - (setq xesam-refreshing t) - (unwind-protect - (let (widget) - - ;; Retrieve needed hits for visualization. - (while (> (min xesam-to xesam-count) (length xesam-objects)) - (xesam-get-hits - engine search - (min xesam-hits-per-page - (- (min xesam-to xesam-count) (length xesam-objects))))) - - ;; Add all result widgets. - (while (< xesam-current (min xesam-to xesam-count)) - (setq xesam-current (1+ xesam-current)) - (xesam-refresh-entry engine search)) - - ;; Add "NEXT" widget. - (when (> xesam-count xesam-to) - (goto-char (point-max)) - (widget-create - 'link - :notify - (lambda (widget &rest ignore) - (setq xesam-to (+ xesam-to xesam-hits-per-page)) - (widget-delete widget) - (xesam-refresh-search-buffer xesam-engine xesam-search)) - "NEXT") - (widget-beginning-of-line)) - - ;; Prefetch next hits. - (when (> (min (+ xesam-hits-per-page xesam-to) xesam-count) - (length xesam-objects)) - (xesam-get-hits - engine search - (min xesam-hits-per-page - (- (min (+ xesam-hits-per-page xesam-to) xesam-count) - (length xesam-objects))))) - - ;; Add "DONE" widget. - (when (= xesam-current xesam-count) - (goto-char (point-max)) - (widget-create 'link :notify 'ignore "DONE") - (widget-beginning-of-line))) - - ;; Return with save settings. - (setq xesam-refreshing nil))))) - - -;;; Search functions. - -(defun xesam-signal-handler (&rest args) - "Handles the different D-Bus signals of a Xesam search." - (let* ((service (dbus-event-service-name last-input-event)) - (member (dbus-event-member-name last-input-event)) - (search (nth 0 args)) - (buffer (xesam-buffer-name service search))) - - (when (get-buffer buffer) - (with-current-buffer buffer - (cond - - ((string-equal member "HitsAdded") - (setq xesam-count (+ xesam-count (nth 1 args))) - ;; We use `run-at-time' in order to not block the event queue. - (run-at-time - 0 nil - 'xesam-refresh-search-buffer - (assoc service xesam-search-engines) search)) - - ((string-equal member "SearchDone") - (setq mode-line-process - (propertize " Done" 'face 'xesam-mode-line)) - (force-mode-line-update))))))) - -(defun xesam-kill-buffer-function () - "Send the CloseSearch indication." - (when (and (eq major-mode 'xesam-mode) (stringp xesam-search)) - (ignore-errors ;; The D-Bus service could have disappeared. - (xesam-dbus-call-method - :session (car xesam-engine) xesam-path-search - xesam-interface-search "CloseSearch" xesam-search)))) - -(defun xesam-new-search (engine type query) - "Create a new search session. -ENGINE identifies the search engine. TYPE is the query type, it -can be either `fulltext-query', or `user-query'. QUERY is a -string in the Xesam query language. A string, identifying the -search, is returned." - (let* ((service (car engine)) - (session (xesam-get-cached-property engine "session")) - (xml-string - (format - (if (eq type 'user-query) xesam-user-query xesam-fulltext-query) - (url-insert-entities-in-string query))) - (search (xesam-dbus-call-method - :session service xesam-path-search - xesam-interface-search "NewSearch" session xml-string))) - - ;; Let us notify for relevant signals. We ignore "HitsRemoved", - ;; "HitsModified" and "StateChanged"; there is nothing to do for - ;; us. - (dbus-register-signal - :session service xesam-path-search - xesam-interface-search "HitsAdded" - 'xesam-signal-handler search) - (dbus-register-signal - :session service xesam-path-search - xesam-interface-search "SearchDone" - 'xesam-signal-handler search) - - ;; Create the search buffer. - (with-current-buffer - (generate-new-buffer (xesam-buffer-name service search)) - (switch-to-buffer-other-window (current-buffer)) - ;; Initialize buffer with `xesam-mode'. `xesam-vendor' must be - ;; set before calling `xesam-mode', because we want to give the - ;; hook functions a chance to identify their search engine. - (setq xesam-vendor (xesam-get-cached-property engine "vendor.id")) - (xesam-mode) - (setq xesam-engine engine - xesam-search search - ;; `xesam-type', `xesam-query' and `xesam-xml-string' - ;; are displayed in the header line. - xesam-type (symbol-name type) - xesam-query query - xesam-xml-string xml-string - xesam-objects nil - ;; The buffer identification shall indicate the search - ;; engine. The `help-echo' property is used for debug - ;; information, when applicable. - mode-line-buffer-identification - (if (not xesam-debug) - (list 12 (propertized-buffer-identification xesam-vendor)) - (propertize - xesam-vendor - 'help-echo - (mapconcat - (lambda (x) - (format "%s: %s" x (xesam-get-cached-property engine x))) - '("vendor.id" "vendor.version" "vendor.display" "vendor.xesam" - "vendor.ontology.fields" "vendor.ontology.contents" - "vendor.ontology.sources" "vendor.extensions" - "vendor.ontologies" "vendor.maxhits") - "\n")))) - (add-hook 'kill-buffer-hook 'xesam-kill-buffer-function) - (force-mode-line-update)) - - ;; Start the search. - (xesam-dbus-call-method - :session (car engine) xesam-path-search - xesam-interface-search "StartSearch" search) - - ;; Return search id. - search)) - -;;;###autoload -(defun xesam-search (engine query) - "Perform an interactive search. -ENGINE is the Xesam search engine to be applied, it must be one of the -entries of `xesam-search-engines'. QUERY is the search string in the -Xesam user query language. If the search engine does not support -the Xesam user query language, a Xesam fulltext search is applied. - -The default search engine is the first entry in `xesam-search-engines'. -Example: - - (xesam-search (car (xesam-search-engines)) \"emacs\")" - (interactive - (let* ((vendors (mapcar - (lambda (x) (xesam-get-cached-property x "vendor.display")) - (xesam-search-engines))) - (vendor - (if (> (length vendors) 1) - (completing-read - "Enter search engine: " vendors nil t - (try-completion "" vendors) 'xesam-minibuffer-vendor-history) - (car vendors)))) - (list - ;; ENGINE. - (when vendor - (dolist (elt (xesam-search-engines) engine) - (when (string-equal - (xesam-get-cached-property elt "vendor.display") vendor) - (setq engine elt)))) - ;; QUERY. - (when vendor - (read-from-minibuffer - "Enter search string: " nil nil nil - 'xesam-minibuffer-query-history))))) - - (if (null engine) - (message "No search engine running") - (if (zerop (length query)) - (message "No query applied") - (xesam-new-search engine xesam-query-type query)))) - -(provide 'xesam) - -;;; TODO: - -;; * Buffer highlighting needs better analysis of query string. -;; * Accept input while retrieving prefetched hits. `run-at-time'? -;; * With prefix, let's choose search engine. -;; * Minibuffer completion for user queries. -;; * `revert-buffer-function' implementation. -;; -;; * Mid term -;; - If available, use ontologies for field selection. -;; - Search engines for Emacs bugs database, wikipedia, google, -;; yahoo, ebay, ... -;; - Construct complex queries via widgets, like in mairix.el. - -;;; xesam.el ends here diff --git a/lisp/obsolete/yow.el b/lisp/obsolete/yow.el index 5cbb2ef21e3..eeeaaec8124 100644 --- a/lisp/obsolete/yow.el +++ b/lisp/obsolete/yow.el @@ -2,8 +2,8 @@ ;; Copyright (C) 1993-1995, 2000-2019 Free Software Foundation, Inc. -;; Maintainer: emacs-devel@gnu.org ;; Author: Richard Mlynarik +;; Maintainer: emacs-devel@gnu.org ;; Keywords: games ;; Obsolete-since: 24.4 diff --git a/lisp/org/ob-abc.el b/lisp/org/ob-abc.el index cefbe716e15..43ee1d9921b 100644 --- a/lisp/org/ob-abc.el +++ b/lisp/org/ob-abc.el @@ -47,7 +47,7 @@ (value (cdr pair))) (setq body (replace-regexp-in-string - (concat "\$" (regexp-quote name)) + (concat "\\$" (regexp-quote name)) (if (stringp value) value (format "%S" value)) body)))) vars) @@ -59,7 +59,7 @@ (message "executing Abc source code block") (let* ((cmdline (cdr (assq :cmdline params))) (out-file (let ((file (cdr (assq :file params)))) - (if file (replace-regexp-in-string "\.pdf$" ".ps" file) + (if file (replace-regexp-in-string "\\.pdf$" ".ps" file) (error "abc code block requires :file header argument")))) (in-file (org-babel-temp-file "abc-")) (render (concat "abcm2ps" " " cmdline diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el index 3649d6666c8..b6c54a92ab6 100644 --- a/lisp/org/ob-core.el +++ b/lisp/org/ob-core.el @@ -2310,10 +2310,9 @@ INFO may provide the values of these header arguments (in the (lambda (r) ;; Non-nil when result R can be turned into ;; a table. - (and (listp r) - (null (cdr (last r))) + (and (proper-list-p r) (cl-every - (lambda (e) (or (atom e) (null (cdr (last e))))) + (lambda (e) (or (atom e) (proper-list-p e))) result))))) ;; insert results based on type (cond @@ -2956,7 +2955,7 @@ If the table is trivial, then return it as a scalar." (defun org-babel-string-read (cell) "Strip nested \"s from around strings." (org-babel-read (or (and (stringp cell) - (string-match "\\\"\\(.+\\)\\\"" cell) + (string-match "\"\\(.+\\)\"" cell) (match-string 1 cell)) cell) t)) diff --git a/lisp/org/ob-eval.el b/lisp/org/ob-eval.el index 0587851e8bd..8d5b7ed2674 100644 --- a/lisp/org/ob-eval.el +++ b/lisp/org/ob-eval.el @@ -120,7 +120,7 @@ function in various versions of Emacs. (delete-file input-file)) (when (and error-file (file-exists-p error-file)) - (when (< 0 (nth 7 (file-attributes error-file))) + (when (< 0 (file-attribute-size (file-attributes error-file))) (with-current-buffer (get-buffer-create error-buffer) (let ((pos-from-end (- (point-max) (point)))) (or (bobp) diff --git a/lisp/org/ob-forth.el b/lisp/org/ob-forth.el index 8ca292656a2..88ed964fd77 100644 --- a/lisp/org/ob-forth.el +++ b/lisp/org/ob-forth.el @@ -53,7 +53,7 @@ This function is called by `org-babel-execute-src-block'" (defun org-babel-forth-session-execute (body params) (require 'forth-mode) (let ((proc (forth-proc)) - (rx " \\(\n:\\|compiled\n\\\|ok\n\\)") + (rx " \\(\n:\\|compiled\n\\|ok\n\\)") (result-start)) (with-current-buffer (process-buffer (forth-proc)) (mapcar (lambda (line) diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el index f1335a50668..23ee8d71e66 100644 --- a/lisp/org/org-agenda.el +++ b/lisp/org/org-agenda.el @@ -1401,6 +1401,9 @@ current display in the agenda." :group 'org-agenda-daily/weekly :type 'plist) +(defvaralias 'org-agenda-search-view-search-words-only + 'org-agenda-search-view-always-boolean) + (defcustom org-agenda-search-view-always-boolean nil "Non-nil means the search string is interpreted as individual parts. @@ -1429,9 +1432,6 @@ boolean search." :version "24.1" :type 'boolean) -(defvaralias 'org-agenda-search-view-search-words-only - 'org-agenda-search-view-always-boolean) - (defcustom org-agenda-search-view-force-full-words nil "Non-nil means, search words must be matches as complete words. When nil, they may also match part of a word." @@ -1873,6 +1873,9 @@ Nil means don't hide any tags." (const :tag "Hide none" nil) (string :tag "Regexp "))) +(defvaralias 'org-agenda-remove-tags-when-in-prefix + 'org-agenda-remove-tags) + (defcustom org-agenda-remove-tags nil "Non-nil means remove the tags from the headline copy in the agenda. When this is the symbol `prefix', only remove tags when @@ -1883,8 +1886,7 @@ When this is the symbol `prefix', only remove tags when (const :tag "Never" nil) (const :tag "When prefix format contains %T" prefix))) -(defvaralias 'org-agenda-remove-tags-when-in-prefix - 'org-agenda-remove-tags) +(defvaralias 'org-agenda-align-tags-to-column 'org-agenda-tags-column) (defcustom org-agenda-tags-column 'auto "Shift tags in agenda items to this column. @@ -1902,8 +1904,6 @@ character screen." :package-version '(Org . "9.1") :version "26.1") -(defvaralias 'org-agenda-align-tags-to-column 'org-agenda-tags-column) - (defcustom org-agenda-fontify-priorities 'cookies "Non-nil means highlight low and high priorities in agenda. When t, the highest priority entries are bold, lowest priority italic. @@ -2067,9 +2067,9 @@ works you probably want to add it to `org-agenda-custom-commands' for good." ;;; Define the org-agenda-mode +(defvaralias 'org-agenda-keymap 'org-agenda-mode-map) (defvar org-agenda-mode-map (make-sparse-keymap) "Keymap for `org-agenda-mode'.") -(defvaralias 'org-agenda-keymap 'org-agenda-mode-map) (defvar org-agenda-menu) ; defined later in this file. (defvar org-agenda-restrict nil) ; defined later in this file. @@ -2205,10 +2205,14 @@ The following commands are available: (add-hook 'post-command-hook 'org-agenda-update-agenda-type nil 'local) (add-hook 'pre-command-hook 'org-unhighlight nil 'local) ;; Make sure properties are removed when copying text - (add-hook 'filter-buffer-substring-functions - (lambda (fun start end delete) - (substring-no-properties (funcall fun start end delete))) - nil t) + (if (boundp 'filter-buffer-substring-functions) + (add-hook 'filter-buffer-substring-functions + (lambda (fun start end delete) + (substring-no-properties (funcall fun start end delete))) + nil t) + ;; Emacs >= 24.4. + (add-function :filter-return (local 'filter-buffer-substring-function) + #'substring-no-properties)) (unless org-agenda-keep-modes (setq org-agenda-follow-mode org-agenda-start-with-follow-mode org-agenda-entry-text-mode org-agenda-start-with-entry-text-mode @@ -2878,13 +2882,12 @@ Pressing `<' twice means to restrict to the current subtree or region (let* ((m (org-agenda-get-any-marker)) (note (and m (org-entry-get m "THEFLAGGINGNOTE")))) (when note - (message (concat - "FLAGGING-NOTE ([?] for more info): " - (org-add-props - (replace-regexp-in-string - "\\\\n" "//" - (copy-sequence note)) - nil 'face 'org-warning))))))) + (message "FLAGGING-NOTE ([?] for more info): %s" + (org-add-props + (replace-regexp-in-string + "\\\\n" "//" + (copy-sequence note)) + nil 'face 'org-warning)))))) t t)) ((equal org-keys "#") (call-interactively 'org-agenda-list-stuck-projects)) ((equal org-keys "/") (call-interactively 'org-occur-in-agenda-files)) @@ -5487,8 +5490,8 @@ displayed in agenda view." (substring (format-time-string (car org-time-stamp-formats) - (apply #'encode-time ; DATE bound by calendar - (list 0 0 0 (nth 1 date) (car date) (nth 2 date)))) + (encode-time ; DATE bound by calendar + 0 0 0 (nth 1 date) (car date) (nth 2 date))) 1 11)) "\\|\\(<[0-9]+-[0-9]+-[0-9]+[^>\n]+?\\+[0-9]+[hdwmy]>\\)" "\\|\\(<%%\\(([^>\n]+)\\)>\\)")) @@ -5738,8 +5741,8 @@ then those holidays will be skipped." (substring (format-time-string (car org-time-stamp-formats) - (apply 'encode-time ; DATE bound by calendar - (list 0 0 0 (nth 1 date) (car date) (nth 2 date)))) + (encode-time ; DATE bound by calendar + 0 0 0 (nth 1 date) (car date) (nth 2 date))) 1 11)))) (org-agenda-search-headline-for-time nil) marker hdmarker priority category level tags closedp @@ -5856,21 +5859,19 @@ See also the user option `org-agenda-clock-consistency-checks'." (throw 'next t)) (setq ts (match-string 1) te (match-string 3) - ts (float-time - (apply #'encode-time (org-parse-time-string ts))) - te (float-time - (apply #'encode-time (org-parse-time-string te))) + ts (float-time (org-time-string-to-time ts)) + te (float-time (org-time-string-to-time te)) dt (- te ts)))) (cond ((> dt (* 60 maxtime)) ;; a very long clocking chunk (setq issue (format "Clocking interval is very long: %s" - (org-duration-from-minutes (floor (/ dt 60.)))) + (org-duration-from-minutes (floor dt 60))) face (or (plist-get pl :long-face) face))) ((< dt (* 60 mintime)) ;; a very short clocking chunk (setq issue (format "Clocking interval is very short: %s" - (org-duration-from-minutes (floor (/ dt 60.)))) + (org-duration-from-minutes (floor dt 60))) face (or (plist-get pl :short-face) face))) ((and (> tlend 0) (< ts tlend)) ;; Two clock entries are overlapping @@ -5910,8 +5911,8 @@ See also the user option `org-agenda-clock-consistency-checks'." (throw 'exit t)) ;; We have a shorter gap. ;; Now we have to get the minute of the day when these times are - (let* ((t1dec (decode-time (seconds-to-time t1))) - (t2dec (decode-time (seconds-to-time t2))) + (let* ((t1dec (decode-time t1)) + (t2dec (decode-time t2)) ;; compute the minute on the day (min1 (+ (nth 1 t1dec) (* 60 (nth 2 t1dec)))) (min2 (+ (nth 1 t2dec) (* 60 (nth 2 t2dec))))) @@ -7005,15 +7006,15 @@ When TYPE is \"scheduled\", \"deadline\", \"timestamp\" or \"timestamp_ia\", compare within each of these type. When TYPE is the empty string, compare all timestamps without respect of their type." - (let* ((def (if org-sort-agenda-notime-is-late most-positive-fixnum -1)) + (let* ((def (and (not org-sort-agenda-notime-is-late) -1)) (ta (or (and (string-match type (or (get-text-property 1 'type a) "")) (get-text-property 1 'ts-date a)) def)) (tb (or (and (string-match type (or (get-text-property 1 'type b) "")) (get-text-property 1 'ts-date b)) def))) - (cond ((< ta tb) -1) - ((< tb ta) +1)))) + (cond ((if ta (and tb (< ta tb)) tb) -1) + ((if tb (and ta (< tb ta)) ta) +1)))) (defsubst org-cmp-habit-p (a b) "Compare the todo states of strings A and B." @@ -9444,7 +9445,7 @@ the resulting entry will not be shown. When TEXT is empty, switch to (goto-char (point-min)) (cond ((eq type 'anniversary) - (or (re-search-forward "^*[ \t]+Anniversaries" nil t) + (or (re-search-forward "^\\*[ \t]+Anniversaries" nil t) (progn (or (org-at-heading-p t) (progn @@ -10155,8 +10156,7 @@ to override `appt-message-warning-time'." ;; Do not use `org-today' here because appt only takes ;; time and without date as argument, so it may pass wrong ;; information otherwise - (today (org-date-to-gregorian - (time-to-days (current-time)))) + (today (org-date-to-gregorian (time-to-days nil))) (org-agenda-restrict nil) (files (org-agenda-files 'unrestricted)) entries file (org-agenda-buffer nil)) diff --git a/lisp/org/org-attach.el b/lisp/org/org-attach.el index db8b61b3d51..f430cd5ed3e 100644 --- a/lisp/org/org-attach.el +++ b/lisp/org/org-attach.el @@ -352,7 +352,7 @@ This checks for the existence of a \".git\" directory in that directory." (shell-command-to-string "git ls-files -zmo --exclude-standard") "\0" t)) (if (and use-annex - (>= (nth 7 (file-attributes new-or-modified)) + (>= (file-attribute-size (file-attributes new-or-modified)) org-attach-git-annex-cutoff)) (call-process "git" nil nil nil "annex" "add" new-or-modified) (call-process "git" nil nil nil "add" new-or-modified)) diff --git a/lisp/org/org-capture.el b/lisp/org/org-capture.el index a699d2e28fc..cbcf6c72f9f 100644 --- a/lisp/org/org-capture.el +++ b/lisp/org/org-capture.el @@ -149,7 +149,7 @@ type The type of entry. Valid types are: first plain list at the target location. checkitem a checkbox item. This differs from the - plain list item only is so far as it uses a + plain list item only in so far as it uses a different default template. table-line a new line in the first table at target location. plain text to be inserted as it is. @@ -1000,8 +1000,7 @@ Store them in the capture property list." (equal current-prefix-arg 1)) ;; Prompt for date. (let ((prompt-time (org-read-date - nil t nil "Date for tree entry:" - (current-time)))) + nil t nil "Date for tree entry:" nil))) (org-capture-put :default-time (cond ((and (or (not (boundp 'org-time-was-given)) @@ -1009,9 +1008,8 @@ Store them in the capture property list." (not (= (time-to-days prompt-time) (org-today)))) ;; Use 00:00 when no time is given for another ;; date than today? - (apply #'encode-time - (append '(0 0 0) - (cl-cdddr (decode-time prompt-time))))) + (apply #'encode-time 0 0 0 + (cl-cdddr (decode-time prompt-time)))) ((string-match "\\([^ ]+\\)--?[^ ]+[ ]+\\(.*\\)" org-read-date-final-answer) ;; Replace any time range by its start. diff --git a/lisp/org/org-clock.el b/lisp/org/org-clock.el index a9b933c8e37..62c7cd92d12 100644 --- a/lisp/org/org-clock.el +++ b/lisp/org/org-clock.el @@ -723,8 +723,8 @@ menu\nmouse-2 will jump to task")) The time returned includes the time spent on this task in previous clocking intervals." (let ((currently-clocked-time - (floor (- (float-time) - (float-time org-clock-start-time)) 60))) + (floor (encode-time (time-since org-clock-start-time) 'integer) + 60))) (+ currently-clocked-time (or org-clock-total-time 0)))) (defun org-clock-modify-effort-estimate (&optional value) @@ -932,7 +932,7 @@ If necessary, clock-out of the currently active clock." (unless (org-is-active-clock clock) (org-clock-clock-in clock t)))) - ((not (time-less-p resolve-to (current-time))) + ((not (time-less-p resolve-to nil)) (error "RESOLVE-TO must refer to a time in the past")) (t @@ -1033,8 +1033,8 @@ to be CLOCKED OUT.")))) nil 45))) (and (not (memq char-pressed '(?i ?q))) char-pressed))))) (default - (floor (/ (float-time - (time-subtract (current-time) last-valid)) 60))) + (floor (encode-time (time-since last-valid) 'integer) + 60)) (keep (and (memq ch '(?k ?K)) (read-number "Keep how many minutes? " default))) @@ -1042,8 +1042,9 @@ to be CLOCKED OUT.")))) (and (memq ch '(?g ?G)) (read-number "Got back how many minutes ago? " default))) (subtractp (memq ch '(?s ?S))) - (barely-started-p (< (- (float-time last-valid) - (float-time (cdr clock))) 45)) + (barely-started-p (time-less-p + (time-subtract last-valid (cdr clock)) + 45)) (start-over (and subtractp barely-started-p))) (cond ((memq ch '(?j ?J)) @@ -1069,10 +1070,9 @@ to be CLOCKED OUT.")))) (and gotback (= gotback default))) 'now) (keep - (time-add last-valid (seconds-to-time (* 60 keep)))) + (time-add last-valid (* 60 keep))) (gotback - (time-subtract (current-time) - (seconds-to-time (* 60 gotback)))) + (time-since (* 60 gotback))) (t (error "Unexpected, please report this as a bug"))) (and gotback last-valid) @@ -1102,8 +1102,8 @@ If `only-dangling-p' is non-nil, only ask to resolve dangling (lambda (clock) (format "Dangling clock started %d mins ago" - (floor (- (float-time) - (float-time (cdr clock))) + (floor (encode-time (time-since (cdr clock)) + 'integer) 60))))) (or last-valid (cdr clock))))))))))) @@ -1154,8 +1154,7 @@ so long." org-clock-marker (marker-buffer org-clock-marker)) (let* ((org-clock-user-idle-seconds (org-user-idle-seconds)) (org-clock-user-idle-start - (time-subtract (current-time) - (seconds-to-time org-clock-user-idle-seconds))) + (time-since org-clock-user-idle-seconds)) (org-clock-resolving-clocks-due-to-idleness t)) (if (> org-clock-user-idle-seconds (* 60 org-clock-idle-time)) (org-clock-resolve @@ -1164,9 +1163,8 @@ so long." (lambda (_) (format "Clocked in & idle for %.1f mins" (/ (float-time - (time-subtract (current-time) - org-clock-user-idle-start)) - 60.0))) + (time-since org-clock-user-idle-start)) + 60))) org-clock-user-idle-start))))) (defvar org-clock-current-task nil "Task currently clocked in.") @@ -1293,8 +1291,7 @@ the default behavior." (setq ts (concat "[" (match-string 1) "]")) (goto-char (match-end 1)) (setq org-clock-start-time - (apply 'encode-time - (org-parse-time-string (match-string 1)))) + (org-time-string-to-time (match-string 1))) (setq org-clock-effort (org-entry-get (point) org-effort-property)) (setq org-clock-total-time (org-clock-sum-current-item (org-clock-get-sum-start)))) @@ -1324,9 +1321,11 @@ the default behavior." (y-or-n-p (format "You stopped another clock %d mins ago; start this one from then? " - (/ (- (float-time - (org-current-time org-clock-rounding-minutes t)) - (float-time leftover)) + (/ (encode-time + (time-subtract + (org-current-time org-clock-rounding-minutes t) + leftover) + 'integer) 60))) leftover) start-time @@ -1431,7 +1430,7 @@ The time is always returned as UTC." (day (nth 3 dt))) (if (< hour org-extend-today-until) (setf (nth 3 dt) (1- day))) (setf (nth 2 dt) org-extend-today-until) - (apply #'encode-time (append (list 0 0) (nthcdr 2 dt))))) + (apply #'encode-time 0 0 (nthcdr 2 dt)))) ((or (equal cmt "all") (and (or (not cmt) (equal cmt "auto")) (not lr))) @@ -1577,21 +1576,19 @@ to, overriding the existing value of `org-clock-out-switch-to-state'." (delete-region (point) (point-at-eol)) (insert "--") (setq te (org-insert-time-stamp (or at-time now) 'with-hm 'inactive)) - (setq s (- (float-time - (apply #'encode-time (org-parse-time-string te))) - (float-time - (apply #'encode-time (org-parse-time-string ts)))) - h (floor (/ s 3600)) - s (- s (* 3600 h)) - m (floor (/ s 60)) - s (- s (* 60 s))) + (setq s (encode-time (time-subtract + (org-time-string-to-time te) + (org-time-string-to-time ts)) + 'integer) + h (floor s 3600) + m (floor (mod s 3600) 60)) (insert " => " (format "%2d:%02d" h m)) (move-marker org-clock-marker nil) (move-marker org-clock-hd-marker nil) ;; Possibly remove zero time clocks. However, do not add ;; a note associated to the CLOCK line in this case. (cond ((and org-clock-out-remove-zero-time-clocks - (= (+ h m) 0)) + (= 0 h m)) (setq remove t) (delete-region (line-beginning-position) (line-beginning-position 2))) @@ -1625,9 +1622,10 @@ to, overriding the existing value of `org-clock-out-switch-to-state'." "\\>")))) (org-todo org-clock-out-switch-to-state)))))) (force-mode-line-update) - (message (concat "Clock stopped at %s after " - (org-duration-from-minutes (+ (* 60 h) m)) "%s") - te (if remove " => LINE REMOVED" "")) + (message (if remove + "Clock stopped at %s after %s => LINE REMOVED" + "Clock stopped at %s after %s") + te (org-duration-from-minutes (+ (* 60 h) m))) (run-hooks 'org-clock-out-hook) (unless (org-clocking-p) (setq org-clock-current-task nil))))))) @@ -1813,15 +1811,15 @@ PROPNAME lets you set a custom text property instead of :org-clock-minutes." ((match-end 2) ;; Two time stamps. (let* ((ts (float-time - (apply #'encode-time - (save-match-data - (org-parse-time-string (match-string 2)))))) + (encode-time + (save-match-data + (org-parse-time-string (match-string 2)))))) (te (float-time - (apply #'encode-time - (org-parse-time-string (match-string 3))))) + (encode-time + (org-parse-time-string (match-string 3))))) (dt (- (if tend (min te tend) te) (if tstart (max ts tstart) ts)))) - (when (> dt 0) (cl-incf t1 (floor (/ dt 60)))))) + (when (> dt 0) (cl-incf t1 (floor dt 60))))) ((match-end 4) ;; A naked time. (setq t1 (+ t1 (string-to-number (match-string 5)) @@ -1835,8 +1833,9 @@ PROPNAME lets you set a custom text property instead of :org-clock-minutes." tend (>= (float-time org-clock-start-time) tstart) (<= (float-time org-clock-start-time) tend)) - (let ((time (floor (- (float-time) - (float-time org-clock-start-time)) + (let ((time (floor (encode-time + (time-since org-clock-start-time) + 'integer) 60))) (setq t1 (+ t1 time)))) (let* ((headline-forced @@ -1927,13 +1926,14 @@ Use `\\[org-clock-remove-overlays]' to remove the subtree times." nil 'local)))) (let* ((h (/ org-clock-file-total-minutes 60)) (m (- org-clock-file-total-minutes (* 60 h)))) - (message (concat (format "Total file time%s: " - (cond (todayp " for today") - (customp " (custom)") - (t ""))) - (org-duration-from-minutes - org-clock-file-total-minutes) - " (%d hours and %d minutes)") + (message (cond + (todayp + "Total file time for today: %s (%d hours and %d minutes)") + (customp + "Total file time (custom): %s (%d hours and %d minutes)") + (t + "Total file time: %s (%d hours and %d minutes)")) + (org-duration-from-minutes org-clock-file-total-minutes) h m)))) (defvar-local org-clock-overlays nil) @@ -2239,8 +2239,18 @@ have priority." (let* ((start (pcase key (`interactive (org-read-date nil t nil "Range start? ")) ;; In theory, all clocks started after the dawn of - ;; humanity. - (`untilnow (encode-time 0 0 0 0 0 -50000)) + ;; humanity. However, the platform's clock + ;; support might not go back that far. Choose the + ;; POSIX timestamp -2**41 (approximately 68,000 + ;; BCE) if that works, otherwise -2**31 (1901) if + ;; that works, otherwise 0 (1970). Going back + ;; billions of years would loop forever on Mac OS + ;; X 10.6 with Emacs 26 and earlier (Bug#27736). + (`untilnow + (let ((old 0)) + (dolist (older '((-32768 0) (-33554432 0)) old) + (when (ignore-errors (decode-time older)) + (setq old older))))) (_ (encode-time 0 m h d month y)))) (end (pcase key (`interactive (org-read-date nil t nil "Range end? ")) @@ -2694,24 +2704,24 @@ LEVEL is an integer. Indent by two spaces per level above 1." (pcase-let ((`(,month ,day ,year) (calendar-gregorian-from-absolute ts))) (setq ts (float-time (encode-time 0 0 0 day month year))))) (ts - (setq ts (float-time (apply #'encode-time (org-parse-time-string ts)))))) + (setq ts (float-time (org-time-string-to-time ts))))) (cond ((numberp te) ;; Likewise for te. (pcase-let ((`(,month ,day ,year) (calendar-gregorian-from-absolute te))) (setq te (float-time (encode-time 0 0 0 day month year))))) (te - (setq te (float-time (apply #'encode-time (org-parse-time-string te)))))) + (setq te (float-time (org-time-string-to-time te))))) (setq tsb (if (eq step0 'week) - (let ((dow (nth 6 (decode-time (seconds-to-time ts))))) + (let ((dow (nth 6 (decode-time ts)))) (if (<= dow ws) ts (- ts (* 86400 (- dow ws))))) ts)) (while (< tsb te) (unless (bolp) (insert "\n")) - (let ((start-time (seconds-to-time (max tsb ts)))) - (cl-incf tsb (let ((dow (nth 6 (decode-time (seconds-to-time tsb))))) + (let ((start-time (max tsb ts))) + (cl-incf tsb (let ((dow (nth 6 (decode-time tsb)))) (if (or (eq step0 'day) (= dow ws)) step @@ -2731,7 +2741,7 @@ LEVEL is an integer. Indent by two spaces per level above 1." :tstart (format-time-string (org-time-stamp-format t t) start-time) :tend (format-time-string (org-time-stamp-format t t) - (seconds-to-time (min te tsb)))))))) + (min te tsb))))))) (re-search-forward "^[ \t]*#\\+END:") (when (and stepskip0 (equal step-time 0)) ;; Remove the empty table @@ -2872,18 +2882,16 @@ Otherwise, return nil." (<= org-clock-marker (point-at-eol))) ;; The clock is running here (setq org-clock-start-time - (apply 'encode-time - (org-parse-time-string (match-string 1)))) + (org-time-string-to-time (match-string 1))) (org-clock-update-mode-line))) (t (and (match-end 4) (delete-region (match-beginning 4) (match-end 4))) (end-of-line 1) (setq ts (match-string 1) te (match-string 3)) - (setq s (- (float-time - (apply #'encode-time (org-parse-time-string te))) - (float-time - (apply #'encode-time (org-parse-time-string ts)))) + (setq s (float-time + (time-subtract (org-time-string-to-time te) + (org-time-string-to-time ts))) neg (< s 0) s (abs s) h (floor (/ s 3600)) diff --git a/lisp/org/org-colview.el b/lisp/org/org-colview.el index 2c34eddcf6b..799cc608bfa 100644 --- a/lisp/org/org-colview.el +++ b/lisp/org/org-colview.el @@ -540,7 +540,7 @@ Where possible, use the standard interface for changing this line." (eol (line-end-position)) (pom (or (get-text-property bol 'org-hd-marker) (point))) (key (or key (get-char-property (point) 'org-columns-key))) - (org-columns--time (float-time (current-time))) + (org-columns--time (float-time)) (action (pcase key ("CLOCKSUM" @@ -719,7 +719,7 @@ around it." (setq time-after (copy-sequence time)) (setf (nth 3 time-before) (1- (nth 3 time))) (setf (nth 3 time-after) (1+ (nth 3 time))) - (mapcar (lambda (x) (format-time-string fmt (apply 'encode-time x))) + (mapcar (lambda (x) (format-time-string fmt (encode-time x))) (list time-before time time-after))))) (defun org-columns-open-link (&optional arg) @@ -790,7 +790,7 @@ When COLUMNS-FMT-STRING is non-nil, use it as the column format." (org-columns-goto-top-level) ;; Initialize `org-columns-current-fmt' and ;; `org-columns-current-fmt-compiled'. - (let ((org-columns--time (float-time (current-time)))) + (let ((org-columns--time (float-time))) (org-columns-get-format columns-fmt-string) (unless org-columns-inhibit-recalculation (org-columns-compute-all)) (save-excursion @@ -1070,7 +1070,7 @@ as a canonical duration, i.e., using units defined in (cond ((string-match-p org-ts-regexp s) (/ (- org-columns--time - (float-time (apply #'encode-time (org-parse-time-string s)))) + (float-time (org-time-string-to-time s))) 60)) ((org-duration-p s) (org-duration-to-minutes s t)) ;skip user units (t (user-error "Invalid age: %S" s)))) @@ -1494,7 +1494,7 @@ PARAMS is a property list of parameters: (if (markerp org-columns-begin-marker) (move-marker org-columns-begin-marker (point)) (setq org-columns-begin-marker (point-marker))) - (let* ((org-columns--time (float-time (current-time))) + (let* ((org-columns--time (float-time)) (fmt (cond ((bound-and-true-p org-agenda-overriding-columns-format)) diff --git a/lisp/org/org-ctags.el b/lisp/org/org-ctags.el index 7dc8dd5b16a..111be379fd4 100644 --- a/lisp/org/org-ctags.el +++ b/lisp/org/org-ctags.el @@ -137,6 +137,7 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) (require 'org) (defgroup org-ctags nil @@ -235,7 +236,7 @@ buffer position where the tag is found." (with-current-buffer (get-file-buffer tags-file-name) (goto-char (point-min)) (cond - ((re-search-forward (format "^.*%s\\([0-9]+\\),\\([0-9]+\\)$" + ((re-search-forward (format "^.*\^?%s\^A\\([0-9]+\\),\\([0-9]+\\)$" (regexp-quote tag)) nil t) (let ((line (string-to-number (match-string 1))) (pos (string-to-number (match-string 2)))) @@ -260,7 +261,7 @@ Return the list." (visit-tags-table-buffer 'same) (with-current-buffer (get-file-buffer tags-file-name) (goto-char (point-min)) - (while (re-search-forward "^.*\\(.*\\)\\([0-9]+\\),\\([0-9]+\\)$" + (while (re-search-forward "^.*\^?\\(.*\\)\^A\\([0-9]+\\),\\([0-9]+\\)$" nil t) (push (substring-no-properties (match-string 1)) taglist))) taglist))) diff --git a/lisp/org/org-datetree.el b/lisp/org/org-datetree.el index aea2c8d3d61..b4797de1e58 100644 --- a/lisp/org/org-datetree.el +++ b/lisp/org/org-datetree.el @@ -138,15 +138,16 @@ will be built under the headline at point." "^\\*+[ \t]+%d-%02d-\\([0123][0-9]\\) \\w+$" year month day)))) -(defun org-datetree--find-create (regex year &optional month day insert) - "Find the datetree matched by REGEX for YEAR, MONTH, or DAY. -REGEX is passed to `format' with YEAR, MONTH, and DAY as +(defun org-datetree--find-create + (regex-template year &optional month day insert) + "Find the datetree matched by REGEX-TEMPLATE for YEAR, MONTH, or DAY. +REGEX-TEMPLATE is passed to `format' with YEAR, MONTH, and DAY as arguments. Match group 1 is compared against the specified date component. If INSERT is non-nil and there is no match then it is inserted into the buffer." (when (or month day) (org-narrow-to-subtree)) - (let ((re (format regex year month day)) + (let ((re (format regex-template year month day)) match) (goto-char (point-min)) (while (and (setq match (re-search-forward re nil t)) diff --git a/lisp/org/org-duration.el b/lisp/org/org-duration.el index f115082243b..770c72fd676 100644 --- a/lisp/org/org-duration.el +++ b/lisp/org/org-duration.el @@ -317,11 +317,10 @@ When optional argument CANONICAL is non-nil, ignore Raise an error if expected format is unknown." (pcase (or fmt org-duration-format) (`h:mm - (let ((minutes (floor minutes))) - (format "%d:%02d" (/ minutes 60) (mod minutes 60)))) + (format "%d:%02d" (/ minutes 60) (mod minutes 60))) (`h:mm:ss (let* ((whole-minutes (floor minutes)) - (seconds (floor (* 60 (- minutes whole-minutes))))) + (seconds (mod (* 60 minutes) 60))) (format "%s:%02d" (org-duration-from-minutes whole-minutes 'h:mm) seconds))) @@ -402,9 +401,7 @@ Raise an error if expected format is unknown." (pcase-let* ((`(,unit . ,required?) units) (modifier (org-duration--modifier unit canonical))) (cond ((<= modifier minutes) - (let ((value (if (integerp modifier) - (/ (floor minutes) modifier) - (floor (/ minutes modifier))))) + (let ((value (floor minutes modifier))) (cl-decf minutes (* value modifier)) (format " %d%s" value unit))) (required? (concat " 0" unit)) diff --git a/lisp/org/org-element.el b/lisp/org/org-element.el index 6458335704e..04e2fda55e3 100644 --- a/lisp/org/org-element.el +++ b/lisp/org/org-element.el @@ -2119,7 +2119,7 @@ containing `:key', `:value', `:begin', `:end', `:post-blank' and ;; this corner case. (let ((begin (or (car affiliated) (point))) (post-affiliated (point)) - (key (progn (looking-at "[ \t]*#\\+\\(\\S-+*\\):") + (key (progn (looking-at "[ \t]*#\\+\\(\\S-*\\):") (upcase (match-string-no-properties 1)))) (value (org-trim (buffer-substring-no-properties (match-end 0) (point-at-eol)))) @@ -4765,13 +4765,13 @@ you want to help debugging the issue.") (defvar org-element-cache-sync-idle-time 0.6 "Length, in seconds, of idle time before syncing cache.") -(defvar org-element-cache-sync-duration (seconds-to-time 0.04) +(defvar org-element-cache-sync-duration 0.04 "Maximum duration, as a time value, for a cache synchronization. If the synchronization is not over after this delay, the process pauses and resumes after `org-element-cache-sync-break' seconds.") -(defvar org-element-cache-sync-break (seconds-to-time 0.3) +(defvar org-element-cache-sync-break 0.3 "Duration, as a time value, of the pause between synchronizations. See `org-element-cache-sync-duration' for more information.") @@ -4856,7 +4856,7 @@ table is cleared once the synchronization is complete." (defun org-element--cache-generate-key (lower upper) "Generate a key between LOWER and UPPER. -LOWER and UPPER are integers or lists, possibly empty. +LOWER and UPPER are fixnums or lists of same, possibly empty. If LOWER and UPPER are equals, return LOWER. Otherwise, return a unique key, as an integer or a list of integers, according to @@ -4950,6 +4950,7 @@ A and B are either integers or lists of integers, as returned by (defsubst org-element--cache-root () "Return root value in cache. This function assumes `org-element--cache' is a valid AVL tree." + ;; FIXME: Why use internal functions of avl-tree? (avl-tree--node-left (avl-tree--dummyroot org-element--cache))) @@ -4978,6 +4979,7 @@ the cache." (aref (car org-element--cache-sync-requests) 0))) (node (org-element--cache-root)) lower upper) + ;; FIXME: Why use internal functions of avl-tree? (while node (let* ((element (avl-tree--node-data node)) (begin (org-element-property :begin element))) @@ -5064,7 +5066,7 @@ Assume ELEMENT belongs to cache and that a cache is active." TIME-LIMIT is a time value or nil." (and time-limit (or (input-pending-p) - (time-less-p time-limit (current-time))))) + (time-less-p time-limit nil)))) (defsubst org-element--cache-shift-positions (element offset &optional props) "Shift ELEMENT properties relative to buffer positions by OFFSET. @@ -5118,8 +5120,7 @@ updated before current modification are actually submitted." (and next (aref next 0)) threshold (and (not threshold) - (time-add (current-time) - org-element-cache-sync-duration)) + (time-add nil org-element-cache-sync-duration)) future-change) ;; Request processed. Merge current and next offsets and ;; transfer ending position. diff --git a/lisp/org/org-eshell.el b/lisp/org/org-eshell.el index bb27d92e12d..2251a1b892f 100644 --- a/lisp/org/org-eshell.el +++ b/lisp/org/org-eshell.el @@ -37,7 +37,7 @@ eshell buffer) or a command line prefixed by a buffer name followed by a colon." (let* ((buffer-and-command - (if (string-match "\\([A-Za-z0-9-+*]+\\):\\(.*\\)" link) + (if (string-match "\\([A-Za-z0-9+*-]+\\):\\(.*\\)" link) (list (match-string 1 link) (match-string 2 link)) (list eshell-buffer-name link))) diff --git a/lisp/org/org-footnote.el b/lisp/org/org-footnote.el index dee127a78ab..f8963184654 100644 --- a/lisp/org/org-footnote.el +++ b/lisp/org/org-footnote.el @@ -636,7 +636,7 @@ or new, let the user edit the definition of the footnote." (let* ((all (org-footnote-all-labels)) (label (if (eq org-footnote-auto-label 'random) - (format "%x" (random most-positive-fixnum)) + (format "%x" (abs (random))) (org-footnote-normalize-label (let ((propose (org-footnote-unique-label all))) (if (eq org-footnote-auto-label t) propose diff --git a/lisp/org/org-gnus.el b/lisp/org/org-gnus.el index 2cb2766ee19..15e95647a09 100644 --- a/lisp/org/org-gnus.el +++ b/lisp/org/org-gnus.el @@ -242,9 +242,7 @@ If `org-store-link' was called with a prefix arg the meaning of (_ (let ((articles 1) group-opened) - (while (and (not group-opened) - ;; Stop on integer overflows. - (> articles 0)) + (while (not group-opened) (setq group-opened (gnus-group-read-group articles t group)) (setq articles (if (< articles 16) (1+ articles) diff --git a/lisp/org/org-habit.el b/lisp/org/org-habit.el index 06429d7ff37..6234d0251e9 100644 --- a/lisp/org/org-habit.el +++ b/lisp/org/org-habit.el @@ -288,7 +288,7 @@ Habits are assigned colors on the following basis: (deadline (if scheduled-days (+ scheduled-days (- d-repeat s-repeat)) (org-habit-deadline habit))) - (m-days (or now-days (time-to-days (current-time))))) + (m-days (or now-days (time-to-days nil)))) (cond ((< m-days scheduled) '(org-habit-clear-face . org-habit-clear-future-face)) @@ -406,8 +406,7 @@ current time." "Insert consistency graph for any habitual tasks." (let ((inhibit-read-only t) (buffer-invisibility-spec '(org-link)) - (moment (time-subtract (current-time) - (list 0 (* 3600 org-extend-today-until) 0)))) + (moment (time-since (* 3600 org-extend-today-until)))) (save-excursion (goto-char (if line (point-at-bol) (point-min))) (while (not (eobp)) diff --git a/lisp/org/org-id.el b/lisp/org/org-id.el index 994aa7e3e83..44cc7b2f14d 100644 --- a/lisp/org/org-id.el +++ b/lisp/org/org-id.el @@ -83,8 +83,7 @@ (defcustom org-id-link-to-org-use-id nil "Non-nil means storing a link to an Org file will use entry IDs. -\\<org-mode-map>\ - +\\<org-mode-map> The variable can have the following values: t Create an ID if needed to make a link to the current entry. @@ -357,7 +356,7 @@ So a typical ID could look like \"Org:4nd91V40HI\"." "Return string with random (version 4) UUID." (let ((rnd (md5 (format "%s%s%s%s%s%s%s" (random) - (current-time) + (encode-time nil 'list) (user-uid) (emacs-pid) (user-full-name) @@ -416,7 +415,7 @@ The input I may be a character, or a single-letter string." "Encode TIME as a 10-digit string. This string holds the time to micro-second accuracy, and can be decoded using `org-id-decode'." - (setq time (or time (current-time))) + (setq time (encode-time time 'list)) (concat (org-id-int-to-b36 (nth 0 time) 4) (org-id-int-to-b36 (nth 1 time) 4) (org-id-int-to-b36 (or (nth 2 time) 0) 4))) diff --git a/lisp/org/org-indent.el b/lisp/org/org-indent.el index 71d6658a56f..97cf8786566 100644 --- a/lisp/org/org-indent.el +++ b/lisp/org/org-indent.el @@ -183,11 +183,15 @@ during idle time." org-hide-leading-stars) (setq-local org-hide-leading-stars t)) (org-indent--compute-prefixes) - (add-hook 'filter-buffer-substring-functions - (lambda (fun start end delete) - (org-indent-remove-properties-from-string - (funcall fun start end delete))) - nil t) + (if (boundp 'filter-buffer-substring-functions) + (add-hook 'filter-buffer-substring-functions + (lambda (fun start end delete) + (org-indent-remove-properties-from-string + (funcall fun start end delete))) + nil t) + ;; Emacs >= 24.4. + (add-function :filter-return (local 'filter-buffer-substring-function) + #'org-indent-remove-properties-from-string)) (add-hook 'after-change-functions 'org-indent-refresh-maybe nil 'local) (add-hook 'before-change-functions 'org-indent-notify-modified-headline nil 'local) @@ -211,10 +215,13 @@ during idle time." (when (boundp 'org-hide-leading-stars-before-indent-mode) (setq-local org-hide-leading-stars org-hide-leading-stars-before-indent-mode)) - (remove-hook 'filter-buffer-substring-functions - (lambda (fun start end delete) - (org-indent-remove-properties-from-string - (funcall fun start end delete)))) + (if (boundp 'filter-buffer-substring-functions) + (remove-hook 'filter-buffer-substring-functions + (lambda (fun start end delete) + (org-indent-remove-properties-from-string + (funcall fun start end delete)))) + (remove-function (local 'filter-buffer-substring-function) + #'org-indent-remove-properties-from-string)) (remove-hook 'after-change-functions 'org-indent-refresh-maybe 'local) (remove-hook 'before-change-functions 'org-indent-notify-modified-headline 'local) @@ -325,7 +332,7 @@ stopped." (let* ((case-fold-search t) (limited-re (org-get-limited-outline-regexp)) (level (or (org-current-level) 0)) - (time-limit (and delay (time-add (current-time) delay)))) + (time-limit (and delay (time-add nil delay)))) ;; For each line, set `line-prefix' and `wrap-prefix' ;; properties depending on the type of line (headline, inline ;; task, item or other). @@ -338,7 +345,7 @@ stopped." ;; In asynchronous mode, take a break of ;; `org-indent-agent-resume-delay' every DELAY to avoid ;; blocking any other idle timer or process output. - ((and delay (time-less-p time-limit (current-time))) + ((and delay (time-less-p time-limit nil)) (setq org-indent-agent-resume-timer (run-with-idle-timer (time-add (current-idle-time) org-indent-agent-resume-delay) diff --git a/lisp/org/org-list.el b/lisp/org/org-list.el index 96c8f55d3a5..22692d224a8 100644 --- a/lisp/org/org-list.el +++ b/lisp/org/org-list.el @@ -236,7 +236,7 @@ into (defcustom org-plain-list-ordered-item-terminator t "The character that makes a line with leading number an ordered list item. -Valid values are ?. and ?\). To get both terminators, use t. +Valid values are ?. and ?\\). To get both terminators, use t. This variable needs to be set before org.el is loaded. If you need to make a change while Emacs is running, use the customize @@ -2678,7 +2678,7 @@ Return t if successful." (error "Cannot outdent beyond margin") ;; Change bullet if necessary. (when (and (= (+ top-ind offset) 0) - (string-match "*" + (string-match "\\*" (org-list-get-bullet beg struct))) (org-list-set-bullet beg struct (org-list-bullet-string "-"))) diff --git a/lisp/org/org-macro.el b/lisp/org/org-macro.el index b2399966dc7..a151e1e8469 100644 --- a/lisp/org/org-macro.el +++ b/lisp/org/org-macro.el @@ -159,7 +159,8 @@ function installs the following ones: \"property\", (format "(eval (format-time-string \"$1\" (or (and (org-string-nw-p \"$2\") (org-macro--vc-modified-time %s)) '%s)))" (prin1-to-string visited-file) (prin1-to-string - (nth 5 (file-attributes visited-file))))))))) + (file-attribute-modification-time + (file-attributes visited-file))))))))) ;; Initialize and install "n" macro. (org-macro--counter-initialize) (funcall update-templates @@ -312,7 +313,7 @@ Return a list of arguments, as strings. This is the opposite of (buffer-substring (point) (line-end-position))))) (when (cl-some #'identity time) - (setq date (apply #'encode-time time)))))))) + (setq date (encode-time time)))))))) (let ((proc (get-buffer-process buf))) (while (and proc (accept-process-output proc .5 nil t))))) (kill-buffer buf)) diff --git a/lisp/org/org-macs.el b/lisp/org/org-macs.el index 9851168e970..3c768244331 100644 --- a/lisp/org/org-macs.el +++ b/lisp/org/org-macs.el @@ -31,6 +31,8 @@ ;;; Code: +(require 'cl-lib) + (defmacro org-with-gensyms (symbols &rest body) (declare (debug (sexp body)) (indent 1)) `(let ,(mapcar (lambda (s) diff --git a/lisp/org/org-mhe.el b/lisp/org/org-mhe.el index 969bff3cc64..a37c41ad06e 100644 --- a/lisp/org/org-mhe.el +++ b/lisp/org/org-mhe.el @@ -142,7 +142,7 @@ So if you use sequences, it will now work." "Return the name of the message folder in an index folder buffer." (save-excursion (mh-index-previous-folder) - (if (re-search-forward "^\\(+.*\\)$" nil t) + (if (re-search-forward "^\\(\\+.*\\)$" nil t) (message "%s" (match-string 1))))) (defun org-mhe-get-message-folder () diff --git a/lisp/org/org-mobile.el b/lisp/org/org-mobile.el index 1ff6358403c..a1552606eb5 100644 --- a/lisp/org/org-mobile.el +++ b/lisp/org/org-mobile.el @@ -472,7 +472,7 @@ agenda view showing the flagged items." (concat (shell-quote-argument org-mobile-checksum-binary) " " (shell-quote-argument (expand-file-name file))))) - (when (string-match "[a-fA-F0-9]\\{30,40\\}" check) + (when (string-match "[[:xdigit:]]\\{30,40\\}" check) (push (cons link-name (match-string 0 check)) org-mobile-checksum-files)))) @@ -761,7 +761,7 @@ If nothing new has been added, return nil." (buffer (find-file-noselect file))) (when buffer (with-current-buffer buffer - (when (re-search-forward (concat "\\([0-9a-fA-F]\\{30,\\}\\).*?" + (when (re-search-forward (concat "\\([[:xdigit:]]\\{30,\\}\\).*?" (regexp-quote org-mobile-capture-file) "[ \t]*$") nil t) (goto-char (match-beginning 1)) @@ -845,11 +845,11 @@ If BEG and END are given, only do this in that region." (cl-incf cnt-error) (throw 'next t)) (move-marker bos-marker (point)) - (if (re-search-forward "^** Old value[ \t]*$" eos t) + (if (re-search-forward "^\\** Old value[ \t]*$" eos t) (setq old (buffer-substring (1+ (match-end 0)) (progn (outline-next-heading) (point))))) - (if (re-search-forward "^** New value[ \t]*$" eos t) + (if (re-search-forward "^\\** New value[ \t]*$" eos t) (setq new (buffer-substring (1+ (match-end 0)) (progn (outline-next-heading) diff --git a/lisp/org/org-mouse.el b/lisp/org/org-mouse.el index ac75decb925..a3dcb77554c 100644 --- a/lisp/org/org-mouse.el +++ b/lisp/org/org-mouse.el @@ -643,7 +643,7 @@ This means, between the beginning of line and the point." ,@(org-mouse-list-options-menu (mapcar 'car org-startup-options) 'org-mode-restart)))) ((or (eolp) - (and (looking-at "\\( \\|\t\\)\\(+:[0-9a-zA-Z_:]+\\)?\\( \\|\t\\)+$") + (and (looking-at "\\( \\|\t\\)\\(\\+:[0-9a-zA-Z_:]+\\)?\\( \\|\t\\)+$") (looking-back " \\|\t" (- (point) 2) (line-beginning-position)))) (org-mouse-popup-global-menu)) diff --git a/lisp/org/org-pcomplete.el b/lisp/org/org-pcomplete.el index 7f944c5a765..cf272de90a8 100644 --- a/lisp/org/org-pcomplete.el +++ b/lisp/org/org-pcomplete.el @@ -49,10 +49,10 @@ "Examine the thing at point and let the caller know what it is. The return value is a string naming the thing at point." (let ((beg1 (save-excursion - (skip-chars-backward "[:alnum:]-_@") + (skip-chars-backward "-[:alnum:]_@") (point))) (beg (save-excursion - (skip-chars-backward "a-zA-Z0-9-_:$") + (skip-chars-backward "-a-zA-Z0-9_:$") (point))) (line-to-here (buffer-substring (point-at-bol) (point)))) (cond @@ -82,7 +82,7 @@ The return value is a string naming the thing at point." (not (equal (char-after (point-at-bol)) ?*)) (save-excursion (move-beginning-of-line 1) - (skip-chars-backward "[ \t\n]") + (skip-chars-backward " \t\n") ;; org-drawer-regexp matches a whole line but while ;; looking-back, we just ignore trailing whitespaces (or (looking-back (substring org-drawer-regexp 0 -1) @@ -194,7 +194,7 @@ When completing for #+STARTUP, for example, this function returns "Complete arguments for the #+LANGUAGE file option." (require 'ox) (pcomplete-here - (pcomplete-uniqify-list + (pcomplete-uniquify-list (list org-export-default-language "en")))) (defvar org-default-priority) @@ -219,7 +219,7 @@ When completing for #+STARTUP, for example, this function returns (defun pcomplete/org-mode/file-option/startup () "Complete arguments for the #+STARTUP file option." (while (pcomplete-here - (let ((opts (pcomplete-uniqify-list + (let ((opts (pcomplete-uniquify-list (mapcar 'car org-startup-options)))) ;; Some options are mutually exclusive, and shouldn't be completed ;; against if certain other options have already been seen. @@ -248,7 +248,7 @@ When completing for #+STARTUP, for example, this function returns (defun pcomplete/org-mode/file-option/options () "Complete arguments for the #+OPTIONS file option." (while (pcomplete-here - (pcomplete-uniqify-list + (pcomplete-uniquify-list (append ;; Hard-coded OPTION items always available. '("H:" "\\n:" "num:" "timestamp:" "arch:" "author:" "c:" @@ -267,7 +267,7 @@ When completing for #+STARTUP, for example, this function returns (defun pcomplete/org-mode/file-option/infojs_opt () "Complete arguments for the #+INFOJS_OPT file option." (while (pcomplete-here - (pcomplete-uniqify-list + (pcomplete-uniquify-list (mapcar (lambda (item) (format "%s:" (car item))) (bound-and-true-p org-html-infojs-opts-table)))))) @@ -283,7 +283,7 @@ When completing for #+STARTUP, for example, this function returns (defun pcomplete/org-mode/link () "Complete against defined #+LINK patterns." (pcomplete-here - (pcomplete-uniqify-list + (pcomplete-uniquify-list (copy-sequence (append (mapcar 'car org-link-abbrev-alist-local) (mapcar 'car org-link-abbrev-alist)))))) @@ -293,13 +293,13 @@ When completing for #+STARTUP, for example, this function returns "Complete against TeX-style HTML entity names." (require 'org-entities) (while (pcomplete-here - (pcomplete-uniqify-list (remove nil (mapcar 'car-safe org-entities))) + (pcomplete-uniquify-list (remove nil (mapcar 'car-safe org-entities))) (substring pcomplete-stub 1)))) (defvar org-todo-keywords-1) (defun pcomplete/org-mode/todo () "Complete against known TODO keywords." - (pcomplete-here (pcomplete-uniqify-list (copy-sequence org-todo-keywords-1)))) + (pcomplete-here (pcomplete-uniquify-list (copy-sequence org-todo-keywords-1)))) (defvar org-todo-line-regexp) (defun pcomplete/org-mode/searchhead () @@ -315,14 +315,14 @@ This needs more work, to handle headings with lots of spaces in them." (push (org-make-org-heading-search-string (match-string-no-properties 3)) tbl))) - (pcomplete-uniqify-list tbl))) + (pcomplete-uniquify-list tbl))) (substring pcomplete-stub 1)))) (defun pcomplete/org-mode/tag () "Complete a tag name. Omit tags already set." (while (pcomplete-here (mapcar (lambda (x) (concat x ":")) - (let ((lst (pcomplete-uniqify-list + (let ((lst (pcomplete-uniquify-list (or (remq nil (mapcar (lambda (x) (org-string-nw-p (car x))) @@ -339,7 +339,7 @@ This needs more work, to handle headings with lots of spaces in them." (pcomplete-here (mapcar (lambda (x) (concat x ": ")) - (let ((lst (pcomplete-uniqify-list + (let ((lst (pcomplete-uniquify-list (copy-sequence (org-buffer-property-keys nil t t t))))) (dolist (prop (org-entry-properties)) diff --git a/lisp/org/org-plot.el b/lisp/org/org-plot.el index aa34e4011ae..a5635e326d4 100644 --- a/lisp/org/org-plot.el +++ b/lisp/org/org-plot.el @@ -336,7 +336,7 @@ line directly before or after the table." (insert "\n") (insert-file-contents (plist-get params :script)) (goto-char (point-min)) - (while (re-search-forward "$datafile" nil t) + (while (re-search-forward "\\$datafile" nil t) (replace-match data-file nil nil))) (insert (org-plot/gnuplot-script data-file num-cols params))) ;; Graph table. diff --git a/lisp/org/org-protocol.el b/lisp/org/org-protocol.el index 3959a17cf4a..016105ef53b 100644 --- a/lisp/org/org-protocol.el +++ b/lisp/org/org-protocol.el @@ -331,7 +331,7 @@ returned list." (len 0) dir ret) - (when (string-match "^\\(.*\\)\\(org-protocol:/+[a-zA-z0-9][-_a-zA-z0-9]*:/+\\)\\(.*\\)" trigger) + (when (string-match "^\\(.*\\)\\(org-protocol:/+[a-zA-Z0-9][-_a-zA-Z0-9]*:/+\\)\\(.*\\)" trigger) (setq dir (match-string 1 trigger)) (setq len (length dir)) (setcar l (concat dir (match-string 3 trigger)))) @@ -349,17 +349,20 @@ returned list." ret) l))) -(defun org-protocol-flatten (list) - "Transform LIST into a flat list. +(defalias 'org-protocol-flatten + (if (fboundp 'flatten-tree) 'flatten-tree + (lambda (list) + "Transform LIST into a flat list. Greedy handlers might receive a list like this from emacsclient: \((\"/dir/org-protocol:/greedy:/~/path1\" (23 . 12)) (\"/dir/param\")) where \"/dir/\" is the absolute path to emacsclients working directory. This function transforms it into a flat list." - (if (null list) () - (if (listp list) - (append (org-protocol-flatten (car list)) (org-protocol-flatten (cdr list))) - (list list)))) + (if list + (if (consp list) + (append (org-protocol-flatten (car list)) + (org-protocol-flatten (cdr list))) + (list list)))))) (defun org-protocol-parse-parameters (info &optional new-style default-order) "Return a property list of parameters from INFO. diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el index 0a8382c8b56..513a534d9b5 100644 --- a/lisp/org/org-table.el +++ b/lisp/org/org-table.el @@ -155,7 +155,7 @@ table, obtained by prompting the user." :type 'string) (defcustom org-table-number-regexp - "^\\([<>]?[-+^.0-9]*[0-9][-+^.0-9eEdDx()%:]*\\|[<>]?[-+]?0[xX][0-9a-fA-F.]+\\|[<>]?[-+]?[0-9]+#[0-9a-zA-Z.]+\\|nan\\|[-+u]?inf\\)$" + "^\\([<>]?[-+^.0-9]*[0-9][-+^.0-9eEdDx()%:]*\\|[<>]?[-+]?0[xX][[:xdigit:].]+\\|[<>]?[-+]?[0-9]+#[0-9a-zA-Z.]+\\|nan\\|[-+u]?inf\\)$" "Regular expression for recognizing numbers in table columns. If a table column contains mostly numbers, it will be aligned to the right. If not, it will be aligned to the left. @@ -180,9 +180,9 @@ Other options offered by the customize interface are more restrictive." (const :tag "Exponential, Floating point, Integer" "^[-+]?[0-9.]+\\([eEdD][-+0-9]+\\)?$") (const :tag "Very General Number-Like, including hex and Calc radix" - "^\\([<>]?[-+^.0-9]*[0-9][-+^.0-9eEdDx()%]*\\|[<>]?[-+]?0[xX][0-9a-fA-F.]+\\|[<>]?[-+]?[0-9]+#[0-9a-zA-Z.]+\\|nan\\|[-+u]?inf\\)$") + "^\\([<>]?[-+^.0-9]*[0-9][-+^.0-9eEdDx()%]*\\|[<>]?[-+]?0[xX][[:xdigit:].]+\\|[<>]?[-+]?[0-9]+#[0-9a-zA-Z.]+\\|nan\\|[-+u]?inf\\)$") (const :tag "Very General Number-Like, including hex and Calc radix, allows comma as decimal mark" - "^\\([<>]?[-+^.,0-9]*[0-9][-+^.0-9eEdDx()%]*\\|[<>]?[-+]?0[xX][0-9a-fA-F.]+\\|[<>]?[-+]?[0-9]+#[0-9a-zA-Z.]+\\|nan\\|[-+u]?inf\\)$") + "^\\([<>]?[-+^.,0-9]*[0-9][-+^.0-9eEdDx()%]*\\|[<>]?[-+]?0[xX][[:xdigit:].]+\\|[<>]?[-+]?[0-9]+#[0-9a-zA-Z.]+\\|nan\\|[-+u]?inf\\)$") (string :tag "Regexp:"))) (defcustom org-table-number-fraction 0.5 @@ -484,8 +484,8 @@ Line numbers are counted from the beginning of the table. This variable is initialized with `org-table-analyze'.") (defconst org-table-range-regexp - "@\\([-+]?I*[-+]?[0-9]*\\)?\\(\\$[-+]?[0-9]+\\)?\\(\\.\\.@?\\([-+]?I*[-+]?[0-9]*\\)?\\(\\$[-+]?[0-9]+\\)?\\)?" - ;; 1 2 3 4 5 + "@\\([-+]?I*[-+]?[0-9]*\\)\\(\\$[-+]?[0-9]+\\)?\\(\\.\\.@?\\([-+]?I*[-+]?[0-9]*\\)\\(\\$[-+]?[0-9]+\\)?\\)?" + ;; 1 2 3 4 5 "Regular expression for matching ranges in formulas.") (defconst org-table-range-regexp2 @@ -1182,7 +1182,7 @@ to a number. In the case of a timestamp, increment by days." (- (org-time-string-to-absolute txt) (org-time-string-to-absolute txt-up))) ((string-match org-ts-regexp3 txt) 1) - ((string-match "\\([-+]\\)?\\(?:[0-9]+\\)?\\(?:\.[0-9]+\\)?" txt-up) + ((string-match "\\([-+]\\)?[0-9]*\\(?:\\.[0-9]+\\)?" txt-up) (- (string-to-number txt) (string-to-number (match-string 0 txt-up)))) (t 1))) @@ -2175,8 +2175,8 @@ If NLAST is a number, only the NLAST fields will actually be summed." (sres (if (= org-timecnt 0) (number-to-string res) (setq diff (* 3600 res) - h (floor (/ diff 3600)) diff (mod diff 3600) - m (floor (/ diff 60)) diff (mod diff 60) + h (floor diff 3600) diff (mod diff 3600) + m (floor diff 60) diff (mod diff 60) s diff) (format "%.0f:%02.0f:%02.0f" h m s)))) (kill-new sres) @@ -2307,7 +2307,7 @@ LOCATION instead." "\n")))) (defsubst org-table-formula-make-cmp-string (a) - (when (string-match "\\`$[<>]" a) + (when (string-match "\\`\\$[<>]" a) (let ((arrow (string-to-char (substring a 1)))) ;; Fake a high number to make sure this is sorted at the end. (setq a (org-table-formula-handle-first/last-rc a)) @@ -2355,7 +2355,7 @@ LOCATION is a buffer position, consider the formulas there." (cond ((not (match-end 2)) m) ;; Is it a column reference? - ((string-match-p "\\`$\\([0-9]+\\|[<>]+\\)\\'" m) m) + ((string-match-p "\\`\\$\\([0-9]+\\|[<>]+\\)\\'" m) m) ;; Since named columns are not possible in ;; LHS, assume this is a named field. (t (match-string 2 string))))) @@ -2909,8 +2909,8 @@ location of point." (format-time-string (org-time-stamp-format (string-match-p "[0-9]\\{1,2\\}:[0-9]\\{2\\}" ts)) - (apply #'encode-time - (save-match-data (org-parse-time-string ts)))))) + (encode-time + (save-match-data (org-parse-time-string ts)))))) form t t)) (setq ev (if (and duration (string-match "^[0-9]+:[0-9]+\\(?::[0-9]+\\)?$" form)) @@ -3216,7 +3216,7 @@ known that the table will be realigned a little later anyway." (cond ((string-match "\\`@-?I+" old-lhs) (user-error "Can't assign to hline relative reference")) - ((string-match "\\`$[<>]" old-lhs) + ((string-match "\\`\\$[<>]" old-lhs) (let ((new (org-table-formula-handle-first/last-rc old-lhs))) (when (assoc new eqlist) @@ -3639,7 +3639,8 @@ Parameters get priority." (setq startline (org-current-line)) (dolist (entry eql) (let* ((type (cond - ((string-match "\\`$\\([0-9]+\\|[<>]+\\)\\'" (car entry)) + ((string-match "\\`\\$\\([0-9]+\\|[<>]+\\)\\'" + (car entry)) 'column) ((equal (string-to-char (car entry)) ?@) 'field) (t 'named))) diff --git a/lisp/org/org-timer.el b/lisp/org/org-timer.el index bf17de4b03e..6529a8b0ddf 100644 --- a/lisp/org/org-timer.el +++ b/lisp/org/org-timer.el @@ -139,12 +139,7 @@ the region 0:00:00." (format "Restart timer with offset [%s]: " def))) (unless (string-match "\\S-" s) (setq s def)) (setq delta (org-timer-hms-to-secs (org-timer-fix-incomplete s))))) - (setq org-timer-start-time - (seconds-to-time - ;; Pass `current-time' result to `float-time' (instead - ;; of calling without arguments) so that only - ;; `current-time' has to be overridden in tests. - (- (float-time (current-time)) delta)))) + (setq org-timer-start-time (time-since delta))) (setq org-timer-pause-time nil) (org-timer-set-mode-line 'on) (message "Timer start time set to %s, current value is %s" @@ -167,14 +162,9 @@ With prefix arg STOP, stop it entirely." (setq org-timer-countdown-timer (org-timer--run-countdown-timer new-secs org-timer-countdown-timer-title)) - (setq org-timer-start-time - (time-add (current-time) (seconds-to-time new-secs)))) + (setq org-timer-start-time (time-add nil new-secs))) (setq org-timer-start-time - ;; Pass `current-time' result to `float-time' (instead - ;; of calling without arguments) so that only - ;; `current-time' has to be overridden in tests. - (seconds-to-time (- (float-time (current-time)) - (- pause-secs start-secs))))) + (time-since (- pause-secs start-secs)))) (setq org-timer-pause-time nil) (org-timer-set-mode-line 'on) (run-hooks 'org-timer-continue-hook) @@ -233,14 +223,9 @@ it in the buffer." (abs (floor (org-timer-seconds)))))) (defun org-timer-seconds () - ;; Pass `current-time' result to `float-time' (instead of calling - ;; without arguments) so that only `current-time' has to be - ;; overridden in tests. - (if org-timer-countdown-timer - (- (float-time org-timer-start-time) - (float-time (or org-timer-pause-time (current-time)))) - (- (float-time (or org-timer-pause-time (current-time))) - (float-time org-timer-start-time)))) + (let ((s (float-time (time-subtract org-timer-pause-time + org-timer-start-time)))) + (if org-timer-countdown-timer (- s) s))) ;;;###autoload (defun org-timer-change-times-in-region (beg end delta) @@ -400,7 +385,7 @@ VALUE can be `on', `off', or `paused'." (message "No timer set") (let* ((rtime (decode-time (time-subtract (timer--time org-timer-countdown-timer) - (current-time)))) + nil))) (rsecs (nth 0 rtime)) (rmins (nth 1 rtime))) (message "%d minute(s) %d seconds left before next time out" @@ -463,8 +448,7 @@ using three `C-u' prefix arguments." (org-timer--run-countdown-timer secs org-timer-countdown-timer-title)) (run-hooks 'org-timer-set-hook) - (setq org-timer-start-time - (time-add (current-time) (seconds-to-time secs))) + (setq org-timer-start-time (time-add nil secs)) (setq org-timer-pause-time nil) (org-timer-set-mode-line 'on)))))) diff --git a/lisp/org/org.el b/lisp/org/org.el index bce12956e23..5aa49b29d6f 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -4,7 +4,6 @@ ;; Copyright (C) 2004-2019 Free Software Foundation, Inc. ;; ;; Author: Carsten Dominik <carsten at orgmode dot org> -;; Maintainer: Carsten Dominik <carsten at orgmode dot org> ;; Keywords: outlines, hypermedia, calendar, wp ;; Homepage: https://orgmode.org ;; Version: 9.1.9 @@ -229,9 +228,10 @@ file to byte-code before it is loaded." (interactive "fFile to load: \nP") (let* ((age (lambda (file) (float-time - (time-subtract (current-time) - (nth 5 (or (file-attributes (file-truename file)) - (file-attributes file))))))) + (time-since + (file-attribute-modification-time + (or (file-attributes (file-truename file)) + (file-attributes file))))))) (base-name (file-name-sans-extension file)) (exported-file (concat base-name ".el"))) ;; tangle if the Org file is newer than the elisp file @@ -429,7 +429,7 @@ Matched keyword is in group 1.") (defconst org-deadline-time-hour-regexp (concat "\\<" org-deadline-string - " *<\\([^>]+[0-9]\\{1,2\\}:[0-9]\\{2\\}[0-9-+:hdwmy \t.]*\\)>") + " *<\\([^>]+[0-9]\\{1,2\\}:[0-9]\\{2\\}[0-9+:hdwmy \t.-]*\\)>") "Matches the DEADLINE keyword together with a time-and-hour stamp.") (defconst org-deadline-line-regexp @@ -445,7 +445,7 @@ Matched keyword is in group 1.") (defconst org-scheduled-time-hour-regexp (concat "\\<" org-scheduled-string - " *<\\([^>]+[0-9]\\{1,2\\}:[0-9]\\{2\\}[0-9-+:hdwmy \t.]*\\)>") + " *<\\([^>]+[0-9]\\{1,2\\}:[0-9]\\{2\\}[0-9+:hdwmy \t.-]*\\)>") "Matches the SCHEDULED keyword together with a time-and-hour stamp.") (defconst org-closed-time-regexp @@ -862,8 +862,7 @@ depends on, if any." (defcustom org-support-shift-select nil "Non-nil means make shift-cursor commands select text when possible. -\\<org-mode-map>\ - +\\<org-mode-map> In Emacs 23, when `shift-select-mode' is on, shifted cursor keys start selecting a region, or enlarge regions started in this way. In Org mode, in special contexts, these same keys are used for @@ -1071,6 +1070,8 @@ has been set." :group 'org-startup :type 'boolean) +(defvaralias 'org-CUA-compatible 'org-replace-disputed-keys) + (defcustom org-replace-disputed-keys nil "Non-nil means use alternative key bindings for some keys. Org mode uses S-<cursor> keys for changing timestamps and priorities. @@ -1095,8 +1096,6 @@ loading Org." :group 'org-startup :type 'boolean) -(defvaralias 'org-CUA-compatible 'org-replace-disputed-keys) - (defcustom org-disputed-keys '(([(shift up)] . [(meta p)]) ([(shift down)] . [(meta n)]) @@ -1490,6 +1489,8 @@ time in Emacs." :group 'org-edit-structure :type 'boolean) +(defvaralias 'org-special-ctrl-a 'org-special-ctrl-a/e) + (defcustom org-special-ctrl-a/e nil "Non-nil means `C-a' and `C-e' behave specially in headlines and items. @@ -1527,7 +1528,6 @@ This may also be a cons cell where the behavior for `C-a' and (const :tag "off" nil) (const :tag "on: before tags first" t) (const :tag "reversed: after tags first" reversed))))) -(defvaralias 'org-special-ctrl-a 'org-special-ctrl-a/e) (defcustom org-special-ctrl-k nil "Non-nil means `C-k' will behave specially in headlines. @@ -2257,8 +2257,7 @@ See `org-file-apps'.") ("\\.x?html?\\'" . default) ("\\.pdf\\'" . default)) "External applications for opening `file:path' items in a document. -\\<org-mode-map>\ - +\\<org-mode-map> Org mode uses system defaults for different file types, but you can use this variable to set the application for a given file extension. The entries in this list are cons cells where the car identifies @@ -3005,6 +3004,8 @@ because Agenda Log mode depends on the format of these entries." (unless (assq 'note org-log-note-headings) (push '(note . "%t") org-log-note-headings)) +(defvaralias 'org-log-state-notes-into-drawer 'org-log-into-drawer) + (defcustom org-log-into-drawer nil "Non-nil means insert state change notes and time stamps into a drawer. When nil, state changes notes will be inserted after the headline and @@ -3036,8 +3037,6 @@ function `org-log-into-drawer' instead." (const :tag "LOGBOOK" t) (string :tag "Other"))) -(defvaralias 'org-log-state-notes-into-drawer 'org-log-into-drawer) - (defun org-log-into-drawer () "Name of the log drawer, as a string, or nil. This is the value of `org-log-into-drawer'. However, if the @@ -3342,6 +3341,9 @@ This display will be in an overlay, in the minibuffer." :group 'org-time :type 'boolean) +(defvaralias 'org-popup-calendar-for-date-prompt + 'org-read-date-popup-calendar) + (defcustom org-read-date-popup-calendar t "Non-nil means pop up a calendar when prompting for a date. In the calendar, the date can be selected with mouse-1. However, the @@ -3349,8 +3351,6 @@ minibuffer will also be active, and you can simply enter the date as well. When nil, only the minibuffer will be available." :group 'org-time :type 'boolean) -(defvaralias 'org-popup-calendar-for-date-prompt - 'org-read-date-popup-calendar) (defcustom org-extend-today-until 0 "The hour when your day really ends. Must be an integer. @@ -3798,6 +3798,9 @@ regular expression will be included." :group 'org-agenda :type 'regexp) +(defvaralias 'org-agenda-multi-occur-extra-files + 'org-agenda-text-search-extra-files) + (defcustom org-agenda-text-search-extra-files nil "List of extra files to be searched by text search commands. These files will be searched in addition to the agenda files by the @@ -3815,9 +3818,6 @@ scope." (const :tag "Agenda Archives" agenda-archives) (repeat :inline t (file)))) -(defvaralias 'org-agenda-multi-occur-extra-files - 'org-agenda-text-search-extra-files) - (defcustom org-agenda-skip-unavailable-files nil "Non-nil means to just skip non-reachable files in `org-agenda-files'. A nil value means to remove them, after a query, from the list." @@ -5610,22 +5610,20 @@ When ROUNDING-MINUTES is not an integer, fall back on the car of the rounding returns a past time." (let ((r (or (and (integerp rounding-minutes) rounding-minutes) (car org-time-stamp-rounding-minutes))) - (time (decode-time)) res) + (now (current-time))) (if (< r 1) - (current-time) - (setq res - (apply 'encode-time - (append (list 0 (* r (floor (+ .5 (/ (float (nth 1 time)) r))))) - (nthcdr 2 time)))) - (if (and past (< (float-time (time-subtract (current-time) res)) 0)) - (seconds-to-time (- (float-time res) (* r 60))) - res)))) + now + (let* ((time (decode-time now)) + (res (apply #'encode-time 0 (* r (round (nth 1 time) r)) + (nthcdr 2 time)))) + (if (or (not past) (time-less-p res now)) + res + (time-subtract res (* r 60))))))) (defun org-today () "Return today date, considering `org-extend-today-until'." (time-to-days - (time-subtract (current-time) - (list 0 (* 3600 org-extend-today-until) 0)))) + (time-since (* 3600 org-extend-today-until)))) ;;;; Font-Lock stuff, including the activators @@ -9740,9 +9738,7 @@ active region." (setq link (format-time-string (car org-time-stamp-formats) - (apply 'encode-time - (list 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd) - nil nil nil)))) + (encode-time 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd)))) (org-store-link-props :type "calendar" :date cd))) ((eq major-mode 'help-mode) @@ -10056,7 +10052,7 @@ Note: this function also decodes single byte encodings like (cons 6 128)))) (when (>= val 192) (setq eat (car shift-xor))) (setq val (logxor val (cdr shift-xor))) - (setq sum (+ (lsh sum (car shift-xor)) val)) + (setq sum (+ (ash sum (car shift-xor)) val)) (when (> eat 0) (setq eat (- eat 1))) (cond ((= 0 eat) ;multi byte @@ -10468,7 +10464,7 @@ This is still an experimental function, your mileage may vary." ((and (equal type "lisp") (string-match "^/" path)) ;; Planner has a slash, we do not. (setq type "elisp" path (substring path 1))) - ((string-match "^//\\(.?*\\)/\\(<.*>\\)$" path) + ((string-match "^//\\(.*\\)/\\(<.*>\\)$" path) ;; A typical message link. Planner has the id after the final slash, ;; we separate it with a hash mark (setq path (concat (match-string 1 path) "#" @@ -11879,7 +11875,8 @@ prefix argument (`C-u C-u C-u C-c C-w')." (when (featurep 'org-inlinetask) (org-inlinetask-remove-END-maybe)) (setq org-markers-to-move nil) - (message (concat actionmsg " to \"%s\" in file %s: done") (car it) file))))))) + (message "%s to \"%s\" in file %s: done" actionmsg + (car it) file))))))) (defun org-refile-goto-last-stored () "Go to the location where the last refile was stored." @@ -13110,8 +13107,7 @@ This function is run automatically after each state change to a DONE state." (while (re-search-forward org-clock-line-re end t) (when (org-at-clock-log-p) (throw :clock t)))))) (org-entry-put nil "LAST_REPEAT" (format-time-string - (org-time-stamp-format t t) - (current-time)))) + (org-time-stamp-format t t)))) (when org-log-repeat (if (or (memq 'org-add-log-note (default-value 'post-command-hook)) (memq 'org-add-log-note post-command-hook)) @@ -13170,7 +13166,7 @@ has been set" (let ((nshiftmax 10) (nshift 0)) (while (or (= nshift 0) - (not (time-less-p (current-time) time))) + (not (time-less-p nil time))) (when (= (cl-incf nshift) nshiftmax) (or (y-or-n-p (format "%d repeater intervals were not \ @@ -13341,7 +13337,7 @@ for calling org-schedule with, or if there is no scheduling, returns nil." (let ((time (org-entry-get pom "SCHEDULED" inherit))) (when time - (apply 'encode-time (org-parse-time-string time))))) + (org-time-string-to-time time)))) (defun org-get-deadline-time (pom &optional inherit) "Get the deadline as a time tuple, of a format suitable for @@ -13349,7 +13345,7 @@ calling org-deadline with, or if there is no scheduling, returns nil." (let ((time (org-entry-get pom "DEADLINE" inherit))) (when time - (apply 'encode-time (org-parse-time-string time))))) + (org-time-string-to-time time)))) (defun org-remove-timestamp-with-keyword (keyword) "Remove all time stamps with KEYWORD in the current entry." @@ -13408,7 +13404,7 @@ WHAT entry will also be removed." org-deadline-time-regexp) end t) (setq ts (match-string 1) - default-time (apply 'encode-time (org-parse-time-string ts)) + default-time (org-time-string-to-time ts) default-input (and ts (org-get-compact-tod ts))))))) (when what (setq time @@ -14665,16 +14661,15 @@ it as a time string and apply `float-time' to it. If S is nil, just return 0." ((numberp s) s) ((stringp s) (condition-case nil - (float-time (apply #'encode-time (org-parse-time-string s))) - (error 0.))) - (t 0.))) + (float-time (org-time-string-to-time s)) + (error 0))) + (t 0))) (defun org-time-today () "Time in seconds today at 0:00. Returns the float number of seconds since the beginning of the epoch to the beginning of today (00:00)." - (float-time (apply 'encode-time - (append '(0 0 0) (nthcdr 3 (decode-time)))))) + (float-time (apply #'encode-time 0 0 0 (nthcdr 3 (decode-time))))) (defun org-matcher-time (s) "Interpret a time comparison value." @@ -14955,7 +14950,7 @@ When JUST-ALIGN is non-nil, only align tags." (unless (equal tags "") (let* ((level (save-excursion (beginning-of-line) - (skip-chars-forward "\\*"))) + (skip-chars-forward "*"))) (offset (if (bound-and-true-p org-indent-mode) (* (1- org-indent-indentation-per-level) (1- level)) @@ -16569,22 +16564,20 @@ non-nil." ((org-at-timestamp-p 'lax) (match-string 0)))) ;; Default time is either the timestamp at point or today. ;; When entering a range, only the range start is considered. - (default-time (if (not ts) (current-time) - (apply #'encode-time (org-parse-time-string ts)))) + (default-time (and ts (org-time-string-to-time ts))) (default-input (and ts (org-get-compact-tod ts))) (repeater (and ts (string-match "\\([.+-]+[0-9]+[hdwmy] ?\\)+" ts) (match-string 0 ts))) org-time-was-given org-end-time-was-given - (time - (and (if (equal arg '(16)) (current-time) + (time (if (equal arg '(16)) (current-time) ;; Preserve `this-command' and `last-command'. (let ((this-command this-command) (last-command last-command)) (org-read-date arg 'totime nil nil default-time default-input - inactive)))))) + inactive))))) (cond ((and ts (memq last-command '(org-time-stamp org-time-stamp-inactive)) @@ -16817,7 +16810,7 @@ user." (when (< (nth 2 org-defdecode) org-extend-today-until) (setf (nth 2 org-defdecode) -1) (setf (nth 1 org-defdecode) 59) - (setq org-def (apply #'encode-time org-defdecode)) + (setq org-def (encode-time org-defdecode)) (setq org-defdecode (decode-time org-def))) (let* ((timestr (format-time-string (if org-with-time "%Y-%m-%d %H:%M" "%Y-%m-%d") @@ -16890,13 +16883,14 @@ user." "range representable on this machine")) (ding)) - ;; One round trip to get rid of 34th of August and stuff like that.... - (setq final (decode-time (apply 'encode-time final))) + (setq final (apply #'encode-time final)) (setq org-read-date-final-answer ans) (if to-time - (apply 'encode-time final) + final + ;; This round-trip gets rid of 34th of August and stuff like that.... + (setq final (decode-time final)) (if (and (boundp 'org-time-was-given) org-time-was-given) (format "%04d-%02d-%02d %02d:%02d" (nth 5 final) (nth 4 final) (nth 3 final) @@ -16926,7 +16920,7 @@ user." (and (boundp 'org-time-was-given) org-time-was-given)) (cdr fmts) (car fmts))) - (txt (format-time-string fmt (apply 'encode-time f))) + (txt (format-time-string fmt (apply #'encode-time f))) (txt (if org-read-date-inactive (concat "[" (substring txt 1 -1) "]") txt)) (txt (concat "=> " txt))) (when (and org-end-time-was-given @@ -16957,7 +16951,7 @@ user." (when (string-match "\\`[ \t]*\\.[ \t]*\\'" ans) (setq ans "+0")) - (when (setq delta (org-read-date-get-relative ans (current-time) org-def)) + (when (setq delta (org-read-date-get-relative ans nil org-def)) (setq ans (replace-match "" t t ans) deltan (car delta) deltaw (nth 1 delta) @@ -17114,7 +17108,7 @@ user." ; (when (and org-read-date-prefer-future ; (not iso-year) ; (< (calendar-absolute-from-gregorian iso-date) - ; (time-to-days (current-time)))) + ; (time-to-days nil))) ; (setq year (1+ year) ; iso-date (calendar-gregorian-from-absolute ; (calendar-iso-to-absolute @@ -17293,7 +17287,7 @@ The command returns the inserted time stamp." time (org-fix-decoded-time t1) str (org-add-props (format-time-string - (substring tf 1 -1) (apply 'encode-time time)) + (substring tf 1 -1) (encode-time time)) nil 'mouse-face 'highlight)) (put-text-property beg end 'display str))) @@ -17308,7 +17302,7 @@ Don't touch the rest." If SECONDS is non-nil, return the difference in seconds." (let ((fdiff (if seconds #'float-time #'time-to-days))) (- (funcall fdiff (org-time-string-to-time timestamp-string)) - (funcall fdiff (current-time))))) + (funcall fdiff nil)))) (defun org-deadline-close-p (timestamp-string &optional ndays) "Is the time in TIMESTAMP-STRING close to the current date?" @@ -17490,10 +17484,8 @@ days in order to avoid rounding problems." (match-end (match-end 0)) (time1 (org-time-string-to-time ts1)) (time2 (org-time-string-to-time ts2)) - (t1 (float-time time1)) - (t2 (float-time time2)) - (diff (abs (- t2 t1))) - (negative (< (- t2 t1) 0)) + (diff (abs (float-time (time-subtract time2 time1)))) + (negative (time-less-p time2 time1)) ;; (ys (floor (* 365 24 60 60))) (ds (* 24 60 60)) (hs (* 60 60)) @@ -17504,14 +17496,14 @@ days in order to avoid rounding problems." (fh "%02d:%02d") y d h m align) (if havetime - (setq ; y (floor (/ diff ys)) diff (mod diff ys) + (setq ; y (floor diff ys) diff (mod diff ys) y 0 - d (floor (/ diff ds)) diff (mod diff ds) - h (floor (/ diff hs)) diff (mod diff hs) - m (floor (/ diff 60))) - (setq ; y (floor (/ diff ys)) diff (mod diff ys) + d (floor diff ds) diff (mod diff ds) + h (floor diff hs) diff (mod diff hs) + m (floor diff 60)) + (setq ; y (floor diff ys) diff (mod diff ys) y 0 - d (floor (+ (/ diff ds) 0.5)) + d (round diff ds) h 0 m 0)) (if (not to-buffer) (message "%s" (org-make-tdiff-string y d h m)) @@ -17550,7 +17542,7 @@ days in order to avoid rounding problems." (defun org-time-string-to-time (s) "Convert timestamp string S into internal time." - (apply #'encode-time (org-parse-time-string s))) + (encode-time (org-parse-time-string s))) (defun org-time-string-to-seconds (s) "Convert a timestamp string S into a number of seconds." @@ -17585,7 +17577,7 @@ signaled." (daynr (org-closest-date s daynr prefer)) (t (time-to-days (condition-case errdata - (apply #'encode-time (org-parse-time-string s)) + (org-time-string-to-time s) (error (error "Bad timestamp `%s'%s\nError was: %s" s (if (not (and buffer pos)) "" @@ -17602,7 +17594,7 @@ signaled." YEAR is expanded into one of the 30 next years, if possible, or into a past one. Any year larger than 99 is returned unchanged." (if (>= year 100) year - (let* ((current (string-to-number (format-time-string "%Y" (current-time)))) + (let* ((current (string-to-number (format-time-string "%Y"))) (century (/ current 100)) (offset (- year (% current 100)))) (cond ((> offset 30) (+ (* (1- century) 100) year)) @@ -17683,12 +17675,12 @@ stamp stay unchanged. In any case, return value is an absolute day number." (if (not (string-match "\\+\\([0-9]+\\)\\([hdwmy]\\)" start)) ;; No repeater. Do not shift time stamp. - (time-to-days (apply #'encode-time (org-parse-time-string start))) + (time-to-days (org-time-string-to-time start)) (let ((value (string-to-number (match-string 1 start))) (type (match-string 2 start))) (if (= 0 value) ;; Repeater with a 0-value is considered as void. - (time-to-days (apply #'encode-time (org-parse-time-string start))) + (time-to-days (org-time-string-to-time start)) (let* ((base (org-date-to-gregorian start)) (target (org-date-to-gregorian current)) (sday (calendar-absolute-from-gregorian base)) @@ -17793,7 +17785,7 @@ NODEFAULT, hour and minute fields will be nil if not given." ;; second argument. However, this requires at least Emacs ;; 25.1. We can do it when we switch to this version as our ;; minimal requirement. - (decode-time (seconds-to-time (org-matcher-time s)))) + (decode-time (encode-time (org-matcher-time s)))) (t (error "Not a standard Org time string: %s" s)))) (defun org-timestamp-up (&optional arg) @@ -17997,7 +17989,7 @@ When SUPPRESS-TMP-DELAY is non-nil, suppress delays like \"--2d\"." (setcar time0 (or (car time0) 0)) (setcar (nthcdr 1 time0) (or (nth 1 time0) 0)) (setcar (nthcdr 2 time0) (or (nth 2 time0) 0)) - (setq time (apply 'encode-time time0)))) + (setq time (encode-time time0)))) ;; Insert the new time-stamp, and ensure point stays in the same ;; category as before (i.e. not after the last position in that ;; category). @@ -18122,7 +18114,7 @@ A prefix ARG can be used to force the current date." diff) (when (or (org-at-timestamp-p 'lax) (org-match-line (concat ".*" org-ts-regexp))) - (let ((d1 (time-to-days (current-time))) + (let ((d1 (time-to-days nil)) (d2 (time-to-days (org-time-string-to-time (match-string 1))))) (setq diff (- d2 d1)))) (calendar) @@ -19324,6 +19316,9 @@ INCLUDE-LINKED is passed to `org-display-inline-images'." (org-toggle-inline-images) (org-toggle-inline-images))) +;; For without-x builds. +(declare-function image-refresh "image" (spec &optional frame)) + (defun org-display-inline-images (&optional include-linked refresh beg end) "Display inline images. @@ -20617,7 +20612,7 @@ this numeric value." (unless inc (setq inc 1)) (let ((pos (point)) (beg (skip-chars-backward "-+^/*0-9eE.")) - (end (skip-chars-forward "-+^/*0-9eE^.")) nap) + (end (skip-chars-forward "-+^/*0-9eE.")) nap) (setq nap (buffer-substring-no-properties (+ pos beg) (+ pos beg end))) (delete-region (+ pos beg) (+ pos beg end)) @@ -22376,7 +22371,9 @@ returned by, e.g., `current-time'." ;; (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) + (not (time-less-p (cl-subseq (file-attribute-modification-time + (file-attributes file)) + 0 2) (cl-subseq time 0 2))))) (defun org-compile-file (source process ext &optional err-msg log-buf spec) @@ -22837,9 +22834,9 @@ assumed to be significant there." (defun org-fill-line-break-nobreak-p () "Non-nil when a new line at point would create an Org line break." (save-excursion - (skip-chars-backward "[ \t]") + (skip-chars-backward " \t") (skip-chars-backward "\\\\") - (looking-at "\\\\\\\\\\($\\|[^\\\\]\\)"))) + (looking-at "\\\\\\\\\\($\\|[^\\]\\)"))) (defun org-fill-paragraph-with-timestamp-nobreak-p () "Non-nil when a new line at point would split a timestamp." @@ -22922,7 +22919,7 @@ matches in paragraphs or comments, use it." (match-string 0) ""))))))))))) -(declare-function message-goto-body "message" ()) +(declare-function message-goto-body "message" (&optional interactive)) (defvar message-cite-prefix-regexp) ; From message.el (defun org-fill-element (&optional justify) @@ -23381,13 +23378,12 @@ strictly within a source block, use appropriate comment syntax." (defun org-timestamp--to-internal-time (timestamp &optional end) "Encode TIMESTAMP object into Emacs internal time. Use end of date range or time range when END is non-nil." - (apply #'encode-time - (cons 0 - (mapcar - (lambda (prop) (or (org-element-property prop timestamp) 0)) - (if end '(:minute-end :hour-end :day-end :month-end :year-end) - '(:minute-start :hour-start :day-start :month-start - :year-start)))))) + (apply #'encode-time 0 + (mapcar + (lambda (prop) (or (org-element-property prop timestamp) 0)) + (if end '(:minute-end :hour-end :day-end :month-end :year-end) + '(:minute-start :hour-start :day-start :month-start + :year-start))))) (defun org-timestamp-has-time-p (timestamp) "Non-nil when TIMESTAMP has a time specified." diff --git a/lisp/org/ox-ascii.el b/lisp/org/ox-ascii.el index c20536184ea..7c9920f64c5 100644 --- a/lisp/org/ox-ascii.el +++ b/lisp/org/ox-ascii.el @@ -1474,8 +1474,8 @@ contextual information." (replace-regexp-in-string "-" "•" (replace-regexp-in-string - "+" "⁃" - (replace-regexp-in-string "*" "‣" bul)))))))) + "\\+" "⁃" + (replace-regexp-in-string "\\*" "‣" bul)))))))) (indentation (if (eq list-type 'descriptive) org-ascii-quote-margin (string-width bullet)))) (concat diff --git a/lisp/org/ox-html.el b/lisp/org/ox-html.el index b547c2181a5..1f98fcdd5cf 100644 --- a/lisp/org/ox-html.el +++ b/lisp/org/ox-html.el @@ -1935,7 +1935,8 @@ INFO is a plist used as a communication channel." (?c . ,(plist-get info :creator)) (?C . ,(let ((file (plist-get info :input-file))) (format-time-string timestamp-format - (and file (nth 5 (file-attributes file)))))) + (and file (file-attribute-modification-time + (file-attributes file)))))) (?v . ,(or (plist-get info :html-validation-link) ""))))) (defun org-html--build-pre/postamble (type info) diff --git a/lisp/org/ox-latex.el b/lisp/org/ox-latex.el index d3e62861499..d711530bf71 100644 --- a/lisp/org/ox-latex.el +++ b/lisp/org/ox-latex.el @@ -1613,7 +1613,7 @@ INFO is a plist used as a communication channel." (defun org-latex-clean-invalid-line-breaks (data _backend _info) (replace-regexp-in-string - "\\(\\end{[A-Za-z0-9*]+}\\|^\\)[ \t]*\\\\\\\\[ \t]*$" "\\1" + "\\(\\\\end{[A-Za-z0-9*]+}\\|^\\)[ \t]*\\\\\\\\[ \t]*$" "\\1" data)) diff --git a/lisp/org/ox-odt.el b/lisp/org/ox-odt.el index 71fd02541a7..8deb6bd51ab 100644 --- a/lisp/org/ox-odt.el +++ b/lisp/org/ox-odt.el @@ -2192,6 +2192,10 @@ SHORT-CAPTION are strings." (org-odt-create-manifest-file-entry media-type target-file) target-file)) +;; For --without-x builds. +(declare-function clear-image-cache "image.c" (&optional filter)) +(declare-function image-size "image.c" (spec &optional pixels frame)) + (defun org-odt--image-size (file info &optional user-width user-height scale dpi embed-as) (let* ((--pixels-to-cms diff --git a/lisp/org/ox-publish.el b/lisp/org/ox-publish.el index 9af50fdac44..9126647e7c3 100644 --- a/lisp/org/ox-publish.el +++ b/lisp/org/ox-publish.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2006-2019 Free Software Foundation, Inc. ;; Author: David O'Toole <dto@gnu.org> -;; Maintainer: Carsten Dominik <carsten DOT dominik AT gmail DOT com> +;; Maintainer: Carsten Dominik <carsten at orgmode dot org> ;; Keywords: hypermedia, outlines, wp ;; This file is part of GNU Emacs. @@ -793,13 +793,11 @@ Default for SITEMAP-FILENAME is `sitemap.org'." (not (string-lessp B A)))))) ((or `anti-chronologically `chronologically) (let* ((adate (org-publish-find-date a project)) - (bdate (org-publish-find-date b project)) - (A (+ (lsh (car adate) 16) (cadr adate))) - (B (+ (lsh (car bdate) 16) (cadr bdate)))) + (bdate (org-publish-find-date b project))) (setq retval - (if (eq sort-files 'chronologically) - (<= A B) - (>= A B))))) + (not (if (eq sort-files 'chronologically) + (time-less-p bdate adate) + (time-less-p adate bdate)))))) (`nil nil) (_ (user-error "Invalid sort value %s" sort-files))) ;; Directory-wise wins: @@ -879,7 +877,8 @@ If FILE is an Org file and provides a DATE keyword use it. In any other case use the file system's modification time. Return time in `current-time' format." (let ((file (org-publish--expand-file-name file project))) - (if (file-directory-p file) (nth 5 (file-attributes file)) + (if (file-directory-p file) (file-attribute-modification-time + (file-attributes file)) (let ((date (org-publish-find-property file :date project))) ;; DATE is a secondary string. If it contains a time-stamp, ;; convert it to internal format. Otherwise, use FILE @@ -889,7 +888,8 @@ time in `current-time' format." (let ((value (org-element-interpret-data ts))) (and (org-string-nw-p value) (org-time-string-to-time value)))))) - ((file-exists-p file) (nth 5 (file-attributes file))) + ((file-exists-p file) (file-attribute-modification-time + (file-attributes file))) (t (error "No such file: \"%s\"" file))))))) (defun org-publish-sitemap-default-entry (entry style project) @@ -1348,8 +1348,7 @@ does not exist." (expand-file-name (or (file-symlink-p file) file) (file-name-directory file))))) (if (not attr) (error "No such file: \"%s\"" file) - (+ (lsh (car (nth 5 attr)) 16) - (cadr (nth 5 attr)))))) + (encode-time (file-attribute-modification-time attr) 'integer)))) (provide 'ox-publish) diff --git a/lisp/org/ox.el b/lisp/org/ox.el index 6c278a1b7cf..58bc9b0ffb0 100644 --- a/lisp/org/ox.el +++ b/lisp/org/ox.el @@ -3252,7 +3252,7 @@ locally for the subtree through node properties." (let ((val (cond ((equal (car key) "DATE") (or (cdr key) (with-temp-buffer - (org-insert-time-stamp (current-time))))) + (org-insert-time-stamp nil)))) ((equal (car key) "TITLE") (or (let ((visited-file (buffer-file-name (buffer-base-buffer)))) @@ -3322,7 +3322,7 @@ storing and resolving footnotes. It is created automatically." (setq value (replace-match "" nil nil value))))) (lines (and (string-match - ":lines +\"\\(\\(?:[0-9]+\\)?-\\(?:[0-9]+\\)?\\)\"" + ":lines +\"\\([0-9]*-[0-9]*\\)\"" value) (prog1 (match-string 1 value) (setq value (replace-match "" nil nil value))))) diff --git a/lisp/outline.el b/lisp/outline.el index 0174dcb8e36..74df77b8be7 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -299,9 +299,6 @@ After that, changing the prefix key requires manipulating keymaps." ;;;###autoload (define-minor-mode outline-minor-mode "Toggle Outline minor mode. -With a prefix argument ARG, enable Outline minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. See the command `outline-mode' for more information on this mode." nil " Outl" (list (cons [menu-bar] outline-minor-mode-menu-bar-map) @@ -1100,28 +1097,26 @@ convenient way to make a table of contents of the buffer." (save-restriction (narrow-to-region beg end) (goto-char (point-min)) - (let ((buffer (current-buffer)) - start end) - (with-temp-buffer - (with-current-buffer buffer - ;; Boundary condition: starting on heading: - (when (outline-on-heading-p) - (outline-back-to-heading) - (setq start (point) - end (progn (outline-end-of-heading) - (point))) - (insert-buffer-substring buffer start end) - (insert "\n\n"))) - (let ((temp-buffer (current-buffer))) - (with-current-buffer buffer - (while (outline-next-heading) - (unless (outline-invisible-p) - (setq start (point) - end (progn (outline-end-of-heading) (point))) - (with-current-buffer temp-buffer - (insert-buffer-substring buffer start end) - (insert "\n\n")))))) - (kill-new (buffer-string))))))) + (let ((buffer (current-buffer)) start end) + (with-temp-buffer + (let ((temp-buffer (current-buffer))) + (with-current-buffer buffer + ;; Boundary condition: starting on heading: + (when (outline-on-heading-p) + (outline-back-to-heading) + (setq start (point) + end (progn (outline-end-of-heading) (point))) + (with-current-buffer temp-buffer + (insert-buffer-substring buffer start end) + (insert "\n\n"))) + (while (outline-next-heading) + (unless (outline-invisible-p) + (setq start (point) + end (progn (outline-end-of-heading) (point))) + (with-current-buffer temp-buffer + (insert-buffer-substring buffer start end) + (insert "\n\n")))))) + (kill-new (buffer-string))))))) (provide 'outline) (provide 'noutline) diff --git a/lisp/paren.el b/lisp/paren.el index b47bb033e20..c7d782a8a1d 100644 --- a/lisp/paren.el +++ b/lisp/paren.el @@ -1,4 +1,4 @@ -;;; paren.el --- highlight matching paren +;;; paren.el --- highlight matching paren -*- lexical-binding:t -*- ;; Copyright (C) 1993, 1996, 2001-2019 Free Software Foundation, Inc. @@ -100,9 +100,6 @@ its position." ;;;###autoload (define-minor-mode show-paren-mode "Toggle visualization of matching parens (Show Paren mode). -With a prefix argument ARG, enable Show Paren mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Show Paren mode is a global minor mode. When enabled, any matching parenthesis is highlighted in `show-paren-style' after @@ -176,7 +173,7 @@ if there's no opener/closer near point, or a list of the form Where HERE-BEG..HERE-END is expected to be near point.") (defun show-paren--default () - "Finds the opener/closer near point and its match. + "Find the opener/closer near point and its match. It is the default value of `show-paren-data-function'." (let* ((temp (show-paren--locate-near-paren)) diff --git a/lisp/password-cache.el b/lisp/password-cache.el index b868b720f00..5a09ae4859d 100644 --- a/lisp/password-cache.el +++ b/lisp/password-cache.el @@ -1,10 +1,10 @@ -;;; password-cache.el --- Read passwords, possibly using a password cache. +;;; password-cache.el --- Read passwords, possibly using a password cache. -*- lexical-binding: t -*- ;; Copyright (C) 1999-2000, 2003-2019 Free Software Foundation, Inc. ;; Author: Simon Josefsson <simon@josefsson.org> ;; Created: 2003-12-21 -;; Keywords: password cache passphrase key +;; Keywords: extensions ;; This file is part of GNU Emacs. diff --git a/lisp/pcmpl-cvs.el b/lisp/pcmpl-cvs.el index 4424af5c3d6..c90e00f8909 100644 --- a/lisp/pcmpl-cvs.el +++ b/lisp/pcmpl-cvs.el @@ -122,7 +122,7 @@ (let (cmds) (while (re-search-forward "^\\s-+\\([a-z]+\\)" nil t) (setq cmds (cons (match-string 1) cmds))) - (pcomplete-uniqify-list cmds)))) + (pcomplete-uniquify-list cmds)))) (defun pcmpl-cvs-modules () "Return a list of available modules under CVS." @@ -132,7 +132,7 @@ (let (entries) (while (re-search-forward "\\(\\S-+\\)$" nil t) (setq entries (cons (match-string 1) entries))) - (pcomplete-uniqify-list entries)))) + (pcomplete-uniquify-list entries)))) (defun pcmpl-cvs-tags (&optional opers) "Return all the tags which could apply to the files related to OPERS." @@ -149,7 +149,7 @@ (error "Error in output from `cvs status -v'")) (setq tags (cons (match-string 1) tags)) (forward-line)))) - (pcomplete-uniqify-list tags))) + (pcomplete-uniquify-list tags))) (defun pcmpl-cvs-entries (&optional opers) "Return the Entries for the current directory. @@ -187,6 +187,6 @@ operation character applies, as displayed by `cvs -n update'." (setq entries (cons text entries)))) (forward-line))))) (setq pcomplete-stub nondir) - (pcomplete-uniqify-list entries))) + (pcomplete-uniquify-list entries))) ;;; pcmpl-cvs.el ends here diff --git a/lisp/pcmpl-gnu.el b/lisp/pcmpl-gnu.el index 4e921ceeb59..391441bd79c 100644 --- a/lisp/pcmpl-gnu.el +++ b/lisp/pcmpl-gnu.el @@ -125,7 +125,7 @@ (while (re-search-forward (concat "^\\s-*\\([^\n#%.$][^:=\n]*\\)\\s-*:[^=]") nil t) (setq rules (append (split-string (match-string 1)) rules)))) - (pcomplete-uniqify-list rules)))) + (pcomplete-uniquify-list rules)))) (defcustom pcmpl-gnu-tarfile-regexp "\\.t\\(ar\\(\\.\\(gz\\|bz2\\|Z\\|xz\\)\\)?\\|gz\\|a[zZ]\\|z2\\)\\'" @@ -158,153 +158,151 @@ "Completion for the GNU tar utility." ;; options that end in an equal sign will want further completion... (let (saw-option complete-within) - (let ((pcomplete-suffix-list (if (boundp 'pcomplete-suffix-list) - (cons ?= pcomplete-suffix-list)))) - (while (pcomplete-match "^-" 0) - (setq saw-option t) - (if (pcomplete-match "^--" 0) - (if (pcomplete-match "^--\\([^= \t\n\f]*\\)\\'" 0) - ;; FIXME: Extract this list from "tar --help". - (pcomplete-here* - '("--absolute-names" - "--after-date=" - "--append" - "--atime-preserve" - "--backup" - "--block-number" - "--blocking-factor=" - "--catenate" - "--checkpoint" - "--compare" - "--compress" - "--concatenate" - "--confirmation" - "--create" - "--delete" - "--dereference" - "--diff" - "--directory=" - "--exclude=" - "--exclude-from=" - "--extract" - "--file=" - "--files-from=" - "--force-local" - "--get" - "--group=" - "--gzip" - "--help" - "--ignore-failed-read" - "--ignore-zeros" - "--incremental" - "--info-script=" - "--interactive" - "--keep-old-files" - "--label=" - "--list" - "--listed-incremental" - "--mode=" - "--modification-time" - "--multi-volume" - "--new-volume-script=" - "--newer=" - "--newer-mtime" - "--no-recursion" - "--null" - "--numeric-owner" - "--old-archive" - "--one-file-system" - "--owner=" - "--portability" - "--posix" - "--preserve" - "--preserve-order" - "--preserve-permissions" - "--read-full-records" - "--record-size=" - "--recursive-unlink" - "--remove-files" - "--rsh-command=" - "--same-order" - "--same-owner" - "--same-permissions" - "--sparse" - "--starting-file=" - "--suffix=" - "--tape-length=" - "--to-stdout" - "--totals" - "--uncompress" - "--ungzip" - "--unlink-first" - "--update" - "--use-compress-program=" - "--verbose" - "--verify" - "--version" - "--volno-file="))) - (pcomplete-opt "01234567ABCFGKLMNOPRSTUVWXZbcdfghiklmoprstuvwxz")) - (cond - ((pcomplete-match "\\`-\\'" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--after-date=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--backup=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--blocking-factor=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--directory=\\(.*\\)" 0) - (pcomplete-here* (pcomplete-dirs) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--exclude-from=\\(.*\\)" 0) - (pcomplete-here* (pcomplete-entries) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--exclude=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--\\(extract\\|list\\)\\'" 0) - (setq complete-within t)) - ((pcomplete-match "\\`--file=\\(.*\\)" 0) - (pcomplete-here* (pcomplete-dirs-or-entries pcmpl-gnu-tarfile-regexp) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--files-from=\\(.*\\)" 0) - (pcomplete-here* (pcomplete-entries) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--group=\\(.*\\)" 0) - (pcomplete-here* (pcmpl-unix-group-names) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--info-script=\\(.*\\)" 0) - (pcomplete-here* (pcomplete-entries) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--label=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--mode=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--new-volume-script=\\(.*\\)" 0) - (pcomplete-here* (pcomplete-entries) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--newer=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--owner=\\(.*\\)" 0) - (pcomplete-here* (pcmpl-unix-user-names) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--record-size=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--rsh-command=\\(.*\\)" 0) - (pcomplete-here* (funcall pcomplete-command-completion-function) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--starting-file=\\(.*\\)" 0) - (pcomplete-here* (pcomplete-entries) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--suffix=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--tape-length=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--use-compress-program=\\(.*\\)" 0) - (pcomplete-here* (funcall pcomplete-command-completion-function) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--volno-file=\\(.*\\)" 0) - (pcomplete-here* (pcomplete-entries) - (pcomplete-match-string 1 0)))))) + (while (pcomplete-match "^-" 0) + (setq saw-option t) + (if (pcomplete-match "^--" 0) + (if (pcomplete-match "^--\\([^= \t\n\f]*\\)\\'" 0) + ;; FIXME: Extract this list from "tar --help". + (pcomplete-here* + '("--absolute-names" + "--after-date=" + "--append" + "--atime-preserve" + "--backup" + "--block-number" + "--blocking-factor=" + "--catenate" + "--checkpoint" + "--compare" + "--compress" + "--concatenate" + "--confirmation" + "--create" + "--delete" + "--dereference" + "--diff" + "--directory=" + "--exclude=" + "--exclude-from=" + "--extract" + "--file=" + "--files-from=" + "--force-local" + "--get" + "--group=" + "--gzip" + "--help" + "--ignore-failed-read" + "--ignore-zeros" + "--incremental" + "--info-script=" + "--interactive" + "--keep-old-files" + "--label=" + "--list" + "--listed-incremental" + "--mode=" + "--modification-time" + "--multi-volume" + "--new-volume-script=" + "--newer=" + "--newer-mtime" + "--no-recursion" + "--null" + "--numeric-owner" + "--old-archive" + "--one-file-system" + "--owner=" + "--portability" + "--posix" + "--preserve" + "--preserve-order" + "--preserve-permissions" + "--read-full-records" + "--record-size=" + "--recursive-unlink" + "--remove-files" + "--rsh-command=" + "--same-order" + "--same-owner" + "--same-permissions" + "--sparse" + "--starting-file=" + "--suffix=" + "--tape-length=" + "--to-stdout" + "--totals" + "--uncompress" + "--ungzip" + "--unlink-first" + "--update" + "--use-compress-program=" + "--verbose" + "--verify" + "--version" + "--volno-file="))) + (pcomplete-opt "01234567ABCFGKLMNOPRSTUVWXZbcdfghiklmoprstuvwxz")) + (cond + ((pcomplete-match "\\`-\\'" 0) + (pcomplete-here*)) + ((pcomplete-match "\\`--after-date=" 0) + (pcomplete-here*)) + ((pcomplete-match "\\`--backup=" 0) + (pcomplete-here*)) + ((pcomplete-match "\\`--blocking-factor=" 0) + (pcomplete-here*)) + ((pcomplete-match "\\`--directory=\\(.*\\)" 0) + (pcomplete-here* (pcomplete-dirs) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--exclude-from=\\(.*\\)" 0) + (pcomplete-here* (pcomplete-entries) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--exclude=" 0) + (pcomplete-here*)) + ((pcomplete-match "\\`--\\(extract\\|list\\)\\'" 0) + (setq complete-within t)) + ((pcomplete-match "\\`--file=\\(.*\\)" 0) + (pcomplete-here* (pcomplete-dirs-or-entries pcmpl-gnu-tarfile-regexp) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--files-from=\\(.*\\)" 0) + (pcomplete-here* (pcomplete-entries) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--group=\\(.*\\)" 0) + (pcomplete-here* (pcmpl-unix-group-names) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--info-script=\\(.*\\)" 0) + (pcomplete-here* (pcomplete-entries) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--label=" 0) + (pcomplete-here*)) + ((pcomplete-match "\\`--mode=" 0) + (pcomplete-here*)) + ((pcomplete-match "\\`--new-volume-script=\\(.*\\)" 0) + (pcomplete-here* (pcomplete-entries) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--newer=" 0) + (pcomplete-here*)) + ((pcomplete-match "\\`--owner=\\(.*\\)" 0) + (pcomplete-here* (pcmpl-unix-user-names) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--record-size=" 0) + (pcomplete-here*)) + ((pcomplete-match "\\`--rsh-command=\\(.*\\)" 0) + (pcomplete-here* (funcall pcomplete-command-completion-function) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--starting-file=\\(.*\\)" 0) + (pcomplete-here* (pcomplete-entries) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--suffix=" 0) + (pcomplete-here*)) + ((pcomplete-match "\\`--tape-length=" 0) + (pcomplete-here*)) + ((pcomplete-match "\\`--use-compress-program=\\(.*\\)" 0) + (pcomplete-here* (funcall pcomplete-command-completion-function) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--volno-file=\\(.*\\)" 0) + (pcomplete-here* (pcomplete-entries) + (pcomplete-match-string 1 0))))) (unless saw-option (pcomplete-here (mapcar 'char-to-string @@ -316,7 +314,7 @@ (while (pcomplete-here (if (and complete-within (let* ((fa (file-attributes (pcomplete-arg 1))) - (size (nth 7 fa))) + (size (file-attribute-size fa))) (and (numberp size) (or (null large-file-warning-threshold) (< size large-file-warning-threshold))))) diff --git a/lisp/pcmpl-linux.el b/lisp/pcmpl-linux.el index f7d03d202d1..9121e78261e 100644 --- a/lisp/pcmpl-linux.el +++ b/lisp/pcmpl-linux.el @@ -43,7 +43,7 @@ "Completion for GNU/Linux `kill', using /proc filesystem." (if (pcomplete-match "^-\\(.*\\)" 0) (pcomplete-here - (pcomplete-uniqify-list + (pcomplete-uniquify-list (split-string (pcomplete-process-result "kill" "-l"))) (pcomplete-match-string 1 0))) @@ -82,7 +82,7 @@ (args (split-string line " "))) (setq points (cons (nth 1 args) points))) (forward-line))) - (pcomplete-uniqify-list points)))) + (pcomplete-uniquify-list points)))) (defun pcomplete-pare-list (l r) "Destructively remove from list L all elements matching any in list R. @@ -109,7 +109,7 @@ Test is done using `equal'." (setq points (cons (nth 1 args) points))) (forward-line))) (pcomplete-pare-list - (pcomplete-uniqify-list points) + (pcomplete-uniquify-list points) (cons "swap" (pcmpl-linux-mounted-directories)))))) ;;; pcmpl-linux.el ends here diff --git a/lisp/pcmpl-rpm.el b/lisp/pcmpl-rpm.el index 33525682405..213eac76e38 100644 --- a/lisp/pcmpl-rpm.el +++ b/lisp/pcmpl-rpm.el @@ -71,7 +71,8 @@ "Return a list of all installed rpm packages." (if (and pcmpl-rpm-cache pcmpl-rpm-cache-time - (let ((mtime (nth 5 (file-attributes pcmpl-rpm-cache-stamp-file)))) + (let ((mtime (file-attribute-modification-time + (file-attributes pcmpl-rpm-cache-stamp-file)))) (and mtime (not (time-less-p pcmpl-rpm-cache-time mtime))))) pcmpl-rpm-packages (message "Getting list of installed rpms...") @@ -96,7 +97,7 @@ (pcomplete-process-result "rpm" "-q" (car pkgs) flag))) (setq pkgs (cdr pkgs))) - (pcomplete-uniqify-list (cdr provs)))) + (pcomplete-uniquify-list (cdr provs)))) (defsubst pcmpl-rpm-files () (pcomplete-dirs-or-entries "\\.rpm\\'")) diff --git a/lisp/pcmpl-unix.el b/lisp/pcmpl-unix.el index 68203d20bf5..fa42809c592 100644 --- a/lisp/pcmpl-unix.el +++ b/lisp/pcmpl-unix.el @@ -111,7 +111,7 @@ documentation), this function returns nil." (point))) ":"))) (setq names (cons (nth 0 fields) names))) (forward-line)))) - (pcomplete-uniqify-list names))) + (pcomplete-uniquify-list names))) (defsubst pcmpl-unix-group-names () "Read the contents of /etc/group for group names." diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el index c5307de92e8..401e5aa1da5 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el @@ -272,6 +272,39 @@ to all arguments, such as variable names after a $." "Complete amongst a list of directories and executables." (pcomplete-entries regexp 'file-executable-p)) +(defmacro pcomplete-here (&optional form stub paring form-only) + "Complete against the current argument, if at the end. +If completion is to be done here, evaluate FORM to generate the completion +table which will be used for completion purposes. If STUB is a +string, use it as the completion stub instead of the default (which is +the entire text of the current argument). + +For an example of when you might want to use STUB: if the current +argument text is `long-path-name/', you don't want the completions +list display to be cluttered by `long-path-name/' appearing at the +beginning of every alternative. Not only does this make things less +intelligible, but it is also inefficient. Yet, if the completion list +does not begin with this string for every entry, the current argument +won't complete correctly. + +The solution is to specify a relative stub. It allows you to +substitute a different argument from the current argument, almost +always for the sake of efficiency. + +If PARING is nil, this argument will be pared against previous +arguments using the function `file-truename' to normalize them. +PARING may be a function, in which case that function is used for +normalization. If PARING is t, the argument dealt with by this +call will not participate in argument paring. If it is the +integer 0, all previous arguments that have been seen will be +cleared. + +If FORM-ONLY is non-nil, only the result of FORM will be used to +generate the completions list. This means that the hook +`pcomplete-try-first-hook' will not be run." + (declare (debug t)) + `(pcomplete--here (lambda () ,form) ,stub ,paring ,form-only)) + (defcustom pcomplete-command-completion-function (function (lambda () @@ -411,10 +444,28 @@ Same as `pcomplete' but using the standard completion UI." ;; table which expects strings using a prefix from the ;; buffer's text but internally uses the corresponding ;; prefix from pcomplete-stub. + ;; + (argbeg (pcomplete-begin)) + ;; When completing an envvar within an argument in Eshell + ;; (e.g. "cd /home/$US TAB"), `pcomplete-stub' will just be + ;; "US" whereas `argbeg' will point to the first "/". + ;; We could rely on c-t-subvert to handle the difference, + ;; but we try here to guess the "real" beginning so as to + ;; rely less on c-t-subvert. (beg (max (- (point) (length pcomplete-stub)) - (pcomplete-begin))) - (buftext (pcomplete-unquote-argument - (buffer-substring beg (point))))) + argbeg)) + buftext) + ;; Try and improve our guess of `beg' in case the difference + ;; between pcomplete-stub and the buffer's text is simply due to + ;; some chars removed by unquoting. Again, this is not + ;; indispensable but reduces the reliance on c-t-subvert and + ;; improves corner case behaviors. + (while (progn (setq buftext (pcomplete-unquote-argument + (buffer-substring beg (point)))) + (and (> beg argbeg) + (> (length pcomplete-stub) (length buftext)))) + (setq beg (max argbeg (- beg (- (length pcomplete-stub) + (length buftext)))))) (when completions (let ((table (completion-table-with-quoting @@ -735,7 +786,7 @@ this is `comint-dynamic-complete-functions'." (push (point) begins) (while (progn - (skip-chars-forward "^ \t\n\\") + (skip-chars-forward "^ \t\n\\\\") (when (eq (char-after) ?\\) (forward-char 1) (unless (eolp) @@ -950,7 +1001,7 @@ Arguments NO-GANGING and ARGS-FOLLOW are currently ignored." (function (lambda (opt) (concat "-" opt))) - (pcomplete-uniqify-list choices)))) + (pcomplete-uniquify-list choices)))) (let ((arg (pcomplete-arg))) (when (and (> (length arg) 1) (stringp arg) @@ -1014,39 +1065,6 @@ See the documentation for `pcomplete-here'." ;; byte-compiled with the older code. (eval form))))) -(defmacro pcomplete-here (&optional form stub paring form-only) - "Complete against the current argument, if at the end. -If completion is to be done here, evaluate FORM to generate the completion -table which will be used for completion purposes. If STUB is a -string, use it as the completion stub instead of the default (which is -the entire text of the current argument). - -For an example of when you might want to use STUB: if the current -argument text is `long-path-name/', you don't want the completions -list display to be cluttered by `long-path-name/' appearing at the -beginning of every alternative. Not only does this make things less -intelligible, but it is also inefficient. Yet, if the completion list -does not begin with this string for every entry, the current argument -won't complete correctly. - -The solution is to specify a relative stub. It allows you to -substitute a different argument from the current argument, almost -always for the sake of efficiency. - -If PARING is nil, this argument will be pared against previous -arguments using the function `file-truename' to normalize them. -PARING may be a function, in which case that function is used for -normalization. If PARING is t, the argument dealt with by this -call will not participate in argument paring. If it is the -integer 0, all previous arguments that have been seen will be -cleared. - -If FORM-ONLY is non-nil, only the result of FORM will be used to -generate the completions list. This means that the hook -`pcomplete-try-first-hook' will not be run." - (declare (debug t)) - `(pcomplete--here (lambda () ,form) ,stub ,paring ,form-only)) - (defmacro pcomplete-here* (&optional form stub form-only) "An alternate form which does not participate in argument paring." @@ -1066,18 +1084,10 @@ generate the completions list. This means that the hook (setq pcomplete-last-window-config nil pcomplete-window-restore-timer nil)) -;; Abstractions so that the code below will work for both Emacs 20 and -;; XEmacs 21 +(define-obsolete-function-alias 'pcomplete-event-matches-key-specifier-p + 'eq "27.1") -(defalias 'pcomplete-event-matches-key-specifier-p - (if (featurep 'xemacs) - 'event-matches-key-specifier-p - 'eq)) - -(defun pcomplete-read-event (&optional prompt) - (if (fboundp 'read-event) - (read-event prompt) - (aref (read-key-sequence prompt) 0))) +(define-obsolete-function-alias 'pcomplete-read-event 'read-event "27.1") (defun pcomplete-show-completions (completions) "List in help buffer sorted COMPLETIONS. @@ -1094,15 +1104,15 @@ Typing SPC flushes the help buffer." (prog1 (catch 'done (while (with-current-buffer (get-buffer "*Completions*") - (setq event (pcomplete-read-event))) + (setq event (read-event))) (cond - ((pcomplete-event-matches-key-specifier-p event ?\s) + ((eq event ?\s) (set-window-configuration pcomplete-last-window-config) (setq pcomplete-last-window-config nil) (throw 'done nil)) - ((or (pcomplete-event-matches-key-specifier-p event 'tab) + ((or (eq event 'tab) ;; Needed on a terminal - (pcomplete-event-matches-key-specifier-p event 9)) + (eq event 9)) (let ((win (or (get-buffer-window "*Completions*" 0) (display-buffer "*Completions*" 'not-this-window)))) @@ -1269,7 +1279,7 @@ If specific documentation can't be given, be generic." ;; general utilities -(defun pcomplete-uniqify-list (l) +(defun pcomplete-uniquify-list (l) "Sort and remove multiples in L." (setq l (sort l 'string-lessp)) (let ((m l)) @@ -1280,6 +1290,9 @@ If specific documentation can't be given, be generic." (setcdr m (cddr m))) (setq m (cdr m)))) l) +(define-obsolete-function-alias + 'pcomplete-uniqify-list + 'pcomplete-uniquify-list "27.1") (defun pcomplete-process-result (cmd &rest args) "Call CMD using `call-process' and return the simplest result." diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index 54d45b39890..dfd9a5ad5b3 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -97,18 +97,16 @@ When scrolling request is delivered soon after the previous one, user is in hurry. When the time since last scroll is larger than `pixel-dead-time', we are ready for another smooth scroll, and this function returns nil." - (let* ((current-time (float-time)) - (scroll-in-rush-p (< (- current-time pixel-last-scroll-time) - pixel-dead-time))) - (setq pixel-last-scroll-time current-time) + (let* ((now (current-time)) + (scroll-in-rush-p (time-less-p + (time-subtract now pixel-last-scroll-time) + pixel-dead-time))) + (setq pixel-last-scroll-time (float-time now)) scroll-in-rush-p)) ;;;###autoload (define-minor-mode pixel-scroll-mode - "A minor mode to scroll text pixel-by-pixel. -With a prefix argument ARG, enable Pixel Scroll mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable Pixel Scroll mode -if ARG is omitted or nil." + "A minor mode to scroll text pixel-by-pixel." :init-value nil :group 'scrolling :global t diff --git a/lisp/play/5x5.el b/lisp/play/5x5.el index e13a3c9a252..28748cc3514 100644 --- a/lisp/play/5x5.el +++ b/lisp/play/5x5.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. ;; Author: Dave Pearson <davep@davep.org> -;; Maintainer: Dave Pearson <davep@davep.org> ;; Created: 1998-10-03 ;; Keywords: games puzzles diff --git a/lisp/play/bubbles.el b/lisp/play/bubbles.el index 8d161775ffd..239fbe4e07c 100644 --- a/lisp/play/bubbles.el +++ b/lisp/play/bubbles.el @@ -1,4 +1,4 @@ -;;; bubbles.el --- Puzzle game for Emacs +;;; bubbles.el --- Puzzle game for Emacs -*- lexical-binding:t -*- ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. @@ -144,8 +144,7 @@ images the `ascii' theme will be used." (const :tag "Diamonds" diamonds) (const :tag "Balls" balls) (const :tag "Emacs" emacs) - (const :tag "ASCII (no images)" ascii)) - :group 'bubbles) + (const :tag "ASCII (no images)" ascii))) (defconst bubbles--grid-small '(10 . 10) "Predefined small bubbles grid.") @@ -168,8 +167,7 @@ images the `ascii' theme will be used." (const :tag "Huge" ,bubbles--grid-huge) (cons :tag "User defined" (integer :tag "Width") - (integer :tag "Height"))) - :group 'bubbles) + (integer :tag "Height")))) (defconst bubbles--colors-2 '("orange" "violet") "Predefined bubbles color list with two colors.") @@ -194,16 +192,14 @@ types are present." (const :tag "Red, darkgreen, blue, orange" ,bubbles--colors-4) (const :tag "Red, darkgreen, blue, orange, violet" ,bubbles--colors-5) - (repeat :tag "User defined" color)) - :group 'bubbles) + (repeat :tag "User defined" color))) (defcustom bubbles-chars '(?+ ?O ?# ?X ?. ?* ?& ?§) "Characters used for bubbles. Note that the actual number of different bubbles is determined by the number of colors, see `bubbles-colors'." - :type '(repeat character) - :group 'bubbles) + :type '(repeat character)) (defcustom bubbles-shift-mode 'default @@ -212,12 +208,10 @@ Available modes are `shift-default' and `shift-always'." :type '(radio (const :tag "Default" default) (const :tag "Shifter" always) ;;(const :tag "Mega Shifter" mega) - ) - :group 'bubbles) + )) (defcustom bubbles-mode-hook nil "Hook run by Bubbles mode." - :group 'bubbles :type 'hook) (defun bubbles-customize () @@ -718,57 +712,57 @@ static char * dot3d_xpm[] = { (defsubst bubbles--grid-width () "Return the grid width for the current game theme." (car (pcase bubbles-game-theme - (`easy + ('easy bubbles--grid-small) - (`medium + ('medium bubbles--grid-medium) - (`difficult + ('difficult bubbles--grid-large) - (`hard + ('hard bubbles--grid-huge) - (`user-defined + ('user-defined bubbles-grid-size)))) (defsubst bubbles--grid-height () "Return the grid height for the current game theme." (cdr (pcase bubbles-game-theme - (`easy + ('easy bubbles--grid-small) - (`medium + ('medium bubbles--grid-medium) - (`difficult + ('difficult bubbles--grid-large) - (`hard + ('hard bubbles--grid-huge) - (`user-defined + ('user-defined bubbles-grid-size)))) (defsubst bubbles--colors () "Return the color list for the current game theme." (pcase bubbles-game-theme - (`easy + ('easy bubbles--colors-2) - (`medium + ('medium bubbles--colors-3) - (`difficult + ('difficult bubbles--colors-4) - (`hard + ('hard bubbles--colors-5) - (`user-defined + ('user-defined bubbles-colors))) (defsubst bubbles--shift-mode () "Return the shift mode for the current game theme." (pcase bubbles-game-theme - (`easy + ('easy 'default) - (`medium + ('medium 'default) - (`difficult + ('difficult 'always) - (`hard + ('hard 'always) - (`user-defined + ('user-defined bubbles-shift-mode))) (defun bubbles-save-settings () @@ -898,7 +892,7 @@ static char * dot3d_xpm[] = { ;; bubbles mode map (defvar bubbles-mode-map (let ((map (make-sparse-keymap 'bubbles-mode-map))) -;; (suppress-keymap map t) + ;; (suppress-keymap map t) (define-key map "q" 'bubbles-quit) (define-key map "\n" 'bubbles-plop) (define-key map " " 'bubbles-plop) @@ -925,7 +919,7 @@ static char * dot3d_xpm[] = { (buffer-disable-undo) (force-mode-line-update) (redisplay) - (add-hook 'post-command-hook 'bubbles--mark-neighborhood t t)) + (add-hook 'post-command-hook #'bubbles--mark-neighborhood t t)) ;;;###autoload (defun bubbles () @@ -1004,14 +998,14 @@ Set `bubbles--col-offset' and `bubbles--row-offset'." (list bubbles--row-offset)))) (insert "\n") (let ((max-char (length (bubbles--colors)))) - (dotimes (i (bubbles--grid-height)) + (dotimes (_ (bubbles--grid-height)) (let ((p (point))) (insert " ") (put-text-property p (point) 'display (cons 'space (list :width (list bubbles--col-offset))))) - (dotimes (j (bubbles--grid-width)) + (dotimes (_ (bubbles--grid-width)) (let* ((index (random max-char)) (char (nth index bubbles-chars))) (insert char) @@ -1268,7 +1262,7 @@ Use optional parameter POS instead of point if given." (while (get-text-property (point) 'removed) (setq shifted-cols (1+ shifted-cols)) (bubbles--shift 'right (1- (bubbles--grid-height)) j)) - (dotimes (k shifted-cols) + (dotimes (_ shifted-cols) (let ((i (- (bubbles--grid-height) 2))) (while (>= i 0) (setq shifted (or (bubbles--shift 'right i j) @@ -1334,11 +1328,11 @@ Return t if new char is non-empty." (when (and (display-images-p) (not (eq bubbles-graphics-theme 'ascii))) (let ((template (pcase bubbles-graphics-theme - (`circles bubbles--image-template-circle) - (`balls bubbles--image-template-ball) - (`squares bubbles--image-template-square) - (`diamonds bubbles--image-template-diamond) - (`emacs bubbles--image-template-emacs)))) + ('circles bubbles--image-template-circle) + ('balls bubbles--image-template-ball) + ('squares bubbles--image-template-square) + ('diamonds bubbles--image-template-diamond) + ('emacs bubbles--image-template-emacs)))) (setq bubbles--empty-image (create-image (replace-regexp-in-string "^\"\\(.*\\)\t.*c .*\",$" @@ -1422,8 +1416,8 @@ Return t if new char is non-empty." (goto-char (point-min)) (forward-line 1) (let ((inhibit-read-only t)) - (dotimes (i (bubbles--grid-height)) - (dotimes (j (bubbles--grid-width)) + (dotimes (_ (bubbles--grid-height)) + (dotimes (_ (bubbles--grid-width)) (forward-char 1) (let ((index (or (get-text-property (point) 'index) -1))) (let ((img bubbles--empty-image)) diff --git a/lisp/play/cookie1.el b/lisp/play/cookie1.el index 165b86d037c..e461b37e362 100644 --- a/lisp/play/cookie1.el +++ b/lisp/play/cookie1.el @@ -125,7 +125,8 @@ and subsequent calls on the same file won't go to disk." (setq phrase-file (cookie-check-file phrase-file)) (let ((sym (intern-soft phrase-file cookie-cache))) (and sym (not (equal (symbol-function sym) - (nth 5 (file-attributes phrase-file)))) + (file-attribute-modification-time + (file-attributes phrase-file)))) (yes-or-no-p (concat phrase-file " has changed. Read new contents? ")) (setq sym nil)) @@ -133,7 +134,8 @@ and subsequent calls on the same file won't go to disk." (symbol-value sym) (setq sym (intern phrase-file cookie-cache)) (if startmsg (message "%s" startmsg)) - (fset sym (nth 5 (file-attributes phrase-file))) + (fset sym (file-attribute-modification-time + (file-attributes phrase-file))) (let (result) (with-temp-buffer (insert-file-contents (expand-file-name phrase-file)) diff --git a/lisp/play/dunnet.el b/lisp/play/dunnet.el index 49e2b877d4d..0a9ab37d198 100644 --- a/lisp/play/dunnet.el +++ b/lisp/play/dunnet.el @@ -2349,7 +2349,6 @@ for a moment, then straighten yourself up.\n") ;;;; This section sets up the keymaps for interactive and batch dunnet. ;;;; -(define-obsolete-variable-alias 'dungeon-mode-map 'dun-mode-map "22.1") (define-key dun-mode-map "\r" 'dun-parse) (defvar dungeon-batch-map (make-keymap)) (if (string= (substring emacs-version 0 2) "18") diff --git a/lisp/play/fortune.el b/lisp/play/fortune.el index 4488bb9c6ec..f4a529fb26c 100644 --- a/lisp/play/fortune.el +++ b/lisp/play/fortune.el @@ -237,21 +237,23 @@ read the file name to use. Otherwise use the value of `fortune-file'." If called with a prefix asks for the FILE to compile, otherwise uses the value of `fortune-file'. This currently cannot handle directories." (interactive - (list - (if current-prefix-arg - (fortune-ask-file) - fortune-file))) + (list + (if current-prefix-arg + (fortune-ask-file) + fortune-file))) (let* ((fortune-file (expand-file-name (substitute-in-file-name file))) (fortune-dat (expand-file-name (substitute-in-file-name - (concat fortune-file fortune-database-extension))))) - (cond ((file-exists-p fortune-file) - (cond ((file-newer-than-file-p fortune-file fortune-dat) - (message "Compiling new fortune database %s" fortune-dat) - (shell-command - (concat fortune-strfile fortune-strfile-options - " " fortune-file fortune-quiet-strfile-options))))) - (t (error "Can't compile fortune file %s" fortune-file))))) + (concat fortune-file fortune-database-extension)))) + (strfile (or (executable-find fortune-strfile) + (error "Can't find strfile program %s" fortune-strfile)))) + (cond ((file-exists-p fortune-file) + (cond ((file-newer-than-file-p fortune-file fortune-dat) + (message "Compiling new fortune database %s" fortune-dat) + (shell-command + (concat strfile fortune-strfile-options + " " fortune-file fortune-quiet-strfile-options))))) + (t (error "Can't compile fortune file %s" fortune-file))))) ;;; ************** @@ -313,6 +315,8 @@ Optional FILE is a fortune file from which a cookie will be selected." (with-temp-buffer (let ((fortune-buffer-name (current-buffer))) (fortune-in-buffer t file) + ;; Avoid trailing newline. + (if (bolp) (delete-char -1)) (message "%s" (buffer-string))))) ;;;###autoload diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el index 7999194207b..2d19c145b0a 100644 --- a/lisp/play/gamegrid.el +++ b/lisp/play/gamegrid.el @@ -1,4 +1,4 @@ -;;; gamegrid.el --- library for implementing grid-based games on Emacs +;;; gamegrid.el --- library for implementing grid-based games on Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1997-1998, 2001-2019 Free Software Foundation, Inc. @@ -86,66 +86,165 @@ directory will be used.") (defvar gamegrid-mono-x-face nil) (defvar gamegrid-mono-tty-face nil) -;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar gamegrid-glyph-height-mm 7.0 + "Desired glyph height in mm.") -(defconst gamegrid-glyph-height 16) +;; ;;;;;;;;;;;;; glyph generation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defconst gamegrid-xpm "\ +(defun gamegrid-calculate-glyph-size () + "Calculate appropriate glyph size in pixels based on display resolution. +Return a multiple of 8 no less than 16." + (if (and (display-pixel-height) (display-mm-height)) + (let* ((y-pitch (/ (display-pixel-height) (float (display-mm-height)))) + (pixels (* y-pitch gamegrid-glyph-height-mm)) + (rounded (* (floor (/ (+ pixels 4) 8)) 8))) + (max 16 rounded)) + 16)) + +;; Example of glyph in XPM format: +;; +;; /* XPM */ +;; static char *noname[] = { +;; /* width height ncolors chars_per_pixel */ +;; \"16 16 3 1\", +;; /* colors */ +;; \"+ s col1\", +;; \". s col2\", +;; \"- s col3\", +;; /* pixels */ +;; \"---------------+\", +;; \"--------------++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"-+++++++++++++++\", +;; \"++++++++++++++++\" +;; }; + +(defun gamegrid-xpm () + "Generate the XPM format image used for each square." + (let* ((glyph-pixel-count (gamegrid-calculate-glyph-size)) + (border-pixel-count (/ glyph-pixel-count 8)) + (center-pixel-count (- glyph-pixel-count (* border-pixel-count 2)))) + (with-temp-buffer + (insert (format "\ /* XPM */ static char *noname[] = { /* width height ncolors chars_per_pixel */ -\"16 16 3 1\", +\"%s %s 3 1\", /* colors */ \"+ s col1\", \". s col2\", \"- s col3\", /* pixels */ -\"---------------+\", -\"--------------++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"-+++++++++++++++\", -\"++++++++++++++++\" -}; -" - "XPM format image used for each square") - -(defvar gamegrid-xbm "\ +" glyph-pixel-count glyph-pixel-count)) + + (dotimes (row border-pixel-count) + (let ((edge-pixel-count (+ row 1))) + (insert "\"") + (dotimes (_ (- glyph-pixel-count edge-pixel-count)) (insert "-")) + (dotimes (_ edge-pixel-count) (insert "+")) + (insert "\",\n"))) + + (let ((middle (format "\"%s%s%s\",\n" + (make-string border-pixel-count ?-) + (make-string center-pixel-count ?.) + (make-string border-pixel-count ?+)))) + (dotimes (_ center-pixel-count) (insert middle))) + + (dotimes (row border-pixel-count) + (let ((edge-pixel-count (- border-pixel-count row 1))) + (insert "\"") + (dotimes (_ edge-pixel-count) (insert "-")) + (dotimes (_ (- glyph-pixel-count edge-pixel-count)) (insert "+")) + (insert "\"") + (if (/= row (1- border-pixel-count)) + (insert ",\n") + (insert "\n};\n")))) + (buffer-string)))) + +;; Example of glyph in XBM format: +;; +;; /* gamegrid XBM */ +;; #define gamegrid_width 16 +;; #define gamegrid_height 16 +;; static unsigned char gamegrid_bits[] = { +;; 0xff, 0xff, 0xff, 0x7f, 0xff, 0x3f, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, +;; 0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, +;; 0x57, 0x15, 0x07, 0x00, 0x03, 0x00, 0x01, 0x00 }; + +(defun gamegrid-xbm () + "Generate XBM format image used for each square." + (let* ((glyph-pixel-count (gamegrid-calculate-glyph-size)) + (border-pixel-count (1- (/ glyph-pixel-count 4))) + (center-pixel-count (- glyph-pixel-count (* 2 border-pixel-count)))) + (with-temp-buffer + (insert (format "\ /* gamegrid XBM */ -#define gamegrid_width 16 -#define gamegrid_height 16 +#define gamegrid_width %s +#define gamegrid_height %s static unsigned char gamegrid_bits[] = { - 0xff, 0xff, 0xff, 0x7f, 0xff, 0x3f, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, - 0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, - 0x57, 0x15, 0x07, 0x00, 0x03, 0x00, 0x01, 0x00 };" - "XBM format image used for each square.") +" glyph-pixel-count glyph-pixel-count)) + (dotimes (row border-pixel-count) + (gamegrid-insert-xbm-bits + (concat (make-string (- glyph-pixel-count row) ?1) + (make-string row ?0))) + (insert ", \n")) + + (let* ((left-border (make-string border-pixel-count ?1)) + (right-border (make-string border-pixel-count ?0)) + (even-line (apply 'concat + (append (list left-border) + (make-list (/ center-pixel-count 2) "10") + (list right-border)))) + (odd-line (apply 'concat + (append (list left-border) + (make-list (/ center-pixel-count 2) "01") + (list right-border))))) + (dotimes (row center-pixel-count) + (gamegrid-insert-xbm-bits (if (eq (logand row 1) 1) odd-line even-line)) + (insert ", \n"))) + + (dotimes (row border-pixel-count) + (let ((edge-pixel-count (- border-pixel-count row))) + (gamegrid-insert-xbm-bits + (concat (make-string edge-pixel-count ?1) + (make-string (- glyph-pixel-count edge-pixel-count) ?0)))) + (if (/= row (1- border-pixel-count)) + (insert ", \n") + (insert " };\n"))) + (buffer-string)))) + +(defun gamegrid-insert-xbm-bits (str) + "Convert binary to hex and insert in current buffer. +STR should be a string composed of 1s and 0s and be a multiple of +8 in length. Divide it into 8 bit bytes, reverse the order of +each, convert them to hex and insert them in comma separated C +format." + (let ((byte-count (/ (length str) 8))) + (dotimes (i byte-count) + (let* ((byte (reverse (substring str (* i 8) (+ (* i 8) 8)))) + (value (string-to-number byte 2))) + (insert (format "0x%02x" value)) + (unless (= i (1- byte-count)) + (insert ", ")))))) ;; ;;;;;;;;;;;;;;;; miscellaneous functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defsubst gamegrid-characterp (arg) - (if (fboundp 'characterp) - (characterp arg) - (integerp arg))) - (defsubst gamegrid-event-x (event) - (if (fboundp 'event-x) - (event-x event) - (car (posn-col-row (event-end event))))) + (car (posn-col-row (event-end event)))) (defsubst gamegrid-event-y (event) - (if (fboundp 'event-y) - (event-y event) - (cdr (posn-col-row (event-end event))))) + (cdr (posn-col-row (event-end event)))) ;; ;;;;;;;;;;;;; display functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -210,31 +309,31 @@ static unsigned char gamegrid_bits[] = { (let ((data (gamegrid-match-spec-list data-spec-list)) (color (gamegrid-match-spec-list color-spec-list))) (pcase data - (`color-x + ('color-x (gamegrid-make-color-x-face color)) - (`grid-x + ('grid-x (unless gamegrid-grid-x-face (setq gamegrid-grid-x-face (gamegrid-make-grid-x-face))) gamegrid-grid-x-face) - (`mono-x + ('mono-x (unless gamegrid-mono-x-face (setq gamegrid-mono-x-face (gamegrid-make-mono-x-face))) gamegrid-mono-x-face) - (`color-tty + ('color-tty (gamegrid-make-color-tty-face color)) - (`mono-tty + ('mono-tty (unless gamegrid-mono-tty-face (setq gamegrid-mono-tty-face (gamegrid-make-mono-tty-face))) gamegrid-mono-tty-face)))) (defun gamegrid-colorize-glyph (color) - (find-image `((:type xpm :data ,gamegrid-xpm + (find-image `((:type xpm :data ,(gamegrid-xpm) :ascent center :color-symbols (("col1" . ,(gamegrid-color color 0.6)) ("col2" . ,(gamegrid-color color 0.8)) ("col3" . ,(gamegrid-color color 1.0)))) - (:type xbm :data ,gamegrid-xbm + (:type xbm :data ,(gamegrid-xbm) :ascent center :foreground ,(gamegrid-color color 1.0) :background ,(gamegrid-color color 0.5))))) @@ -257,7 +356,7 @@ static unsigned char gamegrid_bits[] = { (defun gamegrid-make-glyph (data-spec-list color-spec-list) (let ((data (gamegrid-match-spec-list data-spec-list)) (color (gamegrid-match-spec-list color-spec-list))) - (cond ((gamegrid-characterp data) + (cond ((characterp data) (vector data)) ((eq data 'colorize) (gamegrid-colorize-glyph color)) @@ -291,15 +390,6 @@ static unsigned char gamegrid_bits[] = { (t 'emacs-tty))) -(defun gamegrid-set-display-table () - (if (featurep 'xemacs) - (add-spec-to-specifier current-display-table - gamegrid-display-table - (current-buffer) - nil - 'remove-locale) - (setq buffer-display-table gamegrid-display-table))) - (declare-function image-size "image.c" (spec &optional pixels frame)) (defun gamegrid-setup-default-font () @@ -336,7 +426,7 @@ static unsigned char gamegrid_bits[] = { (aset gamegrid-face-table c face) (aset gamegrid-display-table c glyph))) (gamegrid-setup-default-font) - (gamegrid-set-display-table) + (setq buffer-display-table gamegrid-display-table) (setq cursor-type nil)) @@ -376,7 +466,7 @@ static unsigned char gamegrid_bits[] = { (buffer-read-only nil)) (erase-buffer) (setq gamegrid-buffer-start (point)) - (dotimes (i height) + (dotimes (_ height) (insert line)) ;; Adjust the height of the default face to the height of the ;; images. Unlike XEmacs, Emacs doesn't allow making the default @@ -398,34 +488,19 @@ static unsigned char gamegrid_bits[] = { (defun gamegrid-start-timer (period func) (setq gamegrid-timer - (if (featurep 'xemacs) - (start-itimer "Gamegrid" - func - period - period - nil - t - (current-buffer)) - (run-with-timer period - period - func - (current-buffer))))) + (run-with-timer period period func (current-buffer)))) (defun gamegrid-set-timer (delay) (if gamegrid-timer - (if (fboundp 'set-itimer-restart) - (set-itimer-restart gamegrid-timer delay) - (timer-set-time gamegrid-timer - (list (aref gamegrid-timer 1) - (aref gamegrid-timer 2) - (aref gamegrid-timer 3)) - delay)))) + (timer-set-time gamegrid-timer + (list (aref gamegrid-timer 1) + (aref gamegrid-timer 2) + (aref gamegrid-timer 3)) + delay))) (defun gamegrid-kill-timer () (if gamegrid-timer - (if (featurep 'xemacs) - (delete-itimer gamegrid-timer) - (cancel-timer gamegrid-timer))) + (cancel-timer gamegrid-timer)) (setq gamegrid-timer nil)) ;; ;;;;;;;;;;;;;;; high score functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -449,7 +524,7 @@ On non-POSIX systems Emacs searches for FILE in the directory specified by the variable `temporary-file-directory'. If necessary, FILE is created there." (pcase system-type - ((or `ms-dos `windows-nt) + ((or 'ms-dos 'windows-nt) (gamegrid-add-score-insecure file score)) (_ (gamegrid-add-score-with-update-game-score file score)))) @@ -457,8 +532,8 @@ FILE is created there." ;; On POSIX systems there are four cases to distinguish: -;; 1. FILE is an absolute filename. Then it should be a file in -;; temporary file directory. This is the way, +;; 1. FILE is an absolute filename or "update-game-score" does not exist. +;; Then FILE should be a file in a temporary file directory. This is how ;; `gamegrid-add-score' was supposed to be used in the past and ;; is covered here for backward-compatibility. ;; @@ -475,21 +550,18 @@ FILE is created there." ;; update FILE. This is for the case that a user has installed ;; a game on her own. ;; -;; 4. "update-game-score" does not exist or is not setgid/setuid. -;; Create/update FILE in the user's home directory, without -;; using "update-game-score". There is presumably no shared -;; game directory. +;; 4. "update-game-score" is not setgid/setuid. Use it to +;; create/update FILE in the user's home directory. There is +;; presumably no shared game directory. (defvar gamegrid-shared-game-dir) (defun gamegrid-add-score-with-update-game-score (file score) - (let ((gamegrid-shared-game-dir - (not (zerop (logand (or (file-modes - (expand-file-name "update-game-score" - exec-directory)) - 0) - #o6000))))) - (cond ((file-name-absolute-p file) + (let* ((update-game-score-modes + (file-modes (expand-file-name "update-game-score" exec-directory))) + (gamegrid-shared-game-dir + (not (zerop (logand #o6000 (or update-game-score-modes 0)))))) + (cond ((or (not update-game-score-modes) (file-name-absolute-p file)) (gamegrid-add-score-insecure file score)) ((and gamegrid-shared-game-dir (file-exists-p (expand-file-name file shared-game-score-directory))) @@ -499,25 +571,30 @@ FILE is created there." (expand-file-name file shared-game-score-directory) score)) ;; Else: Add the score to a score file in the user's home ;; directory. - (t + (gamegrid-shared-game-dir + ;; If gamegrid-shared-game-dir is non-nil the + ;; "update-gamescore" program is setuid, so don't use it. (unless (file-exists-p (directory-file-name gamegrid-user-score-file-directory)) (make-directory gamegrid-user-score-file-directory t)) (gamegrid-add-score-insecure file score - gamegrid-user-score-file-directory))))) + gamegrid-user-score-file-directory)) + (t + (unless (file-exists-p + (directory-file-name gamegrid-user-score-file-directory)) + (make-directory gamegrid-user-score-file-directory t)) + (let ((f (expand-file-name file + gamegrid-user-score-file-directory))) + (unless (file-exists-p f) + (write-region "" nil f nil 'silent nil 'excl)) + (gamegrid-add-score-with-update-game-score-1 file f score)))))) (defun gamegrid-add-score-with-update-game-score-1 (file target score) (let ((default-directory "/") (errbuf (generate-new-buffer " *update-game-score loss*")) (marker-string (concat (user-full-name) - " <" - (cond ((fboundp 'user-mail-address) - (user-mail-address)) - ((boundp 'user-mail-address) - user-mail-address) - (t "")) - "> " + " <" user-mail-address "> " (current-time-string)))) ;; This can be called from a timer, so enable local quits. (with-local-quit @@ -547,6 +624,7 @@ FILE is created there." (revert-buffer nil t nil) (display-buffer buf)) (find-file-read-only target)) + (view-mode) (goto-char (point-min)) (search-forward (concat (int-to-string score) " " (user-login-name) " " @@ -564,18 +642,15 @@ FILE is created there." score (current-time-string) (user-full-name) - (cond ((fboundp 'user-mail-address) - (user-mail-address)) - ((boundp 'user-mail-address) - user-mail-address) - (t "")))) + user-mail-address)) (sort-fields 1 (point-min) (point-max)) (reverse-region (point-min) (point-max)) (goto-char (point-min)) (forward-line gamegrid-score-file-length) (delete-region (point) (point-max)) (setq buffer-read-only t) - (save-buffer))) + (save-buffer) + (view-mode))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/lisp/play/gametree.el b/lisp/play/gametree.el index d92914d9118..c0226c85ce1 100644 --- a/lisp/play/gametree.el +++ b/lisp/play/gametree.el @@ -586,8 +586,7 @@ shogi, etc.) players, it is a slightly modified version of Outline mode. \\{gametree-mode-map}" (auto-fill-mode 0) - (make-local-variable 'write-contents-hooks) - (add-hook 'write-contents-hooks 'gametree-save-and-hack-layout)) + (add-hook 'write-contents-functions 'gametree-save-and-hack-layout nil t)) ;;;; Goodies for mousing users (defun gametree-mouse-break-line-here (event) diff --git a/lisp/play/gomoku.el b/lisp/play/gomoku.el index b16938a56d0..6d5553b3202 100644 --- a/lisp/play/gomoku.el +++ b/lisp/play/gomoku.el @@ -656,48 +656,48 @@ that DVAL has been added on SQUARE." ((eq result 'emacs-won) (setq gomoku-number-of-emacs-wins (1+ gomoku-number-of-emacs-wins)) (cond ((< gomoku-number-of-moves 20) - "This was a REALLY QUICK win.") + "I won... I hope you like the game as you get better.") (gomoku-human-refused-draw "I won... Too bad you refused my offer of a draw!") (gomoku-human-took-back - "I won... Taking moves back will not help you!") + "I won... It's OK to take back more moves next time.") ((not gomoku-emacs-played-first) - "I won... Playing first did not help you much!") + "I won... Use C-c C-b to take back a move on second thought.") ((and (zerop gomoku-number-of-human-wins) (zerop gomoku-number-of-draws) (> gomoku-number-of-emacs-wins 1)) - "I'm becoming tired of winning...") + "I won... It might be time take a break before trying again.") ("I won."))) ((eq result 'human-won) (setq gomoku-number-of-human-wins (1+ gomoku-number-of-human-wins)) (concat "OK, you won this one." (cond (gomoku-human-took-back - " I, for one, never take my moves back...") + " For a bigger challenge, play without taking moves back.") (gomoku-emacs-played-first - ".. so what?") - (" Now, let me play first just once.")))) + " Congratulations!") + (" For a bigger challenge, let me play first.")))) ((eq result 'human-resigned) (setq gomoku-number-of-emacs-wins (1+ gomoku-number-of-emacs-wins)) - "So you resign. That's just one more win for me.") + "I see that you resigned. Better luck next time.") ((eq result 'nobody-won) (setq gomoku-number-of-draws (1+ gomoku-number-of-draws)) (concat "This is a draw. " (cond (gomoku-human-took-back - "I, for one, never take my moves back...") + " For a bigger challenge, try without taking moves back.") (gomoku-emacs-played-first - "Just chance, I guess.") - ("Now, let me play first just once.")))) + "Wow, that was a long game. We both played well.") + (" For a bigger challenge, let me play first.")))) ((eq result 'draw-agreed) (setq gomoku-number-of-draws (1+ gomoku-number-of-draws)) (concat "Draw agreed. " (cond (gomoku-human-took-back - "I, for one, never take my moves back...") + " For a bigger challenge, try without taking moves back.") (gomoku-emacs-played-first - "You were lucky.") - ("Now, let me play first just once.")))) + "Good game.") + (" For a bigger challenge, let me play first.")))) ((eq result 'crash-game) "Sorry, I have been interrupted and cannot resume that game..."))) (gomoku-display-statistics) diff --git a/lisp/play/hanoi.el b/lisp/play/hanoi.el index 635e4a95bc3..d762290f0da 100644 --- a/lisp/play/hanoi.el +++ b/lisp/play/hanoi.el @@ -381,7 +381,7 @@ BITS must be of length nrings. Start at START-TIME." (cl-loop for elapsed = (- (float-time) start-time) while (< elapsed hanoi-move-period) with tick-period = (/ (float hanoi-move-period) total-ticks) - for tick = (ceiling (/ elapsed tick-period)) do + for tick = (ceiling elapsed tick-period) do (hanoi-ring-to-pos ring (funcall tick-to-pos tick)) (hanoi-sit-for (- (* tick tick-period) elapsed))) (cl-loop for tick from 1 to total-ticks by 2 do diff --git a/lisp/play/morse.el b/lisp/play/morse.el index 1f62ec3c03c..f4989716556 100644 --- a/lisp/play/morse.el +++ b/lisp/play/morse.el @@ -1,4 +1,4 @@ -;;; morse.el --- convert text to morse code and back +;;; morse.el --- convert text to morse code and back -*- lexical-binding: t -*- ;; Copyright (C) 1995, 2001-2019 Free Software Foundation, Inc. diff --git a/lisp/play/studly.el b/lisp/play/studly.el index ff1bf03e118..c4b32414bd4 100644 --- a/lisp/play/studly.el +++ b/lisp/play/studly.el @@ -1,4 +1,4 @@ -;;; studly.el --- StudlyCaps (tm)(r)(c)(xxx) +;;; studly.el --- StudlyCaps (tm)(r)(c)(xxx) -*- lexical-binding: t -*- ;;; This is in the public domain, since it was distributed ;;; by its author in 1986 without a copyright notice. diff --git a/lisp/play/tetris.el b/lisp/play/tetris.el index 1e0681d7ff1..a797a26d597 100644 --- a/lisp/play/tetris.el +++ b/lisp/play/tetris.el @@ -277,6 +277,7 @@ each one of its four blocks.") (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)) ;; ;;;;;;;;;;;;;;;; game functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/lisp/plstore.el b/lisp/plstore.el index f24bac343a5..cd29283cfb8 100644 --- a/lisp/plstore.el +++ b/lisp/plstore.el @@ -1,7 +1,7 @@ ;;; plstore.el --- secure plist store -*- lexical-binding: t -*- ;; Copyright (C) 2011-2019 Free Software Foundation, Inc. -;; Author: Daiki Ueno <ueno@unixuser.org> +;; Author: Daiki Ueno <ueno@gnu.org> ;; Keywords: PGP, GnuPG ;; This file is part of GNU Emacs. diff --git a/lisp/printing.el b/lisp/printing.el index d3240fe532c..d584e46cecc 100644 --- a/lisp/printing.el +++ b/lisp/printing.el @@ -1,9 +1,8 @@ -;;; printing.el --- printing utilities +;;; printing.el --- printing utilities -*- lexical-binding:t -*- ;; Copyright (C) 2000-2001, 2003-2019 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, print, PostScript ;; Version: 6.9.3 ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre @@ -12,7 +11,7 @@ "printing.el, v 6.9.3 <2007/12/09 vinicius> Please send all bug fixes and enhancements to - bug-gnu-emacs@gnu.org and Vinicius Jose Latorre <viniciusjl@ig.com.br> + bug-gnu-emacs@gnu.org and Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ") ;; This file is part of GNU Emacs. @@ -460,7 +459,7 @@ Please send all bug fixes and enhancements to ;; subjects shows up at the printer. With major mode printing you don't need ;; to switch from gnus *Summary* buffer first. ;; -;; Current global keyboard mapping for GNU Emacs is: +;; Current global keyboard mapping is: ;; ;; (global-set-key [print] 'pr-ps-fast-fire) ;; (global-set-key [M-print] 'pr-ps-mode-using-ghostscript) @@ -468,14 +467,6 @@ Please send all bug fixes and enhancements to ;; (global-set-key [C-print] 'pr-txt-fast-fire) ;; (global-set-key [C-M-print] 'pr-txt-fast-fire) ;; -;; And for XEmacs is: -;; -;; (global-set-key 'f22 'pr-ps-fast-fire) -;; (global-set-key '(meta f22) 'pr-ps-mode-using-ghostscript) -;; (global-set-key '(shift f22) 'pr-ps-mode-using-ghostscript) -;; (global-set-key '(control f22) 'pr-txt-fast-fire) -;; (global-set-key '(control meta f22) 'pr-txt-fast-fire) -;; ;; As a suggestion of global keyboard mapping for some `printing' commands: ;; ;; (global-set-key "\C-ci" 'pr-interface) @@ -493,7 +484,7 @@ Please send all bug fixes and enhancements to ;; Below it's shown a brief description of `printing' options, please, see the ;; options declaration in the code for a long documentation. ;; -;; `pr-path-style' Specify which path style to use for external +;; `pr-filename-style' Specify which filename style to use for external ;; commands. ;; ;; `pr-path-alist' Specify an alist for command paths. @@ -999,7 +990,7 @@ Please send all bug fixes and enhancements to ;; - automagic region detection. ;; - menu entry hiding. ;; - fast fire PostScript printing command. -;; - `pr-path-style' variable. +;; - `pr-filename-style' variable. ;; ;; Thanks to Kim F. Storm <storm@filanet.dk> for beta-test and for suggestions: ;; - PostScript Print and PostScript Print Preview merge. @@ -1023,7 +1014,7 @@ Please send all bug fixes and enhancements to (require 'lpr) (require 'ps-print) - +(require 'easymenu) (and (string< ps-print-version "6.6.4") (error "`printing' requires `ps-print' package version 6.6.4 or later")) @@ -1038,93 +1029,16 @@ Please send all bug fixes and enhancements to ;; To avoid compilation gripes -;; Emacs has this since at least 21.1. -(when (featurep 'xemacs) - (or (fboundp 'subst-char-in-string) ; hacked from subr.el - (defun subst-char-in-string (fromchar tochar string &optional inplace) - "Replace FROMCHAR with TOCHAR in STRING each time it occurs. -Unless optional argument INPLACE is non-nil, return a new string." - (let ((i (length string)) - (newstr (if inplace string (copy-sequence string)))) - (while (> (setq i (1- i)) 0) - (if (eq (aref newstr i) fromchar) - (aset newstr i tochar))) - newstr)))) - - -;; Emacs has this since at least 21.1, but the SUFFIX argument -;; (which this file uses) only since 22.1. So the fboundp test -;; wasn't even correct/adequate. Whatever, no-one is using -;; this file on older Emacs version, so it's irrelevant. -(when (featurep 'xemacs) - (or (fboundp 'make-temp-file) ; hacked from subr.el - (defun make-temp-file (prefix &optional dir-flag suffix) - "Create a temporary file. -The returned file name (created by appending some random characters at the end -of PREFIX, and expanding against `temporary-file-directory' if necessary), -is guaranteed to point to a newly created empty file. -You can then use `write-region' to write new data into the file. - -If DIR-FLAG is non-nil, create a new empty directory instead of a file. - -If SUFFIX is non-nil, add that at the end of the file name." - (let ((umask (default-file-modes)) - file) - (unwind-protect - (progn - ;; Create temp files with strict access rights. It's easy to - ;; loosen them later, whereas it's impossible to close the - ;; time-window of loose permissions otherwise. - (set-default-file-modes ?\700) - (while (condition-case () - (progn - (setq file - (make-temp-name - (expand-file-name prefix temporary-file-directory))) - (if suffix - (setq file (concat file suffix))) - (if dir-flag - (make-directory file) - (write-region "" nil file nil 'silent nil 'excl)) - nil) - (file-already-exists t)) - ;; the file was somehow created by someone else between - ;; `make-temp-name' and `write-region', let's try again. - nil) - file) - ;; Reset the umask. - (set-default-file-modes umask)))))) - - -(eval-when-compile - ;; User Interface --- declared here to avoid compiler warnings - (defvar pr-path-style) - (defvar pr-auto-region) - (defvar pr-menu-char-height) - (defvar pr-menu-char-width) - (defvar pr-menu-lock) - (defvar pr-ps-printer-alist) - (defvar pr-txt-printer-alist) - (defvar pr-ps-utility-alist) - - - ;; Internal fun alias to avoid compilation gripes - (defalias 'pr-menu-lookup 'ignore) - (defalias 'pr-menu-lock 'ignore) - (defalias 'pr-menu-alist 'ignore) - (defalias 'pr-even-or-odd-pages 'ignore) - (defalias 'pr-menu-get-item 'ignore) - (defalias 'pr-menu-set-item-name 'ignore) - (defalias 'pr-menu-set-utility-title 'ignore) - (defalias 'pr-menu-set-ps-title 'ignore) - (defalias 'pr-menu-set-txt-title 'ignore) - (defalias 'pr-region-active-p 'ignore) - (defalias 'pr-do-update-menus 'ignore) - (defalias 'pr-update-mode-line 'ignore) - (defalias 'pr-read-string 'ignore) - (defalias 'pr-set-keymap-parents 'ignore) - (defalias 'pr-keep-region-active 'ignore)) - +;; User Interface --- declared here to avoid compiler warnings +(define-obsolete-variable-alias 'pr-path-style 'pr-filename-style "27.1") +(defvar pr-filename-style) +(defvar pr-auto-region) +(defvar pr-menu-char-height) +(defvar pr-menu-char-width) +(defvar pr-menu-lock) +(defvar pr-ps-printer-alist) +(defvar pr-txt-printer-alist) +(defvar pr-ps-utility-alist) ;; Internal Vars --- defined here to avoid compiler warnings (defvar pr-menu-print-item "print" @@ -1151,480 +1065,206 @@ Used by `pr-menu-bind' and `pr-update-menus'.") ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; XEmacs Definitions - - -(cond - ((featurep 'xemacs) ; XEmacs - ;; XEmacs - (defalias 'pr-set-keymap-parents 'set-keymap-parents) - (defalias 'pr-set-keymap-name 'set-keymap-name) - - ;; XEmacs - (defun pr-read-string (prompt initial history default) - (let ((str (read-string prompt initial))) - (if (and str (not (string= str ""))) - str - default))) - - ;; XEmacs - (defvar zmacs-region-stays nil) - - ;; XEmacs - (defun pr-keep-region-active () - (setq zmacs-region-stays t)) - - ;; XEmacs - (defun pr-region-active-p () - (and pr-auto-region (not zmacs-region-stays) (ps-mark-active-p))) - - ;; XEmacs - (defun pr-menu-char-height () - (font-height (face-font 'default))) - - ;; XEmacs - (defun pr-menu-char-width () - (font-width (face-font 'default))) - - ;; XEmacs - (defmacro pr-xemacs-global-menubar (&rest body) - `(save-excursion - (let ((temp (get-buffer-create (make-temp-name " *Temp")))) - ;; be sure to access global menubar - (set-buffer temp) - ,@body - (kill-buffer temp)))) - - ;; XEmacs - (defun pr-global-menubar (pr-menu-spec) - ;; Menu binding - (pr-xemacs-global-menubar - (add-submenu nil (cons "Printing" pr-menu-spec) "Apps")) - (setq pr-menu-print-item nil)) - - ;; XEmacs - (defvar current-mouse-event nil) - (defun pr-menu-position (entry index horizontal) - (make-event - 'button-release - (list 'button 1 - 'x (- (event-x-pixel current-mouse-event) ; X - (* horizontal pr-menu-char-width)) - 'y (- (event-y-pixel current-mouse-event) ; Y - (* (pr-menu-index entry index) pr-menu-char-height))))) - - (defvar pr-menu-position nil) - (defvar pr-menu-state nil) - - ;; XEmacs - (defvar current-menubar nil) ; to avoid compilation gripes - (defun pr-menu-lookup (path) - (car (find-menu-item current-menubar (cons "Printing" path)))) - - ;; XEmacs - (defun pr-menu-lock (entry index horizontal state path) - (when pr-menu-lock - (or (and pr-menu-position (eq state pr-menu-state)) - (setq pr-menu-position (pr-menu-position entry index horizontal) - pr-menu-state state)) - (let* ((menu (pr-menu-lookup path)) - (result (get-popup-menu-response menu pr-menu-position))) - (and (misc-user-event-p result) - (funcall (event-function result) - (event-object result)))) - (setq pr-menu-position nil))) - - ;; XEmacs - (defalias 'pr-update-mode-line 'set-menubar-dirty-flag) - - ;; XEmacs - (defvar pr-ps-name-old "PostScript Printers") - (defvar pr-txt-name-old "Text Printers") - (defvar pr-ps-utility-old "PostScript Utility") - (defvar pr-even-or-odd-old "Print All Pages") - - ;; XEmacs - (defun pr-do-update-menus (&optional force) - (pr-menu-alist pr-ps-printer-alist - 'pr-ps-name - 'pr-menu-set-ps-title - '("Printing") - 'pr-ps-printer-menu-modified - force - pr-ps-name-old - 'postscript 2) - (pr-menu-alist pr-txt-printer-alist - 'pr-txt-name - 'pr-menu-set-txt-title - '("Printing") - 'pr-txt-printer-menu-modified - force - pr-txt-name-old - 'text 2) - (let ((save-var pr-ps-utility-menu-modified)) - (pr-menu-alist pr-ps-utility-alist - 'pr-ps-utility - 'pr-menu-set-utility-title - '("Printing" "PostScript Print" "File") - 'save-var - force - pr-ps-utility-old - nil 1)) - (pr-menu-alist pr-ps-utility-alist - 'pr-ps-utility - 'pr-menu-set-utility-title - '("Printing" "PostScript Preview" "File") - 'pr-ps-utility-menu-modified - force - pr-ps-utility-old - nil 1) - (pr-even-or-odd-pages ps-even-or-odd-pages force)) - - ;; XEmacs - (defun pr-menu-alist (alist var-sym fun menu-path modified-sym force name - entry index) - (when (and alist (or force (symbol-value modified-sym))) - (pr-xemacs-global-menubar - (add-submenu menu-path - (pr-menu-create name alist var-sym - fun entry index))) - (funcall fun (symbol-value var-sym)) - (set modified-sym nil))) - - ;; XEmacs - (defun pr-relabel-menu-item (newname var-sym) - (pr-xemacs-global-menubar - (relabel-menu-item - (list "Printing" (symbol-value var-sym)) - newname) - (set var-sym newname))) - - ;; XEmacs - (defun pr-menu-set-ps-title (value &optional item entry index) - (pr-relabel-menu-item (format "PostScript Printer: %s" value) - 'pr-ps-name-old) - (pr-ps-set-printer value) - (and index - (pr-menu-lock entry index 12 'toggle nil))) - - ;; XEmacs - (defun pr-menu-set-txt-title (value &optional item entry index) - (pr-relabel-menu-item (format "Text Printer: %s" value) - 'pr-txt-name-old) - (pr-txt-set-printer value) - (and index - (pr-menu-lock entry index 12 'toggle nil))) - - ;; XEmacs - (defun pr-menu-set-utility-title (value &optional item entry index) - (pr-xemacs-global-menubar - (let ((newname (format "%s" value))) - (relabel-menu-item - (list "Printing" "PostScript Print" "File" pr-ps-utility-old) - newname) - (relabel-menu-item - (list "Printing" "PostScript Preview" "File" pr-ps-utility-old) - newname) - (setq pr-ps-utility-old newname))) - (pr-ps-set-utility value) - (and index - (pr-menu-lock entry index 5 nil '("PostScript Print" "File")))) - - ;; XEmacs - (defun pr-even-or-odd-pages (value &optional no-lock) - (pr-relabel-menu-item (cdr (assq value pr-even-or-odd-alist)) - 'pr-even-or-odd-old) - (setq ps-even-or-odd-pages value) - (or no-lock - (pr-menu-lock 'postscript-options 8 12 'toggle nil))) - - ) - (t ; GNU Emacs - ;; Do nothing - )) ; end cond featurep +;; GNU Emacs Definitions +(defun pr-keep-region-active () + (setq deactivate-mark nil)) - -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; GNU Emacs Definitions +(defun pr-region-active-p () + (and pr-auto-region (use-region-p))) -(eval-and-compile - (unless (featurep 'xemacs) - (defvar pr-menu-bar nil - "Specify Printing menu-bar entry."))) - -(cond - ((featurep 'xemacs) ; XEmacs - ;; Do nothing - ) - (t ; GNU Emacs - ;; GNU Emacs - (defalias 'pr-set-keymap-parents 'set-keymap-parent) - (defalias 'pr-set-keymap-name 'ignore) - (defalias 'pr-read-string 'read-string) - - ;; GNU Emacs - (defvar deactivate-mark) - - ;; GNU Emacs - (defun pr-keep-region-active () - (setq deactivate-mark nil)) - - ;; GNU Emacs - (defun pr-region-active-p () - (and pr-auto-region transient-mark-mode mark-active)) - - ;; GNU Emacs - (defun pr-menu-char-height () - (frame-char-height)) - - ;; GNU Emacs - (defun pr-menu-char-width () - (frame-char-width)) - - ;; GNU Emacs - ;; Menu binding - ;; Replace existing "print" item by "Printing" item. - ;; If you're changing this file, you'll load it a second, - ;; third... time, but "print" item exists only in the first load. - (eval-when-compile - (require 'easymenu)) ; to avoid compilation gripes - - (declare-function easy-menu-add-item "easymenu" - (map path item &optional before)) - (declare-function easy-menu-remove-item "easymenu" (map path name)) - - (eval-and-compile - (defun pr-global-menubar (pr-menu-spec) - (require 'easymenu) - (let ((menu-file (if (= emacs-major-version 21) - '("menu-bar" "files") ; GNU Emacs 21 - '("menu-bar" "file")))) ; GNU Emacs 22 or higher - (cond - (pr-menu-print-item - (easy-menu-add-item global-map menu-file - (easy-menu-create-menu "Print" pr-menu-spec) - "print-buffer") - (dolist (item '("print-buffer" "print-region" - "ps-print-buffer-faces" "ps-print-region-faces" - "ps-print-buffer" "ps-print-region")) - (easy-menu-remove-item global-map menu-file item)) - (setq pr-menu-print-item nil - pr-menu-bar (vector 'menu-bar - (pr-get-symbol (nth 1 menu-file)) - (pr-get-symbol "Print")))) - (t - (easy-menu-add-item global-map menu-file - (easy-menu-create-menu "Print" pr-menu-spec))) - )))) - - (eval-and-compile +;; Menu binding +;; Replace existing "print" item by "Printing" item. +;; If you're changing this file, you'll load it a second, +;; third... time, but "print" item exists only in the first load. + +(defvar pr-menu-bar nil + "Specify Printing menu-bar entry.") + +(defun pr-global-menubar (menu-spec) + (let ((menu-file '("menu-bar" "file"))) (cond - (lpr-windows-system - ;; GNU Emacs for Windows 9x/NT - (defun pr-menu-position (entry index horizontal) - (let ((pos (cdr (mouse-pixel-position)))) - (list - (list (or (car pos) 0) ; X - (- (or (cdr pos) 0) ; Y - (* (pr-menu-index entry index) pr-menu-char-height))) - (selected-frame)))) ; frame - ) + (pr-menu-print-item + (easy-menu-add-item global-map menu-file + (easy-menu-create-menu "Print" menu-spec) + "print-buffer") + (dolist (item '("print-buffer" "print-region" + "ps-print-buffer-faces" "ps-print-region-faces" + "ps-print-buffer" "ps-print-region")) + (easy-menu-remove-item global-map menu-file item)) + (setq pr-menu-print-item nil + pr-menu-bar (vector 'menu-bar + (easy-menu-intern (nth 1 menu-file)) + (easy-menu-intern "Print")))) (t - ;; GNU Emacs - (defun pr-menu-position (entry index horizontal) - (let ((pos (cdr (mouse-pixel-position)))) - (list - (list (- (or (car pos) 0) ; X - (* horizontal pr-menu-char-width)) - (- (or (cdr pos) 0) ; Y - (* (pr-menu-index entry index) pr-menu-char-height))) - (selected-frame)))) ; frame - ))) - - (defvar pr-menu-position nil) - (defvar pr-menu-state nil) - - ;; GNU Emacs - (defun pr-menu-lookup (path) - (lookup-key global-map - (if path - (vconcat pr-menu-bar - (mapcar 'pr-get-symbol - (if (listp path) - path - (list path)))) - pr-menu-bar))) - - ;; GNU Emacs - (defun pr-menu-lock (entry index horizontal state path) - (when pr-menu-lock - (or (and pr-menu-position (eq state pr-menu-state)) - (setq pr-menu-position (pr-menu-position entry index horizontal) - pr-menu-state state)) - (let* ((menu (pr-menu-lookup path)) - (result (x-popup-menu pr-menu-position menu))) - (and result - (let ((command (lookup-key menu (vconcat result)))) - (if (fboundp command) - (funcall command) - (eval command))))) - (setq pr-menu-position nil))) - - ;; GNU Emacs - (defalias 'pr-update-mode-line 'force-mode-line-update) - - ;; GNU Emacs - (defun pr-do-update-menus (&optional force) - (pr-menu-alist pr-ps-printer-alist - 'pr-ps-name - 'pr-menu-set-ps-title - "PostScript Printers" - 'pr-ps-printer-menu-modified - force - "PostScript Printers" - 'postscript 2) - (pr-menu-alist pr-txt-printer-alist - 'pr-txt-name - 'pr-menu-set-txt-title - "Text Printers" - 'pr-txt-printer-menu-modified - force - "Text Printers" - 'text 2) - (let ((save-var pr-ps-utility-menu-modified)) - (pr-menu-alist pr-ps-utility-alist - 'pr-ps-utility - 'pr-menu-set-utility-title - '("PostScript Print" "File" "PostScript Utility") - 'save-var - force - "PostScript Utility" - nil 1)) + (easy-menu-add-item global-map menu-file + (easy-menu-create-menu "Print" menu-spec))) + ))) + +(defun pr-menu-position (entry index horizontal) + (let ((pos (cdr (mouse-pixel-position)))) + (list + (list (- (or (car pos) 0) ; X + (if lpr-windows-system + 0 ;; GNU Emacs for Windows 9x/NT + (* horizontal pr-menu-char-width))) + (- (or (cdr pos) 0) ; Y + (* (pr-menu-index entry index) pr-menu-char-height))) + (selected-frame)))) ; frame + +(defvar pr-menu-position nil) +(defvar pr-menu-state nil) + +(defun pr-menu-lookup (path) + (lookup-key global-map + (if path + (vconcat pr-menu-bar + (mapcar #'easy-menu-intern + (if (listp path) + path + (list path)))) + pr-menu-bar))) + +(defun pr-menu-lock (entry index horizontal state path) + (when pr-menu-lock + (or (and pr-menu-position (eq state pr-menu-state)) + (setq pr-menu-position (pr-menu-position entry index horizontal) + pr-menu-state state)) + (let* ((menu (pr-menu-lookup path)) + (result (x-popup-menu pr-menu-position menu))) + (and result + (let ((command (lookup-key menu (vconcat result)))) + (if (fboundp command) + (funcall command) + (eval command))))) + (setq pr-menu-position nil))) + +(defun pr-do-update-menus (&optional force) + (pr-menu-alist pr-ps-printer-alist + 'pr-ps-name + #'pr-menu-set-ps-title + "PostScript Printers" + 'pr-ps-printer-menu-modified + force + "PostScript Printers" + 'postscript 2) + (pr-menu-alist pr-txt-printer-alist + 'pr-txt-name + #'pr-menu-set-txt-title + "Text Printers" + 'pr-txt-printer-menu-modified + force + "Text Printers" + 'text 2) + (defvar pr--save-var) + (let ((pr--save-var pr-ps-utility-menu-modified)) (pr-menu-alist pr-ps-utility-alist 'pr-ps-utility - 'pr-menu-set-utility-title - '("PostScript Preview" "File" "PostScript Utility") - 'pr-ps-utility-menu-modified + #'pr-menu-set-utility-title + '("PostScript Print" "File" "PostScript Utility") + 'pr--save-var force "PostScript Utility" - nil 1) - (pr-even-or-odd-pages ps-even-or-odd-pages force)) - - ;; GNU Emacs - (defun pr-menu-get-item (name-list) - ;; NAME-LIST is a string or a list of strings. - (or (listp name-list) - (setq name-list (list name-list))) - (and name-list - (let* ((reversed (reverse name-list)) - (name (pr-get-symbol (car reversed))) - (path (nreverse (cdr reversed))) - (menu (lookup-key - global-map - (vconcat pr-menu-bar - (mapcar 'pr-get-symbol path))))) - (assq name (nthcdr 2 menu))))) - - ;; GNU Emacs - (defvar pr-temp-menu nil) - - ;; GNU Emacs - (defun pr-menu-alist (alist var-sym fun menu-path modified-sym force name - entry index) - (when (and alist (or force (symbol-value modified-sym))) - (easy-menu-define pr-temp-menu nil "" - (pr-menu-create name alist var-sym fun entry index)) - (let ((item (pr-menu-get-item menu-path))) - (and item - (let* ((binding (nthcdr 3 item)) - (key-binding (cdr binding))) - (setcar binding pr-temp-menu) - (and key-binding (listp (car key-binding)) - (setcdr binding (cdr key-binding))) ; skip KEY-BINDING - (funcall fun (symbol-value var-sym) item)))) - (set modified-sym nil))) - - ;; GNU Emacs - (defun pr-menu-set-item-name (item name) - (and item - (setcar (nthcdr 2 item) name))) ; ITEM-NAME - - ;; GNU Emacs - (defun pr-menu-set-ps-title (value &optional item entry index) - (pr-menu-set-item-name (or item - (pr-menu-get-item "PostScript Printers")) - (format "PostScript Printer: %s" value)) - (pr-ps-set-printer value) - (and index - (pr-menu-lock entry index 12 'toggle nil))) - - ;; GNU Emacs - (defun pr-menu-set-txt-title (value &optional item entry index) - (pr-menu-set-item-name (or item - (pr-menu-get-item "Text Printers")) - (format "Text Printer: %s" value)) - (pr-txt-set-printer value) - (and index - (pr-menu-lock entry index 12 'toggle nil))) - - ;; GNU Emacs - (defun pr-menu-set-utility-title (value &optional item entry index) - (let ((name (symbol-name value))) - (if item - (pr-menu-set-item-name item name) - (pr-menu-set-item-name - (pr-menu-get-item - '("PostScript Print" "File" "PostScript Utility")) - name) - (pr-menu-set-item-name - (pr-menu-get-item - '("PostScript Preview" "File" "PostScript Utility")) - name))) - (pr-ps-set-utility value) - (and index - (pr-menu-lock entry index 5 nil '("PostScript Print" "File")))) - - ;; GNU Emacs - (defun pr-even-or-odd-pages (value &optional no-lock) - (pr-menu-set-item-name (pr-menu-get-item "Print All Pages") - (cdr (assq value pr-even-or-odd-alist))) - (setq ps-even-or-odd-pages value) - (or no-lock - (pr-menu-lock 'postscript-options 8 12 'toggle nil))) - - )) ; end cond featurep - + nil 1)) + (pr-menu-alist pr-ps-utility-alist + 'pr-ps-utility + #'pr-menu-set-utility-title + '("PostScript Preview" "File" "PostScript Utility") + 'pr-ps-utility-menu-modified + force + "PostScript Utility" + nil 1) + (pr-even-or-odd-pages ps-even-or-odd-pages force)) + +(defun pr-menu-get-item (name-list) + ;; NAME-LIST is a string or a list of strings. + (or (listp name-list) + (setq name-list (list name-list))) + (and name-list + (let* ((reversed (reverse name-list)) + (name (easy-menu-intern (car reversed))) + (path (nreverse (cdr reversed))) + (menu (lookup-key + global-map + (vconcat pr-menu-bar + (mapcar #'easy-menu-intern path))))) + (assq name (nthcdr 2 menu))))) + +(defvar pr-temp-menu nil) + +(defun pr-menu-alist (alist var-sym fun menu-path modified-sym force name + entry index) + (when (and alist (or force (symbol-value modified-sym))) + (easy-menu-define pr-temp-menu nil "" + (pr-menu-create name alist var-sym fun entry index)) + (let ((item (pr-menu-get-item menu-path))) + (and item + (progn + (setf (nth 3 item) pr-temp-menu) + (funcall fun (symbol-value var-sym) item)))) + (set modified-sym nil))) + +(defun pr-menu-set-item-name (item name) + (and item + (setcar (nthcdr 2 item) name))) ; ITEM-NAME + +(defun pr-menu-set-ps-title (value &optional item entry index) + (pr-menu-set-item-name (or item + (pr-menu-get-item "PostScript Printers")) + (format "PostScript Printer: %s" value)) + (pr-ps-set-printer value) + (and index + (pr-menu-lock entry index 12 'toggle nil))) + +(defun pr-menu-set-txt-title (value &optional item entry index) + (pr-menu-set-item-name (or item + (pr-menu-get-item "Text Printers")) + (format "Text Printer: %s" value)) + (pr-txt-set-printer value) + (and index + (pr-menu-lock entry index 12 'toggle nil))) + +(defun pr-menu-set-utility-title (value &optional item entry index) + (let ((name (symbol-name value))) + (if item + (pr-menu-set-item-name item name) + (pr-menu-set-item-name + (pr-menu-get-item + '("PostScript Print" "File" "PostScript Utility")) + name) + (pr-menu-set-item-name + (pr-menu-get-item + '("PostScript Preview" "File" "PostScript Utility")) + name))) + (pr-ps-set-utility value) + (and index + (pr-menu-lock entry index 5 nil '("PostScript Print" "File")))) + +(defun pr-even-or-odd-pages (value &optional no-lock) + (pr-menu-set-item-name (pr-menu-get-item "Print All Pages") + (cdr (assq value pr-even-or-odd-alist))) + (setq ps-even-or-odd-pages value) + (or no-lock + (pr-menu-lock 'postscript-options 8 12 'toggle nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Internal Functions (I) -(defun pr-dosify-file-name (path) +(defun pr-dosify-file-name (filename) "Replace unix-style directory separator character with dos/windows one." - (interactive "sPath: ") - (if (eq pr-path-style 'windows) - (subst-char-in-string ?/ ?\\ path) - path)) - + (if (eq pr-filename-style 'windows) + (subst-char-in-string ?/ ?\\ filename) + filename)) -(defun pr-unixify-file-name (path) - "Replace dos/windows-style directory separator character with unix one." - (interactive "sPath: ") - (if (eq pr-path-style 'windows) - (subst-char-in-string ?\\ ?/ path) - path)) - - -(defun pr-standard-file-name (path) +(defun pr-standard-file-name (filename) "Ensure the proper directory separator depending on the OS. That is, if Emacs is running on DOS/Windows, ensure dos/windows-style directory separator; otherwise, ensure unix-style directory separator." + ;; FIXME: Why not use pr-dosify-file-name? (if (or pr-cygwin-system lpr-windows-system) - (subst-char-in-string ?/ ?\\ path) - (subst-char-in-string ?\\ ?/ path))) - + (subst-char-in-string ?/ ?\\ filename) + filename)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Customization Functions @@ -1672,22 +1312,21 @@ separator; otherwise, ensure unix-style directory separator." :group 'postscript) -(defcustom pr-path-style +(defcustom pr-filename-style (if (and (not pr-cygwin-system) lpr-windows-system) 'windows 'unix) - "Specify which path style to use for external commands. + "Specify which filename style to use for external commands. Valid values are: windows Windows 9x/NT style (\\) unix Unix style (/)" - :type '(choice :tag "Path style" + :type '(choice :tag "Filename style" (const :tag "Windows 9x/NT Style (\\)" :value windows) - (const :tag "Unix Style (/)" :value unix)) - :group 'printing) + (const :tag "Unix Style (/)" :value unix))) (defcustom pr-path-alist @@ -1708,13 +1347,13 @@ Where: ENTRY It's a symbol, used to identify this entry. There must exist at least one of the following entries: - unix this entry is used when Emacs is running on GNU or + `unix' this entry is used when Emacs is running on GNU or Unix system. - cygwin this entry is used when Emacs is running on Windows + `cygwin' this entry is used when Emacs is running on Windows 95/98/NT/2000 with Cygwin. - windows this entry is used when Emacs is running on Windows + `windows' this entry is used when Emacs is running on Windows 95/98/NT/2000. DIRECTORY It should be a string or a symbol. If it's a symbol, it should @@ -1764,8 +1403,7 @@ Examples: (choice :menu-tag "Directory" :tag "Directory" (string :value "") - (symbol :value symbol))))) - :group 'printing) + (symbol :value symbol)))))) (defcustom pr-txt-name 'default @@ -1778,8 +1416,7 @@ This variable should be modified by customization engine. If this variable is modified by other means (for example, a lisp function), use `pr-update-menus' function (see it for documentation) to update text printer menu." :type 'symbol - :set 'pr-txt-name-custom-set - :group 'printing) + :set 'pr-txt-name-custom-set) (defcustom pr-txt-printer-alist @@ -1910,8 +1547,7 @@ Useful links: :tag "Printer Name" (const :tag "None" nil) string))) - :set 'pr-alist-custom-set - :group 'printing) + :set 'pr-alist-custom-set) (defcustom pr-ps-name 'default @@ -1924,8 +1560,7 @@ This variable should be modified by customization engine. If this variable is modified by other means (for example, a lisp function), use `pr-update-menus' function (see it for documentation) to update PostScript printer menu." :type 'symbol - :set 'pr-ps-name-custom-set - :group 'printing) + :set 'pr-ps-name-custom-set) (defcustom pr-ps-printer-alist @@ -2196,33 +1831,21 @@ Useful links: (variable :tag "Other")) (sexp :tag "Value"))) )) - :set 'pr-alist-custom-set - :group 'printing) - - -(defcustom pr-temp-dir - (pr-dosify-file-name - (if (boundp 'temporary-file-directory) - (symbol-value 'temporary-file-directory) - ;; hacked from `temporary-file-directory' variable in files.el - (file-name-as-directory - (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") - (cond (lpr-windows-system "c:/temp") - (t "/tmp") - ))))) + :set 'pr-alist-custom-set) + + +(defcustom pr-temp-dir temporary-file-directory "Specify a directory for temporary files during printing. See also `pr-ps-temp-file' and `pr-file-modes'." - :type '(directory :tag "Temporary Directory") - :group 'printing) + :type '(directory :tag "Temporary Directory")) (defcustom pr-ps-temp-file "prspool-" "Specify PostScript temporary file name prefix. See also `pr-temp-dir' and `pr-file-modes'." - :type '(file :tag "PostScript Temporary File Name") - :group 'printing) + :type '(file :tag "PostScript Temporary File Name")) ;; It uses 0600 as default instead of (default-file-modes). @@ -2234,8 +1857,7 @@ See also `pr-temp-dir' and `pr-file-modes'." It should be an integer; only the low 9 bits are used. See also `pr-temp-dir' and `pr-ps-temp-file'." - :type '(integer :tag "File Permission Bits") - :group 'printing) + :type '(integer :tag "File Permission Bits")) (defcustom pr-gv-command @@ -2275,8 +1897,7 @@ Useful links: * MacGSView (Mac OS) `http://www.cs.wisc.edu/~ghost/macos/index.htm' " - :type '(string :tag "Ghostview Utility") - :group 'printing) + :type '(string :tag "Ghostview Utility")) (defcustom pr-gs-command @@ -2301,8 +1922,7 @@ Useful links: * Printer compatibility `http://www.cs.wisc.edu/~ghost/doc/printer.htm' " - :type '(string :tag "Ghostscript Utility") - :group 'printing) + :type '(string :tag "Ghostscript Utility")) (defcustom pr-gs-switches @@ -2343,8 +1963,7 @@ Useful links: * Printer compatibility `http://www.cs.wisc.edu/~ghost/doc/printer.htm' " - :type '(repeat (string :tag "Ghostscript Switch")) - :group 'printing) + :type '(repeat (string :tag "Ghostscript Switch"))) (defcustom pr-gs-device @@ -2359,8 +1978,7 @@ A note on the gs switches: See `pr-gs-switches' for documentation. See also `pr-ps-printer-alist'." - :type '(string :tag "Ghostscript Device") - :group 'printing) + :type '(string :tag "Ghostscript Device")) (defcustom pr-gs-resolution 300 @@ -2372,8 +1990,7 @@ A note on the gs switches: See `pr-gs-switches' for documentation. See also `pr-ps-printer-alist'." - :type '(integer :tag "Ghostscript Resolution") - :group 'printing) + :type '(integer :tag "Ghostscript Resolution")) (defcustom pr-print-using-ghostscript nil @@ -2384,32 +2001,27 @@ ghostscript to print a PostScript file. In GNU or Unix system, if ghostscript is set as a PostScript filter, this variable should be nil." - :type 'boolean - :group 'printing) + :type 'boolean) (defcustom pr-faces-p nil "Non-nil means print with face attributes." - :type 'boolean - :group 'printing) + :type 'boolean) (defcustom pr-spool-p nil "Non-nil means spool printing in a buffer." - :type 'boolean - :group 'printing) + :type 'boolean) (defcustom pr-file-landscape nil "Non-nil means print PostScript file in landscape orientation." - :type 'boolean - :group 'printing) + :type 'boolean) (defcustom pr-file-duplex nil "Non-nil means print PostScript file in duplex mode." - :type 'boolean - :group 'printing) + :type 'boolean) (defcustom pr-file-tumble nil @@ -2419,8 +2031,7 @@ If tumble is off, produces a printing suitable for binding on the left or right. If tumble is on, produces a printing suitable for binding at the top or bottom." - :type 'boolean - :group 'printing) + :type 'boolean) (defcustom pr-auto-region t @@ -2431,8 +2042,7 @@ Note that this will only work if you're using transient mark mode. When this variable is non-nil, the `*-buffer*' commands will behave like `*-region*' commands, that is, `*-buffer*' commands will print only the region marked instead of all buffer." - :type 'boolean - :group 'printing) + :type 'boolean) (defcustom pr-auto-mode t @@ -2442,8 +2052,7 @@ That is, if current major-mode is declared in `pr-mode-alist', the `*-buffer*' and `*-region*' commands will behave like `*-mode*' commands; otherwise, `*-buffer*' commands will print the current buffer and `*-region*' commands will print the current region." - :type 'boolean - :group 'printing) + :type 'boolean) (defcustom pr-mode-alist @@ -2642,8 +2251,7 @@ DEFAULT It's a way to set default values when this entry is selected. (const :tag "inherits-from:" inherits-from:) (variable :tag "Other")) (sexp :tag "Value"))) - )) - :group 'printing) + ))) (defcustom pr-ps-utility 'mpage @@ -2659,8 +2267,7 @@ function (see it for documentation) to update PostScript utility menu. NOTE: Don't forget to download and install the utilities declared on `pr-ps-utility-alist'." :type '(symbol :tag "PS File Utility") - :set 'pr-ps-utility-custom-set - :group 'printing) + :set 'pr-ps-utility-custom-set) (defcustom pr-ps-utility-alist @@ -2871,38 +2478,34 @@ Useful links: (variable :tag "Other")) (sexp :tag "Value"))) )) - :set 'pr-alist-custom-set - :group 'printing) + :set 'pr-alist-custom-set) (defcustom pr-menu-lock t "Non-nil means menu is locked while selecting toggle options. See also `pr-menu-char-height' and `pr-menu-char-width'." - :type 'boolean - :group 'printing) + :type 'boolean) -(defcustom pr-menu-char-height (pr-menu-char-height) +(defcustom pr-menu-char-height (frame-char-height) "Specify menu char height in pixels. This variable is used to guess which vertical position should be locked the menu, so don't forget to adjust it if menu position is not ok. See also `pr-menu-lock' and `pr-menu-char-width'." - :type 'integer - :group 'printing) + :type 'integer) -(defcustom pr-menu-char-width (pr-menu-char-width) +(defcustom pr-menu-char-width (frame-char-width) "Specify menu char width in pixels. This variable is used to guess which horizontal position should be locked the menu, so don't forget to adjust it if menu position is not ok. See also `pr-menu-lock' and `pr-menu-char-height'." - :type 'integer - :group 'printing) + :type 'integer) (defcustom pr-setting-database @@ -3017,8 +2620,7 @@ SETTING It's a cons like: (const :tag "Ghostscript Resolution" pr-gs-resolution) (variable :tag "Other")) (sexp :tag "Value"))) - )) - :group 'printing) + ))) (defcustom pr-visible-entry-list @@ -3070,8 +2672,7 @@ Any other value is ignored." (const postscript-options) (const postscript-process) (const printing) - (const help))) - :group 'printing) + (const help)))) (defcustom pr-delete-temp-file t @@ -3081,8 +2682,7 @@ Set `pr-delete-temp-file' to nil, if the following message (or a similar) happens when printing: Error: could not open \"c:\\temp\\prspool.ps\" for reading." - :type 'boolean - :group 'printing) + :type 'boolean) (defcustom pr-list-directory nil @@ -3094,16 +2694,14 @@ argument of functions below) are also printed (as dired-mode listings). It's used by `pr-ps-directory-preview', `pr-ps-directory-using-ghostscript', `pr-ps-directory-print', `pr-ps-directory-ps-print', `pr-printify-directory' and `pr-txt-directory'." - :type 'boolean - :group 'printing) + :type 'boolean) (defcustom pr-buffer-name "*Printing Interface*" "Specify the name of the buffer interface for printing package. It's used by `pr-interface'." - :type 'string - :group 'printing) + :type 'string) (defcustom pr-buffer-name-ignore @@ -3115,16 +2713,14 @@ NOTE: Case is important for matching, that is, `case-fold-search' is always nil. It's used by `pr-interface'." - :type '(repeat (regexp :tag "Buffer Name Regexp")) - :group 'printing) + :type '(repeat (regexp :tag "Buffer Name Regexp"))) (defcustom pr-buffer-verbose t "Non-nil means to be verbose when editing a field in interface buffer. It's used by `pr-interface'." - :type 'boolean - :group 'printing) + :type 'boolean) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -3167,15 +2763,6 @@ See `pr-ps-printer-alist'.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Macros - - -(defmacro pr-save-file-modes (&rest body) - "Execute BODY with file permissions temporarily set to `pr-file-modes'." - (declare (obsolete with-file-modes "25.1")) - `(with-file-modes pr-file-modes ,@body)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Keys & Menus @@ -3195,252 +2782,211 @@ See `pr-ps-printer-alist'.") (and pr-print-using-ghostscript (not pr-spool-p))) -(defalias 'pr-get-symbol - (if (featurep 'emacs) 'easy-menu-intern ; since 22.1 - (if (fboundp 'easy-menu-intern) ; hacked from easymenu.el - 'easy-menu-intern - (lambda (s) (if (stringp s) (intern s) s))))) - - (defconst pr-menu-spec - ;; Menu mapping: - ;; unfortunately XEmacs doesn't support :active for submenus, - ;; only for items. - ;; So, it uses :included instead of :active. - ;; Also, XEmacs doesn't support :help tag. - (let ((pr-:active (if (featurep 'xemacs) - :included ; XEmacs - :active)) ; GNU Emacs - (pr-:help (if (featurep 'xemacs) - 'ignore ; XEmacs - #'(lambda (text) (list :help text))))) ; GNU Emacs - `( - ["Printing Interface" pr-interface - ,@(funcall - pr-:help "Use buffer interface instead of menu interface")] + '( + ["Printing Interface" pr-interface + :help "Use buffer interface instead of menu interface"] + "--" + ("PostScript Preview" :included (pr-visible-p 'postscript) + :help "Preview PostScript instead of sending to printer" + ("Directory" :active (not pr-spool-p) + ["1-up" (pr-ps-directory-preview 1 nil nil t) t] + ["2-up" (pr-ps-directory-preview 2 nil nil t) t] + ["4-up" (pr-ps-directory-preview 4 nil nil t) t] + ["Other..." (pr-ps-directory-preview nil nil nil t) + :keys "\\[pr-ps-buffer-preview]"]) + ("Buffer" :active (not pr-spool-p) + ["1-up" (pr-ps-buffer-preview 1 t) t] + ["2-up" (pr-ps-buffer-preview 2 t) t] + ["4-up" (pr-ps-buffer-preview 4 t) t] + ["Other..." (pr-ps-buffer-preview nil t) + :keys "\\[pr-ps-buffer-preview]"]) + ("Region" :active (and (not pr-spool-p) (ps-mark-active-p)) + ["1-up" (pr-ps-region-preview 1 t) t] + ["2-up" (pr-ps-region-preview 2 t) t] + ["4-up" (pr-ps-region-preview 4 t) t] + ["Other..." (pr-ps-region-preview nil t) + :keys "\\[pr-ps-region-preview]"]) + ("Mode" :active (and (not pr-spool-p) (pr-mode-alist-p)) + ["1-up" (pr-ps-mode-preview 1 t) t] + ["2-up" (pr-ps-mode-preview 2 t) t] + ["4-up" (pr-ps-mode-preview 4 t) t] + ["Other..." (pr-ps-mode-preview nil t) + :keys "\\[pr-ps-mode-preview]"]) + ("File" + ["No Preprocessing..." (call-interactively 'pr-ps-file-preview) + :keys "\\[pr-ps-file-preview]" + :help "Preview PostScript file"] "--" - ("PostScript Preview" :included (pr-visible-p 'postscript) - ,@(funcall - pr-:help "Preview PostScript instead of sending to printer") - ("Directory" ,pr-:active (not pr-spool-p) - ["1-up" (pr-ps-directory-preview 1 nil nil t) t] - ["2-up" (pr-ps-directory-preview 2 nil nil t) t] - ["4-up" (pr-ps-directory-preview 4 nil nil t) t] - ["Other..." (pr-ps-directory-preview nil nil nil t) - :keys "\\[pr-ps-buffer-preview]"]) - ("Buffer" ,pr-:active (not pr-spool-p) - ["1-up" (pr-ps-buffer-preview 1 t) t] - ["2-up" (pr-ps-buffer-preview 2 t) t] - ["4-up" (pr-ps-buffer-preview 4 t) t] - ["Other..." (pr-ps-buffer-preview nil t) - :keys "\\[pr-ps-buffer-preview]"]) - ("Region" ,pr-:active (and (not pr-spool-p) (ps-mark-active-p)) - ["1-up" (pr-ps-region-preview 1 t) t] - ["2-up" (pr-ps-region-preview 2 t) t] - ["4-up" (pr-ps-region-preview 4 t) t] - ["Other..." (pr-ps-region-preview nil t) - :keys "\\[pr-ps-region-preview]"]) - ("Mode" ,pr-:active (and (not pr-spool-p) (pr-mode-alist-p)) - ["1-up" (pr-ps-mode-preview 1 t) t] - ["2-up" (pr-ps-mode-preview 2 t) t] - ["4-up" (pr-ps-mode-preview 4 t) t] - ["Other..." (pr-ps-mode-preview nil t) - :keys "\\[pr-ps-mode-preview]"]) - ("File" - ["No Preprocessing..." (call-interactively 'pr-ps-file-preview) - :keys "\\[pr-ps-file-preview]" - ,@(funcall - pr-:help "Preview PostScript file")] - "--" - ["PostScript Utility" pr-update-menus :active pr-ps-utility-alist - ,@(funcall - pr-:help "Select PostScript utility")] - "--" - ["1-up..." (pr-ps-file-up-preview 1 t t) pr-ps-utility-alist] - ["2-up..." (pr-ps-file-up-preview 2 t t) pr-ps-utility-alist] - ["4-up..." (pr-ps-file-up-preview 4 t t) pr-ps-utility-alist] - ["Other..." (pr-ps-file-up-preview nil t t) - :keys "\\[pr-ps-file-up-preview]" :active pr-ps-utility-alist] - "--" - ["Landscape" pr-toggle-file-landscape-menu - :style toggle :selected pr-file-landscape - ,@(funcall - pr-:help "Toggle landscape for PostScript file") - :active pr-ps-utility-alist] - ["Duplex" pr-toggle-file-duplex-menu - :style toggle :selected pr-file-duplex - ,@(funcall - pr-:help "Toggle duplex for PostScript file") - :active pr-ps-utility-alist] - ["Tumble" pr-toggle-file-tumble-menu - :style toggle :selected pr-file-tumble - ,@(funcall - pr-:help "Toggle tumble for PostScript file") - :active (and pr-file-duplex pr-ps-utility-alist)]) - ["Despool..." (call-interactively 'pr-despool-preview) - :active pr-spool-p :keys "\\[pr-despool-preview]" - ,@(funcall - pr-:help "Despool PostScript buffer to printer or file (C-u)")]) - ("PostScript Print" :included (pr-visible-p 'postscript) - ,@(funcall - pr-:help "Send PostScript to printer or file (C-u)") - ("Directory" - ["1-up" (pr-ps-directory-ps-print 1 nil nil t) t] - ["2-up" (pr-ps-directory-ps-print 2 nil nil t) t] - ["4-up" (pr-ps-directory-ps-print 4 nil nil t) t] - ["Other..." (pr-ps-directory-ps-print nil nil nil t) - :keys "\\[pr-ps-buffer-ps-print]"]) - ("Buffer" - ["1-up" (pr-ps-buffer-ps-print 1 t) t] - ["2-up" (pr-ps-buffer-ps-print 2 t) t] - ["4-up" (pr-ps-buffer-ps-print 4 t) t] - ["Other..." (pr-ps-buffer-ps-print nil t) - :keys "\\[pr-ps-buffer-ps-print]"]) - ("Region" ,pr-:active (ps-mark-active-p) - ["1-up" (pr-ps-region-ps-print 1 t) t] - ["2-up" (pr-ps-region-ps-print 2 t) t] - ["4-up" (pr-ps-region-ps-print 4 t) t] - ["Other..." (pr-ps-region-ps-print nil t) - :keys "\\[pr-ps-region-ps-print]"]) - ("Mode" ,pr-:active (pr-mode-alist-p) - ["1-up" (pr-ps-mode-ps-print 1 t) t] - ["2-up" (pr-ps-mode-ps-print 2 t) t] - ["4-up" (pr-ps-mode-ps-print 4 t) t] - ["Other..." (pr-ps-mode-ps-print nil t) - :keys "\\[pr-ps-mode-ps-print]"]) - ("File" - ["No Preprocessing..." (call-interactively 'pr-ps-file-ps-print) - :keys "\\[pr-ps-file-ps-print]" - ,@(funcall - pr-:help "Send PostScript file to printer")] - "--" - ["PostScript Utility" pr-update-menus :active pr-ps-utility-alist - ,@(funcall - pr-:help "Select PostScript utility")] - "--" - ["1-up..." (pr-ps-file-up-ps-print 1 t t) pr-ps-utility-alist] - ["2-up..." (pr-ps-file-up-ps-print 2 t t) pr-ps-utility-alist] - ["4-up..." (pr-ps-file-up-ps-print 4 t t) pr-ps-utility-alist] - ["Other..." (pr-ps-file-up-ps-print nil t t) - :keys "\\[pr-ps-file-up-ps-print]" :active pr-ps-utility-alist] - "--" - ["Landscape" pr-toggle-file-landscape-menu - :style toggle :selected pr-file-landscape - ,@(funcall - pr-:help "Toggle landscape for PostScript file") - :active pr-ps-utility-alist] - ["Duplex" pr-toggle-file-duplex-menu - :style toggle :selected pr-file-duplex - ,@(funcall - pr-:help "Toggle duplex for PostScript file") - :active pr-ps-utility-alist] - ["Tumble" pr-toggle-file-tumble-menu - :style toggle :selected pr-file-tumble - ,@(funcall - pr-:help "Toggle tumble for PostScript file") - :active (and pr-file-duplex pr-ps-utility-alist)]) - ["Despool..." (call-interactively 'pr-despool-ps-print) - :active pr-spool-p :keys "\\[pr-despool-ps-print]" - ,@(funcall - pr-:help "Despool PostScript buffer to printer or file (C-u)")]) - ["PostScript Printers" pr-update-menus - :active pr-ps-printer-alist :included (pr-visible-p 'postscript) - ,@(funcall - pr-:help "Select PostScript printer")] + ["PostScript Utility" pr-update-menus :active pr-ps-utility-alist + :help "Select PostScript utility"] "--" - ("Printify" :included (pr-visible-p 'text) - ,@(funcall - pr-:help - "Replace non-printing chars with printable representations.") - ["Directory" pr-printify-directory t] - ["Buffer" pr-printify-buffer t] - ["Region" pr-printify-region (ps-mark-active-p)]) - ("Print" :included (pr-visible-p 'text) - ,@(funcall - pr-:help "Send text to printer") - ["Directory" pr-txt-directory t] - ["Buffer" pr-txt-buffer t] - ["Region" pr-txt-region (ps-mark-active-p)] - ["Mode" pr-txt-mode (pr-mode-alist-p)]) - ["Text Printers" pr-update-menus - :active pr-txt-printer-alist :included (pr-visible-p 'text) - ,@(funcall - pr-:help "Select text printer")] + ["1-up..." (pr-ps-file-up-preview 1 t t) pr-ps-utility-alist] + ["2-up..." (pr-ps-file-up-preview 2 t t) pr-ps-utility-alist] + ["4-up..." (pr-ps-file-up-preview 4 t t) pr-ps-utility-alist] + ["Other..." (pr-ps-file-up-preview nil t t) + :keys "\\[pr-ps-file-up-preview]" :active pr-ps-utility-alist] "--" - ["Landscape" pr-toggle-landscape-menu - :style toggle :selected ps-landscape-mode - :included (pr-visible-p 'postscript-options)] - ["Print Header" pr-toggle-header-menu - :style toggle :selected ps-print-header - :included (pr-visible-p 'postscript-options)] - ["Print Header Frame" pr-toggle-header-frame-menu - :style toggle :selected ps-print-header-frame :active ps-print-header - :included (pr-visible-p 'postscript-options)] - ["Line Number" pr-toggle-line-menu - :style toggle :selected ps-line-number - :included (pr-visible-p 'postscript-options)] - ["Zebra Stripes" pr-toggle-zebra-menu - :style toggle :selected ps-zebra-stripes - :included (pr-visible-p 'postscript-options)] - ["Duplex" pr-toggle-duplex-menu - :style toggle :selected ps-spool-duplex - :included (pr-visible-p 'postscript-options)] - ["Tumble" pr-toggle-tumble-menu - :style toggle :selected ps-spool-tumble :active ps-spool-duplex - :included (pr-visible-p 'postscript-options)] - ["Upside-Down" pr-toggle-upside-down-menu - :style toggle :selected ps-print-upside-down - :included (pr-visible-p 'postscript-options)] - ("Print All Pages" :included (pr-visible-p 'postscript-options) - ,@(funcall - pr-:help "Select odd/even pages/sheets to print") - ["All Pages" (pr-even-or-odd-pages nil) - :style radio :selected (eq ps-even-or-odd-pages nil)] - ["Even Pages" (pr-even-or-odd-pages 'even-page) - :style radio :selected (eq ps-even-or-odd-pages 'even-page)] - ["Odd Pages" (pr-even-or-odd-pages 'odd-page) - :style radio :selected (eq ps-even-or-odd-pages 'odd-page)] - ["Even Sheets" (pr-even-or-odd-pages 'even-sheet) - :style radio :selected (eq ps-even-or-odd-pages 'even-sheet)] - ["Odd Sheets" (pr-even-or-odd-pages 'odd-sheet) - :style radio :selected (eq ps-even-or-odd-pages 'odd-sheet)]) + ["Landscape" pr-toggle-file-landscape-menu + :style toggle :selected pr-file-landscape + :help "Toggle landscape for PostScript file" + :active pr-ps-utility-alist] + ["Duplex" pr-toggle-file-duplex-menu + :style toggle :selected pr-file-duplex + :help "Toggle duplex for PostScript file" + :active pr-ps-utility-alist] + ["Tumble" pr-toggle-file-tumble-menu + :style toggle :selected pr-file-tumble + :help "Toggle tumble for PostScript file" + :active (and pr-file-duplex pr-ps-utility-alist)]) + ["Despool..." (call-interactively 'pr-despool-preview) + :active pr-spool-p :keys "\\[pr-despool-preview]" + :help "Despool PostScript buffer to printer or file (C-u)"]) + ("PostScript Print" :included (pr-visible-p 'postscript) + :help "Send PostScript to printer or file (C-u)" + ("Directory" + ["1-up" (pr-ps-directory-ps-print 1 nil nil t) t] + ["2-up" (pr-ps-directory-ps-print 2 nil nil t) t] + ["4-up" (pr-ps-directory-ps-print 4 nil nil t) t] + ["Other..." (pr-ps-directory-ps-print nil nil nil t) + :keys "\\[pr-ps-buffer-ps-print]"]) + ("Buffer" + ["1-up" (pr-ps-buffer-ps-print 1 t) t] + ["2-up" (pr-ps-buffer-ps-print 2 t) t] + ["4-up" (pr-ps-buffer-ps-print 4 t) t] + ["Other..." (pr-ps-buffer-ps-print nil t) + :keys "\\[pr-ps-buffer-ps-print]"]) + ("Region" :active (ps-mark-active-p) + ["1-up" (pr-ps-region-ps-print 1 t) t] + ["2-up" (pr-ps-region-ps-print 2 t) t] + ["4-up" (pr-ps-region-ps-print 4 t) t] + ["Other..." (pr-ps-region-ps-print nil t) + :keys "\\[pr-ps-region-ps-print]"]) + ("Mode" :active (pr-mode-alist-p) + ["1-up" (pr-ps-mode-ps-print 1 t) t] + ["2-up" (pr-ps-mode-ps-print 2 t) t] + ["4-up" (pr-ps-mode-ps-print 4 t) t] + ["Other..." (pr-ps-mode-ps-print nil t) + :keys "\\[pr-ps-mode-ps-print]"]) + ("File" + ["No Preprocessing..." (call-interactively 'pr-ps-file-ps-print) + :keys "\\[pr-ps-file-ps-print]" + :help "Send PostScript file to printer"] "--" - ["Spool Buffer" pr-toggle-spool-menu - :style toggle :selected pr-spool-p - :included (pr-visible-p 'postscript-process) - ,@(funcall - pr-:help "Toggle PostScript spooling")] - ["Print with faces" pr-toggle-faces-menu - :style toggle :selected pr-faces-p - :included (pr-visible-p 'postscript-process) - ,@(funcall - pr-:help "Toggle PostScript printing with faces")] - ["Print via Ghostscript" pr-toggle-ghostscript-menu - :style toggle :selected pr-print-using-ghostscript - :included (pr-visible-p 'postscript-process) - ,@(funcall - pr-:help "Toggle PostScript generation using ghostscript")] + ["PostScript Utility" pr-update-menus :active pr-ps-utility-alist + :help "Select PostScript utility"] "--" - ["Auto Region" pr-toggle-region-menu - :style toggle :selected pr-auto-region - :included (pr-visible-p 'printing)] - ["Auto Mode" pr-toggle-mode-menu - :style toggle :selected pr-auto-mode - :included (pr-visible-p 'printing)] - ["Menu Lock" pr-toggle-lock-menu - :style toggle :selected pr-menu-lock - :included (pr-visible-p 'printing)] + ["1-up..." (pr-ps-file-up-ps-print 1 t t) pr-ps-utility-alist] + ["2-up..." (pr-ps-file-up-ps-print 2 t t) pr-ps-utility-alist] + ["4-up..." (pr-ps-file-up-ps-print 4 t t) pr-ps-utility-alist] + ["Other..." (pr-ps-file-up-ps-print nil t t) + :keys "\\[pr-ps-file-up-ps-print]" :active pr-ps-utility-alist] "--" - ("Customize" :included (pr-visible-p 'help) - ["printing" pr-customize t] - ["ps-print" ps-print-customize t] - ["lpr" lpr-customize t]) - ("Show Settings" :included (pr-visible-p 'help) - ["printing" pr-show-pr-setup t] - ["ps-print" pr-show-ps-setup t] - ["lpr" pr-show-lpr-setup t]) - ["Help" pr-help :active t :included (pr-visible-p 'help)] - ))) + ["Landscape" pr-toggle-file-landscape-menu + :style toggle :selected pr-file-landscape + :help "Toggle landscape for PostScript file" + :active pr-ps-utility-alist] + ["Duplex" pr-toggle-file-duplex-menu + :style toggle :selected pr-file-duplex + :help "Toggle duplex for PostScript file" + :active pr-ps-utility-alist] + ["Tumble" pr-toggle-file-tumble-menu + :style toggle :selected pr-file-tumble + :help "Toggle tumble for PostScript file" + :active (and pr-file-duplex pr-ps-utility-alist)]) + ["Despool..." (call-interactively 'pr-despool-ps-print) + :active pr-spool-p :keys "\\[pr-despool-ps-print]" + :help "Despool PostScript buffer to printer or file (C-u)"]) + ["PostScript Printers" pr-update-menus + :active pr-ps-printer-alist :included (pr-visible-p 'postscript) + :help "Select PostScript printer"] + "--" + ("Printify" :included (pr-visible-p 'text) + :help + "Replace non-printing chars with printable representations." + ["Directory" pr-printify-directory t] + ["Buffer" pr-printify-buffer t] + ["Region" pr-printify-region (ps-mark-active-p)]) + ("Print" :included (pr-visible-p 'text) + :help "Send text to printer" + ["Directory" pr-txt-directory t] + ["Buffer" pr-txt-buffer t] + ["Region" pr-txt-region (ps-mark-active-p)] + ["Mode" pr-txt-mode (pr-mode-alist-p)]) + ["Text Printers" pr-update-menus + :active pr-txt-printer-alist :included (pr-visible-p 'text) + :help "Select text printer"] + "--" + ["Landscape" pr-toggle-landscape-menu + :style toggle :selected ps-landscape-mode + :included (pr-visible-p 'postscript-options)] + ["Print Header" pr-toggle-header-menu + :style toggle :selected ps-print-header + :included (pr-visible-p 'postscript-options)] + ["Print Header Frame" pr-toggle-header-frame-menu + :style toggle :selected ps-print-header-frame :active ps-print-header + :included (pr-visible-p 'postscript-options)] + ["Line Number" pr-toggle-line-menu + :style toggle :selected ps-line-number + :included (pr-visible-p 'postscript-options)] + ["Zebra Stripes" pr-toggle-zebra-menu + :style toggle :selected ps-zebra-stripes + :included (pr-visible-p 'postscript-options)] + ["Duplex" pr-toggle-duplex-menu + :style toggle :selected ps-spool-duplex + :included (pr-visible-p 'postscript-options)] + ["Tumble" pr-toggle-tumble-menu + :style toggle :selected ps-spool-tumble :active ps-spool-duplex + :included (pr-visible-p 'postscript-options)] + ["Upside-Down" pr-toggle-upside-down-menu + :style toggle :selected ps-print-upside-down + :included (pr-visible-p 'postscript-options)] + ("Print All Pages" :included (pr-visible-p 'postscript-options) + :help "Select odd/even pages/sheets to print" + ["All Pages" (pr-even-or-odd-pages nil) + :style radio :selected (eq ps-even-or-odd-pages nil)] + ["Even Pages" (pr-even-or-odd-pages 'even-page) + :style radio :selected (eq ps-even-or-odd-pages 'even-page)] + ["Odd Pages" (pr-even-or-odd-pages 'odd-page) + :style radio :selected (eq ps-even-or-odd-pages 'odd-page)] + ["Even Sheets" (pr-even-or-odd-pages 'even-sheet) + :style radio :selected (eq ps-even-or-odd-pages 'even-sheet)] + ["Odd Sheets" (pr-even-or-odd-pages 'odd-sheet) + :style radio :selected (eq ps-even-or-odd-pages 'odd-sheet)]) + "--" + ["Spool Buffer" pr-toggle-spool-menu + :style toggle :selected pr-spool-p + :included (pr-visible-p 'postscript-process) + :help "Toggle PostScript spooling"] + ["Print with faces" pr-toggle-faces-menu + :style toggle :selected pr-faces-p + :included (pr-visible-p 'postscript-process) + :help "Toggle PostScript printing with faces"] + ["Print via Ghostscript" pr-toggle-ghostscript-menu + :style toggle :selected pr-print-using-ghostscript + :included (pr-visible-p 'postscript-process) + :help "Toggle PostScript generation using ghostscript"] + "--" + ["Auto Region" pr-toggle-region-menu + :style toggle :selected pr-auto-region + :included (pr-visible-p 'printing)] + ["Auto Mode" pr-toggle-mode-menu + :style toggle :selected pr-auto-mode + :included (pr-visible-p 'printing)] + ["Menu Lock" pr-toggle-lock-menu + :style toggle :selected pr-menu-lock + :included (pr-visible-p 'printing)] + "--" + ("Customize" :included (pr-visible-p 'help) + ["printing" pr-customize t] + ["ps-print" ps-print-customize t] + ["lpr" lpr-customize t]) + ("Show Settings" :included (pr-visible-p 'help) + ["printing" pr-show-pr-setup t] + ["ps-print" pr-show-ps-setup t] + ["lpr" pr-show-lpr-setup t]) + ["Help" pr-help :active t :included (pr-visible-p 'help)] + )) (defun pr-menu-bind () @@ -3453,19 +2999,17 @@ Calls `pr-update-menus' to adjust menus." ;; Key binding -(let ((pr-print-key (if (featurep 'xemacs) - 'f22 ; XEmacs - 'print))) ; GNU Emacs - (global-set-key `[,pr-print-key] 'pr-ps-fast-fire) - ;; Well, M-print and S-print are used because in my keyboard S-print works - ;; and M-print doesn't. But M-print can work in other keyboard. - (global-set-key `[(meta ,pr-print-key)] 'pr-ps-mode-using-ghostscript) - (global-set-key `[(shift ,pr-print-key)] 'pr-ps-mode-using-ghostscript) - ;; Well, C-print and C-M-print are used because in my keyboard C-M-print works - ;; and C-print doesn't. But C-print can work in other keyboard. - (global-set-key `[(control ,pr-print-key)] 'pr-txt-fast-fire) - (global-set-key `[(control meta ,pr-print-key)] 'pr-txt-fast-fire)) - +;; FIXME: These should be moved to a function so that just loading the file +;; doesn't affect the global keymap! +(global-set-key [print] 'pr-ps-fast-fire) +;; Well, M-print and S-print are used because on my keyboard S-print works +;; and M-print doesn't. But M-print can work on other keyboards. +(global-set-key [(meta print)] 'pr-ps-mode-using-ghostscript) +(global-set-key [(shift print)] 'pr-ps-mode-using-ghostscript) +;; Well, C-print and C-M-print are used because in my keyboard C-M-print works +;; and C-print doesn't. But C-print can work in other keyboard. +(global-set-key [(control print)] 'pr-txt-fast-fire) +(global-set-key [(control meta print)] 'pr-txt-fast-fire) ;;; You can also use something like: ;;;(global-set-key "\C-ci" 'pr-interface) @@ -3962,13 +3506,16 @@ file name. See also documentation for `pr-list-directory'." (interactive (pr-interactive-ps-dir-args (pr-prompt "PS preview dir"))) - (pr-set-ps-dir-args 'n-up 'dir 'file-regexp 'filename - (pr-prompt "PS preview dir")) - (setq filename (pr-ps-file filename)) - (pr-ps-file-list n-up dir file-regexp filename) - (or pr-spool-p - (pr-ps-file-preview filename))) - + (defvar pr--n-up) (defvar pr--dir) (defvar pr--file-regexp) + (defvar pr--filename) + (let ((pr--n-up n-up) (pr--dir dir) (pr--file-regexp file-regexp) + (pr--filename filename)) + (pr-set-ps-dir-args 'pr--n-up 'pr--dir 'pr--file-regexp 'pr--filename + (pr-prompt "PS preview dir")) + (setq pr--filename (pr-ps-file pr--filename)) + (pr-ps-file-list pr--n-up pr--dir pr--file-regexp pr--filename) + (or pr-spool-p + (pr-ps-file-preview pr--filename)))) ;;;###autoload (defun pr-ps-directory-using-ghostscript (n-up dir file-regexp &optional filename) @@ -3988,12 +3535,16 @@ file name. See also documentation for `pr-list-directory'." (interactive (pr-interactive-ps-dir-args (pr-prompt "PS print dir GS"))) - (pr-set-ps-dir-args 'n-up 'dir 'file-regexp 'filename - (pr-prompt "PS print dir GS")) - (let ((file (pr-ps-file filename))) - (pr-ps-file-list n-up dir file-regexp file) - (pr-ps-file-using-ghostscript file) - (or filename (pr-delete-file file)))) + (defvar pr--n-up) (defvar pr--dir) (defvar pr--file-regexp) + (defvar pr--filename) + (let ((pr--n-up n-up) (pr--dir dir) (pr--file-regexp file-regexp) + (pr--filename filename)) + (pr-set-ps-dir-args 'pr--n-up 'pr--dir 'pr--file-regexp 'pr--filename + (pr-prompt "PS print dir GS")) + (let ((file (pr-ps-file pr--filename))) + (pr-ps-file-list pr--n-up pr--dir pr--file-regexp file) + (pr-ps-file-using-ghostscript file) + (or pr--filename (pr-delete-file file))))) ;;;###autoload @@ -4014,12 +3565,16 @@ file name. See also documentation for `pr-list-directory'." (interactive (pr-interactive-ps-dir-args (pr-prompt "PS print dir"))) - (pr-set-ps-dir-args 'n-up 'dir 'file-regexp 'filename - (pr-prompt "PS print dir")) - (let ((file (pr-ps-file filename))) - (pr-ps-file-list n-up dir file-regexp file) - (pr-ps-file-print file) - (or filename (pr-delete-file file)))) + (defvar pr--n-up) (defvar pr--dir) (defvar pr--file-regexp) + (defvar pr--filename) + (let ((pr--n-up n-up) (pr--dir dir) (pr--file-regexp file-regexp) + (pr--filename filename)) + (pr-set-ps-dir-args 'pr--n-up 'pr--dir 'pr--file-regexp 'pr--filename + (pr-prompt "PS print dir")) + (let ((file (pr-ps-file pr--filename))) + (pr-ps-file-list pr--n-up pr--dir pr--file-regexp file) + (pr-ps-file-print file) + (or pr--filename (pr-delete-file file))))) ;;;###autoload @@ -4043,11 +3598,16 @@ file name. See also documentation for `pr-list-directory'." (interactive (pr-interactive-ps-dir-args (pr-prompt (pr-prompt-gs "PS print dir")))) - (pr-set-ps-dir-args 'n-up 'dir 'file-regexp 'filename - (pr-prompt (pr-prompt-gs "PS print dir"))) - (if (pr-using-ghostscript-p) - (pr-ps-directory-using-ghostscript n-up dir file-regexp filename) - (pr-ps-directory-print n-up dir file-regexp filename))) + (defvar pr--n-up) (defvar pr--dir) (defvar pr--file-regexp) + (defvar pr--filename) + (let ((pr--n-up n-up) (pr--dir dir) (pr--file-regexp file-regexp) + (pr--filename filename)) + (pr-set-ps-dir-args 'pr--n-up 'pr--dir 'pr--file-regexp 'pr--filename + (pr-prompt (pr-prompt-gs "PS print dir"))) + (funcall (if (pr-using-ghostscript-p) + #'pr-ps-directory-using-ghostscript + #'pr-ps-directory-print) + pr--n-up pr--dir pr--file-regexp pr--filename))) ;;;###autoload @@ -4191,11 +3751,13 @@ See also `pr-ps-buffer-ps-print'." See also `pr-ps-buffer-preview'." (interactive (pr-interactive-n-up-file "PS preview mode")) - (pr-set-n-up-and-filename 'n-up 'filename "PS preview mode") - (let ((file (pr-ps-file filename))) - (and (pr-ps-mode n-up file) - (not pr-spool-p) - (pr-ps-file-preview file)))) + (defvar pr--n-up) (defvar pr--filename) + (let ((pr--n-up n-up) (pr--filename filename)) + (pr-set-n-up-and-filename 'pr--n-up 'pr--filename "PS preview mode") + (let ((file (pr-ps-file pr--filename))) + (and (pr-ps-mode pr--n-up file) + (not pr-spool-p) + (pr-ps-file-preview file))))) ;;;###autoload @@ -4204,12 +3766,14 @@ See also `pr-ps-buffer-preview'." See also `pr-ps-buffer-using-ghostscript'." (interactive (pr-interactive-n-up-file "PS print GS mode")) - (pr-set-n-up-and-filename 'n-up 'filename "PS print GS mode") - (let ((file (pr-ps-file filename))) - (when (and (pr-ps-mode n-up file) - (not pr-spool-p)) - (pr-ps-file-using-ghostscript file) - (or filename (pr-delete-file file))))) + (defvar pr--n-up) (defvar pr--filename) + (let ((pr--n-up n-up) (pr--filename filename)) + (pr-set-n-up-and-filename 'pr--n-up 'pr--filename "PS print GS mode") + (let ((file (pr-ps-file pr--filename))) + (when (and (pr-ps-mode pr--n-up file) + (not pr-spool-p)) + (pr-ps-file-using-ghostscript file) + (or pr--filename (pr-delete-file file)))))) ;;;###autoload @@ -4218,8 +3782,10 @@ See also `pr-ps-buffer-using-ghostscript'." See also `pr-ps-buffer-print'." (interactive (pr-interactive-n-up-file "PS print mode")) - (pr-set-n-up-and-filename 'n-up 'filename "PS print mode") - (pr-ps-mode n-up filename)) + (defvar pr--n-up) (defvar pr--filename) + (let ((pr--n-up n-up) (pr--filename filename)) + (pr-set-n-up-and-filename 'pr--n-up 'pr--filename "PS print mode") + (pr-ps-mode pr--n-up pr--filename))) ;;;###autoload @@ -4247,8 +3813,10 @@ prompts for FILE(name)-REGEXP. See also documentation for `pr-list-directory'." (interactive (pr-interactive-dir-args "Printify dir")) - (pr-set-dir-args 'dir 'file-regexp "Printify dir") - (pr-file-list dir file-regexp 'pr-printify-buffer)) + (defvar pr--dir) (defvar pr--file-regexp) + (let ((pr--dir dir) (pr--file-regexp file-regexp)) + (pr-set-dir-args 'pr--dir 'pr--file-regexp "Printify dir") + (pr-file-list pr--dir pr--file-regexp 'pr-printify-buffer))) ;;;###autoload @@ -4283,8 +3851,10 @@ prompts for FILE(name)-REGEXP. See also documentation for `pr-list-directory'." (interactive (pr-interactive-dir-args "Print dir")) - (pr-set-dir-args 'dir 'file-regexp "Print dir") - (pr-file-list dir file-regexp 'pr-txt-buffer)) + (defvar pr--dir) (defvar pr--file-regexp) + (let ((pr--dir dir) (pr--file-regexp file-regexp)) + (pr-set-dir-args 'pr--dir 'pr--file-regexp "Print dir") + (pr-file-list pr--dir pr--file-regexp 'pr-txt-buffer))) ;;;###autoload @@ -4406,10 +3976,12 @@ image in a file with that name." (defun pr-ps-file-up-preview (n-up ifilename &optional ofilename) "Preview PostScript file FILENAME." (interactive (pr-interactive-n-up-inout "PS preview")) - (let ((outfile (pr-ps-utility-args 'n-up 'ifilename 'ofilename - "PS preview "))) - (pr-ps-utility-process n-up ifilename outfile) - (pr-ps-file-preview outfile))) + (defvar pr--n-up) (defvar pr--ifilename) (defvar pr--ofilename) + (let ((pr--n-up n-up) (pr--ifilename ifilename) (pr--ofilename ofilename)) + (let ((outfile (pr-ps-utility-args 'pr--n-up 'pr--ifilename 'pr--ofilename + "PS preview "))) + (pr-ps-utility-process pr--n-up pr--ifilename outfile) + (pr-ps-file-preview outfile)))) ;;;###autoload @@ -4417,15 +3989,18 @@ image in a file with that name." "Print PostScript file FILENAME using ghostscript." (interactive (list (pr-ps-infile-preprint "Print preview "))) (and (stringp filename) (file-exists-p filename) - (let* ((file (pr-expand-file-name filename)) - (tempfile (pr-dosify-file-name (make-temp-file file)))) + (let* ((file (expand-file-name filename)) + (tempfile (make-temp-file file))) ;; gs use (pr-call-process pr-gs-command (format "-sDEVICE=%s" pr-gs-device) (format "-r%d" pr-gs-resolution) (pr-switches-string pr-gs-switches "pr-gs-switches") - (format "-sOutputFile=\"%s\"" tempfile) - file + (format "-sOutputFile=\"%s\"" + ;; FIXME: Do we need to dosify here really? + (pr-dosify-file-name tempfile)) + ;; FIXME: Do we need to dosify here really? + (pr-dosify-file-name file) "-c quit") ;; printing (pr-ps-file-print tempfile) @@ -4439,7 +4014,7 @@ image in a file with that name." (interactive (list (pr-ps-infile-preprint "Print "))) (and (stringp filename) (file-exists-p filename) ;; printing - (let ((file (pr-expand-file-name filename))) + (let ((file (expand-file-name filename))) (if (string= pr-ps-command "") ;; default action (let ((ps-spool-buffer (get-buffer-create ps-spool-buffer-name))) @@ -4448,16 +4023,16 @@ image in a file with that name." (insert-file-contents-literally file)) (pr-despool-print)) ;; use `pr-ps-command' to print - (apply 'pr-call-process + (apply #'pr-call-process pr-ps-command (pr-switches-string pr-ps-switches "pr-ps-switches") (if (string-match "cp" pr-ps-command) ;; for "cp" (cmd in out) - (list file + (list (pr-dosify-file-name file) (concat pr-ps-printer-switch pr-ps-printer)) ;; else, for others (cmd out in) (list (concat pr-ps-printer-switch pr-ps-printer) - file))))))) + (pr-dosify-file-name file)))))))) ;;;###autoload @@ -4492,14 +4067,16 @@ file name." (if pr-print-using-ghostscript "PS print GS" "PS print"))) - (let ((outfile (pr-ps-utility-args 'n-up 'ifilename 'ofilename - (if pr-print-using-ghostscript - "PS print GS " - "PS print ")))) - (pr-ps-utility-process n-up ifilename outfile) - (unless ofilename - (pr-ps-file-ps-print outfile) - (pr-delete-file outfile)))) + (defvar pr--n-up) (defvar pr--ifilename) (defvar pr--ofilename) + (let ((pr--n-up n-up) (pr--ifilename ifilename) (pr--ofilename ofilename)) + (let ((outfile (pr-ps-utility-args 'pr--n-up 'pr--ifilename 'pr--ofilename + (if pr-print-using-ghostscript + "PS print GS " + "PS print ")))) + (pr-ps-utility-process pr--n-up pr--ifilename outfile) + (unless pr--ofilename + (pr-ps-file-ps-print outfile) + (pr-delete-file outfile))))) ;;;###autoload @@ -5210,9 +4787,9 @@ If menu binding was not done, calls `pr-menu-bind'." (let ((sym (car elt))) (vector (symbol-name sym) - (list fun (list 'quote sym) nil (list 'quote entry) index) + `(,fun ',sym nil ',entry ',index) :style 'radio - :selected (list 'eq var-sym (list 'quote sym))))) + :selected `(eq ,var-sym ',sym)))) alist))) @@ -5224,7 +4801,7 @@ If menu binding was not done, calls `pr-menu-bind'." value)) (setq pr-ps-utility value) (pr-eval-alist (nthcdr 9 item))) - (pr-update-mode-line)) + (force-mode-line-update)) (defun pr-ps-set-printer (value) @@ -5234,7 +4811,7 @@ If menu binding was not done, calls `pr-menu-bind'." "Invalid PostScript printer name `%s' for variable `pr-ps-name'" value)) (setq pr-ps-name value - pr-ps-command (pr-dosify-file-name (nth 0 ps)) + pr-ps-command (nth 0 ps) pr-ps-switches (nth 1 ps) pr-ps-printer-switch (nth 2 ps) pr-ps-printer (nth 3 ps)) @@ -5251,7 +4828,7 @@ If menu binding was not done, calls `pr-menu-bind'." (t "-P") ))) (pr-eval-alist (nthcdr 4 ps))) - (pr-update-mode-line)) + (force-mode-line-update)) (defun pr-txt-set-printer (value) @@ -5260,7 +4837,7 @@ If menu binding was not done, calls `pr-menu-bind'." (error "Invalid text printer name `%s' for variable `pr-txt-name'" value)) (setq pr-txt-name value - pr-txt-command (pr-dosify-file-name (nth 0 txt)) + pr-txt-command (nth 0 txt) pr-txt-switches (nth 1 txt) pr-txt-printer (nth 2 txt))) (or (stringp pr-txt-command) @@ -5269,30 +4846,28 @@ If menu binding was not done, calls `pr-menu-bind'." (lpr-lp-system "lp") (t "lpr") ))) - (pr-update-mode-line)) + (force-mode-line-update)) (defun pr-eval-alist (alist) - (mapcar #'(lambda (option) - (let ((var-sym (car option)) - (value (cdr option))) - (if (eq var-sym 'inherits-from:) - (pr-eval-setting-alist value 'global) - (set var-sym (eval value))))) - alist)) + (dolist (option alist) + (let ((var-sym (car option)) + (value (cdr option))) + (if (eq var-sym 'inherits-from:) + (pr-eval-setting-alist value 'global) + (set var-sym (eval value)))))) (defun pr-eval-local-alist (alist) (let (local-list) - (mapc #'(lambda (option) - (let ((var-sym (car option)) - (value (cdr option))) - (setq local-list - (if (eq var-sym 'inherits-from:) - (nconc (pr-eval-setting-alist value) local-list) - (set (make-local-variable var-sym) (eval value)) - (cons var-sym local-list))))) - alist) + (dolist (option alist) + (let ((var-sym (car option)) + (value (cdr option))) + (setq local-list + (if (eq var-sym 'inherits-from:) + (nconc (pr-eval-setting-alist value) local-list) + (set (make-local-variable var-sym) (eval value)) + (cons var-sym local-list))))) local-list)) @@ -5338,7 +4913,7 @@ If menu binding was not done, calls `pr-menu-bind'." (defun pr-kill-local-variable (local-var-list) - (mapcar 'kill-local-variable local-var-list)) + (mapcar #'kill-local-variable local-var-list)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -5526,10 +5101,6 @@ If menu binding was not done, calls `pr-menu-bind'." (delete-file file))) -(defun pr-expand-file-name (filename) - (pr-dosify-file-name (expand-file-name filename))) - - (defun pr-ps-outfile-preprint (&optional mess) (let* ((prompt (format "%soutput PostScript file name: " (or mess ""))) (res (read-file-name prompt default-directory "" nil))) @@ -5549,7 +5120,7 @@ If menu binding was not done, calls `pr-menu-bind'." (format "File %s; PostScript file: " prompt) (file-name-directory res) nil nil (file-name-nondirectory res)))) - (pr-expand-file-name res))) + (expand-file-name res))) (defun pr-ps-infile-preprint (&optional mess) @@ -5569,7 +5140,7 @@ If menu binding was not done, calls `pr-menu-bind'." (format "File %s; PostScript file: " prompt) (file-name-directory res) nil nil (file-name-nondirectory res)))) - (pr-expand-file-name res))) + (expand-file-name res))) (defun pr-ps-utility-args (n-up-sym infile-sym outfile-sym prompt) @@ -5582,13 +5153,10 @@ If menu binding was not done, calls `pr-menu-bind'." (set infile-sym (pr-ps-infile-preprint prompt))) (or (symbol-value infile-sym) (error "%s: input PostScript file name is missing" prompt)) - (set infile-sym (pr-dosify-file-name (symbol-value infile-sym))) ;; output file (and (eq (symbol-value outfile-sym) t) (set outfile-sym (and current-prefix-arg (pr-ps-outfile-preprint prompt)))) - (and (symbol-value outfile-sym) - (set outfile-sym (pr-dosify-file-name (symbol-value outfile-sym)))) (pr-ps-file (symbol-value outfile-sym))) @@ -5608,9 +5176,9 @@ If menu binding was not done, calls `pr-menu-bind'." (and pr-file-landscape (nth 4 item)) (and pr-file-duplex (nth 5 item)) (and pr-file-tumble (nth 6 item)) - (pr-expand-file-name infile) + (pr-dosify-file-name (expand-file-name infile)) (nth 7 item) - (pr-expand-file-name outfile))))) + (pr-dosify-file-name (expand-file-name outfile)))))) (defun pr-remove-nil-from-list (lst) @@ -5640,7 +5208,7 @@ If menu binding was not done, calls `pr-menu-bind'." (with-file-modes pr-file-modes (setq status (condition-case data - (apply 'call-process cmd nil buffer nil args) + (apply #'call-process cmd nil buffer nil args) ((quit error) (error-message-string data))))) ;; *Printing Command Output* == show exit status @@ -5666,47 +5234,53 @@ If menu binding was not done, calls `pr-menu-bind'." ;; If SWITCHES is nil, return nil. ;; Otherwise, return the list of string in a string. (and switches - (mapconcat 'identity (pr-switches switches mess) " "))) + (mapconcat #'identity (pr-switches switches mess) " "))) (defun pr-switches (switches mess) (or (listp switches) (error "%S should have a list of strings" mess)) - (lpr-flatten-list ; dynamic evaluation + (flatten-tree ; dynamic evaluation (mapcar #'lpr-eval-switch switches))) (defun pr-ps-preview (kind n-up filename mess) - (pr-set-n-up-and-filename 'n-up 'filename mess) - (let ((file (pr-ps-file filename))) - (pr-text2ps kind n-up file) - (or pr-spool-p (pr-ps-file-preview file)))) + (defvar pr--n-up) (defvar pr--filename) + (let ((pr--n-up n-up) (pr--filename filename)) + (pr-set-n-up-and-filename 'pr--n-up 'pr--filename mess) + (let ((file (pr-ps-file pr--filename))) + (pr-text2ps kind pr--n-up file) + (or pr-spool-p (pr-ps-file-preview file))))) (defun pr-ps-using-ghostscript (kind n-up filename mess) - (pr-set-n-up-and-filename 'n-up 'filename mess) - (let ((file (pr-ps-file filename))) - (pr-text2ps kind n-up file) - (unless (or pr-spool-p filename) - (pr-ps-file-using-ghostscript file) - (pr-delete-file file)))) + (defvar pr--n-up) (defvar pr--filename) + (let ((pr--n-up n-up) (pr--filename filename)) + (pr-set-n-up-and-filename 'pr--n-up 'pr--filename mess) + (let ((file (pr-ps-file pr--filename))) + (pr-text2ps kind pr--n-up file) + (unless (or pr-spool-p pr--filename) + (pr-ps-file-using-ghostscript file) + (pr-delete-file file))))) (defun pr-ps-print (kind n-up filename mess) - (pr-set-n-up-and-filename 'n-up 'filename mess) - (let ((file (pr-ps-file filename))) - (pr-text2ps kind n-up file) - (unless (or pr-spool-p filename) - (pr-ps-file-print file) - (pr-delete-file file)))) + (defvar pr--n-up) (defvar pr--filename) + (let ((pr--n-up n-up) (pr--filename filename)) + (pr-set-n-up-and-filename 'pr--n-up 'pr--filename mess) + (let ((file (pr-ps-file pr--filename))) + (pr-text2ps kind pr--n-up file) + (unless (or pr-spool-p pr--filename) + (pr-ps-file-print file) + (pr-delete-file file))))) (defun pr-ps-file (&optional filename) - (pr-dosify-file-name (or filename - (make-temp-file - (convert-standard-filename - (expand-file-name pr-ps-temp-file pr-temp-dir)) - nil ".ps")))) + (or filename + (make-temp-file + (convert-standard-filename + (expand-file-name pr-ps-temp-file pr-temp-dir)) + nil ".ps"))) (defun pr-interactive-n-up (mess) @@ -5714,7 +5288,7 @@ If menu binding was not done, calls `pr-menu-bind'." (save-match-data (let* ((fmt-prompt "%s[%s] N-up printing (default 1): ") (prompt "") - (str (pr-read-string (format fmt-prompt prompt mess) "1" nil "1")) + (str (read-string (format fmt-prompt prompt mess) nil nil "1")) int) (while (if (string-match "^\\s *[0-9]+$" str) (setq int (string-to-number str) @@ -5724,7 +5298,7 @@ If menu binding was not done, calls `pr-menu-bind'." (setq prompt "Invalid integer syntax; ")) (ding) (setq str - (pr-read-string (format fmt-prompt prompt mess) str nil "1"))) + (read-string (format fmt-prompt prompt mess) str nil "1"))) int))) @@ -5749,7 +5323,7 @@ If menu binding was not done, calls `pr-menu-bind'." (defun pr-interactive-regexp (mess) - (pr-read-string (format "[%s] File regexp to print: " mess) "" nil "")) + (read-string (format "[%s] File regexp to print: " mess) nil nil "")) (defun pr-interactive-dir-args (mess) @@ -5796,9 +5370,7 @@ If menu binding was not done, calls `pr-menu-bind'." (and (not pr-spool-p) (eq (symbol-value filename-sym) t) (set filename-sym (and current-prefix-arg - (ps-print-preprint current-prefix-arg)))) - (and (symbol-value filename-sym) - (set filename-sym (pr-dosify-file-name (symbol-value filename-sym))))) + (ps-print-preprint current-prefix-arg))))) (defun pr-set-n-up-and-filename (n-up-sym filename-sym mess) @@ -5875,7 +5447,7 @@ If menu binding was not done, calls `pr-menu-bind'." (defun pr-ps-file-list (n-up dir file-regexp filename) - (pr-delete-file-if-exists (setq filename (pr-expand-file-name filename))) + (pr-delete-file-if-exists (setq filename (expand-file-name filename))) (let ((pr-spool-p t)) (pr-file-list dir file-regexp #'(lambda () @@ -5941,15 +5513,14 @@ If Emacs is running on Windows 95/98/NT/2000, tries to find COMMAND, COMMAND.exe, COMMAND.bat and COMMAND.com in this order." (if (string= command "") command - (pr-dosify-file-name - (or (pr-find-command command) - (pr-path-command (cond (pr-cygwin-system 'cygwin) - (lpr-windows-system 'windows) - (t 'unix)) - (file-name-nondirectory command) - nil) - (error "Command not found: %s" - (file-name-nondirectory command)))))) + (or (pr-find-command command) + (pr-path-command (cond (pr-cygwin-system 'cygwin) + (lpr-windows-system 'windows) + (t 'unix)) + (file-name-nondirectory command) + nil) + (error "Command not found: %s" + (file-name-nondirectory command))))) (defun pr-path-command (symbol command sym-list) @@ -6004,12 +5575,6 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order." ;; Printing Interface (inspired by ps-print-interface.el) -(eval-when-compile - (require 'cus-edit) - (require 'wid-edit) - (require 'widget)) - - (defvar pr-i-window-configuration nil) (defvar pr-i-buffer nil) @@ -6027,20 +5592,13 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order." (defvar pr-i-ps-send 'printer) -(defvar pr-interface-map nil - "Keymap for pr-interface.") - -(unless pr-interface-map +(defvar pr-interface-map (let ((map (make-sparse-keymap))) - (cond ((featurep 'xemacs) ; XEmacs - (pr-set-keymap-parents map (list widget-keymap)) - (pr-set-keymap-name map 'pr-interface-map)) - (t ; GNU Emacs - (pr-set-keymap-parents map widget-keymap))) + (set-keymap-parent map widget-keymap) (define-key map "q" 'pr-interface-quit) (define-key map "?" 'pr-interface-help) - (setq pr-interface-map map))) - + map) + "Keymap for pr-interface.") (defmacro pr-interface-save (&rest body) `(with-current-buffer pr-i-buffer @@ -6111,15 +5669,13 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order." (setq found (string-match (car ignore) name) ignore (cdr ignore))) (or found - (setq choices - (cons (list 'quote - (list 'choice-item - :format "%[%t%]" - name)) - choices))))) + (push (list 'choice-item + :format "%[%t%]" + name) + choices)))) (nreverse choices)) " Buffer : " nil - '(progn + (lambda () (pr-interface-save (setq pr-i-region (ps-mark-active-p) pr-i-mode (pr-mode-alist-p))) @@ -6345,11 +5901,10 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order." (pr-insert-italic "\n\nSelect Pages : " 2 14) (pr-insert-menu "Page Parity" 'ps-even-or-odd-pages (mapcar #'(lambda (alist) - (list 'quote - (list 'choice-item - :format "%[%t%]" - :tag (cdr alist) - :value (car alist)))) + (list 'choice-item + :format "%[%t%]" + :tag (cdr alist) + :value (car alist))) pr-even-or-odd-alist))) @@ -6605,8 +6160,8 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order." (defun pr-insert-toggle (var-sym label) (widget-create 'checkbox - :notify `(lambda (&rest _ignore) - (setq ,var-sym (not ,var-sym))) + :notify (lambda (&rest _ignore) + (set var-sym (not (symbol-value var-sym)))) (symbol-value var-sym)) (widget-insert label)) @@ -6619,32 +6174,32 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order." (widget-insert separator))) -(defun pr-insert-menu (tag var-sym choices &optional before after &rest body) +(defun pr-insert-menu (tag var-sym choices &optional before after body) (and before (widget-insert before)) - (eval `(widget-create 'menu-choice - :tag ,tag - :format "%v" - :inline t - :value ,var-sym - :notify (lambda (widget &rest _ignore) - (setq ,var-sym (widget-value widget)) - ,@body) - :void '(choice-item :format "%[%t%]" - :tag "Can not display value!") - ,@choices)) - (and after (widget-insert after))) + (apply #'widget-create 'menu-choice + :tag tag + :format "%v" + :inline t + :value (symbol-value var-sym) + :notify (lambda (widget &rest _ignore) + (set var-sym (widget-value widget)) + (when body (funcall body))) + :void '(choice-item :format "%[%t%]" + :tag "Can not display value!") + choices) + (and after (widget-insert after))) (defun pr-insert-radio-button (var-sym sym) (widget-insert "\n") (let ((wid-list (get var-sym 'pr-widget-list)) - (wid (eval `(widget-create - 'radio-button - :format " %[%v%]" - :value (eq ,var-sym (quote ,sym)) - :notify (lambda (&rest _ignore) - (setq ,var-sym (quote ,sym)) - (pr-update-radio-button (quote ,var-sym))))))) + (wid (widget-create + 'radio-button + :format " %[%v%]" + :value (eq (symbol-value var-sym) sym) + :notify (lambda (&rest _ignore) + (set var-sym sym) + (pr-update-radio-button var-sym))))) (put var-sym 'pr-widget-list (cons (cons wid sym) wid-list)))) @@ -6666,20 +6221,18 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order." (defun pr-choice-alist (alist) - (let ((max (apply 'max (mapcar #'(lambda (alist) - (length (symbol-name (car alist)))) - alist)))) + (let ((max (apply #'max (mapcar #'(lambda (alist) + (length (symbol-name (car alist)))) + alist)))) (mapcar #'(lambda (alist) (let* ((sym (car alist)) (name (symbol-name sym))) - (list - 'quote - (list - 'choice-item - :format "%[%t%]" - :tag (concat name - (make-string (- max (length name)) ?_)) - :value sym)))) + (list + 'choice-item + :format "%[%t%]" + :tag (concat name + (make-string (- max (length name)) ?_)) + :value sym))) alist))) diff --git a/lisp/proced.el b/lisp/proced.el index b3c8e2cb698..5f35fa34a07 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -1348,7 +1348,7 @@ Prefix ARG controls sort order, see `proced-sort-interactive'." (defun proced-format-time (time) "Format time interval TIME." - (let* ((ftime (float-time time)) + (let* ((ftime (encode-time time 'integer)) (days (truncate ftime 86400)) (ftime (mod ftime 86400)) (hours (truncate ftime 3600)) @@ -1367,12 +1367,12 @@ Prefix ARG controls sort order, see `proced-sort-interactive'." The return string is always 6 characters wide." (let ((d-start (decode-time start)) (d-current (decode-time))) - (cond ( ;; process started in previous years - (< (nth 5 d-start) (nth 5 d-current)) + (cond (;; process started in previous years + (< (decoded-time-year d-start) (decoded-time-year d-current)) (format-time-string " %Y" start)) ;; process started today - ((and (= (nth 3 d-start) (nth 3 d-current)) - (= (nth 4 d-start) (nth 4 d-current))) + ((and (= (decoded-time-day d-start) (decoded-time-day d-current)) + (= (decoded-time-month d-start) (decoded-time-month d-current))) (format-time-string " %H:%M" start)) (t ;; process started this year (format-time-string "%b %e" start))))) @@ -1744,9 +1744,10 @@ The value returned is the value of the last form in BODY." (save-window-excursion ;; Analogous to `dired-pop-to-buffer' ;; Don't split window horizontally. (Bug#1806) - (let (split-width-threshold) - (pop-to-buffer (current-buffer))) - (fit-window-to-buffer (get-buffer-window) nil 1) + (display-buffer (current-buffer) + '(display-buffer-in-direction + (direction . bottom) + (window-height . fit-window-to-buffer))) ,@body)))) (defun proced-send-signal (&optional signal process-alist) diff --git a/lisp/profiler.el b/lisp/profiler.el index 5e6f4be2c12..92495e2de88 100644 --- a/lisp/profiler.el +++ b/lisp/profiler.el @@ -105,13 +105,13 @@ "Format ENTRY in human readable string. ENTRY would be a function name of a function itself." (cond ((memq (car-safe entry) '(closure lambda)) - (format "#<lambda 0x%x>" (sxhash entry))) + (format "#<lambda %#x>" (sxhash entry))) ((byte-code-function-p entry) - (format "#<compiled 0x%x>" (sxhash entry))) + (format "#<compiled %#x>" (sxhash entry))) ((or (subrp entry) (symbolp entry) (stringp entry)) (format "%s" entry)) (t - (format "#<unknown 0x%x>" (sxhash entry))))) + (format "#<unknown %#x>" (sxhash entry))))) (defun profiler-fixup-entry (entry) (if (symbolp entry) @@ -213,21 +213,22 @@ Optional argument MODE means only check for the specified mode (cpu or mem)." (t (or (profiler-running-p 'cpu) (profiler-running-p 'mem))))) +(defvar profiler-cpu-log nil) +(defvar profiler-memory-log nil) + (defun profiler-cpu-profile () "Return CPU profile." - (when (profiler-running-p 'cpu) - (profiler-make-profile - :type 'cpu - :timestamp (current-time) - :log (profiler-cpu-log)))) + (profiler-make-profile + :type 'cpu + :timestamp (current-time) + :log profiler-cpu-log)) (defun profiler-memory-profile () "Return memory profile." - (when (profiler-memory-running-p) - (profiler-make-profile - :type 'memory - :timestamp (current-time) - :log (profiler-memory-log)))) + (profiler-make-profile + :type 'memory + :timestamp (current-time) + :log profiler-memory-log)) ;;; Calltrees @@ -472,6 +473,7 @@ this variable directly.") (fboundp entry)) (propertize (symbol-name entry) 'face 'link + 'follow-link "\r" 'mouse-face 'highlight 'help-echo "\ mouse-2: jump to definition\n\ @@ -533,9 +535,9 @@ RET: expand or collapse")) (define-key map "\r" 'profiler-report-toggle-entry) (define-key map "\t" 'profiler-report-toggle-entry) (define-key map "i" 'profiler-report-toggle-entry) - (define-key map [mouse-1] 'profiler-report-toggle-entry) (define-key map "f" 'profiler-report-find-entry) (define-key map "j" 'profiler-report-find-entry) + (define-key map [follow-link] 'mouse-face) (define-key map [mouse-2] 'profiler-report-find-entry) (define-key map "d" 'profiler-report-describe-entry) (define-key map "C" 'profiler-report-render-calltree) @@ -613,9 +615,12 @@ return it." (profiler-report-render-calltree)) buffer)) +(defun profiler--xref-backend () 'elisp) + (define-derived-mode profiler-report-mode special-mode "Profiler-Report" "Profiler Report Mode." (add-to-invisibility-spec '(profiler . t)) + (add-hook 'xref-backend-functions #'profiler--xref-backend nil t) (setq buffer-read-only t buffer-undo-list t truncate-lines t)) @@ -829,7 +834,12 @@ Also, if MODE is `mem' or `cpu+mem', then memory profiler will be started." (defun profiler-stop () "Stop started profilers. Profiler logs will be kept." (interactive) - (let ((cpu (if (fboundp 'profiler-cpu-stop) (profiler-cpu-stop))) + (when (and (fboundp 'profiler-cpu-running-p) + (profiler-cpu-running-p)) + (setq profiler-cpu-log (profiler-cpu-log))) + (when (profiler-memory-running-p) + (setq profiler-memory-log (profiler-memory-log))) + (let ((cpu (when (fboundp 'profiler-cpu-stop) (profiler-cpu-stop))) (mem (profiler-memory-stop))) (message "%s profiler stopped" (cond ((and mem cpu) "CPU and memory") @@ -840,26 +850,32 @@ Also, if MODE is `mem' or `cpu+mem', then memory profiler will be started." (defun profiler-reset () "Reset profiler logs." (interactive) - (when (fboundp 'profiler-cpu-log) - (ignore (profiler-cpu-log))) - (ignore (profiler-memory-log)) - t) + (when (and (fboundp 'profiler-cpu-running-p) (profiler-cpu-running-p)) + (profiler-cpu-stop)) + (when (profiler-memory-running-p) + (profiler-memory-stop)) + (setq profiler-cpu-log nil + profiler-memory-log nil)) (defun profiler-report-cpu () - (let ((profile (profiler-cpu-profile))) - (when profile - (profiler-report-profile-other-window profile)))) + (when profiler-cpu-log + (profiler-report-profile-other-window (profiler-cpu-profile)))) (defun profiler-report-memory () - (let ((profile (profiler-memory-profile))) - (when profile - (profiler-report-profile-other-window profile)))) + (when profiler-memory-log + (profiler-report-profile-other-window (profiler-memory-profile)))) (defun profiler-report () "Report profiling results." (interactive) - (profiler-report-cpu) - (profiler-report-memory)) + (when (and (fboundp 'profiler-cpu-running-p) (profiler-cpu-running-p)) + (setq profiler-cpu-log (profiler-cpu-log))) + (when (profiler-memory-running-p) + (setq profiler-memory-log (profiler-memory-log))) + (if (and (not profiler-cpu-log) (not profiler-memory-log)) + (user-error "No profiler run recorded") + (profiler-report-cpu) + (profiler-report-memory))) ;;;###autoload (defun profiler-find-profile (filename) diff --git a/lisp/progmodes/ada-mode.el b/lisp/progmodes/ada-mode.el index c9aba0a50d1..4a4e1a7aad4 100644 --- a/lisp/progmodes/ada-mode.el +++ b/lisp/progmodes/ada-mode.el @@ -2,10 +2,10 @@ ;; Copyright (C) 1994-1995, 1997-2019 Free Software Foundation, Inc. -;; Author: Rolf Ebert <ebert@inf.enst.fr> +;; Author: Rolf Ebert <ebert@inf.enst.fr> ;; Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> ;; Emmanuel Briot <briot@gnat.com> -;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org> +;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org> ;; Keywords: languages ada ;; Version: 4.0 @@ -768,7 +768,7 @@ the 4 file locations can be clicked on and jumped to." (interactive "d") (goto-char pos) - (skip-chars-backward "-a-zA-Z0-9_:./\\") + (skip-chars-backward "-a-zA-Z0-9_:./\\\\") (cond ;; special case: looking at a filename:line not at the beginning of a line ;; or a simple line reference "at line ..." @@ -910,7 +910,7 @@ the 4 file locations can be clicked on and jumped to." change)) (replace-match "'A'")) (goto-char from) - (while (re-search-forward "\\(#[0-9a-fA-F]*#\\)" to t) + (while (re-search-forward "\\(#[[:xdigit:]]*#\\)" to t) (setq change (cons (list (match-beginning 1) (length (match-string 1)) (match-string 1)) @@ -1014,7 +1014,7 @@ If PARSE-RESULT is non-nil, use it instead of calling `parse-partial-sexp'." (defsubst ada-in-numeric-literal-p () "Return t if point is after a prefix of a numeric literal." - (looking-back "\\([0-9]+#[0-9a-fA-F_]+\\)" (line-beginning-position))) + (looking-back "\\([0-9]+#[[:xdigit:]_]+\\)" (line-beginning-position))) ;;------------------------------------------------------------------ ;; Contextual menus @@ -4520,6 +4520,7 @@ Moves to `begin' if in a declarative part." (define-key ada-mode-map "\C-c\C-n" 'ada-make-subprogram-body) ;; Use predefined function of Emacs19 for comments (RE) + ;; FIXME: Made redundant with Emacs-21's standard comment-dwim binding on M-; (define-key ada-mode-map "\C-c;" 'comment-region) (define-key ada-mode-map "\C-c:" 'ada-uncomment-region) @@ -4757,16 +4758,17 @@ Moves to `begin' if in a declarative part." ;; function for justifying the comments. ;; ------------------------------------------------------- -(defadvice comment-region (before ada-uncomment-anywhere disable) - (if (and (consp arg) ;; a prefix with \C-u is of the form '(4), whereas - ;; \C-u 2 sets arg to '2' (fixed by S.Leake) - (derived-mode-p 'ada-mode)) - (save-excursion - (let ((cs (concat "^[ \t]*" (regexp-quote comment-start)))) - (goto-char beg) - (while (re-search-forward cs end t) - (replace-match comment-start)) - )))) +(when (or (<= emacs-major-version 20) (featurep 'xemacs)) + (defadvice comment-region (before ada-uncomment-anywhere disable) + (if (and (consp arg) ;; a prefix with \C-u is of the form '(4), whereas + ;; \C-u 2 sets arg to '2' (fixed by S.Leake) + (derived-mode-p 'ada-mode)) + (save-excursion + (let ((cs (concat "^[ \t]*" (regexp-quote comment-start)))) + (goto-char beg) + (while (re-search-forward cs end t) + (replace-match comment-start)) + ))))) (defun ada-uncomment-region (beg end &optional arg) "Uncomment region BEG .. END. @@ -5212,7 +5214,7 @@ Return nil if no body was found." '("<<\\(\\sw+\\)>>" 1 font-lock-constant-face) ;; Highlight based-numbers (R. Reagan <robin-reply@reagans.org>) - (list "\\([0-9]+#[0-9a-fA-F_]+#\\)" '(1 font-lock-constant-face t)) + (list "\\([0-9]+#[[:xdigit:]_]+#\\)" '(1 font-lock-constant-face t)) ;; Ada unnamed numerical constants (list "\\W\\([-+]?[0-9._]+\\)\\>" '(1 font-lock-constant-face)) diff --git a/lisp/progmodes/ada-xref.el b/lisp/progmodes/ada-xref.el index 7f0e1663284..c9c923e1d69 100644 --- a/lisp/progmodes/ada-xref.el +++ b/lisp/progmodes/ada-xref.el @@ -416,7 +416,7 @@ As a special case, ${current} is replaced with the name of the current file, minus extension but with directory, and ${full_current} is replaced by the name including the extension." - (while (string-match "\\(-[^-$IO]*[IO]\\)?${\\([^}]+\\)}" cmd-string) + (while (string-match "\\(-[^-$IO]*[IO]\\)?\\${\\([^}]+\\)}" cmd-string) (let (value (name (match-string 2 cmd-string))) (cond @@ -1133,8 +1133,7 @@ If OTHER-FRAME is non-nil, display the cross-reference in another frame." (ada-find-in-ali identlist other-frame) ;; File not found: print explicit error message (ada-error-file-not-found - (message (concat (error-message-string err) - (nthcdr 1 err)))) + (message "%s%s" (error-message-string err) (nthcdr 1 err))) (error (let ((ali-file (ada-get-ali-file-name (ada-file-of identlist)))) diff --git a/lisp/progmodes/antlr-mode.el b/lisp/progmodes/antlr-mode.el index ef140f38962..40bef0b35b6 100644 --- a/lisp/progmodes/antlr-mode.el +++ b/lisp/progmodes/antlr-mode.el @@ -82,8 +82,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'easymenu) (require 'cc-mode) @@ -1066,7 +1065,7 @@ Used for `antlr-slow-syntactic-context'.") (buffer-syntactic-context-depth) nil) :EMACS -;;; (incf antlr-statistics-inval) +;;; (cl-incf antlr-statistics-inval) (setq antlr-slow-context-cache nil)) (defunx antlr-syntactic-context () @@ -1096,9 +1095,9 @@ WARNING: this may alter `match-data'." (if (>= orig antlr-slow-cache-diff-threshold) (beginning-of-defun) (goto-char (point-min))) -;;; (cond ((and diff (< diff 0)) (incf antlr-statistics-full-neg)) -;;; ((and diff (>= diff 3000)) (incf antlr-statistics-full-diff)) -;;; (t (incf antlr-statistics-full-other))) +;;; (cond ((and diff (< diff 0)) (cl-incf antlr-statistics-full-neg)) +;;; ((and diff (>= diff 3000)) (cl-incf antlr-statistics-full-diff)) +;;; (t (cl-incf antlr-statistics-full-other))) (setq state (parse-partial-sexp (point) orig))) (goto-char orig) (if antlr-slow-context-cache @@ -1110,12 +1109,12 @@ WARNING: this may alter `match-data'." ((nth 4 state) 'comment) ; block-comment? -- we don't care (t (car state))))) -;;; (incf (aref antlr-statistics 2)) +;;; (cl-incf (aref antlr-statistics 2)) ;;; (unless (and (eq (current-buffer) ;;; (caar antlr-slow-context-cache)) ;;; (eq (buffer-modified-tick) ;;; (cdar antlr-slow-context-cache))) -;;; (incf (aref antlr-statistics 1)) +;;; (cl-incf (aref antlr-statistics 1)) ;;; (setq antlr-slow-context-cache nil)) ;;; (let* ((orig (point)) ;;; (base (cadr antlr-slow-context-cache)) @@ -1124,7 +1123,7 @@ WARNING: this may alter `match-data'." ;;; ((eq orig (car base)) (cdr base)))) ;;; diff diff2) ;;; (unless state -;;; (incf (aref antlr-statistics 3)) +;;; (cl-incf (aref antlr-statistics 3)) ;;; (when curr ;;; (if (< (setq diff (abs (- orig (car curr)))) ;;; (setq diff2 (abs (- orig (car base))))) @@ -1137,7 +1136,7 @@ WARNING: this may alter `match-data'." ;;; (setq state ;;; (parse-partial-sexp (car state) orig nil nil (cdr state))) ;;; (if (>= orig 3000) (beginning-of-defun) (goto-char (point-min))) -;;; (incf (aref antlr-statistics 4)) +;;; (cl-incf (aref antlr-statistics 4)) ;;; (setq cw (list orig (point) base curr)) ;;; (setq state (parse-partial-sexp (point) orig))) ;;; (goto-char orig) @@ -1348,10 +1347,10 @@ is non-nil, move to beginning of the rule." (antlr-skip-exception-part skip-comment)) (antlr-skip-file-prelude skip-comment)) (if (< arg 0) - (unless (and (< (point) pos) (zerop (incf arg))) + (unless (and (< (point) pos) (zerop (cl-incf arg))) ;; if we have moved backward, we already moved one defun backward (goto-char beg) ; rewind (to ";" / point) - (while (and arg (<= (incf arg) 0)) + (while (and arg (<= (cl-incf arg) 0)) (if (antlr-search-backward ";") (setq beg (point)) (when (>= arg -1) @@ -1368,9 +1367,9 @@ is non-nil, move to beginning of the rule." (antlr-skip-exception-part skip-comment))) (if (<= (point) pos) ; moved backward? (goto-char pos) ; rewind - (decf arg)) ; already moved one defun forward + (cl-decf arg)) ; already moved one defun forward (unless (zerop arg) - (while (>= (decf arg) 0) + (while (>= (cl-decf arg) 0) (antlr-search-forward ";")) (antlr-skip-exception-part skip-comment))))) @@ -1465,7 +1464,7 @@ If non-nil, TRANSFORM is used on literals instead of `downcase-region'." (antlr-invalidate-context-cache) (while (antlr-re-search-forward "\"\\(\\sw\\(\\sw\\|-\\)*\\)\"" nil) (funcall transform (match-beginning 0) (match-end 0)) - (incf literals)))) + (cl-incf literals)))) (message "Transformed %d literals" literals))) (defun antlr-upcase-literals () @@ -2131,7 +2130,7 @@ its export vocabulary is used as an import vocabulary." (or (null ivocab) (member ivocab import-vocabs) (push ivocab import-vocabs))))) (if classes - (list* (file-name-nondirectory buffer-file-name) + (cl-list* (file-name-nondirectory buffer-file-name) (cons (nreverse classes) (nreverse superclasses)) (cons (nreverse export-vocabs) (nreverse import-vocabs)) antlr-language)))) @@ -2277,7 +2276,7 @@ command `antlr-show-makefile-rules' for detail." (dolist (dep deps) (let ((supers (cdadr dep)) (lang (cdr (assoc (cdddr dep) antlr-file-formats-alist)))) - (if n (incf n)) + (if n (cl-incf n)) (antlr-makefile-insert-variable n "" " =") (if supers (insert " " @@ -2313,7 +2312,7 @@ command `antlr-show-makefile-rules' for detail." (if n (let ((i 0)) (antlr-makefile-insert-variable nil "" " =") - (while (<= (incf i) n) + (while (<= (cl-incf i) n) (antlr-makefile-insert-variable i " $(" ")")) (insert "\n" (car antlr-makefile-specification)))) (if (string-equal (car antlr-makefile-specification) "\n") @@ -2442,8 +2441,8 @@ to a lesser extent, `antlr-tab-offset-alist'." (goto-char boi) (unless (symbolp syntax) ; direct indentation ;;(antlr-invalidate-context-cache) - (incf indent (antlr-syntactic-context)) - (and (> indent 0) (looking-at antlr-indent-item-regexp) (decf indent)) + (cl-incf indent (antlr-syntactic-context)) + (and (> indent 0) (looking-at antlr-indent-item-regexp) (cl-decf indent)) (setq indent (* indent c-basic-offset))) ;; the usual major-mode indent stuff --------------------------------- (setq orig (- (point-max) orig)) diff --git a/lisp/progmodes/asm-mode.el b/lisp/progmodes/asm-mode.el index c56d16e305e..017a5b5bace 100644 --- a/lisp/progmodes/asm-mode.el +++ b/lisp/progmodes/asm-mode.el @@ -1,10 +1,10 @@ -;;; asm-mode.el --- mode for editing assembler code +;;; asm-mode.el --- mode for editing assembler code -*- lexical-binding: t; -*- ;; Copyright (C) 1991, 2001-2019 Free Software Foundation, Inc. ;; Author: Eric S. Raymond <esr@snark.thyrsus.com> ;; Maintainer: emacs-devel@gnu.org -;; Keywords: tools, languages +;; Keywords: languages ;; This file is part of GNU Emacs. @@ -26,7 +26,7 @@ ;; This mode was written by Eric S. Raymond <esr@snark.thyrsus.com>, ;; inspired by an earlier asm-mode by Martin Neitzel. -;; This minor mode is based on text mode. It defines a private abbrev table +;; 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: ;; @@ -53,9 +53,8 @@ :group 'languages) (defcustom asm-comment-char ?\; - "The comment-start character assumed by Asm mode." - :type 'character - :group 'asm) + "The `comment-start' character assumed by Asm mode." + :type 'character) (defvar asm-mode-syntax-table (let ((st (make-syntax-table))) @@ -113,7 +112,7 @@ Features a private abbrev table and the following bindings: \\[asm-colon]\toutdent a preceding label, tab to next tab stop. \\[tab-to-tab-stop]\ttab to next tab stop. -\\[asm-newline]\tnewline, then tab to next tab stop. +\\[newline-and-indent]\tnewline, then tab to next tab stop. \\[asm-comment]\tsmart placement of assembler comments. The character used for making comments is set by the variable @@ -127,10 +126,10 @@ Turning on Asm mode runs the hook `asm-mode-hook' at the end of initialization. Special commands: \\{asm-mode-map}" (setq local-abbrev-table asm-mode-abbrev-table) - (set (make-local-variable 'font-lock-defaults) '(asm-font-lock-keywords)) - (set (make-local-variable 'indent-line-function) 'asm-indent-line) + (setq-local font-lock-defaults '(asm-font-lock-keywords)) + (setq-local indent-line-function #'asm-indent-line) ;; Stay closer to the old TAB behavior (was tab-to-tab-stop). - (set (make-local-variable 'tab-always-indent) nil) + (setq-local tab-always-indent nil) (run-hooks 'asm-mode-set-comment-hook) ;; Make our own local child of asm-mode-map @@ -140,12 +139,11 @@ Special commands: (set-syntax-table (make-syntax-table asm-mode-syntax-table)) (modify-syntax-entry asm-comment-char "< b") - (set (make-local-variable 'comment-start) (string asm-comment-char)) - (set (make-local-variable 'comment-add) 1) - (set (make-local-variable 'comment-start-skip) - "\\(?:\\s<+\\|/[/*]+\\)[ \t]*") - (set (make-local-variable 'comment-end-skip) "[ \t]*\\(\\s>\\|\\*+/\\)") - (set (make-local-variable 'comment-end) "") + (setq-local comment-start (string asm-comment-char)) + (setq-local comment-add 1) + (setq-local comment-start-skip "\\(?:\\s<+\\|/[/*]+\\)[ \t]*") + (setq-local comment-end-skip "[ \t]*\\(\\s>\\|\\*+/\\)") + (setq-local comment-end "") (setq fill-prefix "\t")) (defun asm-indent-line () @@ -172,7 +170,7 @@ Special commands: ;; Simple `;' comments go to the comment-column. (and (looking-at "\\s<\\(\\S<\\|\\'\\)") comment-column) ;; The rest goes at the first tab stop. - (or (indent-next-tab-stop 0)))) + (indent-next-tab-stop 0))) (defun asm-colon () "Insert a colon; if it follows a label, delete the label's indentation." @@ -187,14 +185,13 @@ Special commands: (delete-horizontal-space) (tab-to-tab-stop)))) -;; Obsolete since Emacs-22.1. -(defalias 'asm-newline 'newline-and-indent) +(define-obsolete-function-alias 'asm-newline 'newline-and-indent "27.1") (defun asm-comment () "Convert an empty comment to a `larger' kind, or start a new one. These are the known comment classes: - 1 -- comment to the right of the code (at the comment-column) + 1 -- comment to the right of the code (at the `comment-column') 2 -- comment on its own line, indented like code 3 -- comment on its own line, beginning at the left-most column. diff --git a/lisp/progmodes/autoconf.el b/lisp/progmodes/autoconf.el index d236ef6e750..9d70aeb9d52 100644 --- a/lisp/progmodes/autoconf.el +++ b/lisp/progmodes/autoconf.el @@ -84,7 +84,7 @@ searching backwards at another AC_... command." (setq-local syntax-propertize-function (syntax-propertize-rules ("\\<dnl\\>" (0 "<")))) (setq-local font-lock-defaults - `(autoconf-font-lock-keywords nil nil)) + '(autoconf-font-lock-keywords nil nil)) (setq-local imenu-generic-expression autoconf-imenu-generic-expression) (setq-local indent-line-function #'indent-relative) (setq-local add-log-current-defun-function diff --git a/lisp/progmodes/bat-mode.el b/lisp/progmodes/bat-mode.el index 5853d511c9a..a8b002be59b 100644 --- a/lisp/progmodes/bat-mode.el +++ b/lisp/progmodes/bat-mode.el @@ -78,12 +78,14 @@ "goto" "gtr" "if" "in" "leq" "lss" "neq" "not" "start")) (UNIX '("bash" "cat" "cp" "fgrep" "grep" "ls" "sed" "sh" "mv" "rm"))) - `(("\\_<\\(call\\|goto\\)\\_>[ \t]+%?\\([A-Za-z0-9-_\\:.]+\\)%?" + `(("\\_<\\(call\\|goto\\)\\_>[ \t]+%?\\([A-Za-z0-9_\\:.-]+\\)%?" (2 font-lock-constant-face t)) ("^:[^:].*" . 'bat-label-face) ("\\_<\\(defined\\|set\\)\\_>[ \t]*\\(\\(\\sw\\|\\s_\\)+\\)" (2 font-lock-variable-name-face)) + ("%~\\([0-9]\\)" + (1 font-lock-variable-name-face)) ("%\\([^%~ \n]+\\)%?" (1 font-lock-variable-name-face)) ("!\\([^!%~ \n]+\\)!?" ; delayed-expansion !variable! diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index 861b0137cb0..813ecbe3847 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -1,4 +1,4 @@ -;; bug-reference.el --- buttonize bug references +;; bug-reference.el --- buttonize bug references -*- lexical-binding: t; -*- ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. @@ -69,7 +69,7 @@ so that it is considered safe, see `enable-local-variables'.") (get s 'bug-reference-url-format))))) (defcustom bug-reference-bug-regexp - "\\([Bb]ug ?#?\\|[Pp]atch ?#\\|RFE ?#\\|PR [a-z-+]+/\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)" + "\\([Bb]ug ?#?\\|[Pp]atch ?#\\|RFE ?#\\|PR [a-z+-]+/\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)" "Regular expression matching bug references. The second subexpression should match the bug reference (usually a number)." :type 'string @@ -91,7 +91,7 @@ The second subexpression should match the bug reference (usually a number)." (bug-reference-set-overlay-properties) (defun bug-reference-unfontify (start end) - "Remove bug reference overlays from region." + "Remove bug reference overlays from the region between START and END." (dolist (o (overlays-in start end)) (when (eq (overlay-get o 'category) 'bug-reference) (delete-overlay o)))) @@ -99,7 +99,7 @@ The second subexpression should match the bug reference (usually a number)." (defvar bug-reference-prog-mode) (defun bug-reference-fontify (start end) - "Apply bug reference overlays to region." + "Apply bug reference overlays to the region between START and END." (save-excursion (let ((beg-line (progn (goto-char start) (line-beginning-position))) (end-line (progn (goto-char end) (line-end-position)))) @@ -141,10 +141,7 @@ The second subexpression should match the bug reference (usually a number)." ;;;###autoload (define-minor-mode bug-reference-mode - "Toggle hyperlinking bug references in the buffer (Bug Reference mode). -With a prefix argument ARG, enable Bug Reference mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil." + "Toggle hyperlinking bug references in the buffer (Bug Reference mode)." nil "" nil diff --git a/lisp/progmodes/cc-align.el b/lisp/progmodes/cc-align.el index d658e07774d..74548f643a7 100644 --- a/lisp/progmodes/cc-align.el +++ b/lisp/progmodes/cc-align.el @@ -90,26 +90,26 @@ Works with: topmost-intro-cont." (defun c-lineup-gnu-DEFUN-intro-cont (langelem) "Line up the continuation lines of a DEFUN macro in the Emacs C source. -These lines are indented as though they were `knr-argdecl-intro' lines. +These lines are indented `c-basic-offset' columns, usually from column 0. Return nil when we're not in such a construct. -This function is for historical compatibility with how previous CC Modes (5.28 -and earlier) indented such lines. +This function was formally for use in DEFUNs, which used to have knr +argument lists. Now (2019-05) it just indents the argument list of the +DEFUN's function, which would otherwise go to column 0. Here is an example: DEFUN (\"forward-char\", Fforward_char, Sforward_char, 0, 1, \"p\", doc: /* Move point right N characters (left if N is negative). On reaching end of buffer, stop and signal error. */) - (n) <- c-lineup-gnu-DEFUN-into-cont - Lisp_Object n; <- c-lineup-gnu-DEFUN-into-cont + (Lisp_Object n) <- c-lineup-gnu-DEFUN-into-cont Works with: topmost-intro-cont." (save-excursion (let (case-fold-search) (goto-char (c-langelem-pos langelem)) (if (looking-at "\\<DEFUN\\>") - (c-calc-offset '(knr-argdecl-intro)))))) + c-basic-offset)))) (defun c-block-in-arglist-dwim (arglist-start) ;; This function implements the DWIM to avoid far indentation of @@ -868,12 +868,11 @@ returned if there's no template argument on the first line. Works with: template-args-cont." (save-excursion - (c-with-syntax-table c++-template-syntax-table - (beginning-of-line) - (backward-up-list 1) - (if (and (eq (char-after) ?<) - (zerop (c-forward-token-2 1 nil (c-point 'eol)))) - (vector (current-column)))))) + (beginning-of-line) + (backward-up-list 1) + (if (and (eq (char-after) ?<) + (zerop (c-forward-token-2 1 nil (c-point 'eol)))) + (vector (current-column))))) (defun c-lineup-ObjC-method-call (langelem) "Line up selector args as Emacs Lisp mode does with function args: @@ -1084,6 +1083,130 @@ arglist-cont." (vector (+ (current-column) c-basic-offset)))) (vector 0))))) +(defun c-lineup-2nd-brace-entry-in-arglist (langelem) + "Lineup the second entry of a brace block under the first, when the first +line is also contained in an arglist or an enclosing brace ON THAT LINE. + +I.e. handle something like the following: + + set_line (line_t {point_t{0.4, 0.2}, + point_t{0.2, 0.5}, <---- brace-list-intro + .....}); + ^ enclosing parenthesis. + +The middle line of that example will have a syntactic context +with three syntactic symbols, arglist-cont-nonempty, brace-list-intro, and +brace-list-entry. + +This function is intended for use in a list. If the construct +being analyzed isn't like the preceding, the function returns nil. +Otherwise it returns the function `c-lineup-arglist-intro-after-paren', which +the caller then uses to perform indentation. + +Works with brace-list-intro." + ;; brace-list-intro and brace-list-entry are both present for the second + ;; entry of the list when the first entry is on the same line as the opening + ;; brace. + (and (assq 'brace-list-intro c-syntactic-context) + (assq 'brace-list-entry c-syntactic-context) + (or (assq 'arglist-cont-nonempty c-syntactic-context) ; "(" earlier on + ; the line. + (save-excursion ; "{" earlier on the line + (goto-char (c-langelem-pos + (assq 'brace-list-intro c-syntactic-context))) + (and + (eq (c-backward-token-2 + 1 nil + (c-point 'bol (c-langelem-pos + (assq 'brace-list-entry + c-syntactic-context)))) + 0) + (eq (char-after) ?{)))) + 'c-lineup-arglist-intro-after-paren)) + +(defun c-lineup-class-decl-init-+ (langelem) + "Line up the second entry of a class (etc.) initializer c-basic-offset +characters in from the identifier when: +\(i) The type is a class, struct, union, etc. (but not an enum); +\(ii) There is a brace block in the type declaration, specifying it; and +\(iii) The first element of the initializer is on the same line as its opening +brace. + +I.e. we have a construct like this: + + struct STR { + int i; float f; + } str_1 = {1, 1.7}, + str_2 = {2, + 3.1 <---- brace-list-intro + }; + <--> <---- c-basic-offset + +Note that the syntactic context of the brace-list-intro line also has a +syntactic element with the symbol brace-list-entry. + +This function is intended for use in a list. If the above structure isn't +present, this function returns nil, allowing a different offset specification +to indent the line. + +Works with: brace-list-intro." + (and (assq 'brace-list-intro c-syntactic-context) + (assq 'brace-list-entry c-syntactic-context) + (let ((init-pos (c-point 'boi (c-langelem-pos + (assq 'brace-list-entry + c-syntactic-context)))) + ) + (save-excursion + (goto-char (c-langelem-pos (assq 'brace-list-intro + c-syntactic-context))) + (and + (c-forward-class-decl) + (not (c-do-declarators init-pos t nil nil nil)) + (eq (point) init-pos) + (vector (+ (current-column) c-basic-offset))))))) + +(defun c-lineup-class-decl-init-after-brace (langelem) + "Line up the second entry of a class (etc.) initializer after its opening +brace when: +\(i) The type is a class, struct, union, etc. (but not an enum); +\(ii) There is a brace block in the type declaration, specifying it; and +\(iii) The first element of the initializer is on the same line as its opening +brace. + +I.e. we have a construct like this: + + struct STR { + int i; float f; + } str_1 = {1, 1.7}, + str_2 = {2, + 3.1 <---- brace-list-intro + }; + +Note that the syntactic context of the brace-list-intro line also has a +syntactic element with the symbol brace-list-entry. Also note that this +function works by returning the symbol `c-lineup-arglist-intro-after-paren', +which the caller then uses to perform the indentation. + +This function is intended for use in a list. If the above structure isn't +present, this function returns nil, allowing a different offset specification +to indent the line. + +Works with: brace-list-intro." + (and (assq 'brace-list-intro c-syntactic-context) + (assq 'brace-list-entry c-syntactic-context) + (let ((init-pos (c-point 'boi (c-langelem-pos + (assq 'brace-list-entry + c-syntactic-context)))) + ) + (save-excursion + (goto-char (c-langelem-pos (assq 'brace-list-intro + c-syntactic-context))) + (and + (c-forward-class-decl) + (not (c-do-declarators init-pos t nil nil nil)) + (eq (point) init-pos) + 'c-lineup-arglist-intro-after-paren))))) + (defun c-lineup-cpp-define (_langelem) "Line up macro continuation lines according to the indentation of the construct preceding the macro. E.g.: diff --git a/lisp/progmodes/cc-awk.el b/lisp/progmodes/cc-awk.el index bcb9d0430a3..0fd850eb64f 100644 --- a/lisp/progmodes/cc-awk.el +++ b/lisp/progmodes/cc-awk.el @@ -95,7 +95,7 @@ ;; Emacs has in the past used \r to mark hidden lines in some fashion (and ;; maybe still does). -(defconst c-awk-esc-pair-re "\\\\\\(.\\|\n\\|\r\\|\\'\\)") +(defconst c-awk-esc-pair-re "\\\\\\(.\\|\n\\|\\'\\)") ;; Matches any escaped (with \) character-pair, including an escaped newline. (defconst c-awk-non-eol-esc-pair-re "\\\\\\(.\\|\\'\\)") ;; Matches any escaped (with \) character-pair, apart from an escaped newline. @@ -130,7 +130,7 @@ ;; REGEXPS FOR "HARMLESS" STRINGS/LINES. (defconst c-awk-harmless-_ "_\\([^\"]\\|\\'\\)") ;; Matches an underline NOT followed by ". -(defconst c-awk-harmless-char-re "[^_#/\"{}();\\\\\n\r]") +(defconst c-awk-harmless-char-re "[^_#/\"{}();\\\n\r]") ;; Matches any character not significant in the state machine applying ;; syntax-table properties to "s and /s. (defconst c-awk-harmless-string*-re @@ -141,7 +141,7 @@ (concat "\\=" c-awk-harmless-string*-re)) ;; Matches the (possibly empty) sequence of "insignificant" chars at point. -(defconst c-awk-harmless-line-char-re "[^_#/\"\\\\\n\r]") +(defconst c-awk-harmless-line-char-re "[^_#/\"\\\n\r]") ;; Matches any character but a _, #, /, ", \, or newline. N.B. _" starts a ;; localization string in gawk 3.1 (defconst c-awk-harmless-line-string*-re @@ -188,8 +188,8 @@ "\\[:[a-z]+:\\]") ;; Matches a character class spec (e.g. [:alpha:]). (defconst c-awk-regexp-char-list-re - (concat "\\[" c-awk-escaped-newlines*-re "^?" c-awk-escaped-newlines*-re "]?" - "\\(" c-awk-esc-pair-re "\\|" c-awk-regexp-char-class-re + (concat "\\[\\(" c-awk-escaped-newlines*-re "\\^\\)?" c-awk-escaped-newlines*-re "]?" + "\\(" c-awk-esc-pair-re "\\|" c-awk-regexp-char-class-re "\\|" "[^]\n\r]" "\\)*" "\\(]\\|$\\)")) ;; Matches a regexp char list, up to (but not including) EOL if the ] is ;; missing. @@ -215,10 +215,10 @@ (defconst c-awk-neutrals*-re (concat "\\(" c-awk-neutral-re "\\)*")) ;; A (possibly empty) string of neutral characters (or character pairs). -(defconst c-awk-var-num-ket-re "[])0-9a-zA-Z_$.\x80-\xff]+") +(defconst c-awk-var-num-ket-re "[])0-9a-zA-Z_$.]+") ;; Matches a char which is a constituent of a variable or number, or a ket -;; (i.e. closing bracKET), round or square. Assume that all characters \x80 to -;; \xff are "letters". +;; (i.e. closing bracKET), round or square. (2019-07): No longer assume that +;; all characters \x80 to \xff are "letters". (defconst c-awk-div-sign-re (concat c-awk-var-num-ket-re c-awk-neutrals*-re "/")) ;; Will match a piece of AWK buffer ending in / which is a division sign, in @@ -250,7 +250,7 @@ ;; which can precede an expression. ;; REGEXPS USED FOR FINDING THE POSITION OF A "virtual semicolon" -(defconst c-awk-_-harmless-nonws-char-re "[^#/\"\\\\\n\r \t]") +(defconst c-awk-_-harmless-nonws-char-re "[^#/\"\\\n\r \t]") (defconst c-awk-non-/-syn-ws*-re (concat "\\(" c-awk-escaped-nls*-with-space* diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index 65b44339bc1..2ccdc1d0bc8 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -47,6 +47,7 @@ ;; Silence the compiler. (cc-bytecomp-defvar filladapt-mode) ; c-fill-paragraph contains a kludge ; which looks at this. +(cc-bytecomp-defun electric-pair-post-self-insert-function) ;; Indentation / Display syntax functions (defvar c-fix-backslashes t) @@ -503,7 +504,8 @@ inside a literal or a macro, nothing special happens." (eq (char-before) ?\\)))) (c-in-literal))) ;; do nothing special - (self-insert-command (prefix-numeric-value arg)) + (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))) @@ -694,6 +696,134 @@ inside a literal or a macro, nothing special happens." t)))) (goto-char (- (point-max) pos)))))) +(defun c-do-brace-electrics (before after) + ;; Point is just after a brace. Indent the various lines, add any required + ;; auto newlines, and apply pertinent clean ups. It is assumed that the + ;; caller has checked that point is at EOL if need be, and that the brace is + ;; not in a comment or string, and suchlike. + ;; + ;; BEFORE and AFTER qualify the newlines required before and after the + ;; brace as follows: + ;; If + ;; o - nil: insert a newline or not according to `c-hanging-braces-alist'. + ;; o - 'ignore: don't insert a newline. + ;; o - 'assume: insert a newline. + ;; + ;; The return value has no significance. + (let (;; shut this up too + (c-echo-syntactic-information-p nil) + newlines + ln-syntax br-syntax syntax) ; Syntactic context of the original line, + ; of the brace itself, of the line the + ; brace ends up on. + (c-save-buffer-state ((c-syntactic-indentation-in-macros t) + (c-auto-newline-analysis t)) + (setq ln-syntax (c-guess-basic-syntax))) + (if c-syntactic-indentation + (c-indent-line ln-syntax)) + + (when c-auto-newline + (backward-char) + (setq br-syntax (c-point-syntax) + newlines (c-brace-newlines br-syntax)) + + ;; Insert the BEFORE newline, if wanted, and reindent the newline. + (if (or (and (null before) (memq 'before newlines) + (> (current-column) (current-indentation))) + (eq before 'assume)) + (if c-syntactic-indentation + ;; Only a plain newline for now - it's indented + ;; after the cleanups when the line has its final + ;; appearance. + (newline) + (c-newline-and-indent))) + (forward-char) + + ;; `syntax' is the syntactic context of the line which ends up + ;; with the brace on it. + (setq syntax (if (memq 'before newlines) br-syntax ln-syntax)) + + ;; Do all appropriate clean ups + (let ((here (point)) + (pos (- (point-max) (point))) + mbeg mend + ) + + ;; `}': clean up empty defun braces + (when (c-save-buffer-state () + (and (memq 'empty-defun-braces c-cleanup-list) + (eq (c-last-command-char) ?\}) + (c-intersect-lists '(defun-close class-close inline-close) + syntax) + (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)))) + (delete-region (point) (1- here)) + (setq here (- (point-max) pos))) + (goto-char here) + + ;; `}': compact to a one-liner defun? + (save-match-data + (when + (and (eq (c-last-command-char) ?\}) + (memq 'one-liner-defun c-cleanup-list) + (c-intersect-lists '(defun-close) syntax) + (c-try-one-liner)) + (setq here (- (point-max) pos)))) + + ;; `{': clean up brace-else-brace and brace-elseif-brace + (when (eq (c-last-command-char) ?\{) + (cond + ((and (memq 'brace-else-brace c-cleanup-list) + (re-search-backward + (concat "}" + "\\([ \t\n]\\|\\\\\n\\)*" + "else" + "\\([ \t\n]\\|\\\\\n\\)*" + "{" + "\\=") + nil t)) + (delete-region (match-beginning 0) (match-end 0)) + (insert-and-inherit "} else {")) + ((and (memq 'brace-elseif-brace c-cleanup-list) + (progn + (goto-char (1- here)) + (setq mend (point)) + (c-skip-ws-backward) + (setq mbeg (point)) + (eq (char-before) ?\))) + (zerop (c-save-buffer-state nil (c-backward-token-2 1 t))) + (eq (char-after) ?\() + (re-search-backward + (concat "}" + "\\([ \t\n]\\|\\\\\n\\)*" + "else" + "\\([ \t\n]\\|\\\\\n\\)+" + "if" + "\\([ \t\n]\\|\\\\\n\\)*" + "\\=") + nil t)) + (delete-region mbeg mend) + (goto-char mbeg) + (insert ?\ )))) + + (goto-char (- (point-max) pos)) + + ;; Indent the line after the cleanups since it might + ;; very well indent differently due to them, e.g. if + ;; c-indent-one-line-block is used together with the + ;; one-liner-defun cleanup. + (when c-syntactic-indentation + (c-indent-line))) + + ;; does a newline go after the brace? + (if (or (and (null after) (memq 'after newlines)) + (eq after 'assume)) + (c-newline-and-indent))))) + (defun c-electric-brace (arg) "Insert a brace. @@ -716,7 +846,10 @@ settings of `c-cleanup-list' are done." ;; 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) + 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)) @@ -724,128 +857,36 @@ settings of `c-cleanup-list' are done." ;; Insert the brace. Note that expand-abbrev might reindent ;; the line here if there's a preceding "else" or something. - (self-insert-command (prefix-numeric-value arg)) - - (when (and c-electric-flag (not literal) (not arg)) - (if (not (looking-at "[ \t]*\\\\?$")) - (if c-syntactic-indentation - (indent-according-to-mode)) - - (let ( ;; shut this up too - (c-echo-syntactic-information-p nil) - newlines - ln-syntax br-syntax syntax) ; Syntactic context of the original line, - ; of the brace itself, of the line the brace ends up on. - (c-save-buffer-state ((c-syntactic-indentation-in-macros t) - (c-auto-newline-analysis t)) - (setq ln-syntax (c-guess-basic-syntax))) - (if c-syntactic-indentation - (c-indent-line ln-syntax)) - - (when c-auto-newline - (backward-char) - (setq br-syntax (c-point-syntax) - newlines (c-brace-newlines br-syntax)) - - ;; Insert the BEFORE newline, if wanted, and reindent the newline. - (if (and (memq 'before newlines) - (> (current-column) (current-indentation))) - (if c-syntactic-indentation - ;; Only a plain newline for now - it's indented - ;; after the cleanups when the line has its final - ;; appearance. - (newline) - (c-newline-and-indent))) + (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'. + (when (and (boundp 'electric-pair-mode) + electric-pair-mode) + (let ((size (buffer-size)) + (c-in-electric-pair-functionality t) + post-self-insert-hook) + (electric-pair-post-self-insert-function) + (setq got-pair-} (and at-eol + (eq (c-last-command-char) ?{) + (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-} + (save-excursion (forward-char) - - ;; `syntax' is the syntactic context of the line which ends up - ;; with the brace on it. - (setq syntax (if (memq 'before newlines) br-syntax ln-syntax)) - - ;; Do all appropriate clean ups - (let ((here (point)) - (pos (- (point-max) (point))) - mbeg mend - ) - - ;; `}': clean up empty defun braces - (when (c-save-buffer-state () - (and (memq 'empty-defun-braces c-cleanup-list) - (eq (c-last-command-char) ?\}) - (c-intersect-lists '(defun-close class-close inline-close) - syntax) - (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)))) - (delete-region (point) (1- here)) - (setq here (- (point-max) pos))) - (goto-char here) - - ;; `}': compact to a one-liner defun? - (save-match-data - (when - (and (eq (c-last-command-char) ?\}) - (memq 'one-liner-defun c-cleanup-list) - (c-intersect-lists '(defun-close) syntax) - (c-try-one-liner)) - (setq here (- (point-max) pos)))) - - ;; `{': clean up brace-else-brace and brace-elseif-brace - (when (eq (c-last-command-char) ?\{) - (cond - ((and (memq 'brace-else-brace c-cleanup-list) - (re-search-backward - (concat "}" - "\\([ \t\n]\\|\\\\\n\\)*" - "else" - "\\([ \t\n]\\|\\\\\n\\)*" - "{" - "\\=") - nil t)) - (delete-region (match-beginning 0) (match-end 0)) - (insert-and-inherit "} else {")) - ((and (memq 'brace-elseif-brace c-cleanup-list) - (progn - (goto-char (1- here)) - (setq mend (point)) - (c-skip-ws-backward) - (setq mbeg (point)) - (eq (char-before) ?\))) - (zerop (c-save-buffer-state nil (c-backward-token-2 1 t))) - (eq (char-after) ?\() - ; (progn - ; (setq tmp (point)) - (re-search-backward - (concat "}" - "\\([ \t\n]\\|\\\\\n\\)*" - "else" - "\\([ \t\n]\\|\\\\\n\\)+" - "if" - "\\([ \t\n]\\|\\\\\n\\)*" - "\\=") - nil t);) - ;(eq (match-end 0) tmp); - ) - (delete-region mbeg mend) - (goto-char mbeg) - (insert ?\ )))) - - (goto-char (- (point-max) pos)) - - ;; Indent the line after the cleanups since it might - ;; very well indent differently due to them, e.g. if - ;; c-indent-one-line-block is used together with the - ;; one-liner-defun cleanup. - (when c-syntactic-indentation - (c-indent-line))) - - ;; does a newline go after the brace? - (if (memq 'after newlines) - (c-newline-and-indent)) - )))) + (c-do-brace-electrics 'assume 'ignore)) + (c-indent-line)))) ;; blink the paren (and (eq (c-last-command-char) ?\}) @@ -903,7 +944,8 @@ is inhibited." c-electric-flag (eq (c-last-command-char) ?/) (eq (char-before) (if literal ?* ?/)))) - (self-insert-command (prefix-numeric-value arg)) + (let (post-self-insert-hook) ; Disable random functionality. + (self-insert-command (prefix-numeric-value arg))) (if indentp (indent-according-to-mode)))) @@ -916,7 +958,8 @@ supplied, point is inside a literal, or `c-syntactic-indentation' is nil, this indentation is inhibited." (interactive "*P") - (self-insert-command (prefix-numeric-value arg)) + (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 () @@ -963,7 +1006,8 @@ settings of `c-cleanup-list'." (setq lim (c-most-enclosing-brace (c-parse-state)) literal (c-in-literal lim))) - (self-insert-command (prefix-numeric-value arg)) + (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. @@ -1032,7 +1076,8 @@ reindented unless `c-syntactic-indentation' is nil. newlines is-scope-op ;; shut this up (c-echo-syntactic-information-p nil)) - (self-insert-command (prefix-numeric-value arg)) + (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. @@ -1122,49 +1167,76 @@ 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 ((c-echo-syntactic-information-p nil) + (let ((literal (c-save-buffer-state () (c-in-literal))) + template-delim include-delim + (c-echo-syntactic-information-p nil) final-pos found-delim case-fold-search) - (self-insert-command (prefix-numeric-value arg)) + (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. - ;; 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))) - ;; ..... or is a C++ << operator. + (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 + (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))) + (looking-at ">>")) + (>= (match-end 0) final-pos))))) + (goto-char final-pos) - ;; It's a >. Either a template/generic terminator ... - (or (c-get-char-property (1- final-pos) 'syntax-table) - ;; 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)))))) + (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)))) - (goto-char final-pos) (when found-delim - (indent-according-to-mode) (when (and (eq (char-before) ?>) (not executing-kbd-macro) blink-paren-function) @@ -1190,10 +1262,12 @@ newline cleanups are done if appropriate; see the variable `c-cleanup-list'." ;; shut this up (c-echo-syntactic-information-p nil) case-fold-search) - (self-insert-command (prefix-numeric-value arg)) + (let (post-self-insert-hook) ; The only way to get defined functionality + ; from `self-insert-command'. + (self-insert-command (prefix-numeric-value arg))) (if (and (not arg) (not literal)) - (let* ( ;; We want to inhibit blinking the paren since this will + (let* (;; We want to inhibit blinking the paren since this will ;; be most disruptive. We'll blink it ourselves ;; afterwards. (old-blink-paren blink-paren-function) @@ -1239,6 +1313,12 @@ newline cleanups are done if appropriate; see the variable `c-cleanup-list'." (delete-region (match-beginning 0) (match-end 0)) (insert-and-inherit "} catch ("))) + ;; Apply `electric-pair-mode' stuff. + (when (and (boundp 'electric-pair-mode) + electric-pair-mode) + (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. @@ -1263,21 +1343,26 @@ newline cleanups are done if appropriate; see the variable `c-cleanup-list'." (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-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 - (funcall old-blink-paren)))))) + (funcall old-blink-paren))) + + ;; 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)))))) (defun c-electric-continued-statement () "Reindent the current line if appropriate. @@ -1383,7 +1468,7 @@ No indentation or other \"electric\" behavior is performed." (let ((eo-block (point)) bod) (and (eq (char-before) ?\}) - (eq (car (c-beginning-of-decl-1 lim)) 'previous) + (memq (car (c-beginning-of-decl-1 lim)) '(same previous)) (setq bod (point)) ;; Look for struct or union or ... If we find one, it might ;; be the return type of a function, or the like. Exclude @@ -1397,6 +1482,16 @@ No indentation or other \"electric\" behavior is performed." (not (eq (char-before) ?_)) (c-syntactic-re-search-forward "[;=([{]" eo-block t t t) (eq (char-before) ?\{) + ;; Exclude the entire "struct {...}" being the type of a + ;; function being declared. + (not + (and + (c-go-up-list-forward) + (eq (char-before) ?}) + (progn (c-forward-syntactic-ws) + (c-syntactic-re-search-forward + "[;=([{]" nil t t t)) + (eq (char-before) ?\())) bod))))) (defun c-where-wrt-brace-construct () @@ -1431,10 +1526,23 @@ No indentation or other \"electric\" behavior is performed." 'in-block) ((c-in-function-trailer-p) 'in-trailer) - ((and (not least-enclosing) - (consp paren-state) - (consp (car paren-state)) - (eq start (cdar paren-state))) + ((or (and (eq (char-before) ?\;) + (save-excursion + (backward-char) + (c-in-function-trailer-p))) + (and (not least-enclosing) + (consp paren-state) + (consp (car paren-state)) + (eq start (cdar paren-state)) + (or + (save-excursion + (c-forward-syntactic-ws) + (or (not (looking-at c-symbol-start)) + (looking-at c-keywords-regexp))) + (save-excursion + (goto-char (caar paren-state)) + (c-beginning-of-decl-1) + (not (looking-at c-defun-type-name-decl-key)))))) 'at-function-end) (t ;; Find the start of the current declaration. NOTE: If we're in the @@ -1450,6 +1558,18 @@ No indentation or other \"electric\" behavior is performed." "\\([;#]\\|\\'\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s$\\|\\s<\\|\\s>\\|\\s!\\)"))) (forward-char)) (setq kluge-start (point)) + ;; First approximation as to whether the current "header" we're in is + ;; one followed by braces. + (setq brace-decl-p + (save-excursion + (and (c-syntactic-re-search-forward "[;{]" nil t t) + (or (eq (char-before) ?\{) + (and c-recognize-knr-p + ;; Might have stopped on the + ;; ';' in a K&R argdecl. In + ;; that case the declaration + ;; should contain a block. + (c-in-knr-argdecl)))))) (setq decl-result (car (c-beginning-of-decl-1 ;; NOTE: If we're in a K&R region, this might be the start @@ -1460,17 +1580,9 @@ No indentation or other \"electric\" behavior is performed." (c-safe-position least-enclosing paren-state))))) ;; Has the declaration we've gone back to got braces? - (or (eq decl-result 'label) - (setq brace-decl-p - (save-excursion - (and (c-syntactic-re-search-forward "[;{]" nil t t) - (or (eq (char-before) ?\{) - (and c-recognize-knr-p - ;; Might have stopped on the - ;; ';' in a K&R argdecl. In - ;; that case the declaration - ;; should contain a block. - (c-in-knr-argdecl))))))) + (if (or (eq decl-result 'label) + (looking-at c-protection-key)) + (setq brace-decl-p nil)) (cond ((or (eq decl-result 'label) ; e.g. "private:" or invalid syntax. @@ -1613,6 +1725,8 @@ No indentation or other \"electric\" behavior is performed." paren-state orig-point-min orig-point-max)) (setq where 'in-block)))) +(def-edebug-spec c-while-widening-to-decl-block t) + (defun c-beginning-of-defun (&optional arg) "Move backward to the beginning of a defun. Every top level declaration that contains a brace paren block is @@ -1661,7 +1775,7 @@ defun." (setq arg (1+ arg))) (if (< arg 0) (c-while-widening-to-decl-block - (< (setq arg (- (c-forward-to-nth-EOF-} (- arg) where))) 0))) + (< (setq arg (- (c-forward-to-nth-EOF-\;-or-} (- arg) where))) 0))) ;; Move forward to the next opening brace.... (when (and (= arg 0) (progn @@ -1697,10 +1811,11 @@ defun." (c-keep-region-active) (= arg 0))))) -(defun c-forward-to-nth-EOF-} (n where) - ;; Skip to the closing brace of the Nth function after point. If - ;; point is inside a function, this counts as the first. Point must be - ;; outside any comment/string or macro. +(defun c-forward-to-nth-EOF-\;-or-} (n where) + ;; Skip to the closing brace or semicolon of the Nth function after point. + ;; We move to a semicolon only for things like structs which don't end at a + ;; closing brace. If point is inside a function, this counts as the first. + ;; Point must be outside any comment/string or macro. ;; ;; N must be strictly positive. ;; WHERE describes the position of point, one of the symbols `at-header', @@ -1722,23 +1837,24 @@ defun." (forward-sexp) (setq n (1- n))) ((eq where 'in-trailer) - (c-syntactic-skip-backward "^}") + ;; The actual movement is done below. (setq n (1- n))) ((memq where '(at-function-end outwith-function at-header in-header)) (when (c-syntactic-re-search-forward "{" nil 'eob) (backward-char) (forward-sexp) (setq n (1- n)))) - (t (error "c-forward-to-nth-EOF-}: `where' is %s" where))) + (t (error "c-forward-to-nth-EOF-\\;-or-}: `where' is %s" where))) + + (when (c-in-function-trailer-p) + (c-syntactic-re-search-forward ";" nil 'eob t)) ;; Each time round the loop, go forward to a "}" at the outermost level. (while (and (> n 0) (not (eobp))) - ;(c-parse-state) ; This call speeds up the following one by a factor - ; of ~6. Hmmm. 2006/4/5. (when (c-syntactic-re-search-forward "{" nil 'eob) (backward-char) - (forward-sexp)) - (setq n (1- n))) + (forward-sexp) + (setq n (1- n)))) n) (defun c-end-of-defun (&optional arg) @@ -1793,7 +1909,7 @@ the open-parenthesis that starts a defun; see `beginning-of-defun'." ;; Move forward to the } of a function (if (> arg 0) (c-while-widening-to-decl-block - (> (setq arg (c-forward-to-nth-EOF-} arg where)) 0)))) + (> (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) @@ -1817,251 +1933,268 @@ the open-parenthesis that starts a defun; see `beginning-of-defun'." (c-keep-region-active) (= arg 0)))) -(defun c-defun-name () - "Return the name of the current defun, or NIL if there isn't one. -\"Defun\" here means a function, or other top level construct -with a brace block." +(defun c-defun-name-1 () + "Return the name of the current defun, at the current narrowing, +or NIL if there isn't one. \"Defun\" here means a function, or +other top level construct with a brace block." (c-save-buffer-state (beginning-of-defun-function end-of-defun-function - where pos name-end case-fold-search) + where pos decl0 decl type-pos tag-pos case-fold-search) - (save-restriction - (widen) - (save-excursion - ;; 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)) - - ;; Move to the beginning of the current defun, if any, if we're not - ;; already there. - (if (eq where 'outwith-function) - nil - (unless (eq where 'at-header) - (c-backward-to-nth-BOF-{ 1 where) - (c-beginning-of-decl-1)) - (when (looking-at c-typedef-key) - (goto-char (match-end 0)) - (c-forward-syntactic-ws)) + (save-excursion + ;; 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)) - ;; Pick out the defun name, according to the type of defun. - (cond - ;; struct, union, enum, or similar: - ((save-excursion - (and - (looking-at c-type-prefix-key) - (consp (c-forward-decl-or-cast-1 (c-point 'bosws) 'top nil)) - (or (not (or (eq (char-after) ?{) - (and c-recognize-knr-p - (c-in-knr-argdecl)))) - (progn (c-backward-syntactic-ws) - (not (eq (char-before) ?\))))))) - (let ((key-pos (point))) - (c-forward-over-token-and-ws) ; over "struct ". - (cond - ((looking-at c-symbol-key) ; "struct foo { ..." - (buffer-substring-no-properties key-pos (match-end 0))) - ((eq (char-after) ?{) ; "struct { ... } foo" - (when (c-go-list-forward) - (c-forward-syntactic-ws) - (when (looking-at c-symbol-key) ; a bit bogus - there might - ; be several identifiers. - (match-string-no-properties 0))))))) - - ((looking-at "DEFUN\\s-*(") ;"DEFUN\\_>") think of XEmacs! - ;; DEFUN ("file-name-directory", Ffile_name_directory, Sfile_name_directory, ...) ==> Ffile_name_directory - ;; DEFUN(POSIX::STREAM-LOCK, stream lockp &key BLOCK SHARED START LENGTH) ==> POSIX::STREAM-LOCK - (down-list 1) + (setq where (c-where-wrt-brace-construct)) + + ;; Move to the beginning of the current defun, if any, if we're not + ;; already there. + (if (memq where '(outwith-function at-function-end)) + nil + (unless (eq where 'at-header) + (c-backward-to-nth-BOF-{ 1 where) + (c-beginning-of-decl-1)) + (when (looking-at c-typedef-key) + (goto-char (match-end 0)) + (c-forward-syntactic-ws)) + (setq type-pos (point)) + + ;; Pick out the defun name, according to the type of defun. + (cond + ((looking-at "DEFUN\\s-*(") ;"DEFUN\\_>") think of XEmacs! + ;; DEFUN ("file-name-directory", Ffile_name_directory, Sfile_name_directory, ...) ==> Ffile_name_directory + ;; DEFUN(POSIX::STREAM-LOCK, stream lockp &key BLOCK SHARED START LENGTH) ==> POSIX::STREAM-LOCK + (down-list 1) + (c-forward-syntactic-ws) + (when (eq (char-after) ?\") + (forward-sexp 1) + (c-forward-token-2)) ; over the comma and following WS. + (buffer-substring-no-properties + (point) + (progn + (c-forward-token-2) + (c-backward-syntactic-ws) + (point)))) + + (t ; Normal function or initializer. + (when (looking-at c-defun-type-name-decl-key) ; struct, etc. + (goto-char (match-end 0)) (c-forward-syntactic-ws) - (when (eq (char-after) ?\") - (forward-sexp 1) - (c-forward-token-2)) ; over the comma and following WS. - (buffer-substring-no-properties - (point) - (progn - (c-forward-token-2) - (when (looking-at ":") ; CLISP: DEFUN(PACKAGE:LISP-SYMBOL,...) - (skip-chars-forward "^,")) - (c-backward-syntactic-ws) - (point)))) - - ((looking-at "DEF[a-zA-Z0-9_]* *( *\\([^, ]*\\) *,") - ;; DEFCHECKER(sysconf_arg,prefix=_SC,default=, ...) ==> sysconf_arg - ;; DEFFLAGSET(syslog_opt_flags,LOG_PID ...) ==> syslog_opt_flags - (match-string-no-properties 1)) - - ;; Objc selectors. - ((assq 'objc-method-intro (c-guess-basic-syntax)) - (let ((bound (save-excursion (c-end-of-statement) (point))) - (kw-re (concat "\\(?:" c-symbol-key "\\)?:")) - (stretches)) - (when (c-syntactic-re-search-forward c-symbol-key bound t t t) - (push (match-string-no-properties 0) stretches) - (while (c-syntactic-re-search-forward kw-re bound t t t) - (push (match-string-no-properties 0) stretches))) - (apply 'concat (nreverse stretches)))) - - (t - ;; Normal function or initializer. - (when - (and - (consp (c-forward-decl-or-cast-1 (c-point 'bosws) 'top nil)) - (or (eq (char-after) ?{) - (and c-recognize-knr-p - (c-in-knr-argdecl))) - (progn - (c-backward-syntactic-ws) - (eq (char-before) ?\))) - (c-go-list-backward)) - (c-backward-syntactic-ws) - (when (eq (char-before) ?\=) ; struct foo bar = {0, 0} ; - (c-backward-token-2) - (c-backward-syntactic-ws)) - (setq name-end (point)) - (c-back-over-compound-identifier) - (and (looking-at c-symbol-start) - (buffer-substring-no-properties (point) name-end)))))))))) + (setq tag-pos (point)) + (goto-char type-pos)) + (setq decl0 (c-forward-decl-or-cast-1 (c-point 'bosws) 'top nil)) + (when (consp decl0) + (goto-char (car decl0)) + (setq decl (c-forward-declarator))) + (and decl + (car decl) (cadr decl) + (buffer-substring-no-properties + (if (eq (car decl) tag-pos) + type-pos + (car decl)) + (cadr decl))))))))) -(defun c-declaration-limits (near) - ;; Return a cons of the beginning and end positions of the current - ;; top level declaration or macro. If point is not inside any then - ;; nil is returned, unless NEAR is non-nil in which case the closest - ;; following one is chosen instead (if there is any). The end +(defun c-defun-name () + "Return the name of the current defun, or NIL if there isn't one. +\"Defun\" here means a function, or other top level construct +with a brace block, at the outermost level of nesting." + (c-save-buffer-state () + (save-restriction + (widen) + (c-defun-name-1)))) + +(defun c-declaration-limits-1 (near) + ;; Return a cons of the beginning and end position of the current + ;; declaration or macro in the current narrowing. If there is no current + ;; declaration or macro, return nil, unless NEAR is non-nil, in which case + ;; the closest following one is chosen instead (if there is any). The end ;; position is at the next line, providing there is one before the ;; declaration. ;; ;; This function might do hidden buffer changes. (save-excursion - (save-restriction - (let ((start (point)) - (paren-state (c-parse-state)) - lim pos end-pos where) - ;; Narrow enclosing brace blocks out, as required by the values of - ;; `c-defun-tactic', `near', and the position of point. - (when (eq c-defun-tactic 'go-outward) - (let ((bounds - (save-restriction - (if (and (not (save-excursion (c-beginning-of-macro))) - (save-restriction - (c-narrow-to-most-enclosing-decl-block) - (memq (c-where-wrt-brace-construct) - '(at-function-end outwith-function))) - (not near)) - (c-narrow-to-most-enclosing-decl-block nil 2) - (c-narrow-to-most-enclosing-decl-block)) - (cons (point-min) (point-max))))) - (narrow-to-region (car bounds) (cdr bounds)))) - (setq paren-state (c-parse-state)) - - (or - ;; Note: Some code duplication in `c-beginning-of-defun' and - ;; `c-end-of-defun'. - (catch 'exit - (unless (c-safe - (goto-char (c-least-enclosing-brace paren-state)) - ;; If we moved to the outermost enclosing paren - ;; then we can use c-safe-position to set the - ;; limit. Can't do that otherwise since the - ;; earlier paren pair on paren-state might very - ;; well be part of the declaration we should go - ;; to. - (setq lim (c-safe-position (point) paren-state)) - t) - ;; At top level. Make sure we aren't inside a literal. - (setq pos (c-literal-start - (c-safe-position (point) paren-state))) - (if pos (goto-char pos))) - - (when (c-beginning-of-macro) + (let ((start (point)) + (paren-state (c-parse-state)) + lim pos end-pos where) + (or + ;; Note: Some code duplication in `c-beginning-of-defun' and + ;; `c-end-of-defun'. + (catch 'exit + (unless (c-safe + (goto-char (c-least-enclosing-brace paren-state)) + ;; If we moved to the outermost enclosing paren + ;; then we can use c-safe-position to set the + ;; limit. Can't do that otherwise since the + ;; earlier paren pair on paren-state might very + ;; well be part of the declaration we should go + ;; to. + (setq lim (c-safe-position (point) paren-state)) + ;; We might have a struct foo {...} as the type of the + ;; function, so set LIM back one further block. + (if (eq (char-before lim) ?}) + (setq lim + (or + (save-excursion + (and + (c-go-list-backward lim) + (let ((paren-state-1 (c-parse-state))) + (c-safe-position + (point) paren-state-1)))) + (point-min)))) + t) + ;; At top level. Make sure we aren't inside a literal. + (setq pos (c-literal-start + (c-safe-position (point) paren-state))) + (if pos (goto-char pos))) + + (when (c-beginning-of-macro) + (throw 'exit + (cons (point) + (save-excursion + (c-end-of-macro) + (forward-line 1) + (point))))) + + (setq pos (point)) + (setq where (and (not (save-excursion (c-beginning-of-macro))) + (c-where-wrt-brace-construct))) + (when (and (not (eq where 'at-header)) + (or (and near + (memq where + '(at-function-end outwith-function)) + ;; Check we're not inside a declaration without + ;; braces. + (save-excursion + (memq (car (c-beginning-of-decl-1 lim)) + '(previous label)))) + (eq (car (c-beginning-of-decl-1 lim)) 'previous) + (= pos (point)))) + ;; We moved back over the previous defun. Skip to the next + ;; one. Not using c-forward-syntactic-ws here since we + ;; should not skip a macro. We can also be directly after + ;; the block in a `c-opt-block-decls-with-vars-key' + ;; declaration, but then we won't move significantly far + ;; here. + (goto-char pos) + (c-forward-comments) + + (when (and near (c-beginning-of-macro)) (throw 'exit (cons (point) (save-excursion (c-end-of-macro) (forward-line 1) - (point))))) + (point)))))) - (setq pos (point)) - (setq where (and (not (save-excursion (c-beginning-of-macro))) - (c-where-wrt-brace-construct))) - (when (and (not (eq where 'at-header)) - (or (and near - (memq where - '(at-function-end outwith-function))) - (eq (car (c-beginning-of-decl-1 lim)) 'previous) - (= pos (point)))) - ;; We moved back over the previous defun. Skip to the next - ;; one. Not using c-forward-syntactic-ws here since we - ;; should not skip a macro. We can also be directly after - ;; the block in a `c-opt-block-decls-with-vars-key' - ;; declaration, but then we won't move significantly far - ;; here. - (goto-char pos) - (c-forward-comments) - - (when (and near (c-beginning-of-macro)) - (throw 'exit - (cons (point) - (save-excursion - (c-end-of-macro) - (forward-line 1) - (point)))))) + (if (eobp) (throw 'exit nil)) - (if (eobp) (throw 'exit nil)) + ;; Check if `c-beginning-of-decl-1' put us after the block in a + ;; declaration that doesn't end there. We're searching back and + ;; forth over the block here, which can be expensive. + (setq pos (point)) + (if (and c-opt-block-decls-with-vars-key + (progn + (c-backward-syntactic-ws) + (eq (char-before) ?})) + (eq (car (c-beginning-of-decl-1)) + 'previous) + (save-excursion + (c-end-of-decl-1) + (and (> (point) pos) + (setq end-pos (point))))) + nil + (goto-char pos)) + + (if (or (and (not near) (> (point) start)) + (not (eq (c-where-wrt-brace-construct) 'at-header))) + nil + + ;; Try to be line oriented; position the limits at the + ;; closest preceding boi, and after the next newline, that + ;; isn't inside a comment, but if we hit a neighboring + ;; declaration then we instead use the exact declaration + ;; limit in that direction. + (cons (progn + (setq pos (point)) + (while (and (/= (point) (c-point 'boi)) + (c-backward-single-comment))) + (if (/= (point) (c-point 'boi)) + pos + (point))) + (progn + (if end-pos + (goto-char end-pos) + (c-end-of-decl-1)) + (setq pos (point)) + (while (and (not (bolp)) + (not (looking-at "\\s *$")) + (c-forward-single-comment))) + (cond ((bolp) + (point)) + ((looking-at "\\s *$") + (forward-line 1) + (point)) + (t + pos)))))) + (and (not near) + (goto-char (point-min)) + (c-forward-decl-or-cast-1 -1 nil nil) + (eq (char-after) ?\{) + (cons (point-min) (point-max))))))) - ;; Check if `c-beginning-of-decl-1' put us after the block in a - ;; declaration that doesn't end there. We're searching back and - ;; forth over the block here, which can be expensive. - (setq pos (point)) - (if (and c-opt-block-decls-with-vars-key - (progn - (c-backward-syntactic-ws) - (eq (char-before) ?})) - (eq (car (c-beginning-of-decl-1)) - 'previous) - (save-excursion - (c-end-of-decl-1) - (and (> (point) pos) - (setq end-pos (point))))) - nil - (goto-char pos)) - - (if (and (not near) (> (point) start)) - nil - - ;; Try to be line oriented; position the limits at the - ;; closest preceding boi, and after the next newline, that - ;; isn't inside a comment, but if we hit a neighboring - ;; declaration then we instead use the exact declaration - ;; limit in that direction. - (cons (progn - (setq pos (point)) - (while (and (/= (point) (c-point 'boi)) - (c-backward-single-comment))) - (if (/= (point) (c-point 'boi)) - pos - (point))) - (progn - (if end-pos - (goto-char end-pos) - (c-end-of-decl-1)) - (setq pos (point)) - (while (and (not (bolp)) - (not (looking-at "\\s *$")) - (c-forward-single-comment))) - (cond ((bolp) - (point)) - ((looking-at "\\s *$") - (forward-line 1) - (point)) - (t - pos)))))) - (and (not near) - (goto-char (point-min)) - (c-forward-decl-or-cast-1 -1 nil nil) - (eq (char-after) ?\{) - (cons (point-min) (point-max)))))))) +(defun c-declaration-limits (near) + ;; Return a cons of the beginning and end positions of the current + ;; top level declaration or macro. If point is not inside any then + ;; nil is returned, unless NEAR is non-nil in which case the closest + ;; following one is chosen instead (if there is any). The end + ;; position is at the next line, providing there is one before the + ;; declaration. + ;; + ;; This function might do hidden buffer changes. + (save-restriction + ;; Narrow enclosing brace blocks out, as required by the values of + ;; `c-defun-tactic', `near', and the position of point. + (when (eq c-defun-tactic 'go-outward) + (let ((bounds + (save-restriction + (if (and (not (save-excursion (c-beginning-of-macro))) + (save-restriction + (c-narrow-to-most-enclosing-decl-block) + (memq (c-where-wrt-brace-construct) + '(at-function-end outwith-function))) + (not near)) + (c-narrow-to-most-enclosing-decl-block nil 2) + (c-narrow-to-most-enclosing-decl-block)) + (cons (point-min) (point-max))))) + (narrow-to-region (car bounds) (cdr bounds)))) + (c-declaration-limits-1 near))) + +(defun c-defun-name-and-limits (near) + ;; Return a cons of the name and limits (itself a cons) of the current + ;; top-level declaration or macro, or nil of there is none. + ;; + ;; If `c-defun-tactic' is 'go-outward, we return the name and limits of the + ;; most tightly enclosing declaration or macro. Otherwise, we return that + ;; at the file level. + (save-restriction + (widen) + (if (eq c-defun-tactic 'go-outward) + (c-save-buffer-state ((paren-state (c-parse-state)) + (orig-point-min (point-min)) + (orig-point-max (point-max)) + lim name where limits fdoc) + (setq lim (c-widen-to-enclosing-decl-scope + paren-state orig-point-min orig-point-max)) + (and lim (setq lim (1- lim))) + (c-while-widening-to-decl-block (not (setq name (c-defun-name-1)))) + (when name + (setq limits (c-declaration-limits-1 near)) + (cons name limits))) + (c-save-buffer-state ((name (c-defun-name)) + (limits (c-declaration-limits near))) + (and name limits (cons name limits)))))) (defun c-display-defun-name (&optional arg) "Display the name of the current CC mode defun and the position in it. @@ -2069,12 +2202,13 @@ With a prefix arg, push the name onto the kill ring too." (interactive "P") (save-restriction (widen) - (c-save-buffer-state ((name (c-defun-name)) - (limits (c-declaration-limits t)) + (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) point-bol)) + (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))))) @@ -3477,7 +3611,7 @@ Otherwise reindent just the current line." (save-excursion (goto-char end) (point-marker)) - (nth 1 (current-time)) + (encode-time nil 'integer) context)) (message "Indenting region...")) )) @@ -3485,7 +3619,7 @@ Otherwise reindent just the current line." (defun c-progress-update () (if (not (and c-progress-info c-progress-interval)) nil - (let ((now (nth 1 (current-time))) + (let ((now (encode-time nil 'integer)) (start (aref c-progress-info 0)) (end (aref c-progress-info 1)) (lastsecs (aref c-progress-info 2))) @@ -4737,7 +4871,7 @@ If a fill prefix is specified, it overrides all the above." (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 indent-new-comment-line for older Emacsen +;; 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 diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el index 40318b149d8..ab3e25b226f 100644 --- a/lisp/progmodes/cc-defs.el +++ b/lisp/progmodes/cc-defs.el @@ -81,13 +81,13 @@ (progn (require 'font-lock) (let (font-lock-keywords) - (font-lock-compile-keywords '("\\<\\>")) + (font-lock-compile-keywords (list regexp-unmatchable)) font-lock-keywords)))) ;;; Variables also used at compile time. -(defconst c-version "5.33.2" +(defconst c-version "5.34" "CC Mode version number.") (defconst c-version-sym (intern c-version)) @@ -107,6 +107,13 @@ not known.") ;; survives the initialization of the derived mode. (put 'c-buffer-is-cc-mode 'permanent-local t) +(defvar c-syntax-table-hwm most-positive-fixnum) +;; A workaround for `syntax-ppss''s failure to take account of changes in +;; syntax-table text properties. This variable gets set to the lowest +;; position where the syntax-table text property is changed, and that value +;; gets supplied to `syntax-ppss-flush-cache' just before a font locking is +;; due to take place. + ;; The following is used below during compilation. (eval-and-compile @@ -219,6 +226,7 @@ one of the following symbols: `bol' -- beginning of line `eol' -- end of line +`eoll' -- end of logical line (i.e. without escaped NL) `bod' -- beginning of defun `eod' -- end of defun `boi' -- beginning of indentation @@ -240,7 +248,7 @@ to it is returned. This function does not modify the point or the mark." ((eq position 'bol) (if (and (cc-bytecomp-fboundp 'line-beginning-position) (not point)) - `(line-beginning-position) + '(line-beginning-position) `(save-excursion ,@(if point `((goto-char ,point))) (beginning-of-line) @@ -248,12 +256,26 @@ to it is returned. This function does not modify the point or the mark." ((eq position 'eol) (if (and (cc-bytecomp-fboundp 'line-end-position) (not point)) - `(line-end-position) + '(line-end-position) `(save-excursion ,@(if point `((goto-char ,point))) (end-of-line) (point)))) + ((eq position 'eoll) + `(save-excursion + ,@(if point `((goto-char ,point))) + (while (and + (not (eobp)) + (progn + (end-of-line) + (c-is-escaped (point)) + ;; (prog1 (eq (logand 1 (skip-chars-backward "\\\\")) 1)) + )) + (forward-line)) + (end-of-line) + (point))) + ((eq position 'boi) `(save-excursion ,@(if point `((goto-char ,point))) @@ -274,7 +296,7 @@ to it is returned. This function does not modify the point or the mark." ((eq position 'bopl) (if (and (cc-bytecomp-fboundp 'line-beginning-position) (not point)) - `(line-beginning-position 0) + '(line-beginning-position 0) `(save-excursion ,@(if point `((goto-char ,point))) (forward-line -1) @@ -282,7 +304,7 @@ to it is returned. This function does not modify the point or the mark." ((eq position 'bonl) (if (and (cc-bytecomp-fboundp 'line-beginning-position) (not point)) - `(line-beginning-position 2) + '(line-beginning-position 2) `(save-excursion ,@(if point `((goto-char ,point))) (forward-line 1) @@ -290,7 +312,7 @@ to it is returned. This function does not modify the point or the mark." ((eq position 'eopl) (if (and (cc-bytecomp-fboundp 'line-end-position) (not point)) - `(line-end-position 0) + '(line-end-position 0) `(save-excursion ,@(if point `((goto-char ,point))) (beginning-of-line) @@ -299,7 +321,7 @@ to it is returned. This function does not modify the point or the mark." ((eq position 'eonl) (if (and (cc-bytecomp-fboundp 'line-end-position) (not point)) - `(line-end-position 2) + '(line-end-position 2) `(save-excursion ,@(if point `((goto-char ,point))) (forward-line 1) @@ -386,6 +408,25 @@ to it is returned. This function does not modify the point or the mark." (forward-sexp) (= (point) (+ 4 (point-min))))))) +(defmacro c-is-escaped (pos) + ;; Are there an odd number of backslashes before POS? + `(save-excursion + (goto-char ,pos) + (not (zerop (logand (skip-chars-backward "\\\\") 1))))) + +(defmacro c-will-be-escaped (pos beg end) + ;; Will the character after POS be escaped after the removal of (BEG END)? + ;; It is assumed that (>= POS END). + `(save-excursion + (let ((-end- ,end) + count) + (goto-char ,pos) + (setq count (skip-chars-backward "\\\\" -end-)) + (when (eq (point) -end-) + (goto-char ,beg) + (setq count (+ count (skip-chars-backward "\\\\")))) + (not (zerop (logand count 1)))))) + (defvar c-use-extents) (defmacro c-next-single-property-change (position prop &optional object limit) @@ -453,6 +494,13 @@ to it is returned. This function does not modify the point or the mark." `(int-to-char ,integer) integer)) +(defmacro c-characterp (arg) + ;; Return t when ARG is a character (XEmacs) or integer (Emacs), otherwise + ;; return nil. + (if (integerp ?c) + `(integerp ,arg) + `(characterp ,arg))) + (defmacro c-last-command-char () ;; The last character just typed. Note that `last-command-event' exists in ;; both Emacs and XEmacs, but with confusingly different meanings. @@ -464,17 +512,42 @@ to it is returned. This function does not modify the point or the mark." ;; Get the regular expression `sentence-end'. (if (cc-bytecomp-fboundp 'sentence-end) ;; Emacs 22: - `(sentence-end) + '(sentence-end) ;; Emacs <22 + XEmacs - `sentence-end)) + 'sentence-end)) (defmacro c-default-value-sentence-end () ;; Get the default value of the variable sentence end. (if (cc-bytecomp-fboundp 'sentence-end) ;; Emacs 22: - `(let (sentence-end) (sentence-end)) + '(let (sentence-end) (sentence-end)) ;; Emacs <22 + XEmacs - `(default-value 'sentence-end))) + '(default-value 'sentence-end))) + +(defconst c-c++-raw-string-opener-re "R\"\\([^ ()\\\n\r\t]\\{0,16\\}\\)(") +;; Matches a C++ raw string opener. Submatch 1 is its identifier. + +(defconst c-c++-raw-string-opener-1-re "\"\\([^ ()\\\n\r\t]\\{0,16\\}\\)(") +;; Matches a C++ raw string opener starting after the initial R. + +(defmacro c-sub-at-c++-raw-string-opener () + `(save-excursion + (and + (if (eq (char-after) ?R) + (progn (forward-char) t) + (eq (char-before) ?R)) + (looking-at c-c++-raw-string-opener-1-re)))) + +(defmacro c-at-c++-raw-string-opener (&optional pos) + ;; Return non-nil if POS (default point) is either at the start of a C++ raw + ;; string opener, or after the introductory R of one. The match data is + ;; overwritten. On success the opener's identifier will be (match-string + ;; 1). Text properties on any characters are ignored. + (if pos + `(save-excursion + (goto-char ,pos) + (c-sub-at-c++-raw-string-opener)) + `(c-sub-at-c++-raw-string-opener))) ;; The following is essentially `save-buffer-state' from lazy-lock.el. ;; It ought to be a standard macro. @@ -673,7 +746,7 @@ leave point unmoved. A LIMIT for the search may be given. The start position is assumed to be before it." - `(let ((dest (c-safe-scan-lists ,(or pos `(point)) 1 0 ,limit))) + `(let ((dest (c-safe-scan-lists ,(or pos '(point)) 1 0 ,limit))) (when dest (goto-char dest) dest))) (defmacro c-go-list-backward (&optional pos limit) @@ -683,7 +756,7 @@ leave point unmoved. A LIMIT for the search may be given. The start position is assumed to be after it." - `(let ((dest (c-safe-scan-lists ,(or pos `(point)) -1 0 ,limit))) + `(let ((dest (c-safe-scan-lists ,(or pos '(point)) -1 0 ,limit))) (when dest (goto-char dest) dest))) (defmacro c-up-list-forward (&optional pos limit) @@ -692,7 +765,7 @@ or nil if no such position exists. The point is used if POS is left out. A limit for the search may be given. The start position is assumed to be before it." - `(c-safe-scan-lists ,(or pos `(point)) 1 1 ,limit)) + `(c-safe-scan-lists ,(or pos '(point)) 1 1 ,limit)) (defmacro c-up-list-backward (&optional pos limit) "Return the position of the start of the list sexp containing POS, @@ -700,7 +773,7 @@ or nil if no such position exists. The point is used if POS is left out. A limit for the search may be given. The start position is assumed to be after it." - `(c-safe-scan-lists ,(or pos `(point)) -1 1 ,limit)) + `(c-safe-scan-lists ,(or pos '(point)) -1 1 ,limit)) (defmacro c-down-list-forward (&optional pos limit) "Return the first position inside the first list sexp after POS, @@ -708,7 +781,7 @@ or nil if no such position exists. The point is used if POS is left out. A limit for the search may be given. The start position is assumed to be before it." - `(c-safe-scan-lists ,(or pos `(point)) 1 -1 ,limit)) + `(c-safe-scan-lists ,(or pos '(point)) 1 -1 ,limit)) (defmacro c-down-list-backward (&optional pos limit) "Return the last position inside the last list sexp before POS, @@ -716,7 +789,7 @@ or nil if no such position exists. The point is used if POS is left out. A limit for the search may be given. The start position is assumed to be after it." - `(c-safe-scan-lists ,(or pos `(point)) -1 -1 ,limit)) + `(c-safe-scan-lists ,(or pos '(point)) -1 -1 ,limit)) (defmacro c-go-up-list-forward (&optional pos limit) "Move the point to the first position after the list sexp containing POS, @@ -877,7 +950,7 @@ be after it." ;; c-beginning-of-statement-1. ;; Languages which don't have EOL terminated statements always return NIL ;; (they _know_ there's no vsemi ;-). - `(if c-vsemi-status-unknown-p-fn (funcall c-vsemi-status-unknown-p-fn))) + '(if c-vsemi-status-unknown-p-fn (funcall c-vsemi-status-unknown-p-fn))) (defmacro c-benign-error (format &rest args) @@ -967,6 +1040,15 @@ MODE is either a mode symbol or a list of mode symbols." ;; properties set on a single character and that never spread to any ;; other characters. +(defmacro c-put-syn-tab (pos value) + ;; Set both the syntax-table and the c-fl-syn-tab text properties at POS to + ;; VALUE (which should not be nil). + `(let ((-pos- ,pos) + (-value- ,value)) + (c-put-char-property -pos- 'syntax-table -value-) + (c-put-char-property -pos- 'c-fl-syn-tab -value-) + (c-truncate-lit-pos-cache -pos-))) + (eval-and-compile ;; Constant used at compile time to decide whether or not to use ;; XEmacs extents. Check all the extent functions we'll use since @@ -1037,6 +1119,9 @@ MODE is either a mode symbol or a list of mode symbols." ;; In Emacs 21 we got the `rear-nonsticky' property covered ;; by `text-property-default-nonsticky'. `(let ((-pos- ,pos)) + ,@(when (and (fboundp 'syntax-ppss) + (eq `,property 'syntax-table)) + `((setq c-syntax-table-hwm (min c-syntax-table-hwm -pos-)))) (put-text-property -pos- (1+ -pos-) ',property ,value)))) (defmacro c-get-char-property (pos property) @@ -1082,12 +1167,36 @@ MODE is either a mode symbol or a list of mode symbols." ;; In Emacs 21 we got the `rear-nonsticky' property covered ;; by `text-property-default-nonsticky'. `(let ((pos ,pos)) + ,@(when (and (fboundp 'syntax-ppss) + (eq `,property 'syntax-table)) + `((setq c-syntax-table-hwm (min c-syntax-table-hwm pos)))) (remove-text-properties pos (1+ pos) '(,property nil)))) (t ;; Emacs < 21. `(c-clear-char-property-fun ,pos ',property)))) +(defmacro c-clear-syn-tab (pos) + ;; Remove both the 'syntax-table and `c-fl-syn-tab properties at POS. + `(let ((-pos- ,pos)) + (c-clear-char-property -pos- 'syntax-table) + (c-clear-char-property -pos- 'c-fl-syn-tab) + (c-truncate-lit-pos-cache -pos-))) + +(defmacro c-min-property-position (from to property) + ;; Return the first position in the range [FROM to) where the text property + ;; PROPERTY is set, or `most-positive-fixnum' if there is no such position. + ;; PROPERTY should be a quoted constant. + `(let ((-from- ,from) (-to- ,to) pos) + (cond + ((and (< -from- -to-) + (get-text-property -from- ,property)) + -from-) + ((< (setq pos (next-single-property-change -from- ,property nil -to-)) + -to-) + pos) + (most-positive-fixnum)))) + (defmacro c-clear-char-properties (from to property) ;; Remove all the occurrences of the given property in the given ;; region that has been put with `c-put-char-property'. PROPERTY is @@ -1106,7 +1215,21 @@ MODE is either a mode symbol or a list of mode symbols." (delete-extent ext)) nil ,from ,to nil nil ',property) ;; Emacs. - `(remove-text-properties ,from ,to '(,property nil)))) + (if (and (fboundp 'syntax-ppss) + (eq `,property 'syntax-table)) + `(let ((-from- ,from) (-to- ,to)) + (setq c-syntax-table-hwm + (min c-syntax-table-hwm + (c-min-property-position -from- -to- ',property))) + (remove-text-properties -from- -to- '(,property nil))) + `(remove-text-properties ,from ,to '(,property nil))))) + +(defmacro c-clear-syn-tab-properties (from to) + ;; Remove all occurrences of the `syntax-table' and `c-fl-syn-tab' text + ;; properties between FROM and TO. + `(let ((-from- ,from) (-to- ,to)) + (c-clear-char-properties -from- -to- 'syntax-table) + (c-clear-char-properties -from- -to- 'c-fl-syn-tab))) (defmacro c-search-forward-char-property (property value &optional limit) "Search forward for a text-property PROPERTY having value VALUE. @@ -1124,7 +1247,7 @@ nil; point is then left undefined." place ,property nil ,(or limit '(point-max))))) (when (< place ,(or limit '(point-max))) (goto-char place) - (search-forward-regexp ".") ; to set the match-data. + (search-forward-regexp "\\(\n\\|.\\)") ; to set the match-data. (point)))) (defmacro c-search-backward-char-property (property value &optional limit) @@ -1148,7 +1271,7 @@ point is then left undefined." place ,property nil ,(or limit '(point-min))))) (when (> place ,(or limit '(point-min))) (goto-char place) - (search-backward-regexp ".") ; to set the match-data. + (search-backward-regexp "\\(n\\|.\\)") ; to set the match-data. (point)))) (defun c-clear-char-property-with-value-function (from to property value) @@ -1165,6 +1288,8 @@ been put there by c-put-char-property. POINT remains unchanged." (not (equal (get-text-property place property) value))) (setq place (c-next-single-property-change place property nil to))) (< place to)) + (when (and (fboundp 'syntax-ppss) (eq property 'syntax-table)) + (setq c-syntax-table-hwm (min c-syntax-table-hwm place))) (setq end-place (c-next-single-property-change place property nil to)) (remove-text-properties place end-place (cons property nil)) ;; Do we have to do anything with stickiness here? @@ -1196,7 +1321,7 @@ Leave point just after the character, and set the match data on this character, and return point. If the search fails, return nil; point is then left undefined." `(let ((char-skip (concat "^" (char-to-string ,char))) - (-limit- ,limit) + (-limit- (or ,limit (point-max))) (-value- ,value)) (while (and @@ -1205,7 +1330,30 @@ nil; point is then left undefined." (not (equal (c-get-char-property (point) ,property) -value-))) (forward-char)) (when (< (point) -limit-) - (search-forward-regexp ".") ; to set the match-data. + (search-forward-regexp "\\(\n\\|.\\)") ; to set the match-data. + (point)))) + +(defmacro c-search-forward-char-property-without-value-on-char + (property value char &optional limit) + "Search forward for a character CHAR without text property PROPERTY having +a value CHAR. +LIMIT bounds the search. The value comparison is done with `equal'. +PROPERTY must be a constant. + +Leave point just after the character, and set the match data on +this character, and return point. If the search fails, return +nil; point is then left undefined." + `(let ((char-skip (concat "^" (char-to-string ,char))) + (-limit- (or ,limit (point-max))) + (-value- ,value)) + (while + (and + (progn (skip-chars-forward char-skip -limit-) + (< (point) -limit-)) + (equal (c-get-char-property (point) ,property) -value-)) + (forward-char)) + (when (< (point) -limit-) + (search-forward-regexp "\\(\n\\|.\\)") ; to set the match-data. (point)))) (defun c-clear-char-property-with-value-on-char-function (from to property @@ -1214,9 +1362,10 @@ nil; point is then left undefined." characters with value CHAR from the region [FROM, TO), as tested by `equal'. These properties are assumed to be over individual characters, having been put there by c-put-char-property. POINT -remains unchanged." +remains unchanged. Return the position of the first removed +property, or nil." (let ((place from) - ) + first) (while ; loop round occurrences of (PROPERTY VALUE) (progn (while ; loop round changes in PROPERTY till we find VALUE @@ -1225,28 +1374,37 @@ remains unchanged." (not (equal (get-text-property place property) value))) (setq place (c-next-single-property-change place property nil to))) (< place to)) - (if (eq (char-after place) char) - (remove-text-properties place (1+ place) (cons property nil))) + (when (eq (char-after place) char) + (remove-text-properties place (1+ place) (cons property nil)) + (or first + (progn (setq first place) + (when (eq property 'syntax-table) + (setq c-syntax-table-hwm (min c-syntax-table-hwm place)))))) ;; Do we have to do anything with stickiness here? - (setq place (1+ place))))) + (setq place (1+ place))) + first)) (defmacro c-clear-char-property-with-value-on-char (from to property value char) "Remove all text-properties PROPERTY with value VALUE on characters with value CHAR from the region [FROM, TO), as tested by `equal'. These properties are assumed to be over individual characters, having been put there by c-put-char-property. POINT -remains unchanged." +remains unchanged. Return the position of the first removed +property, or nil." (if c-use-extents ;; XEmacs `(let ((-property- ,property) - (-char- ,char)) + (-char- ,char) + (first (1+ (point-max)))) (map-extents (lambda (ext val) - (if (and (equal (extent-property ext -property-) val) - (eq (char-after - (extent-start-position ext)) - -char-)) - (delete-extent ext))) - nil ,from ,to ,value nil -property-)) + (when (and (equal (extent-property ext -property-) val) + (eq (char-after + (extent-start-position ext)) + -char-)) + (setq first (min first (extent-start-position ext))) + (delete-extent ext))) + nil ,from ,to ,value nil -property-) + (and (<= first (point-max)) first)) ;; GNU Emacs `(c-clear-char-property-with-value-on-char-function ,from ,to ,property ,value ,char))) @@ -1262,8 +1420,34 @@ with value CHAR in the region [FROM to)." (goto-char ,from) (while (progn (skip-chars-forward skip-string -to-) (< (point) -to-)) - (c-put-char-property (point) ,property ,value) - (forward-char))))) + ,@(when (and (fboundp 'syntax-ppss) + (eq (eval property) 'syntax-table)) + `((setq c-syntax-table-hwm (min c-syntax-table-hwm (point))))) + (c-put-char-property (point) ,property ,value) + (forward-char))))) + +(defmacro c-with-extended-string-fences (beg end &rest body) + ;; If needed, extend the region with "mirrored" c-fl-syn-tab properties to + ;; contain the region (BEG END), then evaluate BODY. If this mirrored + ;; region was initially empty, restore it afterwards. + `(let ((-beg- ,beg) + (-end- ,end) + ) + (cond + ((null c-fl-syn-tab-region) + (unwind-protect + (progn + (c-restore-string-fences -beg- -end-) + ,@body) + (c-clear-string-fences))) + ((and (>= -beg- (car c-fl-syn-tab-region)) + (<= -end- (cdr c-fl-syn-tab-region))) + ,@body) + (t ; Crudely extend the mirrored region. + (setq -beg- (min -beg- (car c-fl-syn-tab-region)) + -end- (max -end- (cdr c-fl-syn-tab-region))) + (c-restore-string-fences -beg- -end-) + ,@body)))) ;; Macros to put overlays (Emacs) or extents (XEmacs) on buffer text. ;; For our purposes, these are characterized by being possible to @@ -1298,20 +1482,39 @@ with value CHAR in the region [FROM to)." ;(eval-after-load "edebug" ; 2006-07-09: def-edebug-spec is now in subr.el. ; '(progn (def-edebug-spec cc-eval-when-compile (&rest def-form)) +(def-edebug-spec c-font-lock-flush t) +(def-edebug-spec c--mapcan t) +(def-edebug-spec c--set-difference (form form &rest [symbolp form])) +(def-edebug-spec c--intersection (form form &rest [symbolp form])) +(def-edebug-spec c--delete-duplicates (form &rest [symbolp form])) (def-edebug-spec c-point t) +(def-edebug-spec c-is-escaped t) +(def-edebug-spec c-will-be-escaped t) +(def-edebug-spec c-next-single-property-change t) +(def-edebug-spec c-delete-and-extract-region t) (def-edebug-spec c-set-region-active t) (def-edebug-spec c-set-keymap-parent t) (def-edebug-spec c-safe t) +(def-edebug-spec c-int-to-char t) +(def-edebug-spec c-characterp t) (def-edebug-spec c-save-buffer-state let*) (def-edebug-spec c-tentative-buffer-changes t) (def-edebug-spec c-forward-syntactic-ws t) (def-edebug-spec c-backward-syntactic-ws t) (def-edebug-spec c-forward-sexp t) (def-edebug-spec c-backward-sexp t) +(def-edebug-spec c-safe-scan-lists t) +(def-edebug-spec c-go-list-forward t) +(def-edebug-spec c-go-list-backward t) (def-edebug-spec c-up-list-forward t) (def-edebug-spec c-up-list-backward t) (def-edebug-spec c-down-list-forward t) (def-edebug-spec c-down-list-backward t) +(def-edebug-spec c-go-up-list-forward t) +(def-edebug-spec c-go-up-list-backward t) +(def-edebug-spec c-go-down-list-forward t) +(def-edebug-spec c-go-down-list-backward t) +(def-edebug-spec c-at-vsemi-p t) (def-edebug-spec c-add-syntax t) (def-edebug-spec c-add-class-syntax t) (def-edebug-spec c-benign-error t) @@ -1319,15 +1522,34 @@ with value CHAR in the region [FROM to)." (def-edebug-spec c-skip-ws-forward t) (def-edebug-spec c-skip-ws-backward t) (def-edebug-spec c-major-mode-is t) +(def-edebug-spec c-search-forward-char-property t) +(def-edebug-spec c-search-backward-char-property t) (def-edebug-spec c-put-char-property t) +(def-edebug-spec c-put-syn-tab t) (def-edebug-spec c-get-char-property t) (def-edebug-spec c-clear-char-property t) +(def-edebug-spec c-clear-syn-tab t) +;;(def-edebug-spec c-min-property-position nil) ; invoked only by macros +(def-edebug-spec c-min-property-position t) ; Now invoked from functions (2019-07) +(def-edebug-spec c-clear-char-property-with-value t) (def-edebug-spec c-clear-char-property-with-value-on-char t) (def-edebug-spec c-put-char-properties-on-char t) (def-edebug-spec c-clear-char-properties t) +(def-edebug-spec c-clear-syn-tab-properties t) +(def-edebug-spec c-with-extended-string-fences (form form body)) (def-edebug-spec c-put-overlay t) (def-edebug-spec c-delete-overlay t) -(def-edebug-spec c-self-bind-state-cache t);)) +(def-edebug-spec c-mark-<-as-paren t) +(def-edebug-spec c-mark->-as-paren t) +(def-edebug-spec c-unmark-<->-as-paren t) +(def-edebug-spec c-with-<->-as-parens-suppressed (body)) +(def-edebug-spec c-self-bind-state-cache (body)) +(def-edebug-spec c-sc-scan-lists-no-category+1+1 t) +(def-edebug-spec c-sc-scan-lists-no-category+1-1 t) +(def-edebug-spec c-sc-scan-lists-no-category-1+1 t) +(def-edebug-spec c-sc-scan-lists-no-category-1-1 t) +(def-edebug-spec c-sc-scan-lists t) +(def-edebug-spec c-sc-parse-partial-sexp t);)) ;;; Functions. @@ -1560,12 +1782,12 @@ with value CHAR in the region [FROM to)." (defmacro c-looking-at-non-alphnumspace () "Are we looking at a character which isn't alphanumeric or space?" (if (memq 'gen-comment-delim c-emacs-features) - `(looking-at -"\\([;#]\\|\\'\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s$\\|\\s<\\|\\s>\\|\\s!\\)") - `(or (looking-at -"\\([;#]\\|\\'\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s$\\|\\s<\\|\\s>\\)" - (let ((prop (c-get-char-property (point) 'syntax-table))) - (eq prop '(14))))))) ; '(14) is generic comment delimiter. + '(looking-at + "\\([;#]\\|\\'\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s$\\|\\s<\\|\\s>\\|\\s!\\)") + '(or (looking-at + "\\([;#]\\|\\'\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s$\\|\\s<\\|\\s>\\)" + (let ((prop (c-get-char-property (point) 'syntax-table))) + (eq prop '(14))))))) ; '(14) is generic comment delimiter. (defsubst c-intersect-lists (list alist) @@ -1722,7 +1944,8 @@ when it's needed. The default is the current language taken from t)) (setq pos (cdr pos))) found)) - (setq pos list) + (setq pos (copy-tree list) + ) (while pos (if (string-match "\\w\\'" (car pos)) (setcar pos (concat (car pos) unique))) @@ -1775,10 +1998,10 @@ when it's needed. The default is the current language taken from (t re))) - ;; Produce a regexp that matches nothing. + ;; Produce a regexp that doesn't match anything. (if adorn - "\\(\\<\\>\\)" - "\\<\\>"))) + (concat "\\(" regexp-unmatchable "\\)") + regexp-unmatchable))) (put 'c-make-keywords-re 'lisp-indent-function 1) @@ -1789,7 +2012,7 @@ The returned string is of the type that can be used with non-nil, a caret is prepended to invert the set." ;; This function ought to be in the elisp core somewhere. (let ((str (if inverted "^" "")) char char2) - (setq chars (sort (append chars nil) `<)) + (setq chars (sort (append chars nil) #'<)) (while chars (setq char (pop chars)) (if (memq char '(?\\ ?^ ?-)) @@ -1840,7 +2063,7 @@ non-nil, a caret is prepended to invert the set." (setq entry (get-char-table ?a table))) ;; incompatible (t (error "CC Mode is incompatible with this version of Emacs"))) - (setq list (cons (if (= (logand (lsh entry -16) 255) 255) + (setq list (cons (if (= (logand (ash entry -16) 255) 255) '8-bit '1-bit) list))) diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index 965886727d9..37d4591fc96 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -93,6 +93,14 @@ ;; `text-property-default-nonsticky' if that variable exists (Emacs ;; >= 21). ;; +;; 'c-fl-syn-tab +;; Saves the value of syntax-table properties which have been +;; temporarily removed from certain buffer positions. The syntax-table +;; properties are restored during c-before-change, c-after-change, and +;; font locking. The purpose of the temporary removal is to enable +;; C-M-* key sequences to operate over bogus pairs of string delimiters +;; which are "adjacent", yet do not delimit a string. +;; ;; 'c-is-sws and 'c-in-sws ;; Used by `c-forward-syntactic-ws' and `c-backward-syntactic-ws' to ;; speed them up. See the comment blurb before `c-put-is-sws' @@ -152,7 +160,12 @@ (cc-require-when-compile 'cc-langs) (cc-require 'cc-vars) -(eval-when-compile (require 'cl)) +(defvar c-doc-line-join-re) +(defvar c-doc-bright-comment-start-re) +(defvar c-doc-line-join-end-ch) +(defvar c-fl-syn-tab-region) +(cc-bytecomp-defun c-clear-string-fences) +(cc-bytecomp-defun c-restore-string-fences) ;; Make declarations for all the `c-lang-defvar' variables in cc-langs. @@ -285,7 +298,8 @@ otherwise return nil and leave point unchanged. Note that this function might do hidden buffer changes. See the comment at the start of cc-engine.el for more info." - (let ((here (point))) + (let ((here (point)) + (pause (c-point 'eol))) (when c-opt-cpp-prefix (if (and (car c-macro-cache) (>= (point) (car c-macro-cache)) @@ -305,8 +319,24 @@ comment at the start of cc-engine.el for more info." (save-restriction (if lim (narrow-to-region lim (point-max))) (beginning-of-line) - (while (eq (char-before (1- (point))) ?\\) - (forward-line -1)) + (when (or (null lim) + (>= here lim)) + (save-match-data + (while + (progn + (while (eq (char-before (1- (point))) ?\\) + (forward-line -1)) + (when (and c-last-c-comment-end-on-line-re + (re-search-forward + c-last-c-comment-end-on-line-re pause t)) + (goto-char (match-end 1)) + (if (c-backward-single-comment) + (progn + (beginning-of-line) + (setq pause (point))) + (goto-char pause) + nil)))))) + (back-to-indentation) (if (and (<= (point) here) (save-match-data (looking-at c-opt-cpp-start)) @@ -343,13 +373,29 @@ comment at the start of cc-engine.el for more info." c-macro-cache-start-pos nil c-macro-cache-syntactic nil c-macro-cache-no-comment nil)) - (while (progn - (end-of-line) - (when (and (eq (char-before) ?\\) - (not (eobp))) - (forward-char) - t))) + (save-match-data + (while + (progn + (while (progn + (end-of-line) + (when (and (eq (char-before) ?\\) + (not (eobp))) + (forward-char) + t))) + (let ((cand-EOM (point))) + (if (and c-last-open-c-comment-start-on-line-re + (re-search-backward + c-last-open-c-comment-start-on-line-re + (c-point 'bol) t)) + (progn + (goto-char (match-beginning 1)) + (and (c-forward-single-comment) + (> (point) cand-EOM))) + nil))))) + (when (and (car c-macro-cache) + (> (point) (car c-macro-cache)) ; in case we have a + ; zero-sized region. (bolp) (not (eq (char-before (1- (point))) ?\\))) (setcdr c-macro-cache (point)) @@ -644,6 +690,21 @@ comment at the start of cc-engine.el for more info." (overlay-put (make-overlay end ol-end) 'face face)))) +(defmacro c-looking-at-c++-attribute () + ;; If we're in C++ Mode, and point is at the [[ introducing an attribute, + ;; return the position of the end of the attribute, otherwise return nil. + ;; The match data are NOT preserved over this macro. + `(and + (c-major-mode-is 'c++-mode) + (looking-at "\\[\\[") + (save-excursion + (and + (c-go-list-forward) + (eq (char-before) ?\]) + (eq (char-before (1- (point))) ?\]) + (point))))) + + ;; `c-beginning-of-statement-1' and accompanying stuff. ;; KLUDGE ALERT: c-maybe-labelp is used to pass information between @@ -652,6 +713,10 @@ comment at the start of cc-engine.el for more info." ;; the byte compiler. (defvar c-maybe-labelp) +(defvar c-commas-bound-stmts nil) + ;; Set to non-nil when `c-beginning-of-statement-1' is to regard a comma as + ;; a statement terminator. + ;; New awk-compatible version of c-beginning-of-statement-1, ACM 2002/6/22 ;; Macros used internally in c-beginning-of-statement-1 for the @@ -665,10 +730,12 @@ comment at the start of cc-engine.el for more info." stack (cdr stack)) t ,do-if-done + (setq pre-stmt-found t) (throw 'loop nil))) (defmacro c-bos-pop-state-and-retry () '(throw 'loop (setq state (car (car stack)) saved-pos (cdr (car stack)) + pre-stmt-found (not (cdr stack)) ;; Throw nil if stack is empty, else throw non-nil. stack (cdr stack)))) (defmacro c-bos-save-pos () @@ -694,7 +761,7 @@ comment at the start of cc-engine.el for more info." (c-point 'bol (elt saved-pos 0)))))))) (defun c-beginning-of-statement-1 (&optional lim ignore-labels - noerror comma-delim) + noerror comma-delim hit-lim) "Move to the start of the current statement or declaration, or to the previous one if already at the beginning of one. Only statements/declarations on the same level are considered, i.e. don't @@ -729,14 +796,16 @@ Return: `up' if stepped to a containing statement; `previous' if stepped to a preceding statement; `beginning' if stepped from a statement continuation clause to - its start clause; or -`macro' if stepped to a macro start. + its start clause; +`macro' if stepped to a macro start; or +nil if HIT-LIM is non-nil, and we hit the limit. Note that `same' and not `label' is returned if stopped at the same label without crossing the colon character. LIM may be given to limit the search. If the search hits the limit, point will be left at the closest following token, or at the start -position if that is less (`same' is returned in this case). +position if that is less. If HIT-LIM is non-nil, nil is returned in +this case, otherwise `same'. NOERROR turns off error logging to `c-parsing-error'. @@ -832,14 +901,16 @@ comment at the start of cc-engine.el for more info." (start (point)) macro-start (delims (if comma-delim '(?\; ?,) '(?\;))) - (c-stmt-delim-chars (if comma-delim - c-stmt-delim-chars-with-comma - c-stmt-delim-chars)) + (c-commas-bound-stmts (or c-commas-bound-stmts comma-delim)) c-maybe-labelp after-case:-pos saved ;; Current position. pos ;; Position of last stmt boundary character (e.g. ;). boundary-pos + ;; Non-nil when a construct has been found which delimits the search + ;; for a statement start, e.g. an opening brace or a macro start, or a + ;; keyword like `if' when the PDA stack is empty. + pre-stmt-found ;; The position of the last sexp or bound that follows the ;; first found colon, i.e. the start of the nonlabel part of ;; the statement. It's `start' if a colon is found just after @@ -870,14 +941,17 @@ comment at the start of cc-engine.el for more info." stack ;; Regexp which matches "for", "if", etc. (cond-key (or c-opt-block-stmt-key - "\\<\\>")) ; Matches nothing. + regexp-unmatchable)) ;; Return value. (ret 'same) ;; Positions of the last three sexps or bounds we've stopped at. tok ptok pptok) (save-restriction - (if lim (narrow-to-region lim (point-max))) + (setq lim (if lim + (max lim (point-min)) + (point-min))) + (widen) (if (save-excursion (and (c-beginning-of-macro) @@ -923,9 +997,10 @@ comment at the start of cc-engine.el for more info." ;; The loop is exited only by throwing nil to the (catch 'loop ...): ;; 1. On reaching the start of a macro; ;; 2. On having passed a stmt boundary with the PDA stack empty; - ;; 3. On reaching the start of an Objective C method def; - ;; 4. From macro `c-bos-pop-state'; when the stack is empty; - ;; 5. From macro `c-bos-pop-state-and-retry' when the stack is empty. + ;; 3. Going backwards past the search limit. + ;; 4. On reaching the start of an Objective C method def; + ;; 5. From macro `c-bos-pop-state'; when the stack is empty; + ;; 6. From macro `c-bos-pop-state-and-retry' when the stack is empty. (while (catch 'loop ;; Throw nil to break, non-nil to continue. (cond @@ -950,6 +1025,7 @@ comment at the start of cc-engine.el for more info." (setq pos saved ret 'macro ignore-labels t)) + (setq pre-stmt-found t) (throw 'loop nil)) ; 1. Start of macro. ;; Do a round through the automaton if we've just passed a @@ -959,6 +1035,7 @@ comment at the start of cc-engine.el for more info." (setq sym (intern (match-string 1))))) (when (and (< pos start) (null stack)) + (setq pre-stmt-found t) (throw 'loop nil)) ; 2. Statement boundary. ;; The PDA state handling. @@ -1071,7 +1148,8 @@ comment at the start of cc-engine.el for more info." ;; Step to the previous sexp, but not if we crossed a ;; boundary, since that doesn't consume an sexp. (if (eq sym 'boundary) - (setq ret 'previous) + (when (>= (point) lim) + (setq ret 'previous)) ;; HERE IS THE SINGLE PLACE INSIDE THE PDA LOOP WHERE WE MOVE ;; BACKWARDS THROUGH THE SOURCE. @@ -1080,21 +1158,28 @@ comment at the start of cc-engine.el for more info." (let ((before-sws-pos (point)) ;; The end position of the area to search for statement ;; barriers in this round. - (maybe-after-boundary-pos pos)) + (maybe-after-boundary-pos pos) + comma-delimited) ;; Go back over exactly one logical sexp, taking proper ;; account of macros and escaped EOLs. (while (progn + (setq comma-delimited (and (not comma-delim) + (eq (char-before) ?\,))) (unless (c-safe (c-backward-sexp) t) ;; Give up if we hit an unbalanced block. Since the ;; stack won't be empty the code below will report a ;; suitable error. + (setq pre-stmt-found t) (throw 'loop nil)) (cond ;; Have we moved into a macro? ((and (not macro-start) (c-beginning-of-macro)) + (save-excursion + (c-backward-syntactic-ws) + (setq before-sws-pos (point))) ;; Have we crossed a statement boundary? If not, ;; keep going back until we find one or a "real" sexp. (and @@ -1121,10 +1206,23 @@ comment at the start of cc-engine.el for more info." ;; Just gone back over a brace block? ((and (eq (char-after) ?{) + (not comma-delimited) (not (c-looking-at-inexpr-block lim nil t)) (save-excursion (c-backward-token-2 1 t nil) - (not (looking-at "=\\([^=]\\|$\\)")))) + (not (looking-at "=\\([^=]\\|$\\)"))) + (or + (not c-opt-block-decls-with-vars-key) + (save-excursion + (c-backward-token-2 1 t nil) + (if (and (looking-at c-symbol-start) + (not (looking-at c-keywords-regexp))) + (c-backward-token-2 1 t nil)) + (and + (not (looking-at + c-opt-block-decls-with-vars-key)) + (or comma-delim + (not (eq (char-after) ?\,))))))) (save-excursion (c-forward-sexp) (point))) ;; Just gone back over some paren block? @@ -1146,12 +1244,17 @@ comment at the start of cc-engine.el for more info." ;; Like a C "continue". Analyze the next sexp. (throw 'loop t)))) + ;; Have we gone past the limit? + (when (< (point) lim) + (throw 'loop nil)) ; 3. Gone back over the limit. + ;; ObjC method def? (when (and c-opt-method-key (setq saved (c-in-method-def-p))) (setq pos saved + pre-stmt-found t ignore-labels t) ; Avoid the label check on exit. - (throw 'loop nil)) ; 3. ObjC method def. + (throw 'loop nil)) ; 4. ObjC method def. ;; Might we have a bitfield declaration, "<type> <id> : <size>"? (if c-has-bitfields @@ -1184,12 +1287,20 @@ comment at the start of cc-engine.el for more info." ;; (including a case label) or something like C++'s "public:"? ;; A case label might use an expression rather than a token. (setq after-case:-pos (or tok start)) - (if (or (looking-at c-nonlabel-token-key) ; e.g. "while" or "'a'" + (if (or (looking-at c-nonlabel-nonparen-token-key) + ; e.g. "while" or "'a'" ;; Catch C++'s inheritance construct "class foo : bar". (save-excursion (and (c-safe (c-backward-sexp) t) - (looking-at c-nonlabel-token-2-key)))) + (looking-at c-nonlabel-token-2-key))) + ;; Catch C++'s "case a(1):" + (and (c-major-mode-is 'c++-mode) + (eq (char-after) ?\() + (save-excursion + (not (and + (zerop (c-backward-token-2 2)) + (looking-at c-case-kwds-regexp)))))) (setq c-maybe-labelp nil) (if after-labels-pos ; Have we already encountered a label? (if (not last-label-pos) @@ -1212,9 +1323,15 @@ comment at the start of cc-engine.el for more info." ptok tok tok (point) pos tok) ; always non-nil - ) ; end of (catch loop ....) + ) ; end of (catch 'loop ....) ) ; end of sexp-at-a-time (while ....) + (when (and hit-lim + (or (not pre-stmt-found) + (< pos lim) + (>= pos start))) + (setq ret nil)) + ;; If the stack isn't empty there might be errors to report. (while stack (if (and (vectorp saved-pos) (eq (length saved-pos) 3)) @@ -1273,7 +1390,7 @@ comment at the start of cc-engine.el for more info." (c-backward-syntactic-ws) ;; protect AWK post-inc/decrement operators, etc. (and (not (c-at-vsemi-p (point))) - (/= (skip-chars-backward "-+!*&~@`#") 0))) + (/= (skip-chars-backward "-.+!*&~@`#") 0))) (setq pos (point))) (goto-char pos) ret))) @@ -1307,16 +1424,13 @@ the line. If this virtual semicolon is _at_ from, the function recognizes it. Note that this function might do hidden buffer changes. See the comment at the start of cc-engine.el for more info." - (let* ((skip-chars - ;; If the current language has CPP macros, insert # into skip-chars. - (if c-opt-cpp-symbol - (concat (substring c-stmt-delim-chars 0 1) ; "^" - c-opt-cpp-symbol ; usually "#" - (substring c-stmt-delim-chars 1)) ; e.g. ";{}?:" - c-stmt-delim-chars)) - (non-skip-list - (append (substring skip-chars 1) nil)) ; e.g. (?# ?\; ?{ ?} ?? ?:) - lit-range lit-start vsemi-pos) + (let* ((skip-chars (if c-commas-bound-stmts + c-stmt-boundary-skip-chars-with-comma + c-stmt-boundary-skip-chars)) ; e.g. "^#;{}?:" + (non-skip-list (if c-commas-bound-stmts + c-stmt-boundary-skip-list-with-comma + c-stmt-boundary-skip-list)) ; e.g. (?# ?\; ?{ ?} ?? ?:) + lit-range lit-start vsemi-pos attr-end) (save-restriction (widen) (save-excursion @@ -1340,6 +1454,11 @@ comment at the start of cc-engine.el for more info." ;; In a string/comment? ((setq lit-range (c-literal-limits from)) (goto-char (cdr lit-range))) + ;; Skip over a C++ attribute? + ((eq (char-after) ?\[) + (if (setq attr-end (c-looking-at-c++-attribute)) + (goto-char attr-end) + (forward-char))) ((eq (char-after) ?:) (forward-char) (if (and (eq (char-after) ?:) @@ -1351,7 +1470,11 @@ comment at the start of cc-engine.el for more info." ;; A question mark. Can't be a label, so stop ;; looking for more : and ?. (setq c-maybe-labelp nil - skip-chars (substring c-stmt-delim-chars 0 -2))) + skip-chars + (substring (if c-commas-bound-stmts + c-stmt-delim-chars-with-comma + c-stmt-delim-chars) + 0 -2))) ;; At a CPP construct or a "#" or "##" operator? ((and c-opt-cpp-symbol (looking-at c-opt-cpp-symbol)) (if (save-excursion @@ -1387,7 +1510,13 @@ comment at the start of cc-engine.el for more info." (save-excursion (let ((end (point)) c-maybe-labelp) - (c-syntactic-skip-backward (substring c-stmt-delim-chars 1) nil t) + (c-syntactic-skip-backward + (substring + (if c-commas-bound-stmts + c-stmt-delim-chars-with-comma + c-stmt-delim-chars) + 1) + nil t) (or (bobp) (eq (char-before) ?}) (and (eq (char-before) ?{) @@ -1414,9 +1543,10 @@ comment at the start of cc-engine.el for more info." (save-excursion (let ((end (point)) - (c-stmt-delim-chars c-stmt-delim-chars-with-comma) + (c-commas-bound-stmts t) c-maybe-labelp) - (c-syntactic-skip-backward (substring c-stmt-delim-chars 1) nil t) + (c-syntactic-skip-backward (substring c-stmt-delim-chars-with-comma 1) + nil t) (or (bobp) (memq (char-before) '(?{ ?})) (save-excursion (backward-char) @@ -1690,73 +1820,151 @@ comment at the start of cc-engine.el for more info." `(let ((beg ,beg) (end ,end)) (put-text-property beg end 'c-is-sws t) ,@(when (facep 'c-debug-is-sws-face) - `((c-debug-add-face beg end 'c-debug-is-sws-face))))) + '((c-debug-add-face beg end 'c-debug-is-sws-face))))) +(def-edebug-spec c-put-is-sws t) (defmacro c-put-in-sws (beg end) ;; This macro does a hidden buffer change. `(let ((beg ,beg) (end ,end)) (put-text-property beg end 'c-in-sws t) ,@(when (facep 'c-debug-is-sws-face) - `((c-debug-add-face beg end 'c-debug-in-sws-face))))) + '((c-debug-add-face beg end 'c-debug-in-sws-face))))) +(def-edebug-spec c-put-in-sws t) (defmacro c-remove-is-sws (beg end) ;; This macro does a hidden buffer change. `(let ((beg ,beg) (end ,end)) (remove-text-properties beg end '(c-is-sws nil)) ,@(when (facep 'c-debug-is-sws-face) - `((c-debug-remove-face beg end 'c-debug-is-sws-face))))) + '((c-debug-remove-face beg end 'c-debug-is-sws-face))))) +(def-edebug-spec c-remove-is-sws t) (defmacro c-remove-in-sws (beg end) ;; This macro does a hidden buffer change. `(let ((beg ,beg) (end ,end)) (remove-text-properties beg end '(c-in-sws nil)) ,@(when (facep 'c-debug-is-sws-face) - `((c-debug-remove-face beg end 'c-debug-in-sws-face))))) + '((c-debug-remove-face beg end 'c-debug-in-sws-face))))) +(def-edebug-spec c-remove-in-sws t) (defmacro c-remove-is-and-in-sws (beg end) ;; This macro does a hidden buffer change. `(let ((beg ,beg) (end ,end)) (remove-text-properties beg end '(c-is-sws nil c-in-sws nil)) ,@(when (facep 'c-debug-is-sws-face) - `((c-debug-remove-face beg end 'c-debug-is-sws-face) + '((c-debug-remove-face beg end 'c-debug-is-sws-face) (c-debug-remove-face beg end 'c-debug-in-sws-face))))) +(def-edebug-spec c-remove-is-and-in-sws t) ;; The type of literal position `end' is in a `before-change-functions' -;; function - one of `c', `c++', `pound', or nil (but NOT `string'). +;; function - one of `c', `c++', `pound', `noise', `attribute' or nil (but NOT +;; `string'). (defvar c-sws-lit-type nil) -;; A cons (START . STOP) of the bounds of the comment or CPP construct +;; A cons (START . STOP) of the bounds of the comment or CPP construct, etc., ;; enclosing END, if any, else nil. (defvar c-sws-lit-limits nil) -(defun c-invalidate-sws-region-before (end) - ;; Called from c-before-change. END is the end of the change region, the - ;; standard parameter given to all before-change-functions. - ;; - ;; Note whether END is inside a comment or CPP construct, and if so note its - ;; bounds in `c-sws-lit-limits' and type in `c-sws-lit-type'. - (save-excursion - (goto-char end) - (let* ((limits (c-literal-limits)) - (lit-type (c-literal-type limits))) - (cond - ((memq lit-type '(c c++)) - (setq c-sws-lit-type lit-type - c-sws-lit-limits limits)) - ((c-beginning-of-macro) - (setq c-sws-lit-type 'pound - c-sws-lit-limits (cons (point) - (progn (c-end-of-macro) (point))))) - (t (setq c-sws-lit-type nil - c-sws-lit-limits nil)))))) - -(defun c-invalidate-sws-region-after-del (beg end old-len) +(defun c-enclosing-c++-attribute () + ;; If we're in C++ Mode, and point is within a correctly balanced [[ ... ]] + ;; attribute structure, return a cons of its starting and ending positions. + ;; Otherwise, return nil. We use the c-{in,is}-sws-face text properties for + ;; this determination, this macro being intended only for use in the *-sws-* + ;; functions and macros. The match data are NOT preserved over this macro. + (let (attr-end pos-is-sws) + (and + (c-major-mode-is 'c++-mode) + (> (point) (point-min)) + (setq pos-is-sws + (if (get-text-property (1- (point)) 'c-is-sws) + (1- (point)) + (1- (previous-single-property-change + (point) 'c-is-sws nil (point-min))))) + (save-excursion + (goto-char pos-is-sws) + (setq attr-end (c-looking-at-c++-attribute))) + (> attr-end (point)) + (cons pos-is-sws attr-end)))) + +(defun c-slow-enclosing-c++-attribute () + ;; Like `c-enclosing-c++-attribute', but does not depend on the c-i[ns]-sws + ;; properties being set. + (and + (c-major-mode-is 'c++-mode) + (save-excursion + (let ((paren-state (c-parse-state)) + cand) + (while + (progn + (setq cand + (catch 'found-cand + (while (cdr paren-state) + (when (and (numberp (car paren-state)) + (numberp (cadr paren-state)) + (eq (car paren-state) + (1+ (cadr paren-state))) + (eq (char-after (car paren-state)) ?\[) + (eq (char-after (cadr paren-state)) ?\[)) + (throw 'found-cand (cadr paren-state))) + (setq paren-state (cdr paren-state))))) + (and cand + (not + (and (c-go-list-forward cand) + (eq (char-before) ?\]) + (eq (char-before (1- (point))) ?\]))))) + (setq paren-state (cdr paren-state))) + (and cand (cons cand (point))))))) + +(defun c-invalidate-sws-region-before (beg end) + ;; Called from c-before-change. BEG and END are the bounds of the change + ;; region, the standard parameters given to all before-change-functions. + ;; + ;; Note whether END is inside a comment, CPP construct, or noise macro, and + ;; if so note its bounds in `c-sws-lit-limits' and type in `c-sws-lit-type'. + (setq c-sws-lit-type nil + c-sws-lit-limits nil) + (save-match-data + (save-excursion + (goto-char end) + (let* ((limits (c-literal-limits)) + (lit-type (c-literal-type limits))) + (cond + ((memq lit-type '(c c++)) + (setq c-sws-lit-type lit-type + c-sws-lit-limits limits)) + ((c-beginning-of-macro) + (setq c-sws-lit-type 'pound + c-sws-lit-limits (cons (point) + (progn (c-end-of-macro) (point))))) + ((eq lit-type 'string)) + ((setq c-sws-lit-limits (c-enclosing-c++-attribute)) + (setq c-sws-lit-type 'attribute)) + ((progn (skip-syntax-backward "w_") + (looking-at c-noise-macro-name-re)) + (setq c-sws-lit-type 'noise + c-sws-lit-limits (cons (match-beginning 1) (match-end 1)))) + (t)))) + (save-excursion + (goto-char beg) + (let ((attr-limits (c-enclosing-c++-attribute))) + (if attr-limits + (if (consp c-sws-lit-limits) + (setcar c-sws-lit-limits (car attr-limits)) + (setq c-sws-lit-limits attr-limits)) + (skip-syntax-backward "w_") + (when (looking-at c-noise-macro-name-re) + (setq c-sws-lit-type 'noise) + (if (consp c-sws-lit-limits) + (setcar c-sws-lit-limits (match-beginning 1)) + (setq c-sws-lit-limits (cons (match-beginning 1) + (match-end 1)))))))))) + +(defun c-invalidate-sws-region-after-del (beg end _old-len) ;; Text has been deleted, OLD-LEN characters of it starting from position ;; BEG. END is typically eq to BEG. Should there have been a comment or ;; CPP construct open at END before the deletion, check whether this ;; deletion deleted or "damaged" its opening delimiter. If so, return the ;; current position of where the construct ended, otherwise return nil. (when c-sws-lit-limits - (setcdr c-sws-lit-limits (- (cdr c-sws-lit-limits) old-len)) (if (and (< beg (+ (car c-sws-lit-limits) 2)) ; A lazy assumption that ; comment delimiters are 2 ; chars long. @@ -1774,9 +1982,9 @@ comment at the start of cc-engine.el for more info." ;; or `c-is-sws' text properties inside this literal. If there are, return ;; the buffer position of the end of the literal, else return nil. (save-excursion + (goto-char end) (let* ((limits (c-literal-limits)) (lit-type (c-literal-type limits))) - (goto-char end) (when (and (not (memq lit-type '(c c++))) (c-beginning-of-macro)) (setq lit-type 'pound @@ -1800,6 +2008,10 @@ comment at the start of cc-engine.el for more info." ;; properties right after they're added. ;; ;; This function does hidden buffer changes. + (when c-sws-lit-limits + (setcar c-sws-lit-limits (min beg (car c-sws-lit-limits))) + (setcdr c-sws-lit-limits + (max end (- (+ (cdr c-sws-lit-limits) (- end beg)) old-len)))) (let ((del-end (and (> old-len 0) (c-invalidate-sws-region-after-del beg end old-len))) @@ -1819,6 +2031,10 @@ comment at the start of cc-engine.el for more info." (when (and (eolp) (not (eobp))) (setq end (1+ (point))))) + (when (memq c-sws-lit-type '(noise attribute)) + (setq beg (car c-sws-lit-limits) + end (cdr c-sws-lit-limits))) ; This last setting may be redundant. + (when (and (= beg end) (get-text-property beg 'c-in-sws) (> beg (point-min)) @@ -1838,6 +2054,7 @@ comment at the start of cc-engine.el for more info." (setq end (max (or del-end end) (or ins-end end) + (or (cdr c-sws-lit-limits) end) end)) (c-debug-sws-msg "c-invalidate-sws-region-after [%s..%s]" beg end) @@ -1863,7 +2080,10 @@ comment at the start of cc-engine.el for more info." (skip-chars-forward " \t\n\r\f\v") (when (or (looking-at c-syntactic-ws-start) (and c-opt-cpp-prefix - (looking-at c-noise-macro-name-re))) + (looking-at c-noise-macro-name-re)) + (and (c-major-mode-is 'c++-mode) + (looking-at "\\[\\[")) + (looking-at c-doc-line-join-re)) (setq rung-end-pos (min (1+ (point)) (point-max))) (if (setq rung-is-marked (text-property-any rung-pos rung-end-pos @@ -1935,6 +2155,10 @@ comment at the start of cc-engine.el for more info." ;; Take elaborate precautions to detect an open block comment at ;; the end of a macro. If we find one, we set `safe-start' to nil ;; and break off any further scanning of comments. + ;; + ;; (2019-05-02): `c-end-of-macro' now moves completely over block + ;; comments, even multiline ones lacking \s at their EOLs. So a + ;; lot of the following is probably redundant now. (let ((com-begin (point)) com-end in-macro) (when (and (c-forward-single-comment) (setq com-end (point)) @@ -1993,6 +2217,17 @@ comment at the start of cc-engine.el for more info." (looking-at c-noise-macro-name-re)) ;; Skip over a noise macro. (goto-char (match-end 1)) + (not (eobp))) + + ((setq next-rung-pos (c-looking-at-c++-attribute)) + (goto-char next-rung-pos) + (not (eobp))) + + ((looking-at c-doc-line-join-re) + ;; Skip over a line join in (e.g.) Pike autodoc. + (goto-char (match-end 0)) + (setq safe-start nil) ; Never cache this; the doc style could be + ; changed at any time. (not (eobp))))) ;; We've searched over a piece of non-white syntactic ws. See if this @@ -2076,8 +2311,7 @@ comment at the start of cc-engine.el for more info." "c-forward-sws clearing thoroughly at %s for cache separation" (1- last-put-in-sws-pos)) (c-remove-is-and-in-sws (1- last-put-in-sws-pos) - last-put-in-sws-pos)))) - )))) + last-put-in-sws-pos)))))))) (defun c-backward-sws () ;; Used by `c-backward-syntactic-ws' to implement the unbounded search. @@ -2087,7 +2321,9 @@ comment at the start of cc-engine.el for more info." (let (;; `rung-pos' is set to a position as late as possible in the unmarked ;; part of the simple ws region. (rung-pos (point)) next-rung-pos last-put-in-sws-pos - rung-is-marked simple-ws-beg cmt-skip-pos) + rung-is-marked simple-ws-beg cmt-skip-pos + (doc-line-join-here (concat c-doc-line-join-re "\\=")) + attr-end) ;; Skip simple horizontal ws and do a quick check on the preceding ;; character to see if it's anything that can't end syntactic ws, so we can @@ -2097,16 +2333,31 @@ comment at the start of cc-engine.el for more info." (skip-chars-backward " \t\f") (when (and (not (bobp)) (save-excursion - (backward-char) - (or (looking-at c-syntactic-ws-end) - (and c-opt-cpp-prefix - (looking-at c-symbol-char-key) - (progn (c-beginning-of-current-token) - (looking-at c-noise-macro-name-re)))))) + (or (and + (memq (char-before) c-doc-line-join-end-ch) ; For speed. + (re-search-backward doc-line-join-here + (c-point 'bopl) t)) + (and + (c-major-mode-is 'c++-mode) + (eq (char-before) ?\]) + (eq (char-before (1- (point))) ?\]) + (save-excursion + (and (c-go-list-backward) + (looking-at "\\[\\["))) + (setq attr-end (point))) + (progn + (backward-char) + (or (looking-at c-syntactic-ws-end) + (and c-opt-cpp-prefix + (looking-at c-symbol-char-key) + (progn (c-beginning-of-current-token) + (looking-at c-noise-macro-name-re)))))))) ;; Try to find a rung position in the simple ws preceding point, so that ;; we can get a cache hit even if the last bit of the simple ws has ;; changed recently. - (setq simple-ws-beg (point)) + (setq simple-ws-beg (or attr-end ; After attribute. + (match-end 1) ; Noise macro, etc. + (match-end 0))) ; c-syntactic-ws-end (skip-chars-backward " \t\n\r\f\v") (if (setq rung-is-marked (text-property-any (point) (min (1+ rung-pos) (point-max)) @@ -2241,7 +2492,21 @@ comment at the start of cc-engine.el for more info." (looking-at c-noise-macro-name-re))))) ;; Skipped over a noise macro (goto-char next-rung-pos) - t))) + t) + + ((and (c-major-mode-is 'c++-mode) + (eq (char-before) ?\]) + (eq (char-before (1- (point))) ?\]) + (save-excursion + (and (c-go-list-backward) + (setq next-rung-pos (point)) + (looking-at "\\[\\[")))) + (goto-char next-rung-pos) + t) + + ((and + (memq (char-before) c-doc-line-join-end-ch) ; For speed. + (re-search-backward doc-line-join-here (c-point 'bopl) t))))) ;; We've searched over a piece of non-white syntactic ws. See if this ;; can be cached. @@ -2338,245 +2603,61 @@ comment at the start of cc-engine.el for more info." (c-skip-ws-forward end+1) (eq (point) end+1)))))) -;; A system for finding noteworthy parens before the point. - -(defconst c-state-cache-too-far 5000) -;; A maximum comfortable scanning distance, e.g. between -;; `c-state-cache-good-pos' and "HERE" (where we call c-parse-state). When -;; this distance is exceeded, we take "emergency measures", e.g. by clearing -;; the cache and starting again from point-min or a beginning of defun. This -;; value can be tuned for efficiency or set to a lower value for testing. - -(defvar c-state-cache nil) -(make-variable-buffer-local 'c-state-cache) -;; The state cache used by `c-parse-state' to cut down the amount of -;; searching. It's the result from some earlier `c-parse-state' call. See -;; `c-parse-state''s doc string for details of its structure. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; We maintain a sopisticated cache of positions which are in a literal, +;; disregarding macros (i.e. we don't distinguish between "in a macro" and +;; not). ;; -;; The use of the cached info is more effective if the next -;; `c-parse-state' call is on a line close by the one the cached state -;; was made at; the cache can actually slow down a little if the -;; cached state was made very far back in the buffer. The cache is -;; most effective if `c-parse-state' is used on each line while moving -;; forward. - -(defvar c-state-cache-good-pos 1) -(make-variable-buffer-local 'c-state-cache-good-pos) -;; This is a position where `c-state-cache' is known to be correct, or -;; nil (see below). It's a position inside one of the recorded unclosed -;; parens or the top level, but not further nested inside any literal or -;; subparen that is closed before the last recorded position. +;; This cache is in three parts: two "near" caches, which are association +;; lists of a small number (currently six) of positions and the parser states +;; there; the "far" cache (also known as "the cache"), a list of compressed +;; parser states going back to the beginning of the buffer, one entry every +;; 3000 characters. ;; -;; The exact position is chosen to try to be close to yet earlier than -;; the position where `c-state-cache' will be called next. Right now -;; the heuristic is to set it to the position after the last found -;; closing paren (of any type) before the line on which -;; `c-parse-state' was called. That is chosen primarily to work well -;; with refontification of the current line. +;; The two main callable functions embodying this cache are +;; `c-semi-pp-to-literal', which returns a `parse-partial-sexp' state at a +;; given position, together with the start of any literal enclosing it, and +;; `c-full-pp-to-literal', which additionally returns the end of such literal. +;; One of the above "near" caches is associated with each of these functions. ;; -;; 2009-07-28: When `c-state-point-min' and the last position where -;; `c-parse-state' or for which `c-invalidate-state-cache' was called, are -;; both in the same literal, there is no such "good position", and -;; c-state-cache-good-pos is then nil. This is the ONLY circumstance in which -;; it can be nil. In this case, `c-state-point-min-literal' will be non-nil. +;; When searching this cache, these functions first seek an exact match, then +;; a "close" match from the assiciated near cache. If neither of these +;; succeed, the nearest preceding entry in the far cache is used. ;; -;; 2009-06-12: In a brace desert, c-state-cache-good-pos may also be in -;; the middle of the desert, as long as it is not within a brace pair -;; recorded in `c-state-cache' or a paren/bracket pair. - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; We maintain a simple cache of positions which aren't in a literal, so as to -;; speed up testing for non-literality. -(defconst c-state-nonlit-pos-interval 3000) -;; The approximate interval between entries in `c-state-nonlit-pos-cache'. -(defvar c-state-nonlit-pos-cache nil) -(make-variable-buffer-local 'c-state-nonlit-pos-cache) -;; A list of buffer positions which are known not to be in a literal or a cpp -;; construct. This is ordered with higher positions at the front of the list. -;; Only those which are less than `c-state-nonlit-pos-cache-limit' are valid. - -(defvar c-state-nonlit-pos-cache-limit 1) -(make-variable-buffer-local 'c-state-nonlit-pos-cache-limit) -;; An upper limit on valid entries in `c-state-nonlit-pos-cache'. This is -;; reduced by buffer changes, and increased by invocations of -;; `c-state-literal-at'. - -(defvar c-state-semi-nonlit-pos-cache nil) -(make-variable-buffer-local 'c-state-semi-nonlit-pos-cache) -;; A list of elements which are either buffer positions (when such positions -;; are not in literals) or lists of the form (POS TYPE START), where POS is -;; a buffer position inside a literal, TYPE is the type of the literal -;; ('string, 'c, or 'c++) and START is the start of the literal. - -(defvar c-state-semi-nonlit-pos-cache-limit 1) -(make-variable-buffer-local 'c-state-semi-nonlit-pos-cache-limit) -;; An upper limit on valid entries in `c-state-semi-nonlit-pos-cache'. This +(defvar c-lit-pos-cache nil) +(make-variable-buffer-local 'c-lit-pos-cache) +;; A list of elements in descending order of POS of one of the forms: +;; o - POS (when point is not in a literal); +;; o - (POS CHAR-1) (when the last character before point is potentially +;; the first of a two-character construct +;; o - (POS TYPE STARTING-POS) (when in a literal); +;; o - (POS TYPE STARTING-POS CHAR-1) (Combination of the previous two), +;; +;; where POS is the position for which the entry is valid, TYPE is the type of +;; the comment ('c or 'c++) or the character which should close the string +;; (e.g. ?\") or t for a generic string. STARTING-POS is the starting +;; position of the comment or string. CHAR-1 is either the character +;; potentially forming the first half of a two-char construct (in Emacs <= 25 +;; and XEmacs) or the syntax of the character (Emacs >= 26). + +(defvar c-lit-pos-cache-limit 1) +(make-variable-buffer-local 'c-lit-pos-cache-limit) +;; An upper limit on valid entries in `c-lit-pos-cache'. This ;; is reduced by buffer changes, and increased by invocations of ;; `c-parse-ps-state-below'. -(defsubst c-truncate-semi-nonlit-pos-cache (pos) - ;; Truncate the upper bound of the cache `c-state-semi-nonlit-pos-cache' to - ;; POS, if it is higher than that position. - (setq c-state-semi-nonlit-pos-cache-limit - (min c-state-semi-nonlit-pos-cache-limit pos))) - -(defun c-state-semi-pp-to-literal (here &optional not-in-delimiter) - ;; Do a parse-partial-sexp from a position in the buffer before HERE which - ;; isn't in a literal, and return information about HERE, either: - ;; (STATE TYPE BEG) if HERE is in a literal; or - ;; (STATE) otherwise, - ;; where STATE is the parsing state at HERE, TYPE is the type of the literal - ;; enclosing HERE, (one of 'string, 'c, 'c++) and BEG is the starting - ;; position of that literal (including the delimiter). - ;; - ;; Unless NOT-IN-DELIMITER is non-nil, when TO is inside a two-character - ;; comment opener, this is recognized as being in a comment literal. - ;; - ;; Only elements 3 (in a string), 4 (in a comment), 5 (following a quote), 7 - ;; (comment type), and 8 (start of comment/string), and possibly 10 (in - ;; newer Emacsen only, the syntax of a position after a potential first char - ;; of a two char construct) of STATE are valid. - (save-excursion - (save-restriction - (widen) - (save-match-data - (let* ((base-and-state (c-parse-ps-state-below here)) - (base (car base-and-state)) - (s (cdr base-and-state)) - (s (parse-partial-sexp base here nil nil s)) - ty) - (cond - ((or (nth 3 s) - (and (nth 4 s) - (not (eq (nth 7 s) 'syntax-table)))) ; in a string or comment - (setq ty (cond - ((nth 3 s) 'string) - ((nth 7 s) 'c++) - (t 'c))) - (list s ty (nth 8 s))) - - ((and (not not-in-delimiter) ; inside a comment starter - (not (bobp)) - (progn (backward-char) - (and (not (and (memq 'category-properties c-emacs-features) - (looking-at "\\s!"))) - (looking-at c-comment-start-regexp)))) - (setq ty (if (looking-at c-block-comment-start-regexp) 'c 'c++)) - (list s ty (point))) - - (t (list s)))))))) - -(defun c-state-full-pp-to-literal (here &optional not-in-delimiter) - ;; This function will supersede c-state-pp-to-literal. - ;; - ;; Do a parse-partial-sexp from a position in the buffer before HERE which - ;; isn't in a literal, and return information about HERE, either: - ;; (STATE TYPE (BEG . END)) if HERE is in a literal; or - ;; (STATE) otherwise, - ;; where STATE is the parsing state at HERE, TYPE is the type of the literal - ;; enclosing HERE, (one of 'string, 'c, 'c++) and (BEG . END) is the - ;; boundaries of that literal (including the delimiters). - ;; - ;; Unless NOT-IN-DELIMITER is non-nil, when TO is inside a two-character - ;; comment opener, this is recognized as being in a comment literal. - ;; - ;; Only elements 3 (in a string), 4 (in a comment), 5 (following a quote), 7 - ;; (comment type), and 8 (start of comment/string), and possibly 10 (in - ;; newer Emacsen only, the syntax of a position after a potential first char - ;; of a two char construct) of STATE are valid. - (save-excursion - (save-restriction - (widen) - (save-match-data - (let* ((base-and-state (c-parse-ps-state-below here)) - (base (car base-and-state)) - (s (cdr base-and-state)) - (s (parse-partial-sexp base here nil nil s)) - ty start) - (cond - ((or (nth 3 s) - (and (nth 4 s) - (not (eq (nth 7 s) 'syntax-table)))) ; in a string or comment - (setq ty (cond - ((nth 3 s) 'string) - ((nth 7 s) 'c++) - (t 'c))) - (setq start (nth 8 s)) - (parse-partial-sexp here (point-max) - nil ; TARGETDEPTH - nil ; STOPBEFORE - s ; OLDSTATE - 'syntax-table) ; stop at end of literal - (list s ty (cons start (point)))) - - ((and (not not-in-delimiter) ; inside a comment starter - (not (bobp)) - (progn (backward-char) - (and (not (and (memq 'category-properties c-emacs-features) - (looking-at "\\s!"))) - (looking-at c-comment-start-regexp)))) - (setq ty (if (looking-at c-block-comment-start-regexp) 'c 'c++) - start (point)) - (forward-comment 1) - (list s ty (cons start (point)))) - - (t (list s)))))))) - -(defun c-state-pp-to-literal (from to &optional not-in-delimiter) - ;; Do a parse-partial-sexp from FROM to TO, returning either - ;; (STATE TYPE (BEG . END)) if TO is in a literal; or - ;; (STATE) otherwise, - ;; where STATE is the parsing state at TO, TYPE is the type of the literal - ;; (one of 'c, 'c++, 'string) and (BEG . END) is the boundaries of the literal, - ;; including the delimiters. - ;; - ;; Unless NOT-IN-DELIMITER is non-nil, when TO is inside a two-character - ;; comment opener, this is recognized as being in a comment literal. - ;; - ;; Only elements 3 (in a string), 4 (in a comment), 5 (following a quote), - ;; 7 (comment type) and 8 (start of comment/string) (and possibly 9) of - ;; STATE are valid. - (save-excursion - (save-match-data - (let ((s (parse-partial-sexp from to)) - ty co-st) - (cond - ((or (nth 3 s) - (and (nth 4 s) - (not (eq (nth 7 s) 'syntax-table)))) ; in a string or comment - (setq ty (cond - ((nth 3 s) 'string) - ((nth 7 s) 'c++) - (t 'c))) - (parse-partial-sexp (point) (point-max) - nil ; TARGETDEPTH - nil ; STOPBEFORE - s ; OLDSTATE - 'syntax-table) ; stop at end of literal - `(,s ,ty (,(nth 8 s) . ,(point)))) - - ((and (not not-in-delimiter) ; inside a comment starter - (not (bobp)) - (progn (backward-char) - (and (not (looking-at "\\s!")) - (looking-at c-comment-start-regexp)))) - (setq ty (if (looking-at c-block-comment-start-regexp) 'c 'c++) - co-st (point)) - (forward-comment 1) - `(,s ,ty (,co-st . ,(point)))) - - (t `(,s))))))) - +;; Note that as of 2019-05-27, the forms involving CHAR-1 are no longer used. (defun c-cache-to-parse-ps-state (elt) ;; Create a list suitable to use as the old-state parameter to ;; `parse-partial-sexp', out of ELT, a member of - ;; `c-state-semi-nonlit-pos-cache'. ELT is either just a number, or a list + ;; `c-lit-pos-cache'. ELT is either just a number, or a list ;; with 2, 3, or 4 members (See `c-parse-ps-state-to-cache'). That number ;; or the car of the list is the "position element" of ELT, the position ;; where ELT is valid. ;; - ;; POINT is left at the position for which the returned state is valid. It + ;; POINT is left at the postition for which the returned state is valid. It ;; will be either the position element of ELT, or one character before ;; that. (The latter happens in Emacs <= 25 and XEmacs, when ELT indicates ;; its position element directly follows a potential first character of a @@ -2598,16 +2679,14 @@ comment at the start of cc-engine.el for more info." com-style (if (eq type 'c++) 1 nil))) (t (c-benign-error "Invalid type %s in c-cache-to-parse-ps-state" elt))) + (goto-char (if char-1 + (1- pos) + pos)) (if (memq 'pps-extended-state c-emacs-features) - (progn - (goto-char pos) - (list depth containing last - in-string in-comment after-quote - min-depth com-style com-str-start - intermediate char-1)) - (goto-char (if char-1 - (1- pos) - pos)) + (list depth containing last + in-string in-comment nil + min-depth com-style com-str-start + intermediate nil) (list depth containing last in-string in-comment nil min-depth com-style com-str-start @@ -2627,9 +2706,10 @@ comment at the start of cc-engine.el for more info." nil 0 nil nil nil))))) +;; Note that as of 2019-05-27, the forms involving CHAR-1 are no longer used. (defun c-parse-ps-state-to-cache (state) ;; Convert STATE, a `parse-partial-sexp' state valid at POINT, to an element - ;; for the `c-state-semi-nonlit-pos-cache' cache. This is one of + ;; for the `c-lit-pos-cache' cache. This is one of ;; o - POINT (when point is not in a literal); ;; o - (POINT CHAR-1) (when the last character before point is potentially ;; the first of a two-character construct @@ -2647,7 +2727,7 @@ comment at the start of cc-engine.el for more info." ((nth 3 state) ; A string (list (point) (nth 3 state) (nth 8 state))) ((and (nth 4 state) ; A comment - (not (eq (nth 7 state) 'syntax-table))) ; but not a pseudo comment. + (not (eq (nth 7 state) 'syntax-table))) ; but not a psuedo comment. (list (point) (if (eq (nth 7 state) 1) 'c++ 'c) (nth 8 state))) @@ -2683,11 +2763,22 @@ comment at the start of cc-engine.el for more info." (defsubst c-ps-state-cache-pos (elt) ;; Get the buffer position from ELT, an element from the cache - ;; `c-state-semi-nonlit-pos-cache'. + ;; `c-lit-pos-cache'. (if (atom elt) elt (car elt))) +(defun c-trim-lit-pos-cache () + ;; Trim the `c-lit-pos-cache' to take account of buffer + ;; changes, indicated by `c-lit-pos-cache-limit'. + (while (and c-lit-pos-cache + (> (c-ps-state-cache-pos (car c-lit-pos-cache)) + c-lit-pos-cache-limit)) + (setq c-lit-pos-cache (cdr c-lit-pos-cache)))) + +(defconst c-state-nonlit-pos-interval 3000) +;; The approximate interval between entries in `c-state-nonlit-pos-cache'. + (defun c-parse-ps-state-below (here) ;; Given a buffer position HERE, Return a cons (CACHE-POS . STATE), where ;; CACHE-POS is a position not very far before HERE for which the @@ -2698,14 +2789,9 @@ comment at the start of cc-engine.el for more info." (save-excursion (save-restriction (widen) - (let ((c c-state-semi-nonlit-pos-cache) + (c-trim-lit-pos-cache) + (let ((c c-lit-pos-cache) elt state npos high-elt) - ;; Trim the cache to take account of buffer changes. - (while (and c (> (c-ps-state-cache-pos (car c)) - c-state-semi-nonlit-pos-cache-limit)) - (setq c (cdr c))) - (setq c-state-semi-nonlit-pos-cache c) - (while (and c (> (c-ps-state-cache-pos (car c)) here)) (setq high-elt (car c)) (setq c (cdr c))) @@ -2718,19 +2804,458 @@ comment at the start of cc-engine.el for more info." (when (not high-elt) ;; We need to extend the cache. Add an element to - ;; `c-state-semi-nonlit-pos-cache' each iteration of the following. + ;; `c-lit-pos-cache' each iteration of the following. (while (<= (setq npos (+ (point) c-state-nonlit-pos-interval)) here) (setq state (parse-partial-sexp (point) npos nil nil state)) + ;; If we're after a \ or a / or * which might be a comment + ;; delimiter half, move back a character. + (when (or (nth 5 state) ; After a quote character + (and (memq 'pps-extended-state c-emacs-features) + (nth 10 state))) ; in the middle of a 2-char seq. + (setq npos (1- npos)) + (backward-char) + (when (nth 10 state) + (setcar (nthcdr 10 state) nil)) + (when (nth 5 state) + (setcar (nthcdr 5 state) nil))) + (setq elt (c-parse-ps-state-to-cache state)) - (setq c-state-semi-nonlit-pos-cache - (cons elt c-state-semi-nonlit-pos-cache)))) + (setq c-lit-pos-cache + (cons elt c-lit-pos-cache)))) - (if (> (point) c-state-semi-nonlit-pos-cache-limit) - (setq c-state-semi-nonlit-pos-cache-limit (point))) + (if (> (point) c-lit-pos-cache-limit) + (setq c-lit-pos-cache-limit (point))) (cons (point) state))))) +(defvar c-semi-lit-near-cache nil) +(make-variable-buffer-local 'c-semi-lit-near-cache) +;; A list of up to six recent results from `c-semi-pp-to-literal'. Each +;; element is a cons of the buffer position and the `parse-partial-sexp' state +;; at that position. + +(defvar c-semi-near-cache-limit 1) +(make-variable-buffer-local 'c-semi-near-cache-limit) +;; An upper limit on valid entries in `c-semi-lit-near-cache'. This is +;; reduced by buffer changes, and increased by invocations of +;; `c-semi-pp-to-literal'. + +(defun c-semi-trim-near-cache () + ;; Remove stale entries in `c-semi-lit-near-cache', i.e. those + ;; whose positions are above `c-lit-pos-cache-limit'. + (let ((nc-list c-semi-lit-near-cache)) + (while nc-list + (if (> (caar nc-list) c-semi-near-cache-limit) + (setq c-semi-lit-near-cache + (delq (car nc-list) c-semi-lit-near-cache) + nc-list c-semi-lit-near-cache) ; start again in case + ; of list breakage. + (setq nc-list (cdr nc-list)))))) + +(defun c-semi-get-near-cache-entry (here) + ;; Return the near cache entry at the highest postion before HERE, if any, + ;; or nil. The near cache entry is of the form (POSITION . STATE), where + ;; STATE has the form of a result of `parse-partial-sexp'. + (let ((nc-pos-state + (or (assq here c-semi-lit-near-cache) + (let ((nc-list c-semi-lit-near-cache) + pos (nc-pos 0) cand-pos-state) + (catch 'found + (while nc-list + (setq pos (caar nc-list)) + (when (>= here pos) + (cond + ((and (cdar nc-list) + (nth 8 (cdar nc-list)) + (< here (nth 8 (cdar nc-list)))) + (throw 'found (car nc-list))) + ((> pos nc-pos) + (setq nc-pos pos + cand-pos-state (car nc-list))))) + (setq nc-list (cdr nc-list))) + cand-pos-state))))) + (when (and nc-pos-state + (not (eq nc-pos-state (car c-semi-lit-near-cache)))) + ;; Move the found cache entry to the front of the list. + (setq c-semi-lit-near-cache + (delq nc-pos-state c-semi-lit-near-cache)) + (push nc-pos-state c-semi-lit-near-cache)) + (copy-tree nc-pos-state))) + +(defun c-semi-put-near-cache-entry (here state) + ;; Put a new near cache entry into the near cache. + (while (>= (length c-semi-lit-near-cache) 6) + (setq c-semi-lit-near-cache + (delq (car (last c-semi-lit-near-cache)) + c-semi-lit-near-cache))) + (push (cons here state) c-semi-lit-near-cache) + (setq c-semi-near-cache-limit + (max c-semi-near-cache-limit here))) + +(defun c-semi-pp-to-literal (here &optional not-in-delimiter) + ;; Do a parse-partial-sexp from a position in the buffer before HERE which + ;; isn't in a literal, and return information about HERE, either: + ;; (STATE TYPE BEG) if HERE is in a literal; or + ;; (STATE) otherwise, + ;; where STATE is the parsing state at HERE, TYPE is the type of the literal + ;; enclosing HERE, (one of 'string, 'c, 'c++) and BEG is the starting + ;; position of that literal (including the delimiter). + ;; + ;; Unless NOT-IN-DELIMITER is non-nil, when TO is inside a two-character + ;; comment opener, this is recognized as being in a comment literal. + ;; + ;; Only elements 3 (in a string), 4 (in a comment), 5 (following a quote), 7 + ;; (comment type), and 8 (start of comment/string), and possibly 10 (in + ;; newer Emacsen only, the syntax of a position after a potential first char + ;; of a two char construct) of STATE are valid. + (save-excursion + (save-restriction + (widen) + (c-trim-lit-pos-cache) + (c-semi-trim-near-cache) + (save-match-data + (let* ((pos-and-state (c-semi-get-near-cache-entry here)) + (pos (car pos-and-state)) + (near-pos pos) + (s (cdr pos-and-state)) + far-pos-and-state far-pos far-s ty) + (if (or (not pos) + (< pos (- here 100))) + (progn + (setq far-pos-and-state (c-parse-ps-state-below here) + far-pos (car far-pos-and-state) + far-s (cdr far-pos-and-state)) + (when (or (not pos) (> far-pos pos)) + (setq pos far-pos + s far-s)))) + (when + (or + (> here pos) + (null (nth 8 s)) + (< here (nth 8 s)) ; Can't happen, can it? + (not + (or + (and (nth 3 s) ; string + (not (eq (char-before here) ?\\))) + (and (nth 4 s) (not (nth 7 s)) ; Block comment + (not (memq (char-before here) + c-block-comment-awkward-chars))) + (and (nth 4 s) (nth 7 s) ; Line comment + (not (memq (char-before here) '(?\\ ?\n))))))) + (c-with-extended-string-fences + pos here + (setq s (parse-partial-sexp pos here nil nil s)))) + (when (not (eq near-pos here)) + (c-semi-put-near-cache-entry here s)) + (cond + ((or (nth 3 s) + (and (nth 4 s) + (not (eq (nth 7 s) 'syntax-table)))) ; in a string or comment + (setq ty (cond + ((nth 3 s) 'string) + ((nth 7 s) 'c++) + (t 'c))) + (list s ty (nth 8 s))) + + ((and (not not-in-delimiter) ; inside a comment starter + (not (bobp)) + (progn (backward-char) + (and (not (and (memq 'category-properties c-emacs-features) + (looking-at "\\s!"))) + (looking-at c-comment-start-regexp)))) + (setq ty (if (looking-at c-block-comment-start-regexp) 'c 'c++)) + (list s ty (point))) + + (t (list s)))))))) + +(defvar c-full-near-cache-limit 1) +(make-variable-buffer-local 'c-full-near-cache-limit) +;; An upper limit on valid entries in `c-full-lit-near-cache'. This +;; is reduced by buffer changes, and increased by invocations of +;; `c-full-pp-to-literal'. + +(defvar c-full-lit-near-cache nil) +(make-variable-buffer-local 'c-full-lit-near-cache) +;; A list of up to six recent results from `c-full-pp-to-literal'. Each +;; element is a list (HERE STATE END)), where HERE is the buffer position the +;; function was called for, STATE is the `parse-partial-sexp' state there, and +;; END is the end of the literal enclosing HERE, if any, or nil otherwise. +;; N.B. END will be nil if the literal ends at EOB without a delimiter. + +(defun c-full-trim-near-cache () + ;; Remove stale entries in `c-full-lit-near-cache', i.e. those whose END + ;; entries, or positions, are above `c-full-near-cache-limit'. + (let ((nc-list c-full-lit-near-cache) elt) + (while nc-list + (let ((elt (car nc-list))) + (if (if (car (cddr elt)) + (< c-full-near-cache-limit (car (cddr elt))) + (< c-full-near-cache-limit (car elt))) + (setq c-full-lit-near-cache + (delq elt c-full-lit-near-cache) + nc-list c-full-lit-near-cache) ; start again in + ; case of list breakage. + (setq nc-list (cdr nc-list))))))) + +(defun c-full-get-near-cache-entry (here) + ;; Return a near cache entry which either represents a literal which + ;; encloses HERE, or is at the highest position before HERE. The returned + ;; cache entry is of the form (POSITION STATE END), where STATE has the form + ;; of a result from `parse-partial-sexp' which is valid at POSITION and END + ;; is the end of any enclosing literal, or nil. + (let ((nc-pos-state + (or (assq here c-full-lit-near-cache) + (let ((nc-list c-full-lit-near-cache) + elt (nc-pos 0) cand-pos-state) + (catch 'found + (while nc-list + (setq elt (car nc-list)) + (when + (and (car (cddr elt)) + (> here (nth 8 (cadr elt))) + (< here (car (cddr elt)))) + (throw 'found elt)) + (when + (and (< (car elt) here) + (> (car elt) nc-pos)) + (setq nc-pos (car elt) + cand-pos-state elt)) + (setq nc-list (cdr nc-list))) + cand-pos-state))))) + ;; Move the found cache entry, if any, to the front of the list. + (when (and nc-pos-state + (not (eq nc-pos-state (car c-full-lit-near-cache)))) + (setq c-full-lit-near-cache + (delq nc-pos-state c-full-lit-near-cache)) + (push nc-pos-state c-full-lit-near-cache)) + (copy-tree nc-pos-state))) + +(defun c-full-put-near-cache-entry (here state end) + ;; Put a new near cache entry into the near cache. + (while (>= (length c-full-lit-near-cache) 6) + (setq c-full-lit-near-cache + (delq (car (last c-full-lit-near-cache)) + c-full-lit-near-cache))) + (push (list here state end) c-full-lit-near-cache) + (setq c-full-near-cache-limit + (max c-full-near-cache-limit (or end here)))) + +(defun c-full-pp-to-literal (here &optional not-in-delimiter) + ;; This function will supersede c-state-pp-to-literal. + ;; + ;; Do a parse-partial-sexp from a position in the buffer before HERE which + ;; isn't in a literal, and return information about HERE, either: + ;; (STATE TYPE (BEG . END)) if HERE is in a literal; or + ;; (STATE) otherwise, + ;; where STATE is the parsing state at HERE, TYPE is the type of the literal + ;; enclosing HERE, (one of 'string, 'c, 'c++) and (BEG . END) is the + ;; boundaries of that literal (including the delimiters), with END being nil + ;; if there is no end delimiter (i.e. the literal ends at EOB). + ;; + ;; Unless NOT-IN-DELIMITER is non-nil, when TO is inside a two-character + ;; comment opener, this is recognized as being in a comment literal. + ;; + ;; Only elements 3 (in a string), 4 (in a comment), 5 (following a quote), 7 + ;; (comment type), and 8 (start of comment/string), and possibly 10 (in + ;; newer Emacsen only, the syntax of a position after a potential first char + ;; of a two char construct) of STATE are valid. + (save-excursion + (save-restriction + (widen) + (c-trim-lit-pos-cache) + (c-full-trim-near-cache) + (save-match-data + (let* ((elt (c-full-get-near-cache-entry here)) + (base (car elt)) + (near-base base) + (s (cadr elt)) + s1 + (end (car (cddr elt))) + far-base-and-state far-base far-s ty start) + (if (or + (not base) ; FIXME!!! Compare base and far-base?? + ; (2019-05-21) + (not end) + (> here end)) + (progn + (setq far-base-and-state (c-parse-ps-state-below here) + far-base (car far-base-and-state) + far-s (cdr far-base-and-state)) + (when (or (not base) (> far-base base)) + (setq base far-base + s far-s + end nil)))) + (when + (or + (and (> here base) (null end)) + (null (nth 8 s)) + (and end (> here end)) + (not + (or + (and (nth 3 s) ; string + (not (eq (char-before here) ?\\))) + (and (nth 4 s) (not (nth 7 s)) ; Block comment + (not (memq (char-before here) + c-block-comment-awkward-chars))) + (and (nth 4 s) (nth 7 s) ; Line comment + (not (memq (char-before here) '(?\\ ?\n))))))) + (setq s (parse-partial-sexp base here nil nil s))) + (cond + ((or (nth 3 s) + (and (nth 4 s) + (not (eq (nth 7 s) 'syntax-table)))) ; in a string or comment + (setq ty (cond + ((nth 3 s) 'string) + ((nth 7 s) 'c++) + (t 'c))) + (setq start (nth 8 s)) + (unless end + (setq s1 (parse-partial-sexp here (point-max) + nil ; TARGETDEPTH + nil ; STOPBEFORE + s ; OLDSTATE + 'syntax-table)); stop at EO literal + (unless (or (nth 3 s1) ; still in a string + (and (nth 4 s1) + (not (eq (nth 7 s1) 'syntax-table)))) ; still + ; in a + ; comment + (setq end (point)))) + (unless (eq near-base here) + (c-full-put-near-cache-entry here s end)) + (list s ty (cons start end))) + + ((and (not not-in-delimiter) ; inside a comment starter + (not (bobp)) + (progn (backward-char) + (and (not (and (memq 'category-properties c-emacs-features) + (looking-at "\\s!"))) + (looking-at c-comment-start-regexp)))) + (setq ty (if (looking-at c-block-comment-start-regexp) 'c 'c++) + start (point)) + (forward-comment 1) + (list s ty (cons start (point)))) + + (t + (unless (eq near-base here) + (c-full-put-near-cache-entry here s nil)) + (list s)))))))) + +(defsubst c-truncate-lit-pos-cache (pos) + ;; Truncate the upper bound of each of the three caches to POS, if it is + ;; higher than that position. + (setq c-lit-pos-cache-limit (min c-lit-pos-cache-limit pos) + c-semi-near-cache-limit (min c-semi-near-cache-limit pos) + c-full-near-cache-limit (min c-full-near-cache-limit pos))) + + +;; A system for finding noteworthy parens before the point. + +(defconst c-state-cache-too-far 5000) +;; A maximum comfortable scanning distance, e.g. between +;; `c-state-cache-good-pos' and "HERE" (where we call c-parse-state). When +;; this distance is exceeded, we take "emergency measures", e.g. by clearing +;; the cache and starting again from point-min or a beginning of defun. This +;; value can be tuned for efficiency or set to a lower value for testing. + +(defvar c-state-cache nil) +(make-variable-buffer-local 'c-state-cache) +;; The state cache used by `c-parse-state' to cut down the amount of +;; searching. It's the result from some earlier `c-parse-state' call. See +;; `c-parse-state''s doc string for details of its structure. +;; +;; The use of the cached info is more effective if the next +;; `c-parse-state' call is on a line close by the one the cached state +;; was made at; the cache can actually slow down a little if the +;; cached state was made very far back in the buffer. The cache is +;; most effective if `c-parse-state' is used on each line while moving +;; forward. + +(defvar c-state-cache-good-pos 1) +(make-variable-buffer-local 'c-state-cache-good-pos) +;; This is a position where `c-state-cache' is known to be correct, or +;; nil (see below). It's a position inside one of the recorded unclosed +;; parens or the top level, but not further nested inside any literal or +;; subparen that is closed before the last recorded position. +;; +;; The exact position is chosen to try to be close to yet earlier than +;; the position where `c-state-cache' will be called next. Right now +;; the heuristic is to set it to the position after the last found +;; closing paren (of any type) before the line on which +;; `c-parse-state' was called. That is chosen primarily to work well +;; with refontification of the current line. +;; +;; 2009-07-28: When `c-state-point-min' and the last position where +;; `c-parse-state' or for which `c-invalidate-state-cache' was called, are +;; both in the same literal, there is no such "good position", and +;; c-state-cache-good-pos is then nil. This is the ONLY circumstance in which +;; it can be nil. In this case, `c-state-point-min-literal' will be non-nil. +;; +;; 2009-06-12: In a brace desert, c-state-cache-good-pos may also be in +;; the middle of the desert, as long as it is not within a brace pair +;; recorded in `c-state-cache' or a paren/bracket pair. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; We maintain a simple cache of positions which aren't in a literal, so as to +;; speed up testing for non-literality. +(defvar c-state-nonlit-pos-cache nil) +(make-variable-buffer-local 'c-state-nonlit-pos-cache) +;; A list of buffer positions which are known not to be in a literal or a cpp +;; construct. This is ordered with higher positions at the front of the list. +;; Only those which are less than `c-state-nonlit-pos-cache-limit' are valid. + +(defvar c-state-nonlit-pos-cache-limit 1) +(make-variable-buffer-local 'c-state-nonlit-pos-cache-limit) +;; An upper limit on valid entries in `c-state-nonlit-pos-cache'. This is +;; reduced by buffer changes, and increased by invocations of +;; `c-state-literal-at'. + +(defun c-state-pp-to-literal (from to &optional not-in-delimiter) + ;; Do a parse-partial-sexp from FROM to TO, returning either + ;; (STATE TYPE (BEG . END)) if TO is in a literal; or + ;; (STATE) otherwise, + ;; where STATE is the parsing state at TO, TYPE is the type of the literal + ;; (one of 'c, 'c++, 'string) and (BEG . END) is the boundaries of the literal, + ;; including the delimiters. + ;; + ;; Unless NOT-IN-DELIMITER is non-nil, when TO is inside a two-character + ;; comment opener, this is recognized as being in a comment literal. + ;; + ;; Only elements 3 (in a string), 4 (in a comment), 5 (following a quote), + ;; 7 (comment type) and 8 (start of comment/string) (and possibly 9) of + ;; STATE are valid. + (save-excursion + (save-match-data + (let ((s (parse-partial-sexp from to)) + ty co-st) + (cond + ((or (nth 3 s) + (and (nth 4 s) + (not (eq (nth 7 s) 'syntax-table)))) ; in a string or comment + (setq ty (cond + ((nth 3 s) 'string) + ((nth 7 s) 'c++) + (t 'c))) + (parse-partial-sexp (point) (point-max) + nil ; TARGETDEPTH + nil ; STOPBEFORE + s ; OLDSTATE + 'syntax-table) ; stop at end of literal + `(,s ,ty (,(nth 8 s) . ,(point)))) + + ((and (not not-in-delimiter) ; inside a comment starter + (not (bobp)) + (progn (backward-char) + (and (not (looking-at "\\s!")) + (looking-at c-comment-start-regexp)))) + (setq ty (if (looking-at c-block-comment-start-regexp) 'c 'c++) + co-st (point)) + (forward-comment 1) + `(,s ,ty (,co-st . ,(point)))) + + (t `(,s))))))) + (defun c-state-safe-place (here) ;; Return a buffer position before HERE which is "safe", i.e. outside any ;; string, comment, or macro. @@ -3656,8 +4181,6 @@ comment at the start of cc-engine.el for more info." c-state-cache-good-pos 1 c-state-nonlit-pos-cache nil c-state-nonlit-pos-cache-limit 1 - c-state-semi-nonlit-pos-cache nil - c-state-semi-nonlit-pos-cache-limit 1 c-state-brace-pair-desert nil c-state-point-min 1 c-state-point-min-lit-type nil @@ -3707,7 +4230,7 @@ comment at the start of cc-engine.el for more info." ;; HERE. (if (<= here c-state-nonlit-pos-cache-limit) (setq c-state-nonlit-pos-cache-limit (1- here))) - (c-truncate-semi-nonlit-pos-cache here) + (c-truncate-lit-pos-cache here) ;; `c-state-cache': ;; Case 1: if `here' is in a literal containing point-min, everything @@ -3870,9 +4393,10 @@ comment at the start of cc-engine.el for more info." (defmacro c-state-maybe-marker (place marker) ;; If PLACE is non-nil, return a marker marking it, otherwise nil. ;; We (re)use MARKER. - `(and ,place - (or ,marker (setq ,marker (make-marker))) - (set-marker ,marker ,place))) + `(let ((-place- ,place)) + (and -place- + (or ,marker (setq ,marker (make-marker))) + (set-marker ,marker -place-)))) (defun c-parse-state () ;; This is a wrapper over `c-parse-state-1'. See that function for a @@ -3931,8 +4455,6 @@ comment at the start of cc-engine.el for more info." c-state-cache-good-pos c-state-nonlit-pos-cache c-state-nonlit-pos-cache-limit - c-state-semi-nonlit-pos-cache - c-state-semi-nonlit-pos-cache-limit c-state-brace-pair-desert c-state-point-min c-state-point-min-lit-type @@ -4254,6 +4776,30 @@ comment at the start of cc-engine.el for more info." (goto-char pos)))))) (< (point) start))) +(defun c-end-of-token (&optional back-limit) + ;; Move to the end of the token we're just before or in the middle of. + ;; BACK-LIMIT may be used to bound the backward search; if given it's + ;; assumed to be at the boundary between two tokens. Return non-nil if the + ;; point is moved, nil otherwise. + ;; + ;; This function might do hidden buffer changes. + (let ((start (point))) + (cond ;; ((< (skip-syntax-backward "w_" (1- start)) 0) + ;; (skip-syntax-forward "w_")) + ((> (skip-syntax-forward "w_") 0)) + ((< (skip-syntax-backward ".()" back-limit) 0) + (while (< (point) start) + (if (looking-at c-nonsymbol-token-regexp) + (goto-char (match-end 0)) + ;; `c-nonsymbol-token-regexp' should always match since + ;; we've skipped backward over punctuation or paren + ;; syntax, but move forward in case it doesn't so that + ;; we don't leave point earlier than we started with. + (forward-char)))) + (t (if (looking-at c-nonsymbol-token-regexp) + (goto-char (match-end 0))))) + (> (point) start))) + (defun c-end-of-current-token (&optional back-limit) ;; Move to the end of the current token. Do not move if not in the ;; middle of one. BACK-LIMIT may be used to bound the backward @@ -4286,6 +4832,41 @@ comment at the start of cc-engine.el for more info." "\\w\\|\\s_\\|\\s\"\\|\\s|" "\\w\\|\\s_\\|\\s\"")) +(defun c-forward-over-token (&optional balanced) + "Move forward over a token. +Return t if we moved, nil otherwise (i.e. we were at EOB, or a +non-token or BALANCED is non-nil and we can't move). If we +are at syntactic whitespace, move over this in place of a token. + +If BALANCED is non-nil move over any balanced parens we are at, and never move +out of an enclosing paren." + (let ((jump-syntax (if balanced + c-jump-syntax-balanced + c-jump-syntax-unbalanced)) + (here (point))) + (condition-case nil + (cond + ((/= (point) + (progn (c-forward-syntactic-ws) (point))) + ;; If we're at whitespace, count this as the token. + t) + ((eobp) nil) + ((looking-at jump-syntax) + (goto-char (scan-sexps (point) 1)) + t) + ((looking-at c-nonsymbol-token-regexp) + (goto-char (match-end 0)) + t) + ((save-restriction + (widen) + (looking-at c-nonsymbol-token-regexp)) + nil) + (t + (forward-char) + t)) + (error (goto-char here) + nil)))) + (defun c-forward-over-token-and-ws (&optional balanced) "Move forward over a token and any following whitespace Return t if we moved, nil otherwise (i.e. we were at EOB, or a @@ -4297,35 +4878,8 @@ out of an enclosing paren. This function differs from `c-forward-token-2' in that it will move forward over the final token in a buffer, up to EOB." - (let ((jump-syntax (if balanced - c-jump-syntax-balanced - c-jump-syntax-unbalanced)) - (here (point))) - (when - (condition-case nil - (cond - ((/= (point) - (progn (c-forward-syntactic-ws) (point))) - ;; If we're at whitespace, count this as the token. - t) - ((eobp) nil) - ((looking-at jump-syntax) - (goto-char (scan-sexps (point) 1)) - t) - ((looking-at c-nonsymbol-token-regexp) - (goto-char (match-end 0)) - t) - ((save-restriction - (widen) - (looking-at c-nonsymbol-token-regexp)) - nil) - (t - (forward-char) - t)) - (error (goto-char here) - nil)) - (c-forward-syntactic-ws) - t))) + (prog1 (c-forward-over-token balanced) + (c-forward-syntactic-ws))) (defun c-forward-token-2 (&optional count balanced limit) "Move forward by tokens. @@ -4727,56 +5281,6 @@ comment at the start of cc-engine.el for more info." (defvar safe-pos-list) ; bound in c-syntactic-skip-backward -(defsubst c-ssb-lit-begin () - ;; Return the start of the literal point is in, or nil. - ;; We read and write the variables `safe-pos', `safe-pos-list', `state' - ;; bound in the caller. - - ;; Use `parse-partial-sexp' from a safe position down to the point to check - ;; if it's outside comments and strings. - (save-excursion - (let ((pos (point)) safe-pos state) - ;; Pick a safe position as close to the point as possible. - ;; - ;; FIXME: Consult `syntax-ppss' here if our cache doesn't give a good - ;; position. - - (while (and safe-pos-list - (> (car safe-pos-list) (point))) - (setq safe-pos-list (cdr safe-pos-list))) - (unless (setq safe-pos (car-safe safe-pos-list)) - (setq safe-pos (max (or (c-safe-position - (point) (c-parse-state)) - 0) - (point-min)) - safe-pos-list (list safe-pos))) - - ;; Cache positions along the way to use if we have to back up more. We - ;; cache every closing paren on the same level. If the paren cache is - ;; relevant in this region then we're typically already on the same - ;; level as the target position. Note that we might cache positions - ;; after opening parens in case safe-pos is in a nested list. That's - ;; both uncommon and harmless. - (while (progn - (setq state (parse-partial-sexp - safe-pos pos 0)) - (< (point) pos)) - (setq safe-pos (point) - safe-pos-list (cons safe-pos safe-pos-list))) - - ;; If the state contains the start of the containing sexp we cache that - ;; position too, so that parse-partial-sexp in the next run has a bigger - ;; chance of starting at the same level as the target position and thus - ;; will get more good safe positions into the list. - (if (elt state 1) - (setq safe-pos (1+ (elt state 1)) - safe-pos-list (cons safe-pos safe-pos-list))) - - (if (or (elt state 3) (elt state 4)) - ;; Inside string or comment. Continue search at the - ;; beginning of it. - (elt state 8))))) - (defun c-syntactic-skip-backward (skip-chars &optional limit paren-level) "Like `skip-chars-backward' but only look at syntactically relevant chars, i.e. don't stop at positions inside syntactic whitespace or string @@ -4793,108 +5297,110 @@ Non-nil is returned if the point moved, nil otherwise. Note that this function might do hidden buffer changes. See the comment at the start of cc-engine.el for more info." - - (c-self-bind-state-cache - (let ((start (point)) - ;; A list of syntactically relevant positions in descending - ;; order. It's used to avoid scanning repeatedly over - ;; potentially large regions with `parse-partial-sexp' to verify - ;; each position. Used in `c-ssb-lit-begin' - safe-pos-list + (let* ((start (point)) ;; The result from `c-beginning-of-macro' at the start position or the - ;; start position itself if it isn't within a macro. Evaluated on - ;; demand. - start-macro-beg + ;; start position itself if it isn't within a macro. + (start-macro-beg + (save-excursion + (goto-char start) + (c-beginning-of-macro limit) + (point))) + lit-beg ;; The earliest position after the current one with the same paren ;; level. Used only when `paren-level' is set. - lit-beg - (paren-level-pos (point))) + (paren-level-pos (point)) + ;; Whether we can optimize with an early `c-backward-syntactic-ws'. + (opt-ws (string-match "^\\^[^ \t\n\r]+$" skip-chars))) - (while - (progn - ;; The next loop "tries" to find the end point each time round, - ;; loops when it hasn't succeeded. - (while - (and - (let ((pos (point))) - (while (and - (< (skip-chars-backward skip-chars limit) 0) - ;; Don't stop inside a literal. - (when (setq lit-beg (c-ssb-lit-begin)) + ;; In the next while form, we only loop when `skip-chars' is something + ;; like "^/" and we've stopped at the end of a block comment. + (while + (progn + ;; The next loop "tries" to find the end point each time round, + ;; loops when it's ended up at the wrong level of nesting. + (while + (and + ;; Optimize for, in particular, large blocks of comments from + ;; `comment-region'. + (progn (when opt-ws + (c-backward-syntactic-ws) + (setq paren-level-pos (point))) + t) + ;; Move back to a candidate end point which isn't in a literal + ;; or in a macro we didn't start in. + (let ((pos (point)) + macro-start) + (while (and + (< (skip-chars-backward skip-chars limit) 0) + (or + (when (setq lit-beg (c-literal-start)) (goto-char lit-beg) - t))) - (< (point) pos)) - - (let ((pos (point)) state-2 pps-end-pos) - - (cond - ((and paren-level - (save-excursion - (setq state-2 (parse-partial-sexp - pos paren-level-pos -1) - pps-end-pos (point)) - (/= (car state-2) 0))) - ;; Not at the right level. - - (if (and (< (car state-2) 0) - ;; We stop above if we go out of a paren. - ;; Now check whether it precedes or is - ;; nested in the starting sexp. - (save-excursion - (setq state-2 - (parse-partial-sexp - pps-end-pos paren-level-pos - nil nil state-2)) - (< (car state-2) 0))) - - ;; We've stopped short of the starting position - ;; so the hit was inside a nested list. Go up - ;; until we are at the right level. - (condition-case nil - (progn - (goto-char (scan-lists pos -1 - (- (car state-2)))) - (setq paren-level-pos (point)) - (if (and limit (>= limit paren-level-pos)) - (progn - (goto-char limit) - nil) - t)) - (error - (goto-char (or limit (point-min))) - nil)) - - ;; The hit was outside the list at the start - ;; position. Go to the start of the list and exit. - (goto-char (1+ (elt state-2 1))) - nil)) - - ((c-beginning-of-macro limit) - ;; Inside a macro. - (if (< (point) - (or start-macro-beg - (setq start-macro-beg - (save-excursion - (goto-char start) - (c-beginning-of-macro limit) - (point))))) - t - - ;; It's inside the same macro we started in so it's - ;; a relevant match. - (goto-char pos) - nil)))))) - - (> (point) - (progn - ;; Skip syntactic ws afterwards so that we don't stop at the - ;; end of a comment if `skip-chars' is something like "^/". - (c-backward-syntactic-ws) - (point))))) + t) + ;; Don't stop inside a macro we didn't start in. + (when + (save-excursion + (and (c-beginning-of-macro limit) + (< (point) start-macro-beg) + (setq macro-start (point)))) + (goto-char macro-start)))) + (when opt-ws + (c-backward-syntactic-ws))) + (< (point) pos)) + + ;; Check whether we're at the wrong level of nesting (when + ;; `paren-level' is non-nil). + (let ((pos (point)) state-2 pps-end-pos) + (when + (and paren-level + (save-excursion + (setq state-2 (parse-partial-sexp + pos paren-level-pos -1) + pps-end-pos (point)) + (/= (car state-2) 0))) + ;; Not at the right level. + (if (and (< (car state-2) 0) + ;; We stop above if we go out of a paren. + ;; Now check whether it precedes or is + ;; nested in the starting sexp. + (save-excursion + (setq state-2 + (parse-partial-sexp + pps-end-pos paren-level-pos + nil nil state-2)) + (< (car state-2) 0))) + + ;; We've stopped short of the starting position + ;; so the hit was inside a nested list. Go up + ;; until we are at the right level. + (condition-case nil + (progn + (goto-char (scan-lists pos -1 + (- (car state-2)))) + (setq paren-level-pos (point)) + (if (and limit (>= limit paren-level-pos)) + (progn + (goto-char limit) + nil) + t)) + (error + (goto-char (or limit (point-min))) + nil)) + + ;; The hit was outside the list at the start + ;; position. Go to the start of the list and exit. + (goto-char (1+ (elt state-2 1))) + nil))))) + + (> (point) + (progn + ;; Skip syntactic ws afterwards so that we don't stop at the + ;; end of a comment if `skip-chars' is something like "^/". + (c-backward-syntactic-ws) + (point))))) - ;; We might want to extend this with more useful return values in - ;; the future. - (/= (point) start)))) + ;; We might want to extend this with more useful return values in + ;; the future. + (/= (point) start))) ;; The following is an alternative implementation of ;; `c-syntactic-skip-backward' that uses backward movement to keep @@ -5026,7 +5532,7 @@ Note that this function might do hidden buffer changes. See the comment at the start of cc-engine.el for more info." (save-restriction (widen) - (let ((lit (c-state-semi-pp-to-literal (point)))) + (let ((lit (c-semi-pp-to-literal (point)))) (or (cadr lit) (and detect-cpp (save-excursion (c-beginning-of-macro)) @@ -5061,8 +5567,11 @@ comment at the start of cc-engine.el for more info." s 'syntax-table) (point))))) - (let ((pp-to-lit (c-state-full-pp-to-literal pos not-in-delimiter))) - (car (cddr pp-to-lit)))))) + (let* ((pp-to-lit (c-full-pp-to-literal pos not-in-delimiter)) + (limits (car (cddr pp-to-lit)))) + (if (and limits (null (cdr limits))) + (cons (car limits) (point-max)) + limits))))) (cond (lit-limits) @@ -5089,7 +5598,7 @@ comment at the start of cc-engine.el for more info." (setq beg (c-safe (c-backward-sexp 1) (point)))) ((and (c-safe (forward-char -2) t) - (looking-at "*/")) + (looking-at "\\*/")) ;; Block comment. Due to the nature of line ;; comments, they will always be covered by the ;; normal case above. @@ -5110,7 +5619,7 @@ a known \"safe position\", i.e. outside of any string or comment." (and (or (nth 3 s) (and (nth 4 s) (not (eq (nth 7 s) 'syntax-table)))) (nth 8 s))) - (car (cddr (c-state-semi-pp-to-literal (point)))))) + (car (cddr (c-semi-pp-to-literal (point)))))) ;; In case external callers use this; it did have a docstring. (defalias 'c-literal-limits-fast 'c-literal-limits) @@ -5177,8 +5686,11 @@ comment at the start of cc-engine.el for more info." (defsubst c-determine-limit-get-base (start try-size) ;; Get a "safe place" approximately TRY-SIZE characters before START. ;; This defsubst doesn't preserve point. + (goto-char start) + (c-backward-syntactic-ws) + (setq start (point)) (let* ((pos (max (- start try-size) (point-min))) - (s (c-state-semi-pp-to-literal pos)) + (s (c-semi-pp-to-literal pos)) (cand (or (car (cddr s)) pos))) (if (>= cand (point-min)) cand @@ -5186,9 +5698,9 @@ comment at the start of cc-engine.el for more info." (point)))) (defun c-determine-limit (how-far-back &optional start try-size) - ;; Return a buffer position HOW-FAR-BACK non-literal characters from - ;; START (default point). The starting position, either point or - ;; START may not be in a comment or string. + ;; Return a buffer position approximately HOW-FAR-BACK non-literal + ;; characters from START (default point). The starting position, either + ;; point or START may not be in a comment or string. ;; ;; The position found will not be before POINT-MIN and won't be in a ;; literal. @@ -5206,6 +5718,12 @@ comment at the start of cc-engine.el for more info." (s (parse-partial-sexp pos pos)) ; null state. stack elt size (count 0)) + ;; Optimization for large blocks of comments, particularly those being + ;; created by `comment-region'. + (goto-char pos) + (forward-comment try-size) + (setq pos (point)) + (while (< pos start) ;; Move forward one literal each time round this loop. ;; Move forward to the start of a comment or string. @@ -5248,6 +5766,10 @@ comment at the start of cc-engine.el for more info." ;; Have we found enough yet? (cond + ((null elt) ; No non-literal characters found. + (if (> base (point-min)) + (c-determine-limit how-far-back base (* 2 try-size)) + (point-min))) ((>= count how-far-back) (+ (car elt) (- count how-far-back))) ((eq base (point-min)) @@ -5255,7 +5777,7 @@ comment at the start of cc-engine.el for more info." ((> base (- start try-size)) ; Can only happen if we hit point-min. (car elt)) (t - (c-determine-limit (- how-far-back count) base try-size)))))) + (c-determine-limit (- how-far-back count) base (* 2 try-size))))))) (defun c-determine-+ve-limit (how-far &optional start-pos) ;; Return a buffer position about HOW-FAR non-literal characters forward @@ -5264,6 +5786,7 @@ comment at the start of cc-engine.el for more info." (let ((pos (or start-pos (point))) (count how-far) (s (parse-partial-sexp (point) (point)))) ; null state + (goto-char pos) (while (and (not (eobp)) (> count 0)) ;; Scan over counted characters. @@ -5411,6 +5934,9 @@ comment at the start of cc-engine.el for more info." (setq c-bs-cache-limit (min c-bs-cache-limit pos))) +(defvar c-restricted-<>-arglists) ;FIXME: Move definition here? +(defvar c-parse-and-markup-<>-arglists) ;FIXME: Move definition here? + (defun c-update-brace-stack (stack from to) ;; Given a brace-stack which has the value STACK at position FROM, update it ;; to its value at position TO, where TO is after (or equal to) FROM. @@ -5465,7 +5991,9 @@ comment at the start of cc-engine.el for more info." (prog1 (looking-at "\\s(") (forward-char)))) (backward-char) - (if (c-forward-<>-arglist nil) ; Should always work. + (if (let ((c-parse-and-markup-<>-arglists t) + (c-restricted-<>-arglists t)) + (c-forward-<>-arglist nil)) ; Should always work. (when (> (point) to) (setq bound-<> (point))) (forward-char))) @@ -5514,7 +6042,7 @@ comment at the start of cc-engine.el for more info." (when (not high-elt) (setq stack (cdr elt)) (while - ;; Add an element to `c-state-semi-nonlit-pos-cache' each iteration. + ;; Add an element to `c-bs-cache' each iteration. (<= (setq npos (+ pos c-bs-interval)) here) (setq elt (c-update-brace-stack stack pos npos)) (setq npos (car elt)) @@ -5592,7 +6120,10 @@ comment at the start of cc-engine.el for more info." (setq cfd-re-match cfd-limit) nil) ((c-got-face-at - (if (setq cfd-re-match (match-end 1)) + (if (setq cfd-re-match + (or (match-end 1) + (and c-dposr-cpp-macro-depth + (match-end (1+ c-dposr-cpp-macro-depth))))) ;; Matched the end of a token preceding a decl spot. (progn (goto-char cfd-re-match) @@ -5603,11 +6134,19 @@ comment at the start of cc-engine.el for more info." c-literal-faces) ;; Pseudo match inside a comment or string literal. Skip out ;; of comments and string literals. - (while (progn - (goto-char (c-next-single-property-change - (point) 'face nil cfd-limit)) - (and (< (point) cfd-limit) - (c-got-face-at (point) c-literal-faces)))) + (while + (progn + (unless + (and + (or (match-end 1) + (and c-dposr-cpp-macro-depth + (match-end (1+ c-dposr-cpp-macro-depth)))) + (c-got-face-at (1- (point)) c-literal-faces) + (not (c-got-face-at (point) c-literal-faces))) + (goto-char (c-next-single-property-change + (point) 'face nil cfd-limit))) + (and (< (point) cfd-limit) + (c-got-face-at (point) c-literal-faces)))) t) ; Continue the loop over pseudo matches. ((and c-opt-identifier-concat-key (match-string 1) @@ -5645,7 +6184,21 @@ comment at the start of cc-engine.el for more info." (when (< cfd-match-pos cfd-limit) ;; Skip forward past comments only so we don't skip macros. - (c-forward-comments) + (while + (progn + (c-forward-comments) + ;; The following is of use within a doc comment when a doc + ;; comment style has removed face properties from a construct, + ;; and is relying on `c-font-lock-declarations' to add them + ;; again. + (cond + ((looking-at c-noise-macro-name-re) + (c-forward-noise-clause-not-macro-decl nil)) ; Returns t. + ((looking-at c-noise-macro-with-parens-name-re) + (c-forward-noise-clause-not-macro-decl t)) ; Always returns t. + ((and (< (point) cfd-limit) + (looking-at c-doc-line-join-re)) + (goto-char (match-end 0)))))) ;; Set the position to continue at. We can avoid going over ;; the comments skipped above a second time, but it's possible ;; that the comment skipping has taken us past `cfd-prop-match' @@ -5674,6 +6227,8 @@ comment at the start of cc-engine.el for more info." ;; o The first token after the end of submatch 1 in ;; `c-decl-prefix-or-start-re' when that submatch matches. This ;; submatch is typically a (L or R) brace or paren, a ;, or a ,. + ;; As a special case, noise macros are skipped over and the next + ;; token regarded as the spot. ;; o The start of each `c-decl-prefix-or-start-re' match when ;; submatch 1 doesn't match. This is, for example, the keyword ;; "class" in Pike. @@ -5750,7 +6305,7 @@ comment at the start of cc-engine.el for more info." ;; before the point, and do the first `c-decl-prefix-or-start-re' ;; search unless we're at bob. - (let (start-in-literal start-in-macro syntactic-pos) + (let (start-in-literal start-in-macro syntactic-pos hash-define-pos) ;; Must back up a bit since we look for the end of the previous ;; statement or declaration, which is earlier than the first ;; returned match. @@ -5904,8 +6459,22 @@ comment at the start of cc-engine.el for more info." (goto-char (or start-in-literal cfd-start-pos)) ;; The only syntactic ws in macros are comments. (c-backward-comments) - (backward-char) - (c-beginning-of-current-token)) + (or (bobp) (backward-char)) + (c-beginning-of-current-token) + ;; If we're in a macro without argument parentheses, we could have + ;; now ended up at the macro's identifier. We need to be at #define + ;; for `c-find-decl-prefix-search' to find the first token of the + ;; macro's expansion. + (when (and (c-on-identifier) + (setq hash-define-pos + (save-excursion + (and + (zerop (c-backward-token-2 2)) ; over define, # + (save-excursion + (beginning-of-line) + (looking-at c-opt-cpp-macro-define-id)) + (point))))) + (goto-char hash-define-pos))) (start-in-literal ;; If we're in a comment it can only be the closest @@ -5929,7 +6498,8 @@ comment at the start of cc-engine.el for more info." (not (eq (c-get-char-property (point) 'c-type) 'c-decl-end)))))) - (when (= (point) start-in-literal) + (when (and (= (point) start-in-literal) + (not (looking-at c-doc-bright-comment-start-re))) ;; Didn't find any property inside the comment, so we can ;; skip it entirely. (This won't skip past a string, but ;; that'll be handled quickly by the next @@ -6308,9 +6878,8 @@ comment at the start of cc-engine.el for more info." ;; Set by c-common-init in cc-mode.el. (defvar c-new-BEG) (defvar c-new-END) -;; Set by c-after-change in cc-mode.el. -(defvar c-old-BEG) -(defvar c-old-END) +;; Set by c-before-change-check-raw-strings. +(defvar c-old-END-literality) (defun c-before-change-check-<>-operators (beg end) ;; Unmark certain pairs of "< .... >" which are currently marked as @@ -6332,44 +6901,52 @@ comment at the start of cc-engine.el for more info." ;; ;; FIXME!!! This routine ignores the possibility of macros entirely. ;; 2010-01-29. - (save-excursion - (c-save-buffer-state - ((beg-lit-start (progn (goto-char beg) (c-literal-start))) - (end-lit-limits (progn (goto-char end) (c-literal-limits))) - new-beg new-end beg-limit end-limit) - ;; Locate the earliest < after the barrier before the changed region, - ;; which isn't already marked as a paren. - (goto-char (or beg-lit-start beg)) - (setq beg-limit (c-determine-limit 512)) - - ;; Remove the syntax-table/category properties from each pertinent <...> - ;; pair. Firstly, the ones with the < before beg and > after beg.... - (while (progn (c-syntactic-skip-backward "^;{}<" beg-limit) - (eq (char-before) ?<)) - (c-backward-token-2) - (when (eq (char-after) ?<) - (c-clear-<-pair-props-if-match-after beg) - (setq new-beg (point)))) - (c-forward-syntactic-ws) + (when (and (> end beg) + (or + (progn + (goto-char beg) + (search-backward "<" (max (- (point) 1024) (point-min)) t)) + (progn + (goto-char end) + (search-forward ">" (min (+ (point) 1024) (point-max)) t)))) + (save-excursion + (c-save-buffer-state + ((beg-lit-start (progn (goto-char beg) (c-literal-start))) + (end-lit-limits (progn (goto-char end) (c-literal-limits))) + new-beg new-end beg-limit end-limit) + ;; Locate the earliest < after the barrier before the changed region, + ;; which isn't already marked as a paren. + (goto-char (or beg-lit-start beg)) + (setq beg-limit (c-determine-limit 512)) + + ;; Remove the syntax-table/category properties from each pertinent <...> + ;; pair. Firstly, the ones with the < before beg and > after beg.... + (while (progn (c-syntactic-skip-backward "^;{}<" beg-limit) + (eq (char-before) ?<)) + (c-backward-token-2) + (when (eq (char-after) ?<) + (c-clear-<-pair-props-if-match-after beg) + (setq new-beg (point)))) + (c-forward-syntactic-ws) - ;; ...Then the ones with < before end and > after end. - (goto-char (if end-lit-limits (cdr end-lit-limits) end)) - (setq end-limit (c-determine-+ve-limit 512)) - (while (and (c-syntactic-re-search-forward "[;{}>]" end-limit 'end) - (eq (char-before) ?>)) - (c-end-of-current-token) - (when (eq (char-before) ?>) - (c-clear->-pair-props-if-match-before end (1- (point))) - (setq new-end (point)))) - (c-backward-syntactic-ws) - - ;; Extend the fontification region, if needed. - (and new-beg - (< new-beg c-new-BEG) - (setq c-new-BEG new-beg)) - (and new-end - (> new-end c-new-END) - (setq c-new-END new-end))))) + ;; ...Then the ones with < before end and > after end. + (goto-char (if end-lit-limits (cdr end-lit-limits) end)) + (setq end-limit (c-determine-+ve-limit 512)) + (while (and (c-syntactic-re-search-forward "[;{}>]" end-limit 'end) + (eq (char-before) ?>)) + (c-end-of-current-token) + (when (eq (char-before) ?>) + (c-clear->-pair-props-if-match-before end (1- (point))) + (setq new-end (point)))) + (c-backward-syntactic-ws) + + ;; Extend the fontification region, if needed. + (and new-beg + (< new-beg c-new-BEG) + (setq c-new-BEG new-beg)) + (and new-end + (> new-end c-new-END) + (setq c-new-END new-end)))))) (defun c-after-change-check-<>-operators (beg end) ;; This is called from `after-change-functions' when @@ -6409,9 +6986,6 @@ comment at the start of cc-engine.el for more info." (c-clear-<>-pair-props) (forward-char))))))) -(defvar c-restricted-<>-arglists) ;FIXME: Move definition here? -(defvar c-parse-and-markup-<>-arglists) ;FIXME: Move definition here? - (defun c-restore-<>-properties (_beg _end _old-len) ;; This function is called as an after-change function. It restores the ;; category/syntax-table properties on template/generic <..> pairs between @@ -6442,9 +7016,9 @@ comment at the start of cc-engine.el for more info." ;; A valid C++ raw string looks like ;; R"<id>(<contents>)<id>" ;; , where <id> is an identifier from 0 to 16 characters long, not containing -;; spaces, control characters, double quote or left/right paren. <contents> -;; can include anything which isn't the terminating )<id>", including new -;; lines, "s, parentheses, etc. +;; spaces, control characters, or left/right paren. <contents> can include +;; anything which isn't the terminating )<id>", including new lines, "s, +;; parentheses, etc. ;; ;; CC Mode handles C++ raw strings by the use of `syntax-table' text ;; properties as follows: @@ -6454,16 +7028,18 @@ comment at the start of cc-engine.el for more info." ;; contents is given the property value "punctuation" (`(1)') to prevent it ;; interacting with the "s in the delimiters. ;; -;; The font locking routine `c-font-lock-c++-raw-strings' (in cc-fonts.el) +;; The font locking routine `c-font-lock-raw-strings' (in cc-fonts.el) ;; recognizes valid raw strings, and fontifies the delimiters (apart from ;; the parentheses) with the default face and the parentheses and the ;; <contents> with font-lock-string-face. ;; ;; (ii) A valid, but unterminated, raw string opening delimiter gets the ;; "punctuation" value (`(1)') of the `syntax-table' text property, and the -;; open parenthesis gets the "string fence" value (`(15)'). +;; open parenthesis gets the "string fence" value (`(15)'). When such a +;; delimiter is found, no attempt is made in any way to "correct" any text +;; properties after the delimiter. ;; -;; `c-font-lock-c++-raw-strings' puts c-font-lock-warning-face on the entire +;; `c-font-lock-raw-strings' puts c-font-lock-warning-face on the entire ;; unmatched opening delimiter (from the R up to the open paren), and allows ;; the rest of the buffer to get font-lock-string-face, caused by the ;; unmatched "string fence" `syntax-table' text property value. @@ -6480,10 +7056,17 @@ comment at the start of cc-engine.el for more info." ;; already at the end of the macro, it gets the "punctuation" value, and no ;; "string fence"s are used. ;; -;; The effect on the fontification of either of these tactics is that rest of -;; the macro (if any) after the "(" gets font-lock-string-face, but the rest -;; of the file is fontified normally. - +;; The effect on the fontification of either of these tactics is that the +;; rest of the macro (if any) after the "(" gets font-lock-string-face, but +;; the rest of the file is fontified normally. + +;; The values of the function `c-raw-string-pos' at before-change-functions' +;; BEG and END. +(defvar c-old-beg-rs nil) +(defvar c-old-end-rs nil) +;; Whether a buffer change has disrupted or will disrupt the terminating id of +;; a raw string. +(defvar c-raw-string-end-delim-disrupted nil) (defun c-raw-string-pos () ;; Get POINT's relationship to any containing raw string. @@ -6500,9 +7083,9 @@ comment at the start of cc-engine.el for more info." ;; characters.) If the raw string is not terminated, E\) and E\" are set to ;; nil. ;; - ;; Note: this routine is dependant upon the correct syntax-table text + ;; Note: this function is dependant upon the correct syntax-table text ;; properties being set. - (let ((state (c-state-semi-pp-to-literal (point))) + (let ((state (c-semi-pp-to-literal (point))) open-quote-pos open-paren-pos close-paren-pos close-quote-pos id) (save-excursion (when @@ -6513,11 +7096,22 @@ comment at the start of cc-engine.el for more info." (search-backward "\"" (max (- (point) 17) (point-min)) t))) ((and (eq (cadr state) 'string) (goto-char (nth 2 state)) - (or (eq (char-after) ?\") - (search-backward "\"" (max (- (point) 17) (point-min)) t)) + (cond + ((eq (char-after) ?\")) + ((eq (char-after) ?\() + (let ((here (point))) + (goto-char (max (- (point) 18) (point-min))) + (while + (and + (search-forward-regexp + c-c++-raw-string-opener-re + (1+ here) 'limit) + (< (point) here))) + (and (eq (point) (1+ here)) + (match-beginning 1) + (goto-char (1- (match-beginning 1))))))) (not (bobp))))) - (eq (char-before) ?R) - (looking-at "\"\\([^ ()\\\n\r\t]\\{0,16\\}\\)(")) + (c-at-c++-raw-string-opener)) (setq open-quote-pos (point) open-paren-pos (match-end 1) id (match-string-no-properties 1)) @@ -6537,6 +7131,21 @@ comment at the start of cc-engine.el for more info." (t nil)) open-quote-pos open-paren-pos close-paren-pos close-quote-pos)))) +(defun c-raw-string-in-end-delim (beg end) + ;; If the region (BEG END) intersects a possible raw string terminator, + ;; return a cons of the position of the ) and the position of the " in the + ;; first one found. + (save-excursion + (goto-char (max (- beg 17) (point-min))) + (while + (and + (search-forward-regexp ")\\([^ ()\\\n\r\t]\\{0,16\\}\\)\"" + (min (+ end 17) (point-max)) t) + (<= (point) beg))) + (unless (or (<= (point) beg) + (>= (match-beginning 0) end)) + (cons (match-beginning 0) (match-end 1))))) + (defun c-depropertize-raw-string (id open-quote open-paren bound) ;; Point is immediately after a raw string opening delimiter. Remove any ;; `syntax-table' text properties associated with the delimiter (if it's @@ -6545,49 +7154,70 @@ comment at the start of cc-engine.el for more info." ;; ID, a string, is the delimiter's identifier. OPEN-QUOTE and OPEN-PAREN ;; are the buffer positions of the delimiter's components. BOUND is the ;; bound for searching for a matching closing delimiter; it is usually nil, - ;; but if we're inside a macro, it's the end of the macro. + ;; but if we're inside a macro, it's the end of the macro (i.e. just before + ;; the terminating \n). ;; ;; Point is moved to after the (terminated) raw string, or left after the ;; unmatched opening delimiter, as the case may be. The return value is of ;; no significance. - (let ((open-paren-prop (c-get-char-property open-paren 'syntax-table))) + (let ((open-paren-prop (c-get-char-property open-paren 'syntax-table)) + first) + ;; If the delimiter is "unclosed", or sombody's used " in their id, clear + ;; the 'syntax-table property from all of them. + (setq first (c-clear-char-property-with-value-on-char + open-quote open-paren 'syntax-table '(1) ?\")) + (if first (c-truncate-lit-pos-cache first)) (cond ((null open-paren-prop) - ;; A terminated raw string + ;; Should be a terminated raw string... (when (search-forward (concat ")" id "\"") nil t) + ;; Yes, it is. :-) + ;; Clear any '(1)s from "s in the identifier. + (setq first (c-clear-char-property-with-value-on-char + (1+ (match-beginning 0)) (1- (match-end 0)) + 'syntax-table '(1) ?\")) + (if first (c-truncate-lit-pos-cache first)) + ;; Clear any random `syntax-table' text properties from the contents. (let* ((closing-paren (match-beginning 0)) - (first-punctuation - (save-match-data - (goto-char (1+ open-paren)) - (and (c-search-forward-char-property 'syntax-table '(1) - closing-paren) - (1- (point))))) - ) - (when first-punctuation - (c-clear-char-property-with-value - first-punctuation (match-beginning 0) 'syntax-table '(1)) - (c-truncate-semi-nonlit-pos-cache first-punctuation) - )))) + (first-st + (and + (< (1+ open-paren) closing-paren) + (or + (and (c-get-char-property (1+ open-paren) 'syntax-table) + (1+ open-paren)) + (and + (setq first + (c-next-single-property-change + (1+ open-paren) 'syntax-table nil closing-paren)) + (< first closing-paren) + first))))) + (when first-st + (c-clear-char-properties first-st (match-beginning 0) + 'syntax-table) + (c-truncate-lit-pos-cache first-st)) + (when (c-get-char-property (1- (match-end 0)) 'syntax-table) + ;; Was previously an unterminated (ordinary) string + (save-excursion + (goto-char (1- (match-end 0))) + (when (c-safe (c-forward-sexp)) ; to '(1) at EOL. + (c-clear-char-property (1- (point)) 'syntax-table)) + (c-clear-char-property (1- (match-end 0)) 'syntax-table) + (c-truncate-lit-pos-cache (1- (match-end 0)))))))) ((or (and (equal open-paren-prop '(15)) (null bound)) (equal open-paren-prop '(1))) ;; An unterminated raw string either not in a macro, or in a macro with ;; the open parenthesis right up against the end of macro (c-clear-char-property open-quote 'syntax-table) - (c-truncate-semi-nonlit-pos-cache open-quote) + (c-truncate-lit-pos-cache open-quote) (c-clear-char-property open-paren 'syntax-table)) (t ;; An unterminated string in a macro, with at least one char after the ;; open paren (c-clear-char-property open-quote 'syntax-table) - (c-truncate-semi-nonlit-pos-cache open-quote) + (c-truncate-lit-pos-cache open-quote) (c-clear-char-property open-paren 'syntax-table) - (let ((after-string-fence-pos - (save-excursion - (goto-char (1+ open-paren)) - (c-search-forward-char-property 'syntax-table '(15) bound)))) - (when after-string-fence-pos - (c-clear-char-property (1- after-string-fence-pos) 'syntax-table))) - )))) + (c-clear-char-property-with-value (1+ open-paren) bound 'syntax-table + '(15)))))) (defun c-depropertize-raw-strings-in-region (start finish) ;; Remove any `syntax-table' text properties associated with C++ raw strings @@ -6599,7 +7229,7 @@ comment at the start of cc-engine.el for more info." (concat "\\(" ; 1 c-anchored-cpp-prefix ; 2 "\\)\\|\\(" ; 3 - "R\"\\([^ ()\\\n\r\t]\\{0,16\\}\\)(" ; 4 + c-c++-raw-string-opener-re ; 4 "\\)") finish t)) (when (save-excursion @@ -6618,7 +7248,7 @@ comment at the start of cc-engine.el for more info." (goto-char (match-end 2)) ; after the "#". (while (and (< (point) eom) (c-syntactic-re-search-forward - "R\"\\([^ ()\\\n\r\t]\\{0,16\\}\\)(" eom t)) + c-c++-raw-string-opener-re eom t)) (c-depropertize-raw-string (match-string-no-properties 1) ; id (1+ (match-beginning 0)) ; open quote @@ -6627,37 +7257,85 @@ comment at the start of cc-engine.el for more info." (defun c-before-change-check-raw-strings (beg end) ;; This function clears `syntax-table' text properties from C++ raw strings - ;; in the region (c-new-BEG c-new-END). BEG and END are the standard - ;; arguments supplied to any before-change function. + ;; whose delimiters are about to change in the region (c-new-BEG c-new-END). + ;; BEG and END are the standard arguments supplied to any before-change + ;; function. ;; ;; Point is undefined on both entry and exit, and the return value has no ;; significance. ;; ;; This function is called as a before-change function solely due to its ;; membership of the C++ value of `c-get-state-before-change-functions'. + (goto-char end) + (setq c-raw-string-end-delim-disrupted nil) + ;; We use the following to detect a R"<id>( being swallowed into a string by + ;; the pending change. + (setq c-old-END-literality (c-in-literal)) (c-save-buffer-state - ((beg-rs (progn (goto-char beg) (c-raw-string-pos))) - (beg-plus (if (null beg-rs) - beg - (max beg - (1+ (or (nth 4 beg-rs) (nth 2 beg-rs)))))) - (end-rs (progn (goto-char end) (c-raw-string-pos))) ; FIXME!!! - ; Optimize this so that we don't call - ; `c-raw-string-pos' twice when once - ; will do. (2016-06-02). - (end-minus (if (null end-rs) - end - (min end (cadr end-rs)))) - ) - (when beg-rs - (setq c-new-BEG (min c-new-BEG (1- (cadr beg-rs))))) - (c-depropertize-raw-strings-in-region c-new-BEG beg-plus) - - (when end-rs - (setq c-new-END (max c-new-END - (1+ (or (nth 4 end-rs) - (nth 2 end-rs)))))) - (c-depropertize-raw-strings-in-region end-minus c-new-END))) + ((term-del (c-raw-string-in-end-delim beg end)) + Rquote close-quote) + (setq c-old-beg-rs (progn (goto-char beg) (c-raw-string-pos)) + c-old-end-rs (progn (goto-char end) (c-raw-string-pos))) + (cond + ;; We're not changing, or we're obliterating raw strings. + ((and (null c-old-beg-rs) (null c-old-end-rs))) + ;; We're changing the putative terminating delimiter of a raw string + ;; containing BEG. + ((and c-old-beg-rs term-del + (or (null (nth 3 c-old-beg-rs)) + (<= (car term-del) (nth 3 c-old-beg-rs)))) + (setq Rquote (1- (cadr c-old-beg-rs)) + close-quote (1+ (cdr term-del))) + (setq c-raw-string-end-delim-disrupted t) + (c-depropertize-raw-strings-in-region Rquote close-quote) + (setq c-new-BEG (min c-new-BEG Rquote) + c-new-END (max c-new-END close-quote))) + ;; We're breaking an escaped NL in a raw string in a macro. + ((and c-old-end-rs + (< beg end) + (goto-char end) (eq (char-before) ?\\) + (c-beginning-of-macro)) + (let ((bom (point)) + (eom (progn (c-end-of-macro) (point)))) + (c-depropertize-raw-strings-in-region bom eom) + (setq c-new-BEG (min c-new-BEG bom) + c-new-END (max c-new-END eom)))) + ;; We're changing only the contents of a raw string. + ((and (equal (cdr c-old-beg-rs) (cdr c-old-end-rs)) + (null (car c-old-beg-rs)) (null (car c-old-end-rs)))) + ((or + ;; We're removing (at least part of) the R" of the starting delim of a + ;; raw string: + (null c-old-beg-rs) + (and (eq beg (cadr c-old-beg-rs)) + (< beg end)) + ;; Or we're removing the ( of the starting delim of a raw string. + (and (eq (car c-old-beg-rs) 'open-delim) + (or (null c-old-end-rs) + (not (eq (car c-old-end-rs) 'open-delim)) + (not (equal (cdr c-old-beg-rs) (cdr c-old-end-rs)))))) + (let ((close (nth 4 (or c-old-end-rs c-old-beg-rs)))) + (setq Rquote (1- (cadr (or c-old-end-rs c-old-beg-rs))) + close-quote (if close (1+ close) (point-max)))) + (c-depropertize-raw-strings-in-region Rquote close-quote) + (setq c-new-BEG (min c-new-BEG Rquote) + c-new-END (max c-new-END close-quote))) + ;; We're changing only the text of the identifier of the opening + ;; delimiter of a raw string. + ((and (eq (car c-old-beg-rs) 'open-delim) + (equal c-old-beg-rs c-old-end-rs)))))) + +(defun c-propertize-raw-string-id (start end) + ;; If the raw string identifier between buffer positions START and END + ;; contains any double quote characters, put a punctuation syntax-table text + ;; property on them. The return value is of no significance. + (save-excursion + (goto-char start) + (while (and (skip-chars-forward "^\"" end) + (< (point) end)) + (c-put-char-property (point) 'syntax-table '(1)) + (c-truncate-lit-pos-cache (point)) + (forward-char)))) (defun c-propertize-raw-string-opener (id open-quote open-paren bound) ;; Point is immediately after a raw string opening delimiter. Apply any @@ -6667,117 +7345,220 @@ comment at the start of cc-engine.el for more info." ;; ID, a string, is the delimiter's identifier. OPEN-QUOTE and OPEN-PAREN ;; are the buffer positions of the delimiter's components. BOUND is the ;; bound for searching for a matching closing delimiter; it is usually nil, - ;; but if we're inside a macro, it's the end of the macro. - ;; - ;; Point is moved to after the (terminated) raw string, or left after the - ;; unmatched opening delimiter, as the case may be. The return value is of - ;; no significance. - (if (search-forward (concat ")" id "\"") bound t) - (let ((end-string (match-beginning 0)) - (after-quote (match-end 0))) - (goto-char open-paren) - (while (progn (skip-syntax-forward "^\"" end-string) - (< (point) end-string)) - (c-put-char-property (point) 'syntax-table '(1)) ; punctuation - (c-truncate-semi-nonlit-pos-cache (point)) - (forward-char)) - (goto-char after-quote)) - (c-put-char-property open-quote 'syntax-table '(1)) ; punctuation - (c-truncate-semi-nonlit-pos-cache open-quote) - (c-put-char-property open-paren 'syntax-table '(15)) ; generic string - (when bound - ;; In a CPP construct, we try to apply a generic-string `syntax-table' - ;; text property to the last possible character in the string, so that - ;; only characters within the macro get "stringed out". - (goto-char bound) - (if (save-restriction - (narrow-to-region (1+ open-paren) (point-max)) - (re-search-backward - (eval-when-compile - ;; This regular expression matches either an escape pair (which - ;; isn't an escaped NL) (submatch 5) or a non-escaped character - ;; (which isn't itself a backslash) (submatch 10). The long - ;; preambles to these (respectively submatches 2-4 and 6-9) - ;; ensure that we have the correct parity for sequences of - ;; backslashes, etc.. - (concat "\\(" ; 1 - "\\(\\`[^\\]?\\|[^\\][^\\]\\)\\(\\\\\\(.\\|\n\\)\\)*" ; 2-4 - "\\(\\\\.\\)" ; 5 - "\\|" - "\\(\\`\\|[^\\]\\|\\(\\`[^\\]?\\|[^\\][^\\]\\)\\(\\\\\\(.\\|\n\\)\\)+\\)" ; 6-9 - "\\([^\\]\\)" ; 10 - "\\)" - "\\(\\\\\n\\)*\\=")) ; 11 - (1+ open-paren) t)) - (if (match-beginning 10) - (progn - (c-put-char-property (match-beginning 10) 'syntax-table '(15)) - (c-truncate-semi-nonlit-pos-cache (match-beginning 10))) - (c-put-char-property (match-beginning 5) 'syntax-table '(1)) - (c-put-char-property (1+ (match-beginning 5)) 'syntax-table '(15)) - (c-truncate-semi-nonlit-pos-cache (1+ (match-beginning 5)))) - (c-put-char-property open-paren 'syntax-table '(1))) - (goto-char bound)))) - -(defun c-after-change-re-mark-raw-strings (_beg _end _old-len) - ;; This function applies `syntax-table' text properties to C++ raw strings - ;; beginning in the region (c-new-BEG c-new-END). BEG, END, and OLD-LEN are - ;; the standard arguments supplied to any after-change function. + ;; but if we're inside a macro, it's the end of the macro (i.e. the position + ;; of the closing newline). + ;; + ;; Point is moved to after the (terminated) raw string and t is returned, or + ;; it is left after the unmatched opening delimiter and nil is returned. + (c-propertize-raw-string-id (1+ open-quote) open-paren) + (prog1 + (if (search-forward (concat ")" id "\"") bound t) + (let ((end-string (match-beginning 0)) + (after-quote (match-end 0))) + (c-propertize-raw-string-id + (1+ (match-beginning 0)) (1- (match-end 0))) + (goto-char open-paren) + (while (progn (skip-syntax-forward "^\"" end-string) + (< (point) end-string)) + (c-put-char-property (point) 'syntax-table '(1)) ; punctuation + (c-truncate-lit-pos-cache (point)) + (forward-char)) + (goto-char after-quote) + t) + (c-put-char-property open-quote 'syntax-table '(1)) ; punctuation + (c-truncate-lit-pos-cache open-quote) + (c-put-char-property open-paren 'syntax-table '(15)) ; generic string + (when bound + ;; In a CPP construct, we try to apply a generic-string + ;; `syntax-table' text property to the last possible character in + ;; the string, so that only characters within the macro get + ;; "stringed out". + (goto-char bound) + (if (save-restriction + (narrow-to-region (1+ open-paren) (point-max)) + (re-search-backward + (eval-when-compile + ;; This regular expression matches either an escape pair + ;; (which isn't an escaped NL) (submatch 5) or a + ;; non-escaped character (which isn't itself a backslash) + ;; (submatch 10). The long preambles to these + ;; (respectively submatches 2-4 and 6-9) ensure that we + ;; have the correct parity for sequences of backslashes, + ;; etc.. + (concat "\\(" ; 1 + "\\(\\`[^\\]?\\|[^\\][^\\]\\)\\(\\\\\\(.\\|\n\\)\\)*" ; 2-4 + "\\(\\\\.\\)" ; 5 + "\\|" + "\\(\\`\\|[^\\]\\|\\(\\`[^\\]?\\|[^\\][^\\]\\)\\(\\\\\\(.\\|\n\\)\\)+\\)" ; 6-9 + "\\([^\\]\\)" ; 10 + "\\)" + "\\(\\\\\n\\)*\\=")) ; 11 + (1+ open-paren) t)) + (if (match-beginning 10) + (progn + (c-put-char-property (match-beginning 10) 'syntax-table '(15)) + (c-truncate-lit-pos-cache (match-beginning 10))) + (c-put-char-property (match-beginning 5) 'syntax-table '(1)) + (c-put-char-property (1+ (match-beginning 5)) 'syntax-table '(15)) + (c-truncate-lit-pos-cache (1+ (match-beginning 5)))) + ;; (c-put-char-property open-paren 'syntax-table '(1)) + ) + (goto-char bound)) + nil))) + +(defun c-after-change-unmark-raw-strings (beg end _old-len) + ;; This function removes `syntax-table' text properties from any raw strings + ;; which have been affected by the current change. These are those which + ;; have been "stringed out" and from newly formed raw strings, or any + ;; existing raw string which the new text terminates. BEG, END, and + ;; _OLD-LEN are the standard arguments supplied to any + ;; after-change-function. ;; ;; Point is undefined on both entry and exit, and the return value has no ;; significance. ;; - ;; This function is called as an after-change function solely due to its + ;; This functions is called as an after-change function by virtue of its ;; membership of the C++ value of `c-before-font-lock-functions'. - (c-save-buffer-state () - ;; If the region (c-new-BEG c-new-END) has expanded, remove - ;; `syntax-table' text-properties from the new piece(s). - (when (< c-new-BEG c-old-BEG) - (let ((beg-rs (progn (goto-char c-old-BEG) (c-raw-string-pos)))) - (c-depropertize-raw-strings-in-region - c-new-BEG - (if beg-rs - (1+ (or (nth 4 beg-rs) (nth 2 beg-rs))) - c-old-BEG)))) - (when (> c-new-END c-old-END) - (let ((end-rs (progn (goto-char c-old-END) (c-raw-string-pos)))) - (c-depropertize-raw-strings-in-region - (if end-rs - (cadr end-rs) - c-old-END) - c-new-END))) - - (goto-char c-new-BEG) - (while (and (< (point) c-new-END) - (re-search-forward - (concat "\\(" ; 1 - c-anchored-cpp-prefix ; 2 - "\\)\\|\\(" ; 3 - "R\"\\([^ ()\\\n\r\t]\\{0,16\\}\\)(" ; 4 - "\\)") - c-new-END t)) - (when (save-excursion - (goto-char (match-beginning 0)) (not (c-in-literal))) - (if (match-beginning 4) ; the id - ;; We've found a raw string. - (c-propertize-raw-string-opener - (match-string-no-properties 4) ; id - (1+ (match-beginning 3)) ; open quote - (match-end 4) ; open paren - nil) ; bound - ;; We've found a CPP construct. Search for raw strings within it. - (goto-char (match-beginning 2)) ; the "#" + ;; (when (< beg end) + (c-save-buffer-state (found eoll state id found-beg) + ;; Has an inserted " swallowed up a R"(, turning it into "...R"(? + (goto-char end) + (setq eoll (c-point 'eoll)) + (when (and (null c-old-END-literality) + (search-forward-regexp c-c++-raw-string-opener-re eoll t)) + (setq state (c-semi-pp-to-literal end)) + (when (eq (cadr state) 'string) + (unwind-protect + ;; Temporarily insert a closing string delimiter.... + (progn + (goto-char end) + (cond + ((c-characterp (nth 3 (car state))) + (insert (nth 3 (car state)))) + ((eq (nth 3 (car state)) t) + (insert ?\") + (c-put-char-property end 'syntax-table '(15)))) + (c-truncate-lit-pos-cache end) + ;; ....ensure c-new-END extends right to the end of the about + ;; to be un-stringed raw string.... + (save-excursion + (goto-char (match-beginning 1)) + (let ((end-bs (c-raw-string-pos))) + (setq c-new-END + (max c-new-END + (if (nth 4 end-bs) + (1+ (nth 4 end-bs)) + eoll))))) + + ;; ...and clear `syntax-table' text propertes from the + ;; following raw strings. + (c-depropertize-raw-strings-in-region (point) (1+ eoll))) + ;; Remove the temporary string delimiter. + (goto-char end) + (delete-char 1)))) + + ;; Have we just created a new starting id? + (goto-char (max (- beg 18) (point-min))) + (while + (and + (setq found + (search-forward-regexp c-c++-raw-string-opener-re + c-new-END 'bound)) + (<= (match-end 0) beg))) + (when (and found (<= (match-beginning 0) end)) + (setq c-new-BEG (min c-new-BEG (match-beginning 0))) + (c-depropertize-raw-strings-in-region c-new-BEG c-new-END)) + + ;; Have we invalidated an opening delimiter by typing into it? + (when (and c-old-beg-rs + (eq (car c-old-beg-rs) 'open-delim) + (equal (c-get-char-property (cadr c-old-beg-rs) + 'syntax-table) + '(1))) + (goto-char (1- (cadr c-old-beg-rs))) + (unless (looking-at c-c++-raw-string-opener-re) + (c-clear-char-property (1+ (point)) 'syntax-table) + (c-truncate-lit-pos-cache (1+ (point))) + (if (c-search-forward-char-property 'syntax-table '(15) + (c-point 'eol)) + (c-clear-char-property (1- (point)) 'syntax-table)))) + + ;; Have we matched up with an existing terminator by typing into an + ;; opening delimiter? ... or by messing up a raw string's terminator so + ;; that it now matches a later terminator? + (when + (or c-raw-string-end-delim-disrupted + (and c-old-beg-rs + (eq (car c-old-beg-rs) 'open-delim))) + (goto-char (cadr c-old-beg-rs)) + (when (looking-at c-c++-raw-string-opener-1-re) + (setq id (match-string-no-properties 1)) + (when (search-forward (concat ")" id "\"") nil t) ; No bound. + (setq c-new-END (point-max)) + (c-clear-char-properties (cadr c-old-beg-rs) c-new-END + 'syntax-table) + (c-truncate-lit-pos-cache (cadr c-old-beg-rs))))) + ;; Have we terminated an existing raw string by inserting or removing + ;; text? + (when (eq c-old-END-literality 'string) + ;; Have we just made or modified a closing delimiter? + (goto-char (max (- beg 18) (point-min))) + (while + (and + (setq found + (search-forward-regexp ")\\([^ ()\\\n\r\t]\\{0,16\\}\\)\"" + (+ end 17) t)) + (< (match-end 0) beg))) + (when (and found (<= (match-beginning 0) end)) + (setq id (match-string-no-properties 1)) + (goto-char (match-beginning 0)) + (while + (and + (setq found (search-backward (concat "R\"" id "(") nil t)) + (setq state (c-semi-pp-to-literal (point))) + (memq (nth 3 (car state)) '(t ?\")))) + (when found + (setq c-new-BEG (min (point) c-new-BEG) + c-new-END (point-max)) + (c-clear-syn-tab-properties (point) c-new-END) + (c-truncate-lit-pos-cache (point))))) + + ;; Are there any raw strings in a newly created macro? + (when (< beg end) + (goto-char beg) + (setq found-beg (point)) + (when (search-forward-regexp c-anchored-cpp-prefix end t) (c-end-of-macro) - (let ((eom (point))) - (goto-char (match-end 2)) ; after the "#". - (while (and (< (point) eom) - (c-syntactic-re-search-forward - "R\"\\([^ ()\\\n\r\t]\\{0,16\\}\\)(" eom t)) - (c-propertize-raw-string-opener - (match-string-no-properties 1) ; id - (1+ (match-beginning 0)) ; open quote - (match-end 1) ; open paren - eom)))))))) ; bound + (c-depropertize-raw-strings-in-region found-beg (point)))))) + +(defun c-maybe-re-mark-raw-string () + ;; When this function is called, point is immediately after a " which opens + ;; a string. If this " is the characteristic " of of a raw string + ;; opener, apply the pertinent `syntax-table' text properties to the + ;; entire raw string (when properly terminated) or just the delimiter + ;; (otherwise). In either of these cases, return t, otherwise return nil. + ;; + (let ((here (point)) + in-macro macro-end id Rquote found) + (when + (and + (eq (char-before (1- (point))) ?R) + (looking-at "\\([^ ()\\\n\r\t]\\{0,16\\}\\)(")) + (save-excursion + (setq in-macro (c-beginning-of-macro)) + (setq macro-end (when in-macro + (c-end-of-macro) + (point) ;; (min (1+ (point)) (point-max)) + ))) + (when + (not + (c-propertize-raw-string-opener + (match-string-no-properties 1) ; id + (1- (point)) ; open quote + (match-end 1) ; open paren + macro-end)) ; bound (end of macro) or nil. + (goto-char (or macro-end (point-max)))) + t))) ;; Handling of small scale constructs like types and names. @@ -6890,8 +7671,8 @@ comment at the start of cc-engine.el for more info." `(let (res) (setq c-last-identifier-range nil) (while (if (setq res ,(if (eq type 'type) - `(c-forward-type) - `(c-forward-name))) + '(c-forward-type) + '(c-forward-name))) nil (cond ((looking-at c-keywords-regexp) (c-forward-keyword-clause 1)) @@ -6901,8 +7682,8 @@ comment at the start of cc-engine.el for more info." (when (memq res '(t known found prefix maybe)) (when c-record-type-identifiers ,(if (eq type 'type) - `(c-record-type-id c-last-identifier-range) - `(c-record-ref-id c-last-identifier-range))) + '(c-record-type-id c-last-identifier-range) + '(c-record-ref-id c-last-identifier-range))) t))) (defmacro c-forward-id-comma-list (type update-safe-pos) @@ -6913,7 +7694,7 @@ comment at the start of cc-engine.el for more info." ;; This macro might do hidden buffer changes. `(while (and (progn ,(when update-safe-pos - `(setq safe-pos (point))) + '(setq safe-pos (point))) (eq (char-after) ?,)) (progn (forward-char) @@ -6931,6 +7712,21 @@ comment at the start of cc-engine.el for more info." (c-forward-syntactic-ws)) t) +(defun c-forward-noise-clause-not-macro-decl (maybe-parens) + ;; Point is at a noise macro identifier, which, when MAYBE-PARENS is + ;; non-nil, optionally takes paren arguments. Go forward over this name, + ;; and when there may be optional parens, any parenthesis expression which + ;; follows it, but DO NOT go over any macro declaration which may come + ;; between them. Always return t. + (c-end-of-token) + (when maybe-parens + (let ((here (point))) + (c-forward-comments) + (if (not (and (eq (char-after) ?\() + (c-go-list-forward))) + (goto-char here)))) + t) + (defun c-forward-keyword-clause (match) ;; Submatch MATCH in the current match data is assumed to surround a ;; token. If it's a keyword, move over it and any immediately @@ -7138,7 +7934,9 @@ comment at the start of cc-engine.el for more info." (progn (c-forward-syntactic-ws) (when (or (and c-record-type-identifiers all-types) - (not (equal c-inside-<>-type-key "\\(\\<\\>\\)"))) + (not (equal c-inside-<>-type-key + (concat + "\\(" regexp-unmatchable "\\)")))) (c-forward-syntactic-ws) (cond ((eq (char-after) ??) @@ -7185,7 +7983,7 @@ comment at the start of cc-engine.el for more info." (if (save-excursion (c-backward-token-2) - (looking-at c-multichar->-op-not->>-regexp)) + (looking-at c-multichar->-op-not->>->>>-regexp)) (progn (goto-char (match-end 0)) t) ; Continue the loop. @@ -7688,7 +8486,7 @@ comment at the start of cc-engine.el for more info." (c-record-type-id id-range)) (unless res (setq res 'found))) - (setq res (if (c-check-type id-start id-end) + (setq res (if (c-check-qualified-type id-start) ;; It's an identifier that has been used as ;; a type somewhere else. 'found @@ -7700,7 +8498,7 @@ comment at the start of cc-engine.el for more info." (c-forward-syntactic-ws) (setq res (if (eq (char-after) ?\() - (if (c-check-type id-start id-end) + (if (c-check-qualified-type id-start) ;; It's an identifier that has been used as ;; a type somewhere else. 'found @@ -7825,6 +8623,37 @@ comment at the start of cc-engine.el for more info." (prog1 (car ,ps) (setq ,ps (cdr ,ps))))) +(defun c-forward-over-compound-identifier () + ;; Go over a possibly compound identifier, such as C++'s Foo::Bar::Baz, + ;; returning that identifier (with any syntactic WS removed). Return nil if + ;; we're not at an identifier. + (when (c-on-identifier) + (let ((consolidated "") (consolidated-:: "") + start end) + (while + (progn + (setq start (point)) + (c-forward-over-token) + (setq consolidated + (concat consolidated-:: + (buffer-substring-no-properties start (point)))) + (c-forward-syntactic-ws) + (and c-opt-identifier-concat-key + (looking-at c-opt-identifier-concat-key) + (progn + (setq start (point)) + (c-forward-over-token) + (setq end (point)) + (c-forward-syntactic-ws) + (and + (c-on-identifier) + (setq consolidated-:: + (concat consolidated + (buffer-substring-no-properties start end)))))))) + (if (equal consolidated "") + nil + consolidated)))) + (defun c-back-over-compound-identifier () ;; Point is putatively just after a "compound identifier", i.e. something ;; looking (in C++) like this "FQN::of::base::Class". Move to the start of @@ -7849,6 +8678,21 @@ comment at the start of cc-engine.el for more info." (goto-char end) t))) +(defun c-check-qualified-type (from) + ;; Look up successive tails of a (possibly) qualified type in + ;; `c-found-types'. If one of them matches, return it, else return nil. + (save-excursion + (goto-char from) + (let ((compound (c-forward-over-compound-identifier))) + (when compound + (while (and c-opt-identifier-concat-key + (> (length compound) 0) + (not (gethash compound c-found-types)) + (string-match c-opt-identifier-concat-key compound)) + (setq compound (substring compound (match-end 0)))) + (and (gethash compound c-found-types) + compound))))) + (defun c-back-over-member-initializer-braces () ;; Point is just after a closing brace/parenthesis. Try to parse this as a ;; C++ member initializer list, going back to just after the introducing ":" @@ -7888,7 +8732,7 @@ comment at the start of cc-engine.el for more info." ;; a comma. If either of <symbol> or bracketed <expression> is missing, ;; throw nil to 'level. If the terminating } or ) is unmatched, throw nil ;; to 'done. This is not a general purpose macro! - `(while (eq (char-before) ?,) + '(while (eq (char-before) ?,) (backward-char) (c-backward-syntactic-ws) (when (not (memq (char-before) '(?\) ?}))) @@ -7904,97 +8748,81 @@ comment at the start of cc-engine.el for more info." (throw 'level nil)) (c-backward-syntactic-ws))) -(defun c-back-over-member-initializers () +(defun c-back-over-member-initializers (&optional limit) ;; Test whether we are in a C++ member initializer list, and if so, go back ;; to the introducing ":", returning the position of the opening paren of ;; the function's arglist. Otherwise return nil, leaving point unchanged. - (let ((here (point)) - (paren-state (c-parse-state)) - pos level-plausible at-top-level res) - ;; Assume tentatively that we're at the top level. Try to go back to the - ;; colon we seek. - (setq res - (catch 'done - (setq level-plausible - (catch 'level - (c-backward-syntactic-ws) - (when (memq (char-before) '(?\) ?})) - (when (not (c-go-list-backward)) - (throw 'done nil)) - (c-backward-syntactic-ws)) - (when (c-back-over-compound-identifier) - (c-backward-syntactic-ws)) - (c-back-over-list-of-member-inits) - (and (eq (char-before) ?:) - (save-excursion - (c-backward-token-2) - (not (looking-at c-:$-multichar-token-regexp))) - (c-just-after-func-arglist-p)))) - - (while (and (not (and level-plausible - (setq at-top-level (c-at-toplevel-p)))) - (setq pos (c-pull-open-brace paren-state))) ; might be a paren. + ;; LIMIT, if non-nil, is a limit for the backward search. + (save-restriction + (let ((here (point)) + (paren-state (c-parse-state)) ; Do this outside the narrowing for + ; performance reasons. + pos level-plausible at-top-level res) + (if limit (narrow-to-region limit (point))) + ;; Assume tentatively that we're at the top level. Try to go back to the + ;; colon we seek. + (setq res + (catch 'done (setq level-plausible (catch 'level - (goto-char pos) - (c-backward-syntactic-ws) - (when (not (c-back-over-compound-identifier)) - (throw 'level nil)) (c-backward-syntactic-ws) + (when (memq (char-before) '(?\) ?})) + (when (not (c-go-list-backward)) + (throw 'done nil)) + (c-backward-syntactic-ws)) + (when (c-back-over-compound-identifier) + (c-backward-syntactic-ws)) (c-back-over-list-of-member-inits) (and (eq (char-before) ?:) (save-excursion (c-backward-token-2) (not (looking-at c-:$-multichar-token-regexp))) - (c-just-after-func-arglist-p))))) - - (and at-top-level level-plausible))) - (or res (goto-char here)) - res)) - + (c-just-after-func-arglist-p)))) + + (while (and (not (and level-plausible + (setq at-top-level (c-at-toplevel-p)))) + (setq pos (c-pull-open-brace paren-state)) ; might be a paren. + (or (null limit) (>= pos limit))) + (setq level-plausible + (catch 'level + (goto-char pos) + (c-backward-syntactic-ws) + (when (not (c-back-over-compound-identifier)) + (throw 'level nil)) + (c-backward-syntactic-ws) + (c-back-over-list-of-member-inits) + (and (eq (char-before) ?:) + (save-excursion + (c-backward-token-2) + (not (looking-at c-:$-multichar-token-regexp))) + (c-just-after-func-arglist-p))))) + + (and at-top-level level-plausible))) + (or res (goto-char here)) + res))) + +(defun c-forward-class-decl () + "From the beginning of a struct/union, etc. move forward to +after the brace block which defines it, leaving point at the +start of the next token and returning point. On failure leave +point unchanged and return nil." + (let ((here (point))) + (if + (and + (looking-at c-class-key) + (eq (c-forward-token-2) 0) + (c-on-identifier) + (eq (c-forward-token-2) 0) + (eq (char-after) ?{) + (c-go-list-forward)) + (progn + (c-forward-syntactic-ws) + (point)) + (goto-char here) + nil))) ;; Handling of large scale constructs like statements and declarations. -;; Macro used inside `c-forward-decl-or-cast-1'. It ought to be a -;; defsubst or perhaps even a defun, but it contains lots of free -;; variables that refer to things inside `c-forward-decl-or-cast-1'. -(defmacro c-fdoc-shift-type-backward (&optional short) - ;; `c-forward-decl-or-cast-1' can consume an arbitrary length list - ;; of types when parsing a declaration, which means that it - ;; sometimes consumes the identifier in the declaration as a type. - ;; This is used to "backtrack" and make the last type be treated as - ;; an identifier instead. - `(progn - ,(unless short - ;; These identifiers are bound only in the inner let. - '(setq identifier-type at-type - identifier-start type-start - got-parens nil - got-identifier t - got-suffix t - got-suffix-after-parens id-start - paren-depth 0)) - - (if (setq at-type (if (eq backup-at-type 'prefix) - t - backup-at-type)) - (setq type-start backup-type-start - id-start backup-id-start) - (setq type-start start-pos - id-start start-pos)) - - ;; When these flags already are set we've found specifiers that - ;; unconditionally signal these attributes - backtracking doesn't - ;; change that. So keep them set in that case. - (or at-type-decl - (setq at-type-decl backup-at-type-decl)) - (or maybe-typeless - (setq maybe-typeless backup-maybe-typeless)) - - ,(unless short - ;; This identifier is bound only in the inner let. - '(setq start id-start)))) - (defun c-forward-declarator (&optional limit accept-anon) ;; Assuming point is at the start of a declarator, move forward over it, ;; leaving point at the next token after it (e.g. a ) or a ; or a ,). @@ -8147,6 +8975,176 @@ comment at the start of cc-engine.el for more info." (goto-char here) nil))) +(defun c-do-declarators + (cdd-limit cdd-list cdd-not-top cdd-comma-prop cdd-function) + "Assuming point is at the start of a comma separated list of declarators, +apply CDD-FUNCTION to each declarator (when CDD-LIST is non-nil) or just the +first declarator (when CDD-LIST is nil). When CDD-FUNCTION is nil, no +function is applied. + +CDD-FUNCTION is supplied with 6 arguments: +0. The start position of the declarator's identifier; +1. The end position of this identifier; +\[Note: if there is no identifier, as in int (*);, both of these are nil.] +2. The position of the next token after the declarator (CLARIFY!!!). +3. CDD-NOT-TOP; +4. Non-nil if the identifier is of a function. +5. When there is an initialization following the declarator (such as \"= +....\" or \"( ....\".), the character which introduces this initialization, +otherwise nil. + +Additionally, if CDD-COMMA-PROP is non-nil, mark the separating commas with +this value of the c-type property, when CDD-LIST is non-nil. + +Stop at or before CDD-LIMIT (which may NOT be nil). + +If CDD-NOT-TOP is non-nil, we are not at the top-level (\"top-level\" includes +being directly inside a class or namespace, etc.). + +Return non-nil if we've reached the token after the last declarator (often a +semicolon, or a comma when CDD-LIST is nil); otherwise (when we hit CDD-LIMIT, +or fail otherwise) return nil, leaving point at the beginning of the putative +declarator that could not be processed. + +This function might do hidden buffer changes." + ;; N.B.: We use the "cdd-" prefix in this routine to try to prevent + ;; confusion with possible reference to common variable names from within + ;; CDD-FUNCTION. + (let + ((cdd-pos (point)) cdd-next-pos cdd-id-start cdd-id-end + cdd-decl-res cdd-got-func cdd-got-type cdd-got-init + c-last-identifier-range cdd-exhausted) + + ;; The following `while' applies `cdd-function' to a single declarator id + ;; each time round. It loops only when CDD-LIST is non-nil. + (while + (and (not cdd-exhausted) + (setq cdd-decl-res (c-forward-declarator cdd-limit))) + (setq cdd-next-pos (point) + cdd-id-start (car cdd-decl-res) + cdd-id-end (cadr cdd-decl-res) + cdd-got-func (and (eq (char-after) ?\() + (or (not (c-major-mode-is 'c++-mode)) + (not cdd-not-top) + (car (cddr (cddr cdd-decl-res))) ; Id is in + ; parens, etc. + (save-excursion + (forward-char) + (c-forward-syntactic-ws) + (looking-at "[*&]"))) + (not (car (cddr cdd-decl-res))) + (or (not (c-major-mode-is 'c++-mode)) + (save-excursion + (let (c-last-identifier-range) + (forward-char) + (c-forward-syntactic-ws) + (catch 'is-function + (while + (progn + (if (eq (char-after) ?\)) + (throw 'is-function t)) + (setq cdd-got-type (c-forward-type)) + (cond + ((null cdd-got-type) + (throw 'is-function nil)) + ((not (eq cdd-got-type 'maybe)) + (throw 'is-function t))) + (c-forward-declarator nil t) + (eq (char-after) ?,)) + (forward-char) + (c-forward-syntactic-ws)) + t))))) + cdd-got-init (and (cadr (cddr cdd-decl-res)) + (char-after))) + + ;; Jump past any initializer or function prototype to see if + ;; there's a ',' to continue at. + (cond (cdd-got-func + ;; Skip a parenthesized initializer (C++) or a function + ;; prototype. + (if (c-go-list-forward (point) cdd-limit) ; over the parameter list. + (c-forward-syntactic-ws cdd-limit) + (setq cdd-exhausted t))) ; unbalanced parens + + (cdd-got-init ; "=" sign OR opening "(", "[", or "{" + ;; Skip an initializer expression. If we're at a '=' + ;; then accept a brace list directly after it to cope + ;; with array initializers. Otherwise stop at braces + ;; to avoid going past full function and class blocks. + (if (and (if (and (eq cdd-got-init ?=) + (= (c-forward-token-2 1 nil cdd-limit) 0) + (looking-at "{")) + (c-go-list-forward (point) cdd-limit) + t) + ;; FIXME: Should look for c-decl-end markers here; + ;; we might go far into the following declarations + ;; in e.g. ObjC mode (see e.g. methods-4.m). + (c-syntactic-re-search-forward "[;,{]" cdd-limit 'move t)) + (backward-char) + (setq cdd-exhausted t) + )) + + (t (c-forward-syntactic-ws cdd-limit))) + + (if cdd-function + (funcall cdd-function cdd-id-start cdd-id-end cdd-next-pos + cdd-not-top cdd-got-func cdd-got-init)) + + ;; If a ',' is found we set cdd-pos to the next declarator and iterate. + (if (and cdd-list (< (point) cdd-limit) (looking-at ",")) + (progn + (when cdd-comma-prop + (c-put-char-property (point) 'c-type cdd-comma-prop)) + (forward-char) + (c-forward-syntactic-ws cdd-limit) + (setq cdd-pos (point))) + (setq cdd-exhausted t))) + + (if (> (point) cdd-pos) + t + (goto-char cdd-pos) + nil))) + +;; Macro used inside `c-forward-decl-or-cast-1'. It ought to be a +;; defsubst or perhaps even a defun, but it contains lots of free +;; variables that refer to things inside `c-forward-decl-or-cast-1'. +(defmacro c-fdoc-shift-type-backward (&optional short) + ;; `c-forward-decl-or-cast-1' can consume an arbitrary length list + ;; of types when parsing a declaration, which means that it + ;; sometimes consumes the identifier in the declaration as a type. + ;; This is used to "backtrack" and make the last type be treated as + ;; an identifier instead. + `(progn + ,(unless short + ;; These identifiers are bound only in the inner let. + '(setq identifier-type at-type + identifier-start type-start + got-parens nil + got-identifier t + got-suffix t + got-suffix-after-parens id-start + paren-depth 0)) + + (if (setq at-type (if (eq backup-at-type 'prefix) + t + backup-at-type)) + (setq type-start backup-type-start + id-start backup-id-start) + (setq type-start start-pos + id-start start-pos)) + + ;; When these flags already are set we've found specifiers that + ;; unconditionally signal these attributes - backtracking doesn't + ;; change that. So keep them set in that case. + (or at-type-decl + (setq at-type-decl backup-at-type-decl)) + (or maybe-typeless + (setq maybe-typeless backup-maybe-typeless)) + + ,(unless short + ;; This identifier is bound only in the inner let. + '(setq start id-start)))) + (defun c-forward-decl-or-cast-1 (preceding-token-end context last-cast-end) ;; Move forward over a declaration or a cast if at the start of one. ;; The point is assumed to be at the start of some token. Nil is @@ -8348,7 +9346,10 @@ comment at the start of cc-engine.el for more info." ((and c-opt-cpp-prefix (looking-at c-noise-macro-with-parens-name-re)) (setq noise-start (point)) - (c-forward-noise-clause) + (while + (and + (c-forward-noise-clause) + (looking-at c-noise-macro-with-parens-name-re))) (setq kwd-clause-end (point)))) (when (setq found-type (c-forward-type t)) ; brace-block-too @@ -8550,7 +9551,7 @@ comment at the start of cc-engine.el for more info." ;; Skip over type decl prefix operators. (Note similar code in ;; `c-forward-declarator'.) (if (and c-recognize-typeless-decls - (equal c-type-decl-prefix-key "\\<\\>")) + (equal c-type-decl-prefix-key regexp-unmatchable)) (when (eq (char-after) ?\() (progn (setq paren-depth (1+ paren-depth)) @@ -8609,8 +9610,19 @@ comment at the start of cc-engine.el for more info." ;; construct here in C, since we want to recognize this as a ;; typeless function declaration. (not (and (c-major-mode-is 'c-mode) + (not got-prefix) (or (eq context 'top) make-top) - (eq (char-after) ?\))))) + (eq (char-after) ?\)) + after-paren-pos + (or (memq at-type '(nil maybe)) + (not got-identifier) + (save-excursion + (goto-char after-paren-pos) + (c-forward-syntactic-ws) + ;; Prevent the symbol being recorded as a type. + (let (c-record-type-identifiers) + (not (memq (c-forward-type) + '(nil maybe))))))))) (if (eq (char-after) ?\)) (when (> paren-depth 0) (setq paren-depth (1- paren-depth)) @@ -8638,31 +9650,39 @@ comment at the start of cc-engine.el for more info." ;; (con|de)structors in C++ and `c-typeless-decl-kwds' ;; style declarations. That isn't applicable in an ;; arglist context, though. - (when (and (= paren-depth 1) - (not got-prefix-before-parens) - (not (eq at-type t)) - (or backup-at-type - maybe-typeless - backup-maybe-typeless - (when c-recognize-typeless-decls - (and (memq context '(nil top)) - ;; Deal with C++11's "copy-initialization" - ;; where we have <type>(<constant>), by - ;; contrasting with a typeless - ;; <name>(<type><parameter>, ...). - (save-excursion - (goto-char after-paren-pos) - (c-forward-syntactic-ws) - (or (c-forward-type) - ;; Recognize a top-level typeless - ;; function declaration in C. - (and (c-major-mode-is 'c-mode) - (or (eq context 'top) make-top) - (eq (char-after) ?\)))))))) - (setq pos (c-up-list-forward (point))) - (eq (char-before pos) ?\))) + (when (and (> paren-depth 0) ; ensures `after-paren-pos' is non-nil + (not got-prefix-before-parens) + (not (eq at-type t)) + (or backup-at-type + maybe-typeless + backup-maybe-typeless + (when c-recognize-typeless-decls + (and (memq context '(nil top)) + ;; Deal with C++11's "copy-initialization" + ;; where we have <type>(<constant>), by + ;; contrasting with a typeless + ;; <name>(<type><parameter>, ...). + (save-excursion + (goto-char after-paren-pos) + (c-forward-syntactic-ws) + (or (c-forward-type) + ;; Recognize a top-level typeless + ;; function declaration in C. + (and (c-major-mode-is 'c-mode) + (or (eq context 'top) make-top) + (eq (char-after) ?\)))))))) + (let ((pd paren-depth)) + (setq pos (point)) + (catch 'pd + (while (> pd 0) + (setq pos (c-up-list-forward pos)) + (when (or (null pos) + (not (eq (char-before pos) ?\)))) + (throw 'pd nil)) + (goto-char pos) + (setq pd (1- pd))) + t))) (c-fdoc-shift-type-backward) - (goto-char pos) t))) (c-forward-syntactic-ws)) @@ -8713,7 +9733,7 @@ comment at the start of cc-engine.el for more info." (setq at-decl-end (looking-at (cond ((eq context '<>) "[,>]") - ((not (memq context '(nil top))) "[,\)]") + ((not (memq context '(nil top))) "[,)]") (t "[,;]")))) ;; Now we've collected info about various characteristics of @@ -9531,11 +10551,10 @@ comment at the start of cc-engine.el for more info." ;; back we should search. ;; ;; This function might do hidden buffer changes. - (c-with-syntax-table c++-template-syntax-table - (c-backward-token-2 0 t lim) - (while (and (or (looking-at c-symbol-start) - (looking-at "[<,]\\|::")) - (zerop (c-backward-token-2 1 t lim)))))) + (c-backward-token-2 0 t lim) + (while (and (or (looking-at c-symbol-start) + (looking-at "[<,]\\|::")) + (zerop (c-backward-token-2 1 t lim))))) (defun c-in-method-def-p () ;; Return nil if we aren't in a method definition, otherwise the @@ -9615,7 +10634,7 @@ comment at the start of cc-engine.el for more info." (let ((beg (point)) id-start) (and - (eq (c-beginning-of-statement-1 lim) 'same) + (eq (c-beginning-of-statement-1 lim nil nil nil t) 'same) (not (and (c-major-mode-is 'objc-mode) (c-forward-objc-directive))) @@ -9833,9 +10852,15 @@ comment at the start of cc-engine.el for more info." ;; This function might do hidden buffer changes. (save-excursion (and (zerop (c-backward-token-2 1 t lim)) + (if (looking-at c-block-stmt-hangon-key) + (zerop (c-backward-token-2 1 t lim)) + t) (or (looking-at c-block-stmt-1-key) (and (eq (char-after) ?\() (zerop (c-backward-token-2 1 t lim)) + (if (looking-at c-block-stmt-hangon-key) + (zerop (c-backward-token-2 1 t lim)) + t) (or (looking-at c-block-stmt-2-key) (looking-at c-block-stmt-1-2-key)))) (point)))) @@ -9905,11 +10930,10 @@ comment at the start of cc-engine.el for more info." (and (c-safe (c-backward-sexp) t) (looking-at c-opt-op-identifier-prefix))) (and (eq (char-before) ?<) - (c-with-syntax-table c++-template-syntax-table - (if (c-safe (goto-char (c-up-list-forward (point)))) - t - (goto-char (point-max)) - nil))))) + (if (c-safe (goto-char (c-up-list-forward (point)))) + t + (goto-char (point-max)) + nil)))) (setq base (point))) (while (and @@ -10002,28 +11026,25 @@ comment at the start of cc-engine.el for more info." ;; potentially can search over a large amount of text.). Take special ;; pains not to get mislead by C++'s "operator=", and the like. (if (and (eq move 'previous) - (c-with-syntax-table (if (c-major-mode-is 'c++-mode) - c++-template-syntax-table - (syntax-table)) - (save-excursion - (and - (progn - (while ; keep going back to "[;={"s until we either find - ; no more, or get to one which isn't an "operator =" - (and (c-syntactic-re-search-forward "[;={]" start t t t) - (eq (char-before) ?=) - c-overloadable-operators-regexp - c-opt-op-identifier-prefix - (save-excursion - (eq (c-backward-token-2) 0) - (looking-at c-overloadable-operators-regexp) - (eq (c-backward-token-2) 0) - (looking-at c-opt-op-identifier-prefix)))) - (eq (char-before) ?=)) - (c-syntactic-re-search-forward "[;{]" start t t) - (eq (char-before) ?{) - (c-safe (goto-char (c-up-list-forward (point))) t) - (not (c-syntactic-re-search-forward ";" start t t)))))) + (save-excursion + (and + (progn + (while ; keep going back to "[;={"s until we either find + ; no more, or get to one which isn't an "operator =" + (and (c-syntactic-re-search-forward "[;={]" start t t t) + (eq (char-before) ?=) + c-overloadable-operators-regexp + c-opt-op-identifier-prefix + (save-excursion + (eq (c-backward-token-2) 0) + (looking-at c-overloadable-operators-regexp) + (eq (c-backward-token-2) 0) + (looking-at c-opt-op-identifier-prefix)))) + (eq (char-before) ?=)) + (c-syntactic-re-search-forward "[;{]" start t t) + (eq (char-before) ?{) + (c-safe (goto-char (c-up-list-forward (point))) t) + (not (c-syntactic-re-search-forward ";" start t t))))) (cons 'same nil) (cons move nil))))) @@ -10038,10 +11059,7 @@ comment at the start of cc-engine.el for more info." ;; `c-end-of-macro' instead in those cases. ;; ;; This function might do hidden buffer changes. - (let ((start (point)) - (decl-syntax-table (if (c-major-mode-is 'c++-mode) - c++-template-syntax-table - (syntax-table)))) + (let ((start (point))) (catch 'return (c-search-decl-header-end) @@ -10062,34 +11080,32 @@ comment at the start of cc-engine.el for more info." (throw 'return nil))) (if (or (not c-opt-block-decls-with-vars-key) (save-excursion - (c-with-syntax-table decl-syntax-table - (let ((lim (point))) - (goto-char start) - (not (and - ;; Check for `c-opt-block-decls-with-vars-key' - ;; before the first paren. - (c-syntactic-re-search-forward - (concat "[;=([{]\\|\\(" - c-opt-block-decls-with-vars-key - "\\)") - lim t t t) - (match-beginning 1) - (not (eq (char-before) ?_)) - ;; Check that the first following paren is - ;; the block. - (c-syntactic-re-search-forward "[;=([{]" - lim t t t) - (eq (char-before) ?{))))))) + (let ((lim (point))) + (goto-char start) + (not (and + ;; Check for `c-opt-block-decls-with-vars-key' + ;; before the first paren. + (c-syntactic-re-search-forward + (concat "[;=([{]\\|\\(" + c-opt-block-decls-with-vars-key + "\\)") + lim t t t) + (match-beginning 1) + (not (eq (char-before) ?_)) + ;; Check that the first following paren is + ;; the block. + (c-syntactic-re-search-forward "[;=([{]" + lim t t t) + (eq (char-before) ?{)))))) ;; The declaration doesn't have any of the ;; `c-opt-block-decls-with-vars' keywords in the ;; beginning, so it ends here at the end of the block. (throw 'return t))) - (c-with-syntax-table decl-syntax-table - (while (progn - (if (eq (char-before) ?\;) - (throw 'return t)) - (c-syntactic-re-search-forward ";" nil 'move t)))) + (while (progn + (if (eq (char-before) ?\;) + (throw 'return t)) + (c-syntactic-re-search-forward ";" nil 'move t))) nil))) (defun c-looking-at-decl-block (_containing-sexp goto-start &optional limit) @@ -10169,7 +11185,7 @@ comment at the start of cc-engine.el for more info." ;; legal because it's part of a "compound keyword" like ;; "enum class". Of course, if c-after-brace-list-key ;; is nil, we can skip the test. - (or (equal c-after-brace-list-key "\\<\\>") + (or (equal c-after-brace-list-key regexp-unmatchable) (save-match-data (save-excursion (not @@ -10446,7 +11462,8 @@ comment at the start of cc-engine.el for more info." (eq (char-after) ?\()) (setq braceassignp 'c++-noassign in-paren 'in-paren)) - ((looking-at c-pre-id-bracelist-key)) + ((looking-at c-pre-id-bracelist-key) + (setq braceassignp nil)) ((looking-at c-return-key)) ((and (looking-at c-symbol-start) (not (looking-at c-keywords-regexp))) @@ -10488,6 +11505,8 @@ comment at the start of cc-engine.el for more info." (setq pos (point)) (cond + ((not braceassignp) + nil) ((and after-type-id-pos (goto-char after-type-id-pos) (setq res (c-back-over-member-initializers)) @@ -10520,6 +11539,10 @@ comment at the start of cc-engine.el for more info." ((and class-key (looking-at class-key)) (setq braceassignp nil)) + ((and c-has-compound-literals + (looking-at c-return-key)) + (setq braceassignp t) + nil) ((eq (char-after) ?=) ;; We've seen a =, but must check earlier tokens so ;; that it isn't something that should be ignored. @@ -10558,9 +11581,20 @@ comment at the start of cc-engine.el for more info." )))) nil) (t t)))))) - (if (and (eq braceassignp 'dontknow) - (/= (c-backward-token-2 1 t lim) 0)) - (setq braceassignp nil))) + (when (eq braceassignp 'dontknow) + (cond ((and + (not (eq (char-after) ?,)) + (save-excursion + (c-backward-syntactic-ws) + (eq (char-before) ?}))) + (setq braceassignp nil)) + ((/= (c-backward-token-2 1 t lim) 0) + (if (save-excursion + (and c-has-compound-literals + (eq (c-backward-token-2 1 nil lim) 0) + (eq (char-after) ?\())) + (setq braceassignp t) + (setq braceassignp nil)))))) (cond (braceassignp @@ -10592,9 +11626,14 @@ comment at the start of cc-engine.el for more info." (and (consp res) (eq (car res) after-type-id-pos)))))) (cons bufpos (or in-paren inexpr-brace-list))) - ((eq (char-after) ?\;) - ;; Brace lists can't contain a semicolon, so we're done. - ;; (setq containing-sexp nil) + ((or (eq (char-after) ?\;) + ;; Brace lists can't contain a semicolon, so we're done. + (save-excursion + (c-backward-syntactic-ws) + (eq (char-before) ?})) + ;; They also can't contain a bare }, which is probably the end + ;; of a function. + ) nil) ((and (setq macro-start (point)) (c-forward-to-cpp-define-body) @@ -10616,12 +11655,17 @@ comment at the start of cc-engine.el for more info." ))) (defun c-inside-bracelist-p (containing-sexp paren-state accept-in-paren) - ;; return the buffer position of the beginning of the brace list - ;; statement if we're inside a brace list, otherwise return nil. - ;; CONTAINING-SEXP is the buffer pos of the innermost containing - ;; paren. PAREN-STATE is the remainder of the state of enclosing - ;; braces. ACCEPT-IN-PAREN is non-nil iff we will accept as a brace - ;; list a brace directly enclosed in a parenthesis. + ;; return the buffer position of the beginning of the brace list statement + ;; if CONTAINING-SEXP is inside a brace list, otherwise return nil. + ;; + ;; CONTAINING-SEXP is the buffer pos of the innermost containing paren. NO + ;; IT ISN'T!!! [This function is badly designed, and probably needs + ;; reformulating without its first argument, and the critical position being + ;; at point.] + ;; + ;; PAREN-STATE is the remainder of the state of enclosing braces. + ;; ACCEPT-IN-PAREN is non-nil iff we will accept as a brace list a brace + ;; directly enclosed in a parenthesis. ;; ;; The "brace list" here is recognized solely by its context, not by ;; its contents. @@ -10635,7 +11679,8 @@ comment at the start of cc-engine.el for more info." ;; This will pick up brace list declarations. (save-excursion (goto-char containing-sexp) - (c-backward-over-enum-header)) + (and (c-backward-over-enum-header) + (point))) ;; this will pick up array/aggregate init lists, even if they are nested. (save-excursion (let ((bufpos t) @@ -10740,7 +11785,8 @@ comment at the start of cc-engine.el for more info." (defun c-looking-at-statement-block () ;; Point is at an opening brace. If this is a statement block (i.e. the ;; elements in the block are terminated by semicolons, or the block is - ;; empty, or the block contains a keyword) return t. Otherwise, return nil. + ;; empty, or the block contains a keyword) return non-nil. Otherwise, + ;; return nil. (let ((here (point))) (prog1 (if (c-go-list-forward) @@ -10925,7 +11971,7 @@ comment at the start of cc-engine.el for more info." (c-on-identifier))) (and c-special-brace-lists (c-looking-at-special-brace-list)) - (and (c-major-mode-is 'c++-mode) + (and c-has-compound-literals (save-excursion (goto-char block-follows) (not (c-looking-at-statement-block))))) @@ -11244,7 +12290,7 @@ comment at the start of cc-engine.el for more info." (if (and (eq step-type 'same) (/= paren-pos (point))) - (let (inexpr) + (let (inexpr bspec) (cond ((save-excursion (goto-char paren-pos) @@ -11260,14 +12306,19 @@ comment at the start of cc-engine.el for more info." (cdr (assoc (match-string 1) c-other-decl-block-key-in-symbols-alist)) (max (c-point 'boi paren-pos) (point)))) - ((save-excursion - (goto-char paren-pos) - (c-looking-at-or-maybe-in-bracelist containing-sexp)) + ((c-inside-bracelist-p paren-pos paren-state nil) (if (save-excursion (goto-char paren-pos) (c-looking-at-statement-block)) (c-add-syntax 'defun-block-intro nil) (c-add-syntax 'brace-list-intro nil))) + ((save-excursion + (goto-char paren-pos) + (setq bspec (c-looking-at-or-maybe-in-bracelist + containing-sexp containing-sexp)) + (and (consp bspec) + (eq (cdr bspec) 'in-paren))) + (c-add-syntax 'brace-list-intro (car bspec))) (t (c-add-syntax 'defun-block-intro nil)))) (c-add-syntax 'statement-block-intro nil))) @@ -11354,10 +12405,9 @@ comment at the start of cc-engine.el for more info." ;; CASE B.2: brace-list-open ((or (consp special-brace-list) - (consp - (c-looking-at-or-maybe-in-bracelist - containing-sexp beg-of-same-or-containing-stmt)) - ) + (c-inside-bracelist-p (point) + (cons containing-sexp paren-state) + nil)) ;; The most semantically accurate symbol here is ;; brace-list-open, but we normally report it simply as a ;; statement-cont. The reason is that one normally adjusts @@ -11468,17 +12518,15 @@ comment at the start of cc-engine.el for more info." ((and (c-major-mode-is 'c++-mode) (save-excursion (goto-char indent-point) - (c-with-syntax-table c++-template-syntax-table - (setq placeholder (c-up-list-backward))) + (setq placeholder (c-up-list-backward)) (and placeholder (eq (char-after placeholder) ?<) (/= (char-before placeholder) ?<) (progn (goto-char (1+ placeholder)) (not (looking-at c-<-op-cont-regexp)))))) - (c-with-syntax-table c++-template-syntax-table - (goto-char placeholder) - (c-beginning-of-statement-1 containing-sexp t)) + (goto-char placeholder) + (c-beginning-of-statement-1 containing-sexp t) (if (save-excursion (c-backward-syntactic-ws containing-sexp) (eq (char-before) ?<)) @@ -11543,7 +12591,7 @@ comment at the start of cc-engine.el for more info." ;; There's always at most one syntactic element which got ;; an anchor pos. It's stored in syntactic-relpos. syntactic-relpos - (c-stmt-delim-chars c-stmt-delim-chars)) + (c-commas-bound-stmts c-commas-bound-stmts)) ;; Check if we're directly inside an enclosing declaration ;; level block. @@ -11595,7 +12643,7 @@ comment at the start of cc-engine.el for more info." ;; arglists. (when (and containing-sexp (eq (char-after containing-sexp) ?\()) - (setq c-stmt-delim-chars c-stmt-delim-chars-with-comma)) + (setq c-commas-bound-stmts t)) ;; cache char before and after indent point, and move point to ;; the most likely position to perform the majority of tests (goto-char indent-point) @@ -12138,21 +13186,38 @@ comment at the start of cc-engine.el for more info." ;; NB: No c-after-special-operator-id stuff in this ;; clause - we assume only C++ needs it. (c-syntactic-skip-backward "^;,=" lim t)) + (setq placeholder (point)) (memq (char-before) '(?, ?= ?<))) (cond + ;; CASE 5D.6: Something like C++11's "using foo = <type-exp>" + ((save-excursion + (and (eq (char-before placeholder) ?=) + (goto-char placeholder) + (eq (c-backward-token-2 1 nil lim) 0) + (eq (point) (1- placeholder)) + (eq (c-beginning-of-statement-1 lim) 'same) + (looking-at c-equals-type-clause-key) + (let ((preserve-point (point))) + (when + (and + (eq (c-forward-token-2 1 nil nil) 0) + (c-on-identifier)) + (setq placeholder preserve-point))))) + (c-add-syntax + 'statement-cont placeholder) + ) + ;; CASE 5D.3: perhaps a template list continuation? ((and (c-major-mode-is 'c++-mode) (save-excursion (save-restriction - (c-with-syntax-table c++-template-syntax-table - (goto-char indent-point) - (setq placeholder (c-up-list-backward)) - (and placeholder - (eq (char-after placeholder) ?<)))))) - (c-with-syntax-table c++-template-syntax-table - (goto-char placeholder) - (c-beginning-of-statement-1 lim t)) + (goto-char indent-point) + (setq placeholder (c-up-list-backward)) + (and placeholder + (eq (char-after placeholder) ?<))))) + (goto-char placeholder) + (c-beginning-of-statement-1 lim t) (if (save-excursion (c-backward-syntactic-ws lim) (eq (char-before) ?<)) @@ -12176,8 +13241,14 @@ comment at the start of cc-engine.el for more info." (and (looking-at c-class-key) (zerop (c-forward-token-2 2 nil indent-point)) (if (eq (char-after) ?<) - (c-with-syntax-table c++-template-syntax-table - (zerop (c-forward-token-2 1 t indent-point))) + (zerop (c-forward-token-2 1 t indent-point)) + t) + (progn + (while + (and + (< (point) indent-point) + (looking-at c-class-id-suffix-ws-ids-key) + (zerop (c-forward-token-2 1 nil indent-point)))) t) (eq (char-after) ?:)))) (goto-char placeholder) @@ -12284,7 +13355,18 @@ comment at the start of cc-engine.el for more info." ;; The '}' is unbalanced. nil (c-end-of-decl-1) - (>= (point) indent-point)))))) + (>= (point) indent-point)))) + ;; Check that we only have one brace block here, i.e. that we + ;; don't have something like a function with a struct + ;; declaration as its type. + (save-excursion + (or (not (and state-cache (consp (car state-cache)))) + ;; The above probably can't happen. + (progn + (goto-char placeholder) + (and (c-syntactic-re-search-forward + "{" indent-point t) + (eq (1- (point)) (caar state-cache)))))))) (goto-char placeholder) (c-add-stmt-syntax 'topmost-intro-cont nil nil containing-sexp paren-state)) @@ -12432,6 +13514,11 @@ comment at the start of cc-engine.el for more info." ;; in-expression block or brace list. C.f. cases 4, 16A ;; and 17E. ((and (eq char-after-ip ?{) + (or (not (eq (char-after containing-sexp) ?\()) + (save-excursion + (and c-opt-inexpr-brace-list-key + (eq (c-beginning-of-statement-1 lim t nil t) 'same) + (looking-at c-opt-inexpr-brace-list-key)))) (progn (setq placeholder (c-inside-bracelist-p (point) paren-state @@ -12606,23 +13693,30 @@ comment at the start of cc-engine.el for more info." (= (point) containing-sexp))) (if (eq (point) (c-point 'boi)) (c-add-syntax 'brace-list-close (point)) - (setq lim (c-most-enclosing-brace state-cache (point))) + (setq lim (or (save-excursion + (and + (c-back-over-member-initializers) + (point))) + (c-most-enclosing-brace state-cache (point)))) (c-beginning-of-statement-1 lim nil nil t) (c-add-stmt-syntax 'brace-list-close nil t lim paren-state))) (t - ;; Prepare for the rest of the cases below by going to the - ;; token following the opening brace - (if (consp special-brace-list) - (progn - (goto-char (car (car special-brace-list))) - (c-forward-token-2 1 nil indent-point)) - (goto-char containing-sexp)) - (forward-char) - (let ((start (point))) - (c-forward-syntactic-ws indent-point) - (goto-char (max start (c-point 'bol)))) - (c-skip-ws-forward indent-point) + ;; Prepare for the rest of the cases below by going back to the + ;; previous entry, or BOI before that, providing that this is + ;; inside the enclosing brace. + (goto-char indent-point) + (c-beginning-of-statement-1 containing-sexp nil nil t) + (when (/= (point) indent-point) + (if (> (c-point 'boi) containing-sexp) + (goto-char (c-point 'boi)) + (if (consp special-brace-list) + (progn + (goto-char (caar special-brace-list)) + (c-forward-token-2 1 nil indent-point)) + (goto-char containing-sexp)) + (forward-char) + (c-skip-ws-forward indent-point))) (cond ;; CASE 9C: we're looking at the first line in a brace-list @@ -12632,8 +13726,12 @@ comment at the start of cc-engine.el for more info." (goto-char containing-sexp)) (if (eq (point) (c-point 'boi)) (c-add-syntax 'brace-list-intro (point)) - (setq lim (c-most-enclosing-brace state-cache (point))) - (c-beginning-of-statement-1 lim) + (setq lim (or (save-excursion + (and + (c-back-over-member-initializers) + (point))) + (c-most-enclosing-brace state-cache (point)))) + (c-beginning-of-statement-1 lim nil nil t) (c-add-stmt-syntax 'brace-list-intro nil t lim paren-state))) ;; CASE 9D: this is just a later brace-list-entry or @@ -13092,7 +14190,7 @@ Cannot combine absolute offsets %S and %S in `add' method" nil)))) (if (or (null res) (integerp res) - (and (vectorp res) (= (length res) 1) (integerp (aref res 0)))) + (and (vectorp res) (>= (length res) 1) (integerp (aref res 0)))) res (c-benign-error "Error evaluating offset %S for %s: Got invalid value %S" offset symbol res) @@ -13115,12 +14213,11 @@ Cannot combine absolute offsets %S and %S in `add' method" (if c-strict-syntax-p (c-benign-error "No offset found for syntactic symbol %s" symbol)) (setq offset 0)) - (if (vectorp offset) - offset - (or (and (numberp offset) offset) - (and (symbolp offset) (symbol-value offset)) - 0)) - )) + (cond + ((or (vectorp offset) (numberp offset)) + offset) + ((and (symbolp offset) (symbol-value offset))) + (t 0)))) (defun c-get-offset (langelem) ;; This is a compatibility wrapper for `c-calc-offset' in case @@ -13177,6 +14274,18 @@ Cannot combine absolute offsets %S and %S in `add' method" indent))) +(def-edebug-spec c-bos-pop-state t) +(def-edebug-spec c-bos-save-error-info t) +(def-edebug-spec c-state-cache-top-lparen t) +(def-edebug-spec c-state-cache-top-paren t) +(def-edebug-spec c-state-cache-after-top-paren t) +(def-edebug-spec c-state-maybe-marker (form symbolp)) +(def-edebug-spec c-record-type-id t) +(def-edebug-spec c-record-ref-id t) +(def-edebug-spec c-forward-keyword-prefixed-id t) +(def-edebug-spec c-forward-id-comma-list t) +(def-edebug-spec c-pull-open-brace (symbolp)) + (cc-provide 'cc-engine) ;; Local Variables: diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index b4ebecf56e4..f58caf2f1ae 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -488,6 +488,9 @@ ; (eval-after-load "edebug" ; 2006-07-09: def-edebug-spec is now in subr.el. ; '(progn +(def-edebug-spec c-put-font-lock-face t) +(def-edebug-spec c-remove-font-lock-face t) +(def-edebug-spec c-put-font-lock-string-face t) (def-edebug-spec c-fontify-types-and-refs let*) (def-edebug-spec c-make-syntactic-matcher t) ;; If there are literal quoted or backquoted highlight specs in @@ -669,7 +672,7 @@ stuff. Used on level 1 and higher." ,@(when (c-major-mode-is 'pike-mode) ;; Recognize hashbangs in Pike. - `((eval . (list "\\`#![^\n\r]*" + '((eval . (list "\\`#![^\n\r]*" 0 c-preprocessor-face-name)))) ;; Make hard spaces visible through an inverted `font-lock-warning-face'. @@ -682,33 +685,6 @@ stuff. Used on level 1 and higher." ''c-nonbreakable-space-face))) )) -(defun c-font-lock-invalid-string () - ;; Assuming the point is after the opening character of a string, - ;; fontify that char with `font-lock-warning-face' if the string - ;; decidedly isn't terminated properly. - ;; - ;; This function does hidden buffer changes. - (let ((start (1- (point)))) - (save-excursion - (and (eq (elt (parse-partial-sexp start (c-point 'eol)) 8) start) - (if (if (eval-when-compile (integerp ?c)) - ;; Emacs - (integerp c-multiline-string-start-char) - ;; XEmacs - (characterp c-multiline-string-start-char)) - ;; There's no multiline string start char before the - ;; string, so newlines aren't allowed. - (not (eq (char-before start) c-multiline-string-start-char)) - ;; Multiline strings are allowed anywhere if - ;; c-multiline-string-start-char is t. - (not c-multiline-string-start-char)) - (if c-string-escaped-newlines - ;; There's no \ before the newline. - (not (eq (char-before (point)) ?\\)) - ;; Escaped newlines aren't supported. - t) - (c-put-font-lock-face start (1+ start) 'font-lock-warning-face))))) - (defun c-font-lock-invalid-single-quotes (limit) ;; This function will be called from font-lock for a region bounded by POINT ;; and LIMIT, as though it were to identify a keyword for @@ -749,16 +725,12 @@ casts and declarations are fontified. Used on level 2 and higher." ;; `c-recognize-<>-arglists' is set. t `(;; Put a warning face on the opener of unclosed strings that - ;; can't span lines. Later font + ;; can't span lines and on the "terminating" newlines. Later font ;; lock packages have a `font-lock-syntactic-face-function' for ;; this, but it doesn't give the control we want since any ;; fontification done inside the function will be ;; unconditionally overridden. - ,(c-make-font-lock-search-function - ;; Match a char before the string starter to make - ;; `c-skip-comments-and-strings' work correctly. - (concat ".\\(" c-string-limit-regexp "\\)") - '((c-font-lock-invalid-string))) + ("\\s|" 0 font-lock-warning-face t nil) ;; Invalid single quotes. c-font-lock-invalid-single-quotes @@ -908,48 +880,51 @@ casts and declarations are fontified. Used on level 2 and higher." (when (bobp) (c-clear-found-types)) - ;; Clear the c-type char properties which mark the region, to recalculate - ;; them properly. The most interesting properties are those put on the - ;; closest token before the region. - (save-excursion - (let ((pos (point))) - (c-backward-syntactic-ws) - (c-clear-char-properties - (if (and (not (bobp)) - (memq (c-get-char-property (1- (point)) 'c-type) - '(c-decl-arg-start - c-decl-end - c-decl-id-start - c-decl-type-start))) - (1- (point)) - pos) - limit 'c-type))) - - ;; Update `c-state-cache' to the beginning of the region. This will - ;; make `c-beginning-of-syntax' go faster when it's used later on, - ;; and it's near the point most of the time. - (c-parse-state) - - ;; Check if the fontified region starts inside a declarator list so - ;; that `c-font-lock-declarators' should be called at the start. - ;; The declared identifiers are font-locked correctly as types, if - ;; that is what they are. - (let ((prop (save-excursion - (c-backward-syntactic-ws) - (unless (bobp) - (c-get-char-property (1- (point)) 'c-type))))) - (when (memq prop '(c-decl-id-start c-decl-type-start)) - (c-forward-syntactic-ws limit) - (c-font-lock-declarators limit t (eq prop 'c-decl-type-start) - (not (c-bs-at-toplevel-p (point)))))) - - (setq c-font-lock-context ;; (c-guess-font-lock-context) - (save-excursion - (if (and c-cpp-expr-intro-re - (c-beginning-of-macro) - (looking-at c-cpp-expr-intro-re)) - 'in-cpp-expr))) - nil) + (c-skip-comments-and-strings limit) + (when (< (point) limit) + + ;; Clear the c-type char properties which mark the region, to recalculate + ;; them properly. The most interesting properties are those put on the + ;; closest token before the region. + (save-excursion + (let ((pos (point))) + (c-backward-syntactic-ws) + (c-clear-char-properties + (if (and (not (bobp)) + (memq (c-get-char-property (1- (point)) 'c-type) + '(c-decl-arg-start + c-decl-end + c-decl-id-start + c-decl-type-start))) + (1- (point)) + pos) + limit 'c-type))) + + ;; Update `c-state-cache' to the beginning of the region. This will + ;; make `c-beginning-of-syntax' go faster when it's used later on, + ;; and it's near the point most of the time. + (c-parse-state) + + ;; Check if the fontified region starts inside a declarator list so + ;; that `c-font-lock-declarators' should be called at the start. + ;; The declared identifiers are font-locked correctly as types, if + ;; that is what they are. + (let ((prop (save-excursion + (c-backward-syntactic-ws) + (unless (bobp) + (c-get-char-property (1- (point)) 'c-type))))) + (when (memq prop '(c-decl-id-start c-decl-type-start)) + (c-forward-syntactic-ws limit) + (c-font-lock-declarators limit t (eq prop 'c-decl-type-start) + (not (c-bs-at-toplevel-p (point)))))) + + (setq c-font-lock-context ;; (c-guess-font-lock-context) + (save-excursion + (if (and c-cpp-expr-intro-re + (c-beginning-of-macro) + (looking-at c-cpp-expr-intro-re)) + 'in-cpp-expr))) + nil)) (defun c-font-lock-<>-arglists (limit) ;; This function will be called from font-lock for a region bounded by POINT @@ -964,73 +939,76 @@ casts and declarations are fontified. Used on level 2 and higher." ;; ;; This function might do hidden buffer changes. - (let (;; The font-lock package in Emacs is known to clobber - ;; `parse-sexp-lookup-properties' (when it exists). - (parse-sexp-lookup-properties - (cc-eval-when-compile - (boundp 'parse-sexp-lookup-properties))) - (c-parse-and-markup-<>-arglists t) - c-restricted-<>-arglists - id-start id-end id-face pos kwd-sym) + (c-skip-comments-and-strings limit) + (when (< (point) limit) - (while (and (< (point) limit) - (re-search-forward c-opt-<>-arglist-start limit t)) + (let (;; The font-lock package in Emacs is known to clobber + ;; `parse-sexp-lookup-properties' (when it exists). + (parse-sexp-lookup-properties + (cc-eval-when-compile + (boundp 'parse-sexp-lookup-properties))) + (c-parse-and-markup-<>-arglists t) + c-restricted-<>-arglists + id-start id-end id-face pos kwd-sym) - (setq id-start (match-beginning 1) - id-end (match-end 1) - pos (point)) + (while (and (< (point) limit) + (re-search-forward c-opt-<>-arglist-start limit t)) - (goto-char id-start) - (unless (c-skip-comments-and-strings limit) - (setq kwd-sym nil - c-restricted-<>-arglists nil - id-face (get-text-property id-start 'face)) - - (if (cond - ((eq id-face 'font-lock-type-face) - ;; The identifier got the type face so it has already been - ;; handled in `c-font-lock-declarations'. - nil) - - ((eq id-face 'font-lock-keyword-face) - (when (looking-at c-opt-<>-sexp-key) - ;; There's a special keyword before the "<" that tells - ;; that it's an angle bracket arglist. - (setq kwd-sym (c-keyword-sym (match-string 1))))) - - (t - ;; There's a normal identifier before the "<". If we're not in - ;; a declaration context then we set `c-restricted-<>-arglists' - ;; to avoid recognizing templates in function calls like "foo (a - ;; < b, c > d)". - (c-backward-syntactic-ws) - (when (and (memq (char-before) '(?\( ?,)) - (not (eq (get-text-property (1- (point)) 'c-type) - 'c-decl-arg-start))) - (setq c-restricted-<>-arglists t)) - t)) + (setq id-start (match-beginning 1) + id-end (match-end 1) + pos (point)) - (progn - (goto-char (1- pos)) - ;; Check for comment/string both at the identifier and - ;; at the "<". - (unless (c-skip-comments-and-strings limit) - - (c-fontify-types-and-refs () - (when (c-forward-<>-arglist (c-keyword-member - kwd-sym 'c-<>-type-kwds)) - (when (and c-opt-identifier-concat-key - (not (get-text-property id-start 'face))) - (c-forward-syntactic-ws) - (cond ((looking-at c-opt-identifier-concat-key) - (c-put-font-lock-face id-start id-end - c-reference-face-name)) - ((eq (char-after) ?\()) - (t (c-put-font-lock-face id-start id-end - 'font-lock-type-face)))))) - - (goto-char pos))) - (goto-char pos))))) + (goto-char id-start) + (unless (c-skip-comments-and-strings limit) + (setq kwd-sym nil + c-restricted-<>-arglists nil + id-face (get-text-property id-start 'face)) + + (if (cond + ((eq id-face 'font-lock-type-face) + ;; The identifier got the type face so it has already been + ;; handled in `c-font-lock-declarations'. + nil) + + ((eq id-face 'font-lock-keyword-face) + (when (looking-at c-opt-<>-sexp-key) + ;; There's a special keyword before the "<" that tells + ;; that it's an angle bracket arglist. + (setq kwd-sym (c-keyword-sym (match-string 1))))) + + (t + ;; There's a normal identifier before the "<". If we're not in + ;; a declaration context then we set `c-restricted-<>-arglists' + ;; to avoid recognizing templates in function calls like "foo (a + ;; < b, c > d)". + (c-backward-syntactic-ws) + (when (and (memq (char-before) '(?\( ?,)) + (not (eq (get-text-property (1- (point)) 'c-type) + 'c-decl-arg-start))) + (setq c-restricted-<>-arglists t)) + t)) + + (progn + (goto-char (1- pos)) + ;; Check for comment/string both at the identifier and + ;; at the "<". + (unless (c-skip-comments-and-strings limit) + + (c-fontify-types-and-refs () + (when (c-forward-<>-arglist (c-keyword-member + kwd-sym 'c-<>-type-kwds)) + (when (and c-opt-identifier-concat-key + (not (get-text-property id-start 'face))) + (c-forward-syntactic-ws) + (cond ((looking-at c-opt-identifier-concat-key) + (c-put-font-lock-face id-start id-end + c-reference-face-name)) + ((eq (char-after) ?\()) + (t (c-put-font-lock-face id-start id-end + 'font-lock-type-face)))))) + + (goto-char pos))) + (goto-char pos)))))) nil) (defun c-font-lock-declarators (limit list types not-top @@ -1060,114 +1038,41 @@ casts and declarations are fontified. Used on level 2 and higher." ;;(message "c-font-lock-declarators from %s to %s" (point) limit) (c-fontify-types-and-refs - ((pos (point)) next-pos id-start - decl-res - id-face got-type got-init - c-last-identifier-range - (separator-prop (if types 'c-decl-type-start 'c-decl-id-start))) - - ;; The following `while' fontifies a single declarator id each time round. - ;; It loops only when LIST is non-nil. - (while - (and pos (setq decl-res (c-forward-declarator))) - (setq next-pos (point) - id-start (car decl-res) - id-face (if (and (eq (char-after) ?\() - (or (not (c-major-mode-is 'c++-mode)) - (not not-top) - (car (cddr (cddr decl-res))) ; Id is in - ; parens, etc. - (save-excursion - (forward-char) - (c-forward-syntactic-ws) - (looking-at "[*&]"))) - (not (car (cddr decl-res))) - (or (not (c-major-mode-is 'c++-mode)) - (save-excursion - (let (c-last-identifier-range) - (forward-char) - (c-forward-syntactic-ws) - (catch 'is-function - (while - (progn - (if (eq (char-after) ?\)) - (throw 'is-function t)) - (setq got-type (c-forward-type)) - (cond - ((null got-type) - (throw 'is-function nil)) - ((not (eq got-type 'maybe)) - (throw 'is-function t))) - (c-forward-declarator nil t) - (eq (char-after) ?,)) - (forward-char) - (c-forward-syntactic-ws)) - t))))) - 'font-lock-function-name-face - 'font-lock-variable-name-face) - got-init (and (cadr (cddr decl-res)) ; got-init - (char-after))) - - (if types - ;; Register and fontify the identifier as a type. - (let ((c-promote-possible-types t)) - (goto-char id-start) - (c-forward-type)) - ;; Fontify the last symbol in the identifier if it isn't fontified - ;; already. The check is necessary only in certain cases where this - ;; function is used "sloppily", e.g. in `c-simple-decl-matchers'. - (when (and c-last-identifier-range - (not (get-text-property (car c-last-identifier-range) - 'face))) - (c-put-font-lock-face (car c-last-identifier-range) - (cdr c-last-identifier-range) - id-face))) - - (goto-char next-pos) - (setq pos nil) ; So as to terminate the enclosing `while' form. - (if (and template-class - (eq got-init ?=) ; C++ "<class X = Y>"? - (c-forward-token-2 1 nil limit) ; Over "=" - (let ((c-promote-possible-types t)) - (c-forward-type t))) ; Over "Y" - (setq list nil)) ; Shouldn't be needed. We can't have a list, here. - - (when list - ;; Jump past any initializer or function prototype to see if - ;; there's a ',' to continue at. - (cond ((eq id-face 'font-lock-function-name-face) - ;; Skip a parenthesized initializer (C++) or a function - ;; prototype. - (if (c-safe (c-forward-sexp 1) t) ; over the parameter list. - (c-forward-syntactic-ws limit) - (goto-char limit))) ; unbalanced parens - - (got-init ; "=" sign OR opening "(", "[", or "{" - ;; Skip an initializer expression. If we're at a '=' - ;; then accept a brace list directly after it to cope - ;; with array initializers. Otherwise stop at braces - ;; to avoid going past full function and class blocks. - (and (if (and (eq got-init ?=) - (= (c-forward-token-2 1 nil limit) 0) - (looking-at "{")) - (c-safe (c-forward-sexp) t) ; over { .... } - t) - (< (point) limit) - ;; FIXME: Should look for c-decl-end markers here; - ;; we might go far into the following declarations - ;; in e.g. ObjC mode (see e.g. methods-4.m). - (c-syntactic-re-search-forward "[;,{]" limit 'move t) - (backward-char))) - - (t (c-forward-syntactic-ws limit))) - - ;; If a ',' is found we set pos to the next declarator and iterate. - (when (and (< (point) limit) (looking-at ",")) - (c-put-char-property (point) 'c-type separator-prop) - (forward-char) - (c-forward-syntactic-ws limit) - (setq pos (point)))))) ; acts to make the `while' form continue. - nil) + () + (c-do-declarators + limit list not-top + (if types 'c-decl-type-start 'c-decl-id-start) + (lambda (id-start _id-end end-pos _not-top is-function init-char) + (if types + ;; Register and fontify the identifier as a type. + (let ((c-promote-possible-types t)) + (goto-char id-start) + (c-forward-type)) + ;; The following doesn't work properly (yet, 2018-09-22). + ;; (c-put-font-lock-face id-start id-end + ;; (if is-function + ;; 'font-lock-function-name-face + ;; 'font-lock-variable-name-face)) + (when (and c-last-identifier-range + (not (get-text-property (car c-last-identifier-range) + 'face))) + ;; We use `c-last-identifier-range' rather than `id-start' and + ;; `id-end', since the latter two can be erroneous. E.g. in + ;; "~Foo", `id-start' is at the tilde. This is a bug in + ;; `c-forward-declarator'. + (c-put-font-lock-face (car c-last-identifier-range) + (cdr c-last-identifier-range) + (if is-function + 'font-lock-function-name-face + 'font-lock-variable-name-face)))) + (and template-class + (eq init-char ?=) ; C++ "<class X = Y>"? + (progn + (goto-char end-pos) + (c-forward-token-2 1 nil limit) ; Over "=" + (let ((c-promote-possible-types t)) + (c-forward-type t)))))) + nil)) (defun c-get-fontification-context (match-pos not-front-decl &optional toplev) ;; Return a cons (CONTEXT . RESTRICTED-<>-ARGLISTS) for MATCH-POS. @@ -1234,10 +1139,9 @@ casts and declarations are fontified. Used on level 2 and higher." (cons 'decl nil)) ;; We're inside a brace list. ((and (eq (char-before match-pos) ?{) - (save-excursion - (goto-char (1- match-pos)) - (consp - (c-looking-at-or-maybe-in-bracelist)))) + (c-inside-bracelist-p (1- match-pos) + (cdr (c-parse-state)) + nil)) (c-put-char-property (1- match-pos) 'c-type 'c-not-decl) (cons 'not-decl nil)) @@ -1300,7 +1204,9 @@ casts and declarations are fontified. Used on level 2 and higher." ((save-excursion (goto-char match-pos) (and (memq (char-before match-pos) '(?\( ?\,)) - (c-go-up-list-backward match-pos) + (c-go-up-list-backward match-pos + ; c-determine-limit is too slow, here. + (max (- (point) 2000) (point-min))) (eq (char-after) ?\() (let ((type (c-get-char-property (point) 'c-type))) (or (memq type '(c-decl-arg-start c-decl-type-start)) @@ -1413,227 +1319,229 @@ casts and declarations are fontified. Used on level 2 and higher." ;; This function might do hidden buffer changes. ;;(message "c-font-lock-declarations search from %s to %s" (point) limit) + (c-skip-comments-and-strings limit) + (when (< (point) limit) + + (save-restriction + (let (;; The position where `c-find-decl-spots' last stopped. + start-pos + ;; o - 'decl if we're in an arglist containing declarations + ;; (but if `c-recognize-paren-inits' is set it might also be + ;; an initializer arglist); + ;; o - '<> if the arglist is of angle bracket type; + ;; o - 'arglist if it's some other arglist; + ;; o - nil, if not in an arglist at all. This includes the + ;; parenthesized condition which follows "if", "while", etc. + context + ;; A list of starting positions of possible type declarations, or of + ;; the typedef preceding one, if any. + last-cast-end + ;; The result from `c-forward-decl-or-cast-1'. + decl-or-cast + ;; The maximum of the end positions of all the checked type + ;; decl expressions in the successfully identified + ;; declarations. The position might be either before or + ;; after the syntactic whitespace following the last token + ;; in the type decl expression. + (max-type-decl-end 0) + ;; Same as `max-type-decl-*', but used when we're before + ;; `token-pos'. + (max-type-decl-end-before-token 0) + ;; End of <..> construct which has had c-<>-arg-sep c-type + ;; properties set within it. + (max-<>-end 0) + ;; Set according to the context to direct the heuristics for + ;; recognizing C++ templates. + c-restricted-<>-arglists + ;; Turn on recording of identifier ranges in + ;; `c-forward-decl-or-cast-1' and `c-forward-label' for + ;; later fontification. + (c-record-type-identifiers t) + label-type + c-record-ref-identifiers + ;; Make `c-forward-type' calls mark up template arglists if + ;; it finds any. That's necessary so that we later will + ;; stop inside them to fontify types there. + (c-parse-and-markup-<>-arglists t) + ;; The font-lock package in Emacs is known to clobber + ;; `parse-sexp-lookup-properties' (when it exists). + (parse-sexp-lookup-properties + (cc-eval-when-compile + (boundp 'parse-sexp-lookup-properties)) + )) + + ;; Below we fontify a whole declaration even when it crosses the limit, + ;; to avoid gaps when jit/lazy-lock fontifies the file a block at a + ;; time. That is however annoying during editing, e.g. the following is + ;; a common situation while the first line is being written: + ;; + ;; my_variable + ;; some_other_variable = 0; + ;; + ;; font-lock will put the limit at the beginning of the second line + ;; here, and if we go past it we'll fontify "my_variable" as a type and + ;; "some_other_variable" as an identifier, and the latter will not + ;; correct itself until the second line is changed. To avoid that we + ;; narrow to the limit if the region to fontify is a single line. + (if (<= limit (c-point 'bonl)) + (narrow-to-region + (point-min) + (save-excursion + ;; Narrow after any operator chars following the limit though, + ;; since those characters can be useful in recognizing a + ;; declaration (in particular the '{' that opens a function body + ;; after the header). + (goto-char limit) + (skip-chars-forward c-nonsymbol-chars) + (point)))) + + (c-find-decl-spots + limit + c-decl-start-re + (eval c-maybe-decl-faces) + + (lambda (match-pos inside-macro &optional toplev) + ;; Note to maintainers: don't use `limit' inside this lambda form; + ;; c-find-decl-spots sometimes narrows to less than `limit'. + (setq start-pos (point)) + (when + ;; The result of the form below is true when we don't recognize a + ;; declaration or cast, and we don't recognize a "non-decl", + ;; typically a brace list. + (if (or (and (eq (get-text-property (point) 'face) + 'font-lock-keyword-face) + (looking-at c-not-decl-init-keywords)) + (and c-macro-with-semi-re + (looking-at c-macro-with-semi-re))) ; 2008-11-04 + ;; Don't do anything more if we're looking at a keyword that + ;; can't start a declaration. + t + + ;; Set `context' and `c-restricted-<>-arglists'. Look for + ;; "<" for the sake of C++-style template arglists. + ;; Ignore "(" when it's part of a control flow construct + ;; (e.g. "for ("). + (let ((got-context + (c-get-fontification-context + match-pos + (< match-pos (if inside-macro + max-type-decl-end-before-token + max-type-decl-end)) + toplev))) + (setq context (car got-context) + c-restricted-<>-arglists (cdr got-context))) + + ;; Check we haven't missed a preceding "typedef". + (when (not (looking-at c-typedef-key)) + (c-backward-syntactic-ws) + (c-backward-token-2) + (or (looking-at c-typedef-key) + (goto-char start-pos))) + + ;; In QT, "more" is an irritating keyword that expands to nothing. + ;; We skip over it to prevent recognition of "more slots: <symbol>" + ;; as a bitfield declaration. + (when (and (c-major-mode-is 'c++-mode) + (looking-at + (concat "\\(more\\)\\([^" c-symbol-chars "]\\|$\\)"))) + (goto-char (match-end 1)) + (c-forward-syntactic-ws)) - (save-restriction - (let (;; The position where `c-find-decl-spots' last stopped. - start-pos - ;; o - 'decl if we're in an arglist containing declarations - ;; (but if `c-recognize-paren-inits' is set it might also be - ;; an initializer arglist); - ;; o - '<> if the arglist is of angle bracket type; - ;; o - 'arglist if it's some other arglist; - ;; o - nil, if not in an arglist at all. This includes the - ;; parenthesized condition which follows "if", "while", etc. - context - ;; A list of starting positions of possible type declarations, or of - ;; the typedef preceding one, if any. - last-cast-end - ;; The result from `c-forward-decl-or-cast-1'. - decl-or-cast - ;; The maximum of the end positions of all the checked type - ;; decl expressions in the successfully identified - ;; declarations. The position might be either before or - ;; after the syntactic whitespace following the last token - ;; in the type decl expression. - (max-type-decl-end 0) - ;; Same as `max-type-decl-*', but used when we're before - ;; `token-pos'. - (max-type-decl-end-before-token 0) - ;; End of <..> construct which has had c-<>-arg-sep c-type - ;; properties set within it. - (max-<>-end 0) - ;; Set according to the context to direct the heuristics for - ;; recognizing C++ templates. - c-restricted-<>-arglists - ;; Turn on recording of identifier ranges in - ;; `c-forward-decl-or-cast-1' and `c-forward-label' for - ;; later fontification. - (c-record-type-identifiers t) - label-type - c-record-ref-identifiers - ;; Make `c-forward-type' calls mark up template arglists if - ;; it finds any. That's necessary so that we later will - ;; stop inside them to fontify types there. - (c-parse-and-markup-<>-arglists t) - ;; The font-lock package in Emacs is known to clobber - ;; `parse-sexp-lookup-properties' (when it exists). - (parse-sexp-lookup-properties - (cc-eval-when-compile - (boundp 'parse-sexp-lookup-properties)) - )) - - ;; Below we fontify a whole declaration even when it crosses the limit, - ;; to avoid gaps when jit/lazy-lock fontifies the file a block at a - ;; time. That is however annoying during editing, e.g. the following is - ;; a common situation while the first line is being written: - ;; - ;; my_variable - ;; some_other_variable = 0; - ;; - ;; font-lock will put the limit at the beginning of the second line - ;; here, and if we go past it we'll fontify "my_variable" as a type and - ;; "some_other_variable" as an identifier, and the latter will not - ;; correct itself until the second line is changed. To avoid that we - ;; narrow to the limit if the region to fontify is a single line. - (if (<= limit (c-point 'bonl)) - (narrow-to-region - (point-min) - (save-excursion - ;; Narrow after any operator chars following the limit though, - ;; since those characters can be useful in recognizing a - ;; declaration (in particular the '{' that opens a function body - ;; after the header). - (goto-char limit) - (skip-chars-forward c-nonsymbol-chars) - (point)))) - - (c-find-decl-spots - limit - c-decl-start-re - (eval c-maybe-decl-faces) - - (lambda (match-pos inside-macro &optional toplev) - ;; Note to maintainers: don't use `limit' inside this lambda form; - ;; c-find-decl-spots sometimes narrows to less than `limit'. - (setq start-pos (point)) - (when - ;; The result of the form below is true when we don't recognize a - ;; declaration or cast, and we don't recognize a "non-decl", - ;; typically a brace list. - (if (or (and (eq (get-text-property (point) 'face) - 'font-lock-keyword-face) - (looking-at c-not-decl-init-keywords)) - (and c-macro-with-semi-re - (looking-at c-macro-with-semi-re))) ; 2008-11-04 - ;; Don't do anything more if we're looking at a keyword that - ;; can't start a declaration. - t - - ;; Set `context' and `c-restricted-<>-arglists'. Look for - ;; "<" for the sake of C++-style template arglists. - ;; Ignore "(" when it's part of a control flow construct - ;; (e.g. "for ("). - (let ((got-context - (c-get-fontification-context - match-pos - (< match-pos (if inside-macro - max-type-decl-end-before-token - max-type-decl-end)) - toplev))) - (setq context (car got-context) - c-restricted-<>-arglists (cdr got-context))) - - ;; Check we haven't missed a preceding "typedef". - (when (not (looking-at c-typedef-key)) - (c-backward-syntactic-ws) - (c-backward-token-2) - (or (looking-at c-typedef-key) - (goto-char start-pos))) - - ;; In QT, "more" is an irritating keyword that expands to nothing. - ;; We skip over it to prevent recognition of "more slots: <symbol>" - ;; as a bitfield declaration. - (when (and (c-major-mode-is 'c++-mode) - (looking-at - (concat "\\(more\\)\\([^" c-symbol-chars "]\\|$\\)"))) - (goto-char (match-end 1)) - (c-forward-syntactic-ws)) - - ;; Now analyze the construct. - (if (eq context 'not-decl) - (progn - (setq decl-or-cast nil) - (if (c-syntactic-re-search-forward - "," (min limit (point-max)) 'at-limit t) - (c-put-char-property (1- (point)) 'c-type 'c-not-decl)) - nil) - (setq decl-or-cast - (c-forward-decl-or-cast-1 - match-pos context last-cast-end)) - - ;; Ensure that c-<>-arg-sep c-type properties are in place on the - ;; commas separating the arguments inside template/generic <..>s. - (when (and (eq (char-before match-pos) ?<) - (> match-pos max-<>-end)) - (save-excursion - (goto-char match-pos) - (c-backward-token-2) - (if (and - (eq (char-after) ?<) - (let ((c-restricted-<>-arglists - (save-excursion - (c-backward-token-2) - (and - (not (looking-at c-opt-<>-sexp-key)) - (progn (c-backward-syntactic-ws) - (memq (char-before) '(?\( ?,))) - (not (eq (c-get-char-property (1- (point)) - 'c-type) - 'c-decl-arg-start)))))) - (c-forward-<>-arglist nil))) - (setq max-<>-end (point))))) - - (cond - ((eq decl-or-cast 'cast) - ;; Save the position after the previous cast so we can feed - ;; it to `c-forward-decl-or-cast-1' in the next round. That - ;; helps it discover cast chains like "(a) (b) c". - (setq last-cast-end (point)) - (c-fontify-recorded-types-and-refs) - nil) - - (decl-or-cast - ;; We've found a declaration. - - ;; Set `max-type-decl-end' or `max-type-decl-end-before-token' - ;; under the assumption that we're after the first type decl - ;; expression in the declaration now. That's not really true; - ;; we could also be after a parenthesized initializer - ;; expression in C++, but this is only used as a last resort - ;; to slant ambiguous expression/declarations, and overall - ;; it's worth the risk to occasionally fontify an expression - ;; as a declaration in an initializer expression compared to - ;; getting ambiguous things in normal function prototypes - ;; fontified as expressions. - (if inside-macro - (when (> (point) max-type-decl-end-before-token) - (setq max-type-decl-end-before-token (point))) - (when (> (point) max-type-decl-end) - (setq max-type-decl-end (point)))) - (goto-char start-pos) - (c-font-lock-single-decl limit decl-or-cast match-pos - context - (or toplev (nth 4 decl-or-cast)))) - - (t t)))) - - ;; It was a false alarm. Check if we're in a label (or other - ;; construct with `:' except bitfield) instead. - (goto-char start-pos) - (when (setq label-type (c-forward-label t match-pos nil)) - ;; Can't use `c-fontify-types-and-refs' here since we - ;; use the label face at times. - (cond ((eq label-type 'goto-target) - (c-put-font-lock-face (caar c-record-ref-identifiers) - (cdar c-record-ref-identifiers) - c-label-face-name)) - ((eq label-type 'qt-1kwd-colon) - (c-put-font-lock-face (caar c-record-ref-identifiers) - (cdar c-record-ref-identifiers) - 'font-lock-keyword-face)) - ((eq label-type 'qt-2kwds-colon) - (mapc - (lambda (kwd) - (c-put-font-lock-face (car kwd) (cdr kwd) + ;; Now analyze the construct. + (if (eq context 'not-decl) + (progn + (setq decl-or-cast nil) + (if (c-syntactic-re-search-forward + "," (min limit (point-max)) 'at-limit t) + (c-put-char-property (1- (point)) 'c-type 'c-not-decl)) + nil) + (setq decl-or-cast + (c-forward-decl-or-cast-1 + match-pos context last-cast-end)) + + ;; Ensure that c-<>-arg-sep c-type properties are in place on the + ;; commas separating the arguments inside template/generic <..>s. + (when (and (eq (char-before match-pos) ?<) + (> match-pos max-<>-end)) + (save-excursion + (goto-char match-pos) + (c-backward-token-2) + (if (and + (eq (char-after) ?<) + (let ((c-restricted-<>-arglists + (save-excursion + (c-backward-token-2) + (and + (not (looking-at c-opt-<>-sexp-key)) + (progn (c-backward-syntactic-ws) + (memq (char-before) '(?\( ?,))) + (not (eq (c-get-char-property (1- (point)) + 'c-type) + 'c-decl-arg-start)))))) + (c-forward-<>-arglist nil))) + (setq max-<>-end (point))))) + + (cond + ((eq decl-or-cast 'cast) + ;; Save the position after the previous cast so we can feed + ;; it to `c-forward-decl-or-cast-1' in the next round. That + ;; helps it discover cast chains like "(a) (b) c". + (setq last-cast-end (point)) + (c-fontify-recorded-types-and-refs) + nil) + + (decl-or-cast + ;; We've found a declaration. + + ;; Set `max-type-decl-end' or `max-type-decl-end-before-token' + ;; under the assumption that we're after the first type decl + ;; expression in the declaration now. That's not really true; + ;; we could also be after a parenthesized initializer + ;; expression in C++, but this is only used as a last resort + ;; to slant ambiguous expression/declarations, and overall + ;; it's worth the risk to occasionally fontify an expression + ;; as a declaration in an initializer expression compared to + ;; getting ambiguous things in normal function prototypes + ;; fontified as expressions. + (if inside-macro + (when (> (point) max-type-decl-end-before-token) + (setq max-type-decl-end-before-token (point))) + (when (> (point) max-type-decl-end) + (setq max-type-decl-end (point)))) + (goto-char start-pos) + (c-font-lock-single-decl limit decl-or-cast match-pos + context + (or toplev (nth 4 decl-or-cast)))) + + (t t)))) + + ;; It was a false alarm. Check if we're in a label (or other + ;; construct with `:' except bitfield) instead. + (goto-char start-pos) + (when (setq label-type (c-forward-label t match-pos nil)) + ;; Can't use `c-fontify-types-and-refs' here since we + ;; use the label face at times. + (cond ((eq label-type 'goto-target) + (c-put-font-lock-face (caar c-record-ref-identifiers) + (cdar c-record-ref-identifiers) + c-label-face-name)) + ((eq label-type 'qt-1kwd-colon) + (c-put-font-lock-face (caar c-record-ref-identifiers) + (cdar c-record-ref-identifiers) 'font-lock-keyword-face)) - c-record-ref-identifiers))) - (setq c-record-ref-identifiers nil) - ;; `c-forward-label' has probably added a `c-decl-end' - ;; marker, so return t to `c-find-decl-spots' to signal - ;; that. - t)))) - - nil))) + ((eq label-type 'qt-2kwds-colon) + (mapc + (lambda (kwd) + (c-put-font-lock-face (car kwd) (cdr kwd) + 'font-lock-keyword-face)) + c-record-ref-identifiers))) + (setq c-record-ref-identifiers nil) + ;; `c-forward-label' has probably added a `c-decl-end' + ;; marker, so return t to `c-find-decl-spots' to signal + ;; that. + t)))) + + nil)))) (defun c-font-lock-enum-body (limit) ;; Fontify the identifiers of each enum we find by searching forward. @@ -1643,7 +1551,8 @@ casts and declarations are fontified. Used on level 2 and higher." ;; font-lock-keyword-face. It always returns NIL to inhibit this and ;; prevent a repeat invocation. See elisp/lispref page "Search-based ;; Fontification". - (while (search-forward-regexp c-enum-clause-introduction-re limit t) + (while (and (< (point) limit) + (search-forward-regexp c-enum-clause-introduction-re limit t)) (when (save-excursion (backward-char) (c-backward-over-enum-header)) @@ -1663,19 +1572,21 @@ casts and declarations are fontified. Used on level 2 and higher." ;; ;; Note that this function won't attempt to fontify beyond the end of the ;; current enum block, if any. - (let* ((paren-state (c-parse-state)) - (encl-pos (c-most-enclosing-brace paren-state))) - (when (and - encl-pos - (eq (char-after encl-pos) ?\{) - (save-excursion - (goto-char encl-pos) - (c-backward-over-enum-header))) - (c-syntactic-skip-backward "^{," nil t) - (c-put-char-property (1- (point)) 'c-type 'c-decl-id-start) + (c-skip-comments-and-strings limit) + (when (< (point) limit) + (let* ((paren-state (c-parse-state)) + (encl-pos (c-most-enclosing-brace paren-state))) + (when (and + encl-pos + (eq (char-after encl-pos) ?\{) + (save-excursion + (goto-char encl-pos) + (c-backward-over-enum-header))) + (c-syntactic-skip-backward "^{," nil t) + (c-put-char-property (1- (point)) 'c-type 'c-decl-id-start) - (c-forward-syntactic-ws) - (c-font-lock-declarators limit t nil t))) + (c-forward-syntactic-ws) + (c-font-lock-declarators limit t nil t)))) nil) (defun c-font-lock-cut-off-declarators (limit) @@ -1687,46 +1598,50 @@ casts and declarations are fontified. Used on level 2 and higher." ;; font-lock-keyword-face. It always returns NIL to inhibit this and ;; prevent a repeat invocation. See elisp/lispref page "Search-based ;; fontification". - (let ((here (point)) - (decl-search-lim (c-determine-limit 1000)) - paren-state encl-pos token-end context decl-or-cast - start-pos top-level c-restricted-<>-arglists - c-recognize-knr-p) ; Strictly speaking, bogus, but it + (c-skip-comments-and-strings limit) + (when (< (point) limit) + (let ((here (point)) + (decl-search-lim (c-determine-limit 1000)) + paren-state encl-pos token-end context decl-or-cast + start-pos top-level c-restricted-<>-arglists + c-recognize-knr-p) ; Strictly speaking, bogus, but it ; speeds up lisp.h tremendously. - (save-excursion - (when (not (c-back-over-member-initializers)) - (unless (or (eobp) - (looking-at "\\s(\\|\\s)")) - (forward-char)) - (c-syntactic-skip-backward "^;{}" decl-search-lim t) - (when (eq (char-before) ?}) - (c-go-list-backward) ; brace block of struct, etc.? - (c-syntactic-skip-backward "^;{}" decl-search-lim t)) - (when (or (bobp) - (memq (char-before) '(?\; ?{ ?}))) - (setq token-end (point)) - (c-forward-syntactic-ws here) - (when (< (point) here) - ;; We're now putatively at the declaration. - (setq start-pos (point)) - (setq paren-state (c-parse-state)) - ;; At top level or inside a "{"? - (if (or (not (setq encl-pos - (c-most-enclosing-brace paren-state))) - (eq (char-after encl-pos) ?\{)) - (progn - (setq top-level (c-at-toplevel-p)) - (let ((got-context (c-get-fontification-context - token-end nil top-level))) - (setq context (car got-context) - c-restricted-<>-arglists (cdr got-context))) - (setq decl-or-cast - (c-forward-decl-or-cast-1 token-end context nil)) - (when (consp decl-or-cast) - (goto-char start-pos) - (c-font-lock-single-decl limit decl-or-cast token-end - context top-level)))))))) - nil)) + (save-excursion + (when (not (c-back-over-member-initializers + (max (- (point) 2000) (point-min)))) ; c-determine-limit + ; is too slow, here. + (unless (or (eobp) + (looking-at "\\s(\\|\\s)")) + (forward-char)) + (c-syntactic-skip-backward "^;{}" decl-search-lim t) + (when (eq (char-before) ?}) + (c-go-list-backward) ; brace block of struct, etc.? + (c-syntactic-skip-backward "^;{}" decl-search-lim t)) + (when (or (bobp) + (memq (char-before) '(?\; ?{ ?}))) + (setq token-end (point)) + (c-forward-syntactic-ws here) + (when (< (point) here) + ;; We're now putatively at the declaration. + (setq start-pos (point)) + (setq paren-state (c-parse-state)) + ;; At top level or inside a "{"? + (if (or (not (setq encl-pos + (c-most-enclosing-brace paren-state))) + (eq (char-after encl-pos) ?\{)) + (progn + (setq top-level (c-at-toplevel-p)) + (let ((got-context (c-get-fontification-context + token-end nil top-level))) + (setq context (car got-context) + c-restricted-<>-arglists (cdr got-context))) + (setq decl-or-cast + (c-forward-decl-or-cast-1 token-end context nil)) + (when (consp decl-or-cast) + (goto-char start-pos) + (c-font-lock-single-decl limit decl-or-cast token-end + context top-level)))))))) + nil))) (defun c-font-lock-enclosing-decls (limit) ;; Fontify the declarators of (nested) declarations we're in the middle of. @@ -1738,27 +1653,29 @@ casts and declarations are fontified. Used on level 2 and higher." ;; font-lock-keyword-face. It always returns NIL to inhibit this and ;; prevent a repeat invocation. See elisp/lispref page "Search-based ;; Fontification". - (let* ((paren-state (c-parse-state)) - (decl-search-lim (c-determine-limit 1000)) - in-typedef ps-elt) - ;; Are we in any nested struct/union/class/etc. braces? - (while paren-state - (setq ps-elt (car paren-state) - paren-state (cdr paren-state)) - (when (and (atom ps-elt) - (eq (char-after ps-elt) ?\{)) - (goto-char ps-elt) - (c-syntactic-skip-backward "^;{}" decl-search-lim) - (c-forward-syntactic-ws) - (setq in-typedef (looking-at c-typedef-key)) - (if in-typedef (c-forward-over-token-and-ws)) - (when (and c-opt-block-decls-with-vars-key - (looking-at c-opt-block-decls-with-vars-key)) + (c-skip-comments-and-strings limit) + (when (< (point) limit) + (let* ((paren-state (c-parse-state)) + (decl-search-lim (c-determine-limit 1000)) + in-typedef ps-elt) + ;; Are we in any nested struct/union/class/etc. braces? + (while paren-state + (setq ps-elt (car paren-state) + paren-state (cdr paren-state)) + (when (and (atom ps-elt) + (eq (char-after ps-elt) ?\{)) (goto-char ps-elt) - (when (c-safe (c-forward-sexp)) - (c-forward-syntactic-ws) - (c-font-lock-declarators limit t in-typedef - (not (c-bs-at-toplevel-p (point)))))))))) + (c-syntactic-skip-backward "^;{}" decl-search-lim) + (c-forward-syntactic-ws) + (setq in-typedef (looking-at c-typedef-key)) + (if in-typedef (c-forward-over-token-and-ws)) + (when (and c-opt-block-decls-with-vars-key + (looking-at c-opt-block-decls-with-vars-key)) + (goto-char ps-elt) + (when (c-safe (c-forward-sexp)) + (c-forward-syntactic-ws) + (c-font-lock-declarators limit t in-typedef + (not (c-bs-at-toplevel-p (point))))))))))) (defun c-font-lock-raw-strings (limit) ;; Fontify C++ raw strings. @@ -1768,33 +1685,41 @@ casts and declarations are fontified. Used on level 2 and higher." ;; font-lock-keyword-face. It always returns NIL to inhibit this and ;; prevent a repeat invocation. See elisp/lispref page "Search-based ;; Fontification". - (let* ((state (c-state-semi-pp-to-literal (point))) + (let* ((state (c-semi-pp-to-literal (point))) (string-start (and (eq (cadr state) 'string) (car (cddr state)))) (raw-id (and string-start - (save-excursion - (goto-char string-start) - (and (eq (char-before) ?R) - (looking-at "\"\\([^ ()\\\n\r\t]\\{0,16\\}\\)(") - (match-string-no-properties 1)))))) + (c-at-c++-raw-string-opener string-start) + (match-string-no-properties 1))) + (content-start (and raw-id (point)))) + ;; We go round the next loop twice per raw string, once for each "end". (while (< (point) limit) (if raw-id + ;; Search for the raw string end delimiter (progn - (if (search-forward-regexp (concat ")\\(" (regexp-quote raw-id) "\\)\"") - limit 'limit) - (c-put-font-lock-face (match-beginning 1) (point) 'default)) + (when (search-forward-regexp (concat ")\\(" (regexp-quote raw-id) "\\)\"") + limit 'limit) + (c-put-font-lock-face content-start (match-beginning 1) + 'font-lock-string-face) + (c-remove-font-lock-face (match-beginning 1) (point))) (setq raw-id nil)) - + ;; Search for the start of a raw string. (when (search-forward-regexp "R\\(\"\\)\\([^ ()\\\n\r\t]\\{0,16\\}\\)(" limit 'limit) (when - (or (and (eobp) - (eq (c-get-char-property (1- (point)) 'face) - 'font-lock-warning-face)) - (eq (c-get-char-property (point) 'face) 'font-lock-string-face) - (and (equal (c-get-char-property (match-end 2) 'syntax-table) '(1)) - (equal (c-get-char-property (match-beginning 1) 'syntax-table) - '(1)))) + ;; Make sure we're not in a comment or string. + (and + (not (memq (c-get-char-property (match-beginning 0) 'face) + '(font-lock-comment-face font-lock-comment-delimiter-face + font-lock-string-face))) + (or (and (eobp) + (eq (c-get-char-property (1- (point)) 'face) + 'font-lock-warning-face)) + (not (eq (c-get-char-property (point) 'face) 'font-lock-comment-face)) + ;; (eq (c-get-char-property (point) 'face) 'font-lock-string-face) + (and (equal (c-get-char-property (match-end 2) 'syntax-table) '(1)) + (equal (c-get-char-property (match-beginning 1) 'syntax-table) + '(1))))) (let ((paren-prop (c-get-char-property (1- (point)) 'syntax-table))) (if paren-prop (progn @@ -1805,8 +1730,9 @@ casts and declarations are fontified. Used on level 2 and higher." (equal paren-prop '(15)) (not (c-search-forward-char-property 'syntax-table '(15) limit))) (goto-char limit))) - (c-put-font-lock-face (match-beginning 1) (match-end 2) 'default) - (setq raw-id (match-string-no-properties 2))))))))) + (c-remove-font-lock-face (match-beginning 0) (match-end 2)) + (setq raw-id (match-string-no-properties 2)) + (setq content-start (match-end 0))))))))) nil) (defun c-font-lock-c++-lambda-captures (limit) @@ -1968,7 +1894,7 @@ on level 2 only and so aren't combined with `c-complex-decl-matchers'." ;; Fontify generic colon labels in languages that support them. ,@(when (c-lang-const c-recognize-colon-labels) - `(c-font-lock-labels)))) + '(c-font-lock-labels)))) (c-lang-defconst c-complex-decl-matchers "Complex font lock matchers for types and declarations. Used on level @@ -2014,10 +1940,10 @@ on level 2 only and so aren't combined with `c-complex-decl-matchers'." ;; Fontify angle bracket arglists like templates in C++. ,@(when (c-lang-const c-recognize-<>-arglists) - `(c-font-lock-<>-arglists)) + '(c-font-lock-<>-arglists)) ,@(when (c-major-mode-is 'c++-mode) - `(c-font-lock-c++-lambda-captures)) + '(c-font-lock-c++-lambda-captures)) ;; The first two rules here mostly find occurrences that ;; `c-font-lock-declarations' has found already, but not @@ -2039,7 +1965,7 @@ on level 2 only and so aren't combined with `c-complex-decl-matchers'." ,@(when (c-major-mode-is 'c++-mode) ;; This pattern is a probably a "(MATCHER . ANCHORED-HIGHLIGHTER)" ;; (see Elisp page "Search-based Fontification"). - `(("\\<new\\>" + '(("\\<new\\>" (c-font-lock-c++-new)))) )) @@ -2107,10 +2033,10 @@ higher." t `(,@(when (c-lang-const c-brace-list-decl-kwds) ;; Fontify the remaining identifiers inside an enum list when we start ;; inside it. - `(c-font-lock-enum-tail - ;; Fontify the identifiers inside enum lists. (The enum type - ;; name is handled by `c-simple-decl-matchers' or - ;; `c-complex-decl-matchers' below. + '(c-font-lock-enum-tail + ;; Fontify the identifiers inside enum lists. (The enum type + ;; name is handled by `c-simple-decl-matchers' or + ;; `c-complex-decl-matchers' below. c-font-lock-enum-body)) ;; Fontify labels after goto etc. @@ -2161,7 +2087,7 @@ higher." (if (> (point) limit) (goto-char limit)))))))) ,@(when (c-major-mode-is 'java-mode) - `((eval . (list "\\<\\(@[a-zA-Z0-9]+\\)\\>" 1 c-annotation-face)))) + '((eval . (list "\\<\\(@[a-zA-Z0-9]+\\)\\>" 1 c-annotation-face)))) )) (c-lang-defconst c-matchers-1 @@ -2179,6 +2105,14 @@ higher." (c-lang-const c-complex-decl-matchers) (c-lang-const c-basic-matchers-after))) +(defun c-get-doc-comment-style () + ;; Get the symbol (or list of symbols) constituting the document style. + ;; Return nil if there is no such, otherwise something like `autodoc'. + (if (consp (car-safe c-doc-comment-style)) + (cdr-safe (or (assq c-buffer-is-cc-mode c-doc-comment-style) + (assq 'other c-doc-comment-style))) + c-doc-comment-style)) + (defun c-compose-keywords-list (base-list) ;; Incorporate the font lock keyword lists according to ;; `c-doc-comment-style' on the given keyword list and return it. @@ -2189,11 +2123,7 @@ higher." (unless (memq c-doc-face-name c-literal-faces) (setq c-literal-faces (cons c-doc-face-name c-literal-faces))) - (let* ((doc-keywords - (if (consp (car-safe c-doc-comment-style)) - (cdr-safe (or (assq c-buffer-is-cc-mode c-doc-comment-style) - (assq 'other c-doc-comment-style))) - c-doc-comment-style)) + (let* ((doc-keywords (c-get-doc-comment-style)) (list (nconc (c--mapcan (lambda (doc-style) (let ((sym (intern @@ -2642,15 +2572,88 @@ need for `pike-font-lock-extra-types'.") "Default expressions to highlight in Pike mode.") (defun pike-font-lock-keywords-2 () + (c-set-doc-comment-res) (c-compose-keywords-list pike-font-lock-keywords-2)) (defun pike-font-lock-keywords-3 () + (c-set-doc-comment-res) (c-compose-keywords-list pike-font-lock-keywords-3)) (defun pike-font-lock-keywords () + (c-set-doc-comment-res) (c-compose-keywords-list pike-font-lock-keywords)) ;;; Doc comments. +(cc-bytecomp-defvar c-doc-line-join-re) +;; matches a join of two lines in a doc comment. +;; This should not be changed directly, but instead set by +;; `c-setup-doc-comment-style'. This variable is used in `c-find-decl-spots' +;; in (e.g.) autodoc style comments to bridge the gap between a "@\n" at an +;; EOL and the token following "//!" on the next line. + +(cc-bytecomp-defvar c-doc-bright-comment-start-re) +;; Matches the start of a "bright" comment, one whose contents may be +;; fontified by, e.g., `c-font-lock-declarations'. + +(cc-bytecomp-defvar c-doc-line-join-end-ch) +;; A list of characters, each being a last character of a doc comment marker, +;; e.g. the ! from pike autodoc's "//!". + +(defmacro c-set-doc-comment-re-element (suffix) + ;; Set the variable `c-doc-line-join-re' to a buffer local value suitable + ;; for the current doc comment style, or kill the local value. + (let ((var (intern (concat "c-doc" suffix)))) + `(let* ((styles (c-get-doc-comment-style)) + elts) + (when (atom styles) + (setq styles (list styles))) + (setq elts + (mapcar (lambda (style) + (let ((sym + (intern-soft + (concat (symbol-name style) ,suffix)))) + (and sym + (boundp sym) + (symbol-value sym)))) + styles)) + (setq elts (delq nil elts)) + (setq elts (and elts + (concat "\\(" + (mapconcat #'identity elts "\\|") + "\\)"))) + (if elts + (set (make-local-variable ',var) elts) + (kill-local-variable ',var))))) + +(defmacro c-set-doc-comment-char-list (suffix) + ;; Set the variable 'c-doc-<suffix>' to the list of *-<suffix>, which must + ;; be characters, and * represents the doc comment style. + (let ((var (intern (concat "c-doc" suffix)))) + `(let* ((styles (c-get-doc-comment-style)) + elts) + (when (atom styles) + (setq styles (list styles))) + (setq elts + (mapcar (lambda (style) + (let ((sym + (intern-soft + (concat (symbol-name style) ,suffix)))) + (and sym + (boundp sym) + (symbol-value sym)))) + styles)) + (setq elts (delq nil elts)) + (if elts + (set (make-local-variable ',var) elts) + (kill-local-variable ',var))))) + +(defun c-set-doc-comment-res () + ;; Set the variables `c-doc-line-join-re' and + ;; `c-doc-bright-comment-start-re' from the current doc comment style(s). + (c-set-doc-comment-re-element "-line-join-re") + (c-set-doc-comment-re-element "-bright-comment-start-re") + (c-set-doc-comment-char-list "-line-join-end-ch")) + (defun c-font-lock-doc-comments (prefix limit keywords) ;; Fontify the comments between the point and LIMIT whose start ;; matches PREFIX with `c-doc-face-name'. Assumes comments have been @@ -2711,17 +2714,20 @@ need for `pike-font-lock-extra-types'.") (goto-char comment-beg) (while (and (progn (c-forward-single-comment) + (c-put-font-lock-face comment-beg (point) + c-doc-face-name) (skip-syntax-forward " ") + (setq comment-beg (point)) (< (point) limit)) (looking-at prefix)))) (goto-char comment-beg) - (c-forward-single-comment)) + (c-forward-single-comment) + (c-put-font-lock-face comment-beg (point) c-doc-face-name)) (if (> (point) limit) (goto-char limit)) (setq comment-beg nil) (let ((region-end (point)) (keylist keywords) keyword matcher highlights) - (c-put-font-lock-face region-beg region-end c-doc-face-name) (save-restriction ;; Narrow to the doc comment. Among other things, this ;; helps by making "^" match at the start of the comment. @@ -2771,7 +2777,7 @@ need for `pike-font-lock-extra-types'.") (copy-marker (1+ start)))) t))) -;; GtkDoc patterns contributed by Masatake YAMATO <jet@gyve.org>. +;; GtkDoc patterns contributed by Masatake YAMATO <yamato@redhat.com>. (defconst gtkdoc-font-lock-doc-comments (let ((symbol "[a-zA-Z0-9_]+") @@ -2792,7 +2798,7 @@ need for `pike-font-lock-extra-types'.") (defconst gtkdoc-font-lock-keywords `((,(lambda (limit) - (c-font-lock-doc-comments "/\\*\\*$" limit + (c-font-lock-doc-comments "/\\*\\*\\([^*/\n\r].*\\)?$" limit gtkdoc-font-lock-doc-comments) (c-font-lock-doc-comments "/\\*< " limit gtkdoc-font-lock-doc-protection) @@ -2849,7 +2855,8 @@ need for `pike-font-lock-extra-types'.") "\\)\\)\\s *\\)@[A-Za-z_-]+\\(\\s \\|$\\)")) (markup-faces (list c-doc-markup-face-name c-doc-face-name))) - (while (re-search-forward line-re limit t) + (while (and (< (point) limit) + (re-search-forward line-re limit t)) (goto-char (match-end 1)) (if (looking-at autodoc-decl-keywords) @@ -2928,6 +2935,13 @@ need for `pike-font-lock-extra-types'.") 0 'font-lock-warning-face prepend nil) )) +(defconst autodoc-line-join-re "@[\n\r][ \t]*/[/*]!") +;; Matches a line continuation in autodoc comment style. +(defconst autodoc-bright-comment-start-re "/[/*]!") +;; Matches an autodoc comment opener. +(defconst autodoc-line-join-end-ch ?!) +;; The final character of `autodoc-line-join-re'. + (defun autodoc-font-lock-keywords () ;; Note that we depend on that `c-current-comment-prefix' has got ;; its proper value here. diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index e45440b5bfd..f3dd0c6c4c9 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -205,12 +205,13 @@ the evaluated constant value at compile time." ; ' (def-edebug-spec c-lang-defvar (&define name def-form &optional &or ("quote" symbolp) stringp)) +(def-edebug-spec c-lang-setvar (&define name def-form)) ;; Suppress "might not be defined at runtime" warning. ;; This file is only used when compiling other cc files. -;; These are defined in cl as aliases to the cl- versions. -;(declare-function delete-duplicates "cl-seq" (cl-seq &rest cl-keys) t) -;(declare-function mapcan "cl-extra" (cl-func cl-seq &rest cl-rest) t) +(declare-function cl-delete-duplicates "cl-seq" (cl-seq &rest cl-keys)) +(declare-function cl-intersection "cl-seq" (cl-list1 cl-list2 &rest cl-keys)) +(declare-function cl-set-difference "cl-seq" (cl-list1 cl-list2 &rest cl-keys)) (eval-and-compile ;; Some helper functions used when building the language constants. @@ -292,7 +293,7 @@ the evaluated constant value at compile time." ["Forward Statement" c-end-of-statement t] ,@(when (c-lang-const c-opt-cpp-prefix) ;; Only applicable if there's a cpp preprocessor. - `(["Up Conditional" c-up-conditional t] + '(["Up Conditional" c-up-conditional t] ["Backward Conditional" c-backward-conditional t] ["Forward Conditional" c-forward-conditional t] "----" @@ -382,9 +383,9 @@ The syntax tables aren't stored directly since they're quite large." ;; its compiler directives as single keyword tokens. ;; This is then necessary since it's assumed that ;; every keyword is a single symbol. - `(modify-syntax-entry ?@ "_" table)) + '(modify-syntax-entry ?@ "_" table)) ((c-major-mode-is 'pike-mode) - `(modify-syntax-entry ?@ "." table))) + '(modify-syntax-entry ?@ "." table))) table))) (c-lang-defconst c-mode-syntax-table @@ -392,27 +393,6 @@ The syntax tables aren't stored directly since they're quite large." ;; the constants in this file are evaluated. t (funcall (c-lang-const c-make-mode-syntax-table))) -(c-lang-defconst c++-make-template-syntax-table - ;; A variant of `c++-mode-syntax-table' that defines `<' and `>' as - ;; parenthesis characters. Used temporarily when template argument - ;; lists are parsed. Note that this encourages incorrect parsing of - ;; templates since they might contain normal operators that uses the - ;; '<' and '>' characters. Therefore this syntax table might go - ;; away when CC Mode handles templates correctly everywhere. WHILE - ;; THIS SYNTAX TABLE IS CURRENT, `c-parse-state' MUST _NOT_ BE - ;; CALLED!!! - t nil - (java c++) `(lambda () - (let ((table (funcall ,(c-lang-const c-make-mode-syntax-table)))) - (modify-syntax-entry ?< "(>" table) - (modify-syntax-entry ?> ")<" table) - table))) -(c-lang-defvar c++-template-syntax-table - (and (c-lang-const c++-make-template-syntax-table) - ;; The next eval remove a superfluous ' from '(lambda. This - ;; gets rid of compilation warnings. - (funcall (eval (c-lang-const c++-make-template-syntax-table))))) - (c-lang-defconst c-make-no-parens-syntax-table ;; A variant of the standard syntax table which is used to find matching ;; "<"s and ">"s which have been marked as parens using syntax table @@ -472,21 +452,24 @@ so that all identifiers are recognized as words.") (c-lang-defconst c-get-state-before-change-functions ;; For documentation see the following c-lang-defvar of the same name. ;; The value here may be a list of functions or a single function. - t nil + t 'c-before-change-check-unbalanced-strings c++ '(c-extend-region-for-CPP c-before-change-check-raw-strings c-before-change-check-<>-operators c-depropertize-CPP c-invalidate-macro-cache c-truncate-bs-cache + c-before-change-check-unbalanced-strings c-parse-quotes-before-change) (c objc) '(c-extend-region-for-CPP c-depropertize-CPP c-invalidate-macro-cache c-truncate-bs-cache + c-before-change-check-unbalanced-strings c-parse-quotes-before-change) - java 'c-parse-quotes-before-change - ;; 'c-before-change-check-<>-operators + java '(c-parse-quotes-before-change + c-before-change-check-unbalanced-strings + c-before-change-check-<>-operators) awk 'c-awk-record-region-clear-NL) (c-lang-defvar c-get-state-before-change-functions (let ((fs (c-lang-const c-get-state-before-change-functions))) @@ -495,7 +478,7 @@ so that all identifiers are recognized as words.") (list fs))) "If non-nil, a list of functions called from c-before-change-hook. Typically these will record enough state to allow -`c-before-font-lock-function' to extend the region to fontify, +`c-before-font-lock-functions' to extend the region to fontify, and may do such things as removing text-properties which must be recalculated. @@ -514,21 +497,29 @@ parameters \(point-min) and \(point-max).") ;; For documentation see the following c-lang-defvar of the same name. ;; The value here may be a list of functions or a single function. t '(c-depropertize-new-text + c-after-change-escape-NL-in-string + c-after-change-mark-abnormal-strings c-change-expand-fl-region) (c objc) '(c-depropertize-new-text + c-after-change-escape-NL-in-string c-parse-quotes-after-change + c-after-change-mark-abnormal-strings c-extend-font-lock-region-for-macros c-neutralize-syntax-in-CPP c-change-expand-fl-region) c++ '(c-depropertize-new-text + c-after-change-escape-NL-in-string + c-after-change-unmark-raw-strings c-parse-quotes-after-change + c-after-change-mark-abnormal-strings c-extend-font-lock-region-for-macros - c-after-change-re-mark-raw-strings c-neutralize-syntax-in-CPP c-restore-<>-properties c-change-expand-fl-region) java '(c-depropertize-new-text + c-after-change-escape-NL-in-string c-parse-quotes-after-change + c-after-change-mark-abnormal-strings c-restore-<>-properties c-change-expand-fl-region) awk '(c-depropertize-new-text @@ -611,12 +602,39 @@ EOL terminated statements." (c c++ objc) t) (c-lang-defvar c-has-bitfields (c-lang-const c-has-bitfields)) +(c-lang-defconst c-single-quotes-quote-strings + "Whether the language uses single quotes for multi-char strings. + +Note that to set up a language to use this, additionally: +\(i) the syntax of \"'\" must be \"string quote\" (7); +\(ii) the language's value of `c-has-quoted-numbers' must be nil; +\(iii) the language's value of `c-get-state-before-change-functions' may not + contain `c-parse-quotes-before-change'; +\(iv) the language's value of `c-before-font-lock-functions' may not contain + `c-parse-quotes-after-change'." + t nil) +(c-lang-defvar c-single-quotes-quote-strings + (c-lang-const c-single-quotes-quote-strings)) + +(c-lang-defconst c-string-delims +;; A list of characters which can delimit arbitrary length strings. + t (if (c-lang-const c-single-quotes-quote-strings) + '(?\" ?\') + '(?\"))) +(c-lang-defvar c-string-delims (c-lang-const c-string-delims)) + (c-lang-defconst c-has-quoted-numbers "Whether the language has numbers quoted like 4'294'967'295." t nil c++ t) (c-lang-defvar c-has-quoted-numbers (c-lang-const c-has-quoted-numbers)) +(c-lang-defconst c-has-compound-literals + "Whether literal initializers {...} are used other than in initializations." + t nil + (c c++) t) +(c-lang-defvar c-has-compound-literals (c-lang-const c-has-compound-literals)) + (c-lang-defconst c-modified-constant "Regexp that matches a “modified” constant literal such as \"L\\='a\\='\", a “long character”. In particular, this recognizes forms of constant @@ -850,6 +868,28 @@ literal are multiline." (c-lang-defvar c-multiline-string-start-char (c-lang-const c-multiline-string-start-char)) +(c-lang-defconst c-string-innards-re-alist + ;; An alist of regexps matching the innards of a string, the key being the + ;; string's delimiter. + ;; + ;; The regexps' matches extend up to, but not including, the closing string + ;; delimiter or an unescaped NL. An EOL is part of the string only if it is + ;; escaped. + t (mapcar (lambda (delim) + (cons + delim + (concat "\\(\\\\\\(.\\|\n\\|\r\\)\\|[^\\\n\r" + (string delim) + "]\\)*"))) + (and + (or (null (c-lang-const c-multiline-string-start-char)) + (c-characterp (c-lang-const c-multiline-string-start-char))) + (if (c-lang-const c-single-quotes-quote-strings) + '(?\" ?\') + '(?\"))))) +(c-lang-defvar c-string-innards-re-alist + (c-lang-const c-string-innards-re-alist)) + (c-lang-defconst c-opt-cpp-symbol "The symbol which starts preprocessor constructs when in the margin." t "#" @@ -899,6 +939,19 @@ file name in angle brackets or quotes." '("include")) objc '("include" "import")) +(c-lang-defconst c-cpp-include-key + ;; Matches an include directive anchored at BOL including any trailing + ;; whitespace, e.g. " # include " + t (if (and (c-lang-const c-anchored-cpp-prefix) + (c-lang-const c-cpp-include-directives)) + (concat + (c-lang-const c-anchored-cpp-prefix) + (c-make-keywords-re 'appendable + (c-lang-const c-cpp-include-directives)) + "[ \t]*") + regexp-unmatchable)) +(c-lang-defvar c-cpp-include-key (c-lang-const c-cpp-include-key)) + (c-lang-defconst c-opt-cpp-macro-define "Cpp directive (without the prefix) that is followed by a macro definition, or nil if the language doesn't have any." @@ -930,6 +983,14 @@ definition, or nil if the language doesn't have any." (c-lang-defvar c-opt-cpp-macro-define-id (c-lang-const c-opt-cpp-macro-define-id)) +(c-lang-defconst c-anchored-hash-define-no-parens + ;; Regexp matching everything up to the end of a cpp define which has no + ;; argument parentheses. Or nil in languages which don't have them. + t (if (c-lang-const c-opt-cpp-macro-define) + (concat (c-lang-const c-anchored-cpp-prefix) + (c-lang-const c-opt-cpp-macro-define) + "[ \t]+\\(\\sw\\|_\\)+\\([^(a-zA-Z0-9_]\\|$\\)"))) + (c-lang-defconst c-cpp-expr-directives "List of cpp directives (without the prefix) that are followed by an expression." @@ -1018,16 +1079,16 @@ since CC Mode treats every identifier as an expression." ;; Primary. ,@(c-lang-const c-identifier-ops) ,@(cond ((or (c-major-mode-is 'c++-mode) (c-major-mode-is 'java-mode)) - `((postfix-if-paren "<" ">"))) ; Templates. + '((postfix-if-paren "<" ">"))) ; Templates. ((c-major-mode-is 'pike-mode) - `((prefix "global" "predef"))) + '((prefix "global" "predef"))) ((c-major-mode-is 'java-mode) - `((prefix "super")))) + '((prefix "super")))) ;; Postfix. ,@(when (c-major-mode-is 'c++-mode) ;; The following need special treatment. - `((prefix "dynamic_cast" "static_cast" + '((prefix "dynamic_cast" "static_cast" "reinterpret_cast" "const_cast" "typeid" "alignof"))) (left-assoc "." @@ -1057,7 +1118,7 @@ since CC Mode treats every identifier as an expression." ;; Member selection. ,@(when (c-major-mode-is 'c++-mode) - `((left-assoc ".*" "->*"))) + '((left-assoc ".*" "->*"))) ;; Multiplicative. (left-assoc "*" "/" "%") @@ -1183,13 +1244,6 @@ This regexp is assumed to not match any non-operator identifier." (c-lang-defvar c-opt-op-identifier-prefix (c-lang-const c-opt-op-identifier-prefix)) -;; Note: the following alias is an old name which was a mis-spelling. It has -;; been corrected above and throughout cc-engine.el. It will be removed at -;; some release very shortly in the future. ACM, 2006-04-14. -(defvaralias 'c-opt-op-identitier-prefix 'c-opt-op-identifier-prefix) -(make-obsolete-variable 'c-opt-op-identitier-prefix 'c-opt-op-identifier-prefix - "CC Mode 5.31.4, 2006-04-14") - (c-lang-defconst c-ambiguous-overloadable-or-identifier-prefixes ;; A list of strings which can be either overloadable operators or ;; identifier prefixes. @@ -1274,7 +1328,7 @@ operators." (c--set-difference (c-lang-const c-assignment-operators) '("=") :test 'string-equal))) - "\\<\\>")) + regexp-unmatchable)) (c-lang-defvar c-assignment-op-regexp (c-lang-const c-assignment-op-regexp)) @@ -1355,15 +1409,17 @@ operators." (c-lang-defvar c->-op-without->-cont-regexp (c-lang-const c->-op-without->-cont-regexp)) -(c-lang-defconst c-multichar->-op-not->>-regexp - ;; Regexp matching multichar tokens containing ">", except ">>" +(c-lang-defconst c-multichar->-op-not->>->>>-regexp + ;; Regexp matching multichar tokens containing ">", except ">>" and ">>>" t (c-make-keywords-re nil - (delete ">>" - (c-filter-ops (c-lang-const c-all-op-syntax-tokens) - t - "\\(.>\\|>.\\)")))) -(c-lang-defvar c-multichar->-op-not->>-regexp - (c-lang-const c-multichar->-op-not->>-regexp)) + (c--set-difference + (c-filter-ops (c-lang-const c-all-op-syntax-tokens) + t + "\\(.>\\|>.\\)") + '(">>" ">>>") + :test 'string-equal))) +(c-lang-defvar c-multichar->-op-not->>->>>-regexp + (c-lang-const c-multichar->-op-not->>->>>-regexp)) (c-lang-defconst c-:-op-cont-tokens ;; A list of second and subsequent characters of all multicharacter tokens @@ -1388,12 +1444,56 @@ operators." t "^;{}?:") (c-lang-defvar c-stmt-delim-chars (c-lang-const c-stmt-delim-chars)) +(c-lang-defconst c-stmt-boundary-skip-chars + ;; Like `c-stmt-delim-chars', but augmented by "#" for languages with CPP + ;; constructs, and for C++ Mode, also by "[", to help deal with C++ + ;; attributes. + t (if (c-lang-const c-opt-cpp-symbol) + (concat (substring (c-lang-const c-stmt-delim-chars) 0 1) ; "^" + (c-lang-const c-opt-cpp-symbol) ; usually # + (substring (c-lang-const c-stmt-delim-chars) 1)) ; ";{}?:" + (c-lang-const c-stmt-delim-chars)) + c++ (concat (substring (c-lang-const c-stmt-boundary-skip-chars) 0 1) ; "^" + "[" + (substring (c-lang-const c-stmt-boundary-skip-chars) 1))) ; ";{}?:" +(c-lang-defvar c-stmt-boundary-skip-chars + (c-lang-const c-stmt-boundary-skip-chars)) + +(c-lang-defconst c-stmt-boundary-skip-list + ;; The characters (apart from the initial ^) in `c-stmt-boundary-skip-chars' + ;; as a list of characters. + t (append (substring (c-lang-const c-stmt-boundary-skip-chars) 1) nil)) +(c-lang-defvar c-stmt-boundary-skip-list + (c-lang-const c-stmt-boundary-skip-list)) + (c-lang-defconst c-stmt-delim-chars-with-comma ;; Variant of `c-stmt-delim-chars' that additionally contains ','. t "^;,{}?:") (c-lang-defvar c-stmt-delim-chars-with-comma (c-lang-const c-stmt-delim-chars-with-comma)) +(c-lang-defconst c-stmt-boundary-skip-chars-with-comma + ;; Variant of `c-stmt-boundary-skip-chars' also containing ','. + t (if (c-lang-const c-opt-cpp-symbol) + (concat (substring (c-lang-const c-stmt-delim-chars-with-comma) 0 1) + (c-lang-const c-opt-cpp-symbol) ; usually # + (substring (c-lang-const c-stmt-delim-chars-with-comma) 1)) + (c-lang-const c-stmt-delim-chars-with-comma)) + c++ (concat + (substring (c-lang-const c-stmt-boundary-skip-chars-with-comma) 0 1) ; "^" + "[" + (substring (c-lang-const c-stmt-boundary-skip-chars-with-comma) 1))) ; ";,{}?:" +(c-lang-defvar c-stmt-boundary-skip-chars-with-comma + (c-lang-const c-stmt-boundary-skip-chars-with-comma)) + +(c-lang-defconst c-stmt-boundary-skip-list-with-comma + ;; Variant of `c-stmt-boundary-skip-list' also including a comma. + t (append (substring (c-lang-const c-stmt-boundary-skip-chars-with-comma) + 1) + nil)) +(c-lang-defvar c-stmt-boundary-skip-list-with-comma + (c-lang-const c-stmt-boundary-skip-list-with-comma)) + (c-lang-defconst c-pack-ops "Ops which signal C++11's \"parameter pack\"" t nil @@ -1497,10 +1597,30 @@ properly." ;; language) t (if (c-lang-const c-block-comment-ender) (regexp-quote (c-lang-const c-block-comment-ender)) - "\\<\\>")) + regexp-unmatchable)) (c-lang-defvar c-block-comment-ender-regexp (c-lang-const c-block-comment-ender-regexp)) +(c-lang-defconst c-block-comment-awkward-chars + "List of characters which, inside a block comment, could be the first +character of a double character construct. This doesn't include +backslash." + t (when (> (length (c-lang-const c-block-comment-ender)) 1) + (list (aref (c-lang-const c-block-comment-ender) 0)))) +(c-lang-defvar c-block-comment-awkward-chars + (c-lang-const c-block-comment-awkward-chars)) + +(c-lang-defconst c-font-lock-comment-end-skip + ;; Regexp which matches whitespace followed by the end of a block comment + ;; (if such exists in the language). This is used by font lock to determine + ;; the portion of the end of a comment to fontify with + ;; `font-lock-comment-delimiter-face'. + t (if (c-lang-const c-block-comment-ender) + (concat "[ \t]*" (c-lang-const c-block-comment-ender-regexp)) + regexp-unmatchable)) +(c-lang-setvar font-lock-comment-end-skip + (c-lang-const c-font-lock-comment-end-skip)) + (c-lang-defconst c-comment-start-regexp ;; Regexp to match the start of any type of comment. t (let ((re (c-make-keywords-re nil @@ -1516,7 +1636,7 @@ properly." ;; language) t (if (c-lang-const c-block-comment-starter) (regexp-quote (c-lang-const c-block-comment-starter)) - "\\<\\>")) + regexp-unmatchable)) (c-lang-defvar c-block-comment-start-regexp (c-lang-const c-block-comment-start-regexp)) @@ -1525,22 +1645,42 @@ properly." ;; language; it does in all 7 CC Mode languages). t (if (c-lang-const c-line-comment-starter) (regexp-quote (c-lang-const c-line-comment-starter)) - "\\<\\>")) + regexp-unmatchable)) (c-lang-defvar c-line-comment-start-regexp (c-lang-const c-line-comment-start-regexp)) +(c-lang-defconst c-last-c-comment-end-on-line-re + "Regexp which matches the last block comment ender on the +current line, if any, or nil in those languages without block +comments. When a match is found, submatch 1 contains the comment +ender." + t "\\(\\*/\\)\\([^*]\\|\\*+\\([^*/]\\|$\\)\\)*$" + awk nil) +(c-lang-defvar c-last-c-comment-end-on-line-re + (c-lang-const c-last-c-comment-end-on-line-re)) + +(c-lang-defconst c-last-open-c-comment-start-on-line-re + "Regexp which matches the last block comment start on the +current ine, if any, or nil in those languages without block +comments. When a match is found, submatch 1 contains the comment +starter." + t "\\(/\\*\\)\\([^*]\\|\\*+\\([^*/]\\|$\\)\\)*$" + awk nil) +(c-lang-defvar c-last-open-c-comment-start-on-line-re + (c-lang-const c-last-open-c-comment-start-on-line-re)) + (c-lang-defconst c-literal-start-regexp ;; Regexp to match the start of comments and string literals. t (concat (c-lang-const c-comment-start-regexp) "\\|" (if (memq 'gen-string-delim c-emacs-features) - "\"|" + "\"\\|\\s|" "\""))) (c-lang-defvar c-literal-start-regexp (c-lang-const c-literal-start-regexp)) (c-lang-defconst c-doc-comment-start-regexp "Regexp to match the start of documentation comments." - t "\\<\\>" + t regexp-unmatchable ;; From font-lock.el: `doxygen' uses /*! while others use /**. (c c++ objc) "/\\*[*!]" java "/\\*\\*" @@ -1989,6 +2129,19 @@ effect in the declaration, but are syntactically like whitespace." (c-lang-defvar c-type-decl-suffix-ws-ids-key (c-lang-const c-type-decl-suffix-ws-ids-key)) +(c-lang-defconst c-class-id-suffix-ws-ids-kwds + "\"Identifiers\" that when immediately following the identifier +of a class declaration have semantic effect in the declaration, +but are syntactically like whitespace." + t nil + c++ '("final")) + +(c-lang-defconst c-class-id-suffix-ws-ids-key + ;; An adorned regexp matching `c-class-id-suffix-ws-ids-kwds'. + t (c-make-keywords-re t (c-lang-const c-class-id-suffix-ws-ids-kwds))) +(c-lang-defvar c-class-id-suffix-ws-ids-key + (c-lang-const c-class-id-suffix-ws-ids-key)) + (c-lang-defconst c-class-decl-kwds "Keywords introducing declarations where the following block (if any) contains another declaration level that should be considered a class. @@ -2101,6 +2254,18 @@ will be handled." "Alist associating keywords in c-other-decl-block-decl-kwds with their matching \"in\" syntactic symbols.") +(c-lang-defconst c-defun-type-name-decl-kwds + "Keywords introducing a named block, where the name is a \"defun\" + name." + t (append (c-lang-const c-class-decl-kwds) + (c-lang-const c-brace-list-decl-kwds))) + +(c-lang-defconst c-defun-type-name-decl-key + ;; Regexp matching a keyword in `c-defun-name-decl-kwds'. + t (c-make-keywords-re t (c-lang-const c-defun-type-name-decl-kwds))) +(c-lang-defvar c-defun-type-name-decl-key + (c-lang-const c-defun-type-name-decl-key)) + (c-lang-defconst c-typedef-decl-kwds "Keywords introducing declarations where the identifier(s) being declared are types. @@ -2150,6 +2315,18 @@ will be handled." pike (append (c-lang-const c-class-decl-kwds) '("constant"))) +(c-lang-defconst c-equals-type-clause-kwds + "Keywords which are followed by an identifier then an \"=\" + sign, which declares the identifier to be a type." + t nil + c++ '("using")) + +(c-lang-defconst c-equals-type-clause-key + ;; A regular expression which matches any member of + ;; `c-equals-type-clause-kwds'. + t (c-make-keywords-re t (c-lang-const c-equals-type-clause-kwds))) +(c-lang-defvar c-equals-type-clause-key (c-lang-const c-equals-type-clause-key)) + (c-lang-defconst c-modifier-kwds "Keywords that can prefix normal declarations of identifiers \(and typically act as flags). Things like argument declarations @@ -2443,7 +2620,11 @@ regexp if `c-colon-type-list-kwds' isn't nil." ;; before the ":" that starts the inherit list after "class" ;; or "struct" in C++. (Also used as default for other ;; languages.) - "[^][{}();,/#=:]*:")) + (if (c-lang-const c-opt-identifier-concat-key) + (concat "\\([^][{}();,/#=:]\\|" + (c-lang-const c-opt-identifier-concat-key) + "\\)*:") + "[^][{}();,/#=:]*:"))) (c-lang-defvar c-colon-type-list-re (c-lang-const c-colon-type-list-re)) (c-lang-defconst c-paren-nontype-kwds @@ -2569,6 +2750,17 @@ Keywords here should also be in `c-block-stmt-1-kwds'." (c-lang-const c-block-stmt-2-kwds)) :test 'string-equal)) +(c-lang-defconst c-block-stmt-hangon-kwds + "Keywords which may directly follow a member of `c-block-stmt-1/2-kwds'." + t nil + c++ '("constexpr")) + +(c-lang-defconst c-block-stmt-hangon-key + ;; Regexp matching a "hangon" keyword in a `c-block-stmt-1/2-kwds' + ;; construct. + t (c-make-keywords-re t (c-lang-const c-block-stmt-hangon-kwds))) +(c-lang-defvar c-block-stmt-hangon-key (c-lang-const c-block-stmt-hangon-key)) + (c-lang-defconst c-opt-block-stmt-key ;; Regexp matching the start of any statement that has a ;; substatement (except a bare block). Nil in languages that @@ -2972,7 +3164,7 @@ Note that Java specific rules are currently applied to tell this from "Regexp matching a keyword that is followed by a colon, where the whole construct can precede a declaration. E.g. \"public:\" in C++." - t "\\<\\>" + t regexp-unmatchable c++ (c-make-keywords-re t (c-lang-const c-protection-kwds))) (c-lang-defvar c-decl-start-colon-kwd-re (c-lang-const c-decl-start-colon-kwd-re)) @@ -3051,24 +3243,40 @@ constructs." ;; token that might precede such a construct, e.g. ';', '}' or '{'. ;; It's built from `c-decl-prefix-re'. ;; - ;; If the first submatch did not match, the match of the whole - ;; regexp is taken to be at the first token in the declaration. - ;; `c-decl-start-re' is not checked in this case. + ;; If the first submatch did not match, we have either a #define construct + ;; without parentheses or the match of the whole regexp is taken to be at + ;; the first token in the declaration. `c-decl-start-re' is not checked in + ;; these cases. ;; ;; Design note: The reason the same regexp is used to match both ;; tokens that precede declarations and start them is to avoid an ;; extra regexp search from the previous declaration spot in ;; `c-find-decl-spots'. Users of `c-find-decl-spots' also count on - ;; that it finds all declaration/cast/label starts in approximately + ;; it finding all declaration/cast/label starts in approximately ;; linear order, so we can't do the searches in two separate passes. - t (if (c-lang-const c-decl-start-kwds) - (concat (c-lang-const c-decl-prefix-re) - "\\|" - (c-make-keywords-re t (c-lang-const c-decl-start-kwds))) - (c-lang-const c-decl-prefix-re))) + t (cond + ((and (c-lang-const c-decl-start-kwds) + (c-lang-const c-anchored-hash-define-no-parens)) + (concat (c-lang-const c-decl-prefix-re) + "\\|" (c-lang-const c-anchored-hash-define-no-parens) + "\\|" (c-make-keywords-re t (c-lang-const c-decl-start-kwds)))) + ((c-lang-const c-decl-start-kwds) + (concat (c-lang-const c-decl-prefix-re) + "\\|" (c-make-keywords-re t (c-lang-const c-decl-start-kwds)))) + ((c-lang-const c-anchored-hash-define-no-parens) + (concat (c-lang-const c-decl-prefix-re) + "\\|" (c-lang-const c-anchored-hash-define-no-parens))) + (t (c-lang-const c-decl-prefix-re)))) (c-lang-defvar c-decl-prefix-or-start-re (c-lang-const c-decl-prefix-or-start-re)) +(c-lang-defconst c-dposr-cpp-macro-depth + ;; The match number of `c-anchored-hash-define-no-parens''s first match + ;; within `c-decl-prefix-or-start-re', or nil if there is no such component. + t (if (c-lang-const c-anchored-hash-define-no-parens) + (1+ (regexp-opt-depth (c-lang-const c-decl-prefix-re))))) +(c-lang-defvar c-dposr-cpp-macro-depth (c-lang-const c-dposr-cpp-macro-depth)) + (c-lang-defconst c-cast-parens ;; List containing the paren characters that can open a cast, or nil in ;; languages without casts. @@ -3153,7 +3361,7 @@ Identifier syntax is in effect when this is matched \(see t (if (c-lang-const c-type-modifier-kwds) (concat (regexp-opt (c-lang-const c-type-modifier-kwds) t) "\\>") ;; Default to a regexp that never matches. - "\\<\\>") + regexp-unmatchable) ;; Check that there's no "=" afterwards to avoid matching tokens ;; like "*=". (c objc) (concat "\\(" @@ -3167,7 +3375,7 @@ Identifier syntax is in effect when this is matched \(see "\\|" "\\.\\.\\." "\\|" - "[*(&]" + "[*(&~]" "\\|" (c-lang-const c-type-decl-prefix-key) "\\|" @@ -3191,7 +3399,7 @@ that might precede the identifier in a declaration, e.g. the as the end of the operator. Identifier syntax is in effect when this is matched \(see `c-identifier-syntax-table')." t ;; Default to a regexp that never matches. - "\\<\\>" + regexp-unmatchable ;; Check that there's no "=" afterwards to avoid matching tokens ;; like "*=". (c objc) (concat "\\(\\*\\)" @@ -3350,7 +3558,7 @@ list." (c-lang-defconst c-pre-id-bracelist-key "A regexp matching tokens which, preceding an identifier, signify a bracelist. " - t "\\<\\>" + t regexp-unmatchable c++ "new\\([^[:alnum:]_$]\\|$\\)\\|&&?\\(\\S.\\|$\\)") (c-lang-defvar c-pre-id-bracelist-key (c-lang-const c-pre-id-bracelist-key)) @@ -3406,7 +3614,7 @@ the invalidity of the putative template construct." ;; before the '{' of the enum list, to avoid searching too far. "[^][{};/#=]*" "{") - "\\<\\>")) + regexp-unmatchable)) (c-lang-defvar c-enum-clause-introduction-re (c-lang-const c-enum-clause-introduction-re)) @@ -3518,11 +3726,36 @@ i.e. before \":\". Only used if `c-recognize-colon-labels' is set." c++ (concat "\\s(\\|\"\\|" (c-lang-const c-nonlabel-token-key))) (c-lang-defvar c-nonlabel-token-key (c-lang-const c-nonlabel-token-key)) +(c-lang-defconst c-nonlabel-nonparen-token-key + "Regexp matching things that can't occur in generic colon labels, +neither in a statement nor in a declaration context, with the +exception of an open parenthesis. The regexp is tested at the +beginning of every sexp in a suspected label, i.e. before \":\". +Only used if `c-recognize-colon-labels' is set." + ;; This lang const is the same as `c-nonlabel-token-key', except for a + ;; slight difference in the c++-mode value. + t (concat + ;; All keywords except `c-label-kwds' and `c-protection-kwds'. + (c-make-keywords-re t + (c--set-difference (c-lang-const c-keywords) + (append (c-lang-const c-label-kwds) + (c-lang-const c-protection-kwds)) + :test 'string-equal))) + ;; Don't allow string literals, except in AWK and Java. Character constants are OK. + (c objc pike idl) (concat "\"\\|" + (c-lang-const c-nonlabel-nonparen-token-key)) + ;; Also check for open parens in C++, to catch member init lists in + ;; constructors. We normally allow it so that macros with arguments + ;; work in labels. + c++ (concat "[{[]\\|\"\\|" (c-lang-const c-nonlabel-nonparen-token-key))) +(c-lang-defvar c-nonlabel-nonparen-token-key + (c-lang-const c-nonlabel-nonparen-token-key)) + (c-lang-defconst c-nonlabel-token-2-key "Regexp matching things that can't occur two symbols before a colon in a label construct. This catches C++'s inheritance construct \"class foo : bar\". Only used if `c-recognize-colon-labels' is set." - t "\\<\\>" ; matches nothing + t regexp-unmatchable c++ (c-make-keywords-re t '("class"))) (c-lang-defvar c-nonlabel-token-2-key (c-lang-const c-nonlabel-token-2-key)) diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index aa2a286dbe9..5e373b6e170 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -11,6 +11,8 @@ ;; Maintainer: bug-cc-mode@gnu.org ;; Created: a long, long, time ago. adapted from the original c-mode.el ;; Keywords: c languages +;; The version header below is used for ELPA packaging. +;; Version: 5.33.1 ;; This file is part of GNU Emacs. @@ -126,6 +128,25 @@ ; ' (require 'cc-fonts) ;) +;; The following three really belong to cc-fonts.el, but they are required +;; even when cc-fonts.el hasn't been loaded (this happens in XEmacs when +;; font-lock-mode is nil). + +(defvar c-doc-line-join-re regexp-unmatchable) +;; Matches a join of two lines in a doc comment. +;; This should not be changed directly, but instead set by +;; `c-setup-doc-comment-style'. This variable is used in `c-find-decl-spots' +;; in (e.g.) autodoc style comments to bridge the gap between a "@\n" at an +;; EOL and the token following "//!" on the next line. + +(defvar c-doc-bright-comment-start-re regexp-unmatchable) +;; Matches the start of a "bright" comment, one whose contents may be +;; fontified by, e.g., `c-font-lock-declarations'. + +(defvar c-doc-line-join-end-ch nil) +;; A list of characters, each being a last character of a doc comment marker, +;; e.g. the ! from pike autodoc's "//!". + ;; Other modes and packages which depend on CC Mode should do the ;; following to make sure everything is loaded and available for their @@ -160,6 +181,7 @@ (c-save-buffer-state () (c-clear-char-properties (point-min) (point-max) 'category) (c-clear-char-properties (point-min) (point-max) 'syntax-table) + (c-clear-char-properties (point-min) (point-max) 'c-fl-syn-tab) (c-clear-char-properties (point-min) (point-max) 'c-is-sws) (c-clear-char-properties (point-min) (point-max) 'c-in-sws) (c-clear-char-properties (point-min) (point-max) 'c-type) @@ -205,6 +227,15 @@ control). See \"cc-mode.el\" for more info." (if (boundp 'c-comment-continuation-stars) (setq c-block-comment-prefix c-comment-continuation-stars)) (add-hook 'change-major-mode-hook 'c-leave-cc-mode-mode) + ;; Connect up with Emacs's electric-pair-mode + (eval-after-load "elec-pair" + '(when (boundp 'electric-pair-inhibit-predicate) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when c-buffer-is-cc-mode + (make-local-variable 'electric-pair-inhibit-predicate) + (setq electric-pair-inhibit-predicate + #'c-electric-pair-inhibit-predicate)))))) (setq c-initialization-ok t) ;; Connect up with Emacs's electric-indent-mode, for >= Emacs 24.4 (when (fboundp 'electric-indent-local-mode) @@ -499,9 +530,10 @@ preferably use the `c-mode-menu' language constant directly." ;; `basic-save-buffer' does (insert ?\n) when `require-final-newline' is ;; non-nil; (ii) to detect when Emacs fails to invoke ;; `before-change-functions'. This can happen when reverting a buffer - see -;; bug #24094. It seems these failures happen only in GNU Emacs; XEmacs -;; seems to maintain the strict alternation of calls to -;; `before-change-functions' and `after-change-functions'. +;; bug #24094. It seems these failures happen only in GNU Emacs; XEmacs seems +;; to maintain the strict alternation of calls to `before-change-functions' +;; and `after-change-functions'. Note that this variable is not set when +;; `c-before-change' is invoked by a change to text properties. (defun c-basic-common-init (mode default-style) "Do the necessary initialization for the syntax handling routines @@ -531,6 +563,17 @@ that requires a literal mode spec at compile time." (make-local-variable 'adaptive-fill-regexp) (make-local-variable 'fill-paragraph-handle-comment) + (setq c-buffer-is-cc-mode mode) + + ;; Prepare for the use of `electric-pair-mode'. Note: if this mode is not + ;; yet loaded, `electric-pair-inhibit-predicate' will get set from an + ;; `eval-after-load' form in `c-initialize-cc-mode' when elec-pair.elc is + ;; loaded. + (when (boundp 'electric-pair-inhibit-predicate) + (make-local-variable 'electric-pair-inhibit-predicate) + (setq electric-pair-inhibit-predicate + #'c-electric-pair-inhibit-predicate)) + ;; now set their values (set (make-local-variable 'parse-sexp-ignore-comments) t) (set (make-local-variable 'indent-line-function) 'c-indent-line) @@ -556,6 +599,8 @@ that requires a literal mode spec at compile time." ;; doesn't work with filladapt but it's better than nothing. (set (make-local-variable 'fill-paragraph-function) 'c-fill-paragraph) + ;; Initialize the three literal sub-caches. + (c-truncate-lit-pos-cache 1) ;; Initialize the cache of brace pairs, and opening braces/brackets/parens. (c-state-cache-init) ;; Initialize the "brace stack" cache. @@ -563,7 +608,7 @@ that requires a literal mode spec at compile time." (when (or c-recognize-<>-arglists (c-major-mode-is 'awk-mode) - (c-major-mode-is '(java-mode c-mode c++-mode objc-mode))) + (c-major-mode-is '(java-mode c-mode c++-mode objc-mode pike-mode))) ;; We'll use the syntax-table text property to change the syntax ;; of some chars for this language, so do the necessary setup for ;; that. @@ -588,7 +633,7 @@ that requires a literal mode spec at compile time." (unless (assq tprop text-property-default-nonsticky) (setq text-property-default-nonsticky (cons `(,tprop . t) text-property-default-nonsticky)))) - '(syntax-table category c-type))) + '(syntax-table c-fl-syn-tab category c-type))) ;; In Emacs 21 and later it's possible to turn off the ad-hoc ;; heuristic that open parens in column 0 are defun starters. Since @@ -650,6 +695,9 @@ that requires a literal mode spec at compile time." (make-local-hook 'after-change-functions)) (add-hook 'before-change-functions 'c-before-change nil t) (setq c-just-done-before-change nil) + ;; FIXME: We should use the new `depth' arg in Emacs-27 (e.g. a depth of -10 + ;; 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) (when (boundp 'font-lock-extend-after-change-region-function) (set (make-local-variable 'font-lock-extend-after-change-region-function) @@ -675,14 +723,12 @@ that requires a literal mode spec at compile time." (make-variable-buffer-local 'c-new-BEG) (defvar c-new-END 0) (make-variable-buffer-local 'c-new-END) -;; The following two variables record the values of `c-new-BEG' and -;; `c-new-END' just after `c-new-END' has been adjusted for the length of text -;; inserted or removed. They may be read by any after-change function (but -;; should not be altered by one). -(defvar c-old-BEG 0) -(make-variable-buffer-local 'c-old-BEG) -(defvar c-old-END 0) -(make-variable-buffer-local 'c-old-END) + +;; Buffer local variable which notes the value of calling `c-in-literal' just +;; before a change. It is one of 'string, 'c, 'c++ (for the two sorts of +;; comments), or nil. +(defvar c-old-END-literality nil) +(make-variable-buffer-local 'c-old-END-literality) (defun c-common-init (&optional mode) "Common initialization for all CC Mode modes. @@ -882,7 +928,6 @@ Note that the style variables are always made local to the buffer." ;;; Change hooks, linking with Font Lock and electric-indent-mode. - (defun c-called-from-text-property-change-p () ;; Is the primitive which invoked `before-change-functions' or ;; `after-change-functions' one which merely changes text properties? This @@ -897,7 +942,8 @@ Note that the style variables are always made local to the buffer." (defun c-depropertize-CPP (beg end) ;; Remove the punctuation syntax-table text property from the CPP parts of - ;; (c-new-BEG c-new-END). + ;; (c-new-BEG c-new-END), and remove all syntax-table properties from any + ;; raw strings within these CPP parts. ;; ;; This function is in the C/C++/ObjC values of ;; `c-get-state-before-change-functions' and is called exclusively as a @@ -909,6 +955,8 @@ Note that the style variables are always made local to the buffer." (goto-char (match-beginning 1)) (setq m-beg (point)) (c-end-of-macro) + (when (c-major-mode-is 'c++-mode) + (save-excursion (c-depropertize-raw-strings-in-region m-beg (point)))) (c-clear-char-property-with-value m-beg (point) 'syntax-table '(1))) (while (and (< (point) end) @@ -917,14 +965,18 @@ Note that the style variables are always made local to the buffer." (goto-char (match-beginning 1)) (setq m-beg (point)) (c-end-of-macro)) - (if (and ss-found (> (point) end)) - (c-clear-char-property-with-value m-beg (point) 'syntax-table '(1))) + (when (and ss-found (> (point) end)) + (when (c-major-mode-is 'c++-mode) + (save-excursion (c-depropertize-raw-strings-in-region m-beg (point)))) + (c-clear-char-property-with-value m-beg (point) 'syntax-table '(1))) (while (and (< (point) c-new-END) (search-forward-regexp c-anchored-cpp-prefix c-new-END 'bound)) (goto-char (match-beginning 1)) (setq m-beg (point)) (c-end-of-macro) + (when (c-major-mode-is 'c++-mode) + (save-excursion (c-depropertize-raw-strings-in-region m-beg (point)))) (c-clear-char-property-with-value m-beg (point) 'syntax-table '(1))))) @@ -965,6 +1017,7 @@ Note that the style variables are always made local to the buffer." (c-save-buffer-state () (when (> end beg) (c-clear-char-properties beg end 'syntax-table) + (c-clear-char-properties beg end 'c-fl-syn-tab) (c-clear-char-properties beg end 'category) (c-clear-char-properties beg end 'c-is-sws) (c-clear-char-properties beg end 'c-in-sws) @@ -996,9 +1049,9 @@ Note that the style variables are always made local to the buffer." ;; characters, ones which would interact syntactically with stuff outside ;; this region. ;; - ;; These are unmatched string delimiters, or unmatched - ;; parens/brackets/braces. An unclosed comment is regarded as valid, NOT - ;; obtrusive. + ;; These are unmatched parens/brackets/braces. An unclosed comment is + ;; regarded as valid, NOT obtrusive. Unbalanced strings are handled + ;; elsewhere. (save-excursion (let (s) (while @@ -1008,9 +1061,11 @@ Note that the style variables are always made local to the buffer." ((< (nth 0 s) 0) ; found an unmated ),},] (c-put-char-property (1- (point)) 'syntax-table '(1)) t) - ((nth 3 s) ; In a string - (c-put-char-property (nth 8 s) 'syntax-table '(1)) - t) + ;; Unbalanced strings are now handled by + ;; `c-before-change-check-unbalanced-strings', etc. + ;; ((nth 3 s) ; In a string + ;; (c-put-char-property (nth 8 s) 'syntax-table '(1)) + ;; t) ((> (nth 0 s) 0) ; In a (,{,[ (c-put-char-property (nth 1 s) 'syntax-table '(1)) t) @@ -1070,6 +1125,472 @@ Note that the style variables are always made local to the buffer." (forward-line)) ; no infinite loop with, e.g., "#//" ))))) +(defun c-unescaped-nls-in-string-p (&optional quote-pos) + ;; Return whether unescaped newlines can be inside strings. + ;; + ;; QUOTE-POS, if present, is the position of the opening quote of a string. + ;; Depending on the language, there might be a special character before it + ;; signifying the validity of such NLs. + (cond + ((null c-multiline-string-start-char) nil) + ((c-characterp c-multiline-string-start-char) + (and quote-pos + (eq (char-before quote-pos) c-multiline-string-start-char))) + (t t))) + +(defun c-multiline-string-start-is-being-detached (end) + ;; If (e.g.), the # character in Pike is being detached from the string + ;; opener it applies to, return t. Else return nil. END is the argument + ;; supplied to every before-change function. + (and (memq (char-after end) c-string-delims) + (c-characterp c-multiline-string-start-char) + (eq (char-before end) c-multiline-string-start-char))) + +(defun c-pps-to-string-delim (end) + ;; parse-partial-sexp forward to the next string quote, which is deemed to + ;; be a closing quote. Return nil. + ;; + ;; We remove string-fence syntax-table text properties from characters we + ;; pass over. + (let* ((start (point)) + (no-st-s `(0 nil nil ?\" nil nil 0 nil ,start nil nil)) + (st-s `(0 nil nil t nil nil 0 nil ,start nil nil)) + no-st-pos st-pos + ) + (parse-partial-sexp start end nil nil no-st-s 'syntax-table) + (setq no-st-pos (point)) + (goto-char start) + (while (progn + (parse-partial-sexp (point) end nil nil st-s 'syntax-table) + (unless (bobp) + (c-clear-char-property (1- (point)) 'syntax-table)) + (setq st-pos (point)) + (and (< (point) end) + (not (eq (char-before) ?\"))))) + (goto-char (min no-st-pos st-pos)) + nil)) + +(defun c-multiline-string-check-final-quote () + ;; Check that the final quote in the buffer is correctly marked or not with + ;; a string-fence syntax-table text propery. The return value has no + ;; significance. + (let (pos-ll pos-lt) + (save-excursion + (goto-char (point-max)) + (skip-chars-backward "^\"") + (while + (and + (not (bobp)) + (cond + ((progn + (setq pos-ll (c-literal-limits) + pos-lt (c-literal-type pos-ll)) + (memq pos-lt '(c c++))) + ;; In a comment. + (goto-char (car pos-ll))) + ((save-excursion + (backward-char) ; over " + (c-is-escaped (point))) + ;; At an escaped string. + (backward-char) + t) + (t + ;; At a significant " + (c-clear-char-property (1- (point)) 'syntax-table) + (setq pos-ll (c-literal-limits) + pos-lt (c-literal-type pos-ll)) + nil))) + (skip-chars-backward "^\"")) + (cond + ((bobp)) + ((eq pos-lt 'string) + (c-put-char-property (1- (point)) 'syntax-table '(15))) + (t nil))))) + +(defvar c-fl-syn-tab-region nil) + ;; Non-nil when a `c-restore-string-fences' is "in force". It's value is a + ;; cons of the BEG and END of the region currently "mirroring" the + ;; c-fl-syn-tab properties as syntax-table properties. + +(defun c-clear-string-fences () + ;; Clear syntax-table text properties in the region defined by + ;; `c-cl-syn-tab-region' which are "mirrored" by c-fl-syn-tab text + ;; properties. However, any such " character which ends up not being + ;; balanced by another " is left with a '(1) syntax-table property. + (when c-fl-syn-tab-region + (let ((beg (car c-fl-syn-tab-region)) + (end (cdr c-fl-syn-tab-region)) + s pos) + (setq pos beg) + (while + (and + (< pos end) + (setq pos + (c-min-property-position pos end 'c-fl-syn-tab)) + (< pos end)) + (c-clear-char-property pos 'syntax-table) + (setq pos (1+ pos))) + ;; Check we haven't left any unbalanced "s. + (save-excursion + (setq pos beg) + (while (< pos end) + (setq pos + (c-min-property-position pos end 'c-fl-syn-tab)) + (when (< pos end) + (if (memq (char-after pos) c-string-delims) + (progn + ;; Step over the ". + (setq s (parse-partial-sexp pos end nil nil nil + 'syntax-table)) + ;; Seek a (bogus) matching ". + (setq s (parse-partial-sexp (point) end nil nil s + 'syntax-table)) + ;; When a bogus matching " is found, do nothing. + ;; Otherwise mark the " with 'syntax-table '(1). + (unless + (and ;(< (point) end) + (not (nth 3 s)) + (c-get-char-property (1- (point)) 'c-fl-syn-tab)) + (c-put-char-property pos 'syntax-table '(1))) + (setq pos (point))) + (setq pos (1+ pos)))))) + (setq c-fl-syn-tab-region nil)))) + +(defun c-restore-string-fences (beg end) + ;; Restore any syntax-table text properties in the region (BEG END) which + ;; are "mirrored" by c-fl-syn-tab text properties. + (let ((pos beg)) + (while + (and + (< pos end) + (setq pos + (c-min-property-position pos end 'c-fl-syn-tab)) + (< pos end)) + (c-put-char-property pos 'syntax-table + (c-get-char-property pos 'c-fl-syn-tab)) + (setq pos (1+ pos))) + (setq c-fl-syn-tab-region (cons beg end)))) + +(defvar c-bc-changed-stringiness nil) +;; Non-nil when, in a before-change function, the deletion of a range of text +;; will change the "stringiness" of the subsequent text. Only used when +;; `c-multiline-sting-start-char' is a non-nil value which isn't a character. + +(defun c-remove-string-fences (&optional here) + ;; The character after HERE (default point) is either a string delimiter or + ;; a newline, which is marked with a string fence text property for both + ;; syntax-table and c-fl-syn-tab. Remove these properties from that + ;; character and its matching newline or string delimiter, if any (there may + ;; not be one if there is a missing newline at EOB). + (save-excursion + (if here + (goto-char here) + (setq here (point))) + (cond + ((memq (char-after) c-string-delims) + (save-excursion + (save-match-data + (forward-char) + (if (and (c-search-forward-char-property 'syntax-table '(15)) + (memq (char-before) '(?\n ?\r))) + (c-clear-syn-tab (1- (point)))))) + (c-clear-syn-tab (point))) + ((memq (char-after) '(?\n ?\r)) + (save-excursion + (save-match-data + (when (and (c-search-backward-char-property 'syntax-table '(15)) + (memq (char-after) c-string-delims)) + (c-clear-syn-tab (point))))) + (c-clear-syn-tab (point))) + (t (c-benign-error "c-remove-string-fences: wrong position"))))) + +(defun c-before-change-check-unbalanced-strings (beg end) + ;; If BEG or END is inside an unbalanced string, remove the syntax-table + ;; text property from respectively the start or end of the string. Also + ;; extend the region (c-new-BEG c-new-END) as necessary to cope with the + ;; coming change involving the insertion or deletion of an odd number of + ;; quotes. + ;; + ;; POINT is undefined both at entry to and exit from this function, the + ;; buffer will have been widened, and match data will have been saved. + ;; + ;; This function is called exclusively as a before-change function via + ;; `c-get-state-before-change-functions'. + (c-save-buffer-state + ((end-limits + (progn + (goto-char (if (c-multiline-string-start-is-being-detached end) + (1+ end) + end)) + (c-literal-limits))) + (end-literal-type (and end-limits + (c-literal-type end-limits))) + (beg-limits + (progn + (goto-char beg) + (c-literal-limits))) + (beg-literal-type (and beg-limits + (c-literal-type beg-limits)))) + + ;; It is possible the buffer change will include inserting a string quote. + ;; This could have the effect of flipping the meaning of any following + ;; quotes up until the next unescaped EOL. Also guard against the change + ;; being the insertion of \ before an EOL, escaping it. + (cond + ((c-characterp c-multiline-string-start-char) + ;; The text about to be inserted might contain a multiline string + ;; opener. Set c-new-END after anything which might be affected. + ;; Go to the end of the putative multiline string. + (goto-char end) + (c-pps-to-string-delim (point-max)) + (when (< (point) (point-max)) + (while + (and + (progn + (while + (and + (c-syntactic-re-search-forward + (if c-single-quotes-quote-strings + "[\"']\\|\\s|" + "\"\\|\\s|") + (point-max) t t) + (progn + (c-clear-syn-tab (1- (point))) + (not (memq (char-before) c-string-delims))))) + (memq (char-before) c-string-delims)) + (progn + (c-pps-to-string-delim (point-max)) + (< (point) (point-max)))))) + (setq c-new-END (max (point) c-new-END))) + + (c-multiline-string-start-char + (setq c-bc-changed-stringiness + (not (eq (eq end-literal-type 'string) + (eq beg-literal-type 'string)))) + ;; Deal with deletion of backslashes before "s. + (goto-char end) + (if (and (looking-at (if c-single-quotes-quote-strings + "\\\\*[\"']" + "\\\\*\"")) + (c-is-escaped (point))) + (setq c-bc-changed-stringiness (not c-bc-changed-stringiness))) + (if (eq beg-literal-type 'string) + (setq c-new-BEG (min (car beg-limits) c-new-BEG)))) + + ((< end (point-max)) + ;; Have we just escaped a newline by deleting characters? + (if (and (eq end-literal-type 'string) + (memq (char-after end) '(?\n ?\r))) + (cond + ;; Are we escaping a newline by deleting stuff between \ and \n? + ((and (> end beg) + (c-will-be-escaped end beg end)) + (c-remove-string-fences end) + (goto-char (1+ end))) + ;; Are we unescaping a newline by inserting stuff between \ and \n? + ((and (eq end beg) + (c-is-escaped end)) + (goto-char (1+ end))) ; To after the NL which is being unescaped. + (t + (goto-char end))) + (goto-char end)) + + ;; Move to end of logical line (as it will be after the change, or as it + ;; was before unescaping a NL.) + (re-search-forward "\\(\\\\\\(.\\|\n\\|\r\\)\\|[^\\\n\r]\\)*" nil t) + ;; We're at an EOLL or point-max. + (if (equal (c-get-char-property (point) 'syntax-table) '(15)) + (if (memq (char-after) '(?\n ?\r)) + ;; Normally terminated invalid string. + (c-remove-string-fences) + ;; Opening " at EOB. + (c-clear-syn-tab (1- (point)))) + (when (and (c-search-backward-char-property 'syntax-table '(15) c-new-BEG) + (memq (char-after) c-string-delims)) ; Ignore an unterminated raw string's (. + ;; Opening " on last line of text (without EOL). + (c-remove-string-fences) + (setq c-new-BEG (min c-new-BEG (point)))))) + + (t (goto-char end) ; point-max + (when + (and + (c-search-backward-char-property 'syntax-table '(15) c-new-BEG) + (memq (char-after) c-string-delims)) + (c-remove-string-fences)))) + + (unless + (or (and + ;; Don't set c-new-BEG/END if we're in a raw string. + (eq beg-literal-type 'string) + (c-at-c++-raw-string-opener (car beg-limits))) + (and c-multiline-string-start-char + (not (c-characterp c-multiline-string-start-char)))) + (when (and (eq end-literal-type 'string) + (not (eq (char-before (cdr end-limits)) ?\())) + (c-remove-string-fences (1- (cdr end-limits))) + (setq c-new-END (max c-new-END (cdr end-limits)))) + + (when (and (eq beg-literal-type 'string) + (memq (char-after (car beg-limits)) c-string-delims)) + (c-remove-string-fences (car beg-limits)) + (setq c-new-BEG (min c-new-BEG (car beg-limits))))))) + +(defun c-after-change-mark-abnormal-strings (beg end _old-len) + ;; Mark any unbalanced strings in the region (c-new-BEG c-new-END) with + ;; string fence syntax-table text properties. + ;; + ;; POINT is undefined both at entry to and exit from this function, the + ;; buffer will have been widened, and match data will have been saved. + ;; + ;; This function is called exclusively as an after-change function via + ;; `c-before-font-lock-functions'. + (if (and c-multiline-string-start-char + (not (c-characterp c-multiline-string-start-char))) + ;; Only the last " might need to be marked. + (c-save-buffer-state + ((beg-literal-limits + (progn (goto-char beg) (c-literal-limits))) + (beg-literal-type (c-literal-type beg-literal-limits)) + end-literal-limits end-literal-type) + (when (and (eq beg-literal-type 'string) + (c-get-char-property (car beg-literal-limits) 'syntax-table)) + (c-clear-syn-tab (car beg-literal-limits)) + (setq c-bc-changed-stringiness (not c-bc-changed-stringiness))) + (setq end-literal-limits (progn (goto-char end) (c-literal-limits)) + end-literal-type (c-literal-type end-literal-limits)) + ;; Deal with the insertion of backslashes before a ". + (goto-char end) + (if (and (looking-at "\\\\*\"") + (eq (logand (skip-chars-backward "\\\\" beg) 1) 1)) + (setq c-bc-changed-stringiness (not c-bc-changed-stringiness))) + (when (eq (eq (eq beg-literal-type 'string) + (eq end-literal-type 'string)) + c-bc-changed-stringiness) + (c-multiline-string-check-final-quote))) + ;; There could be several "s needing marking. + (c-save-buffer-state + ((cll (progn (goto-char c-new-BEG) + (c-literal-limits))) + (beg-literal-type (and cll (c-literal-type cll))) + (beg-limits + (cond + ((and (eq beg-literal-type 'string) + (c-unescaped-nls-in-string-p (car cll))) + (cons + (car cll) + (progn + (goto-char (1+ (car cll))) + (search-forward-regexp + (cdr (assq (char-after (car cll)) c-string-innards-re-alist)) + nil t) + (min (1+ (point)) (point-max))))) + ((and (null beg-literal-type) + (goto-char beg) + (and (not (bobp)) + (eq (char-before) c-multiline-string-start-char)) + (memq (char-after) c-string-delims)) + (cons (point) + (progn + (forward-char) + (search-forward-regexp + (cdr (assq (char-before) c-string-innards-re-alist)) nil t) + (1+ (point))))) + (cll))) + (end-hwm ; the highest position which could possibly be affected by + ; insertion/deletion of string delimiters. + (max + (progn + (goto-char (min (1+ end) ; 1+, in case a NL has become escaped. + (point-max))) + (re-search-forward "\\(\\\\\\(.\\|\n\\|\r\\)\\|[^\\\n\r]\\)*" + nil t) + (point)) + c-new-END)) + s) + (goto-char + (cond ((null beg-literal-type) + c-new-BEG) + ((eq beg-literal-type 'string) + (car beg-limits)) + (t ; comment + (cdr beg-limits)))) + ;; Handle one string each time around the next while loop. + (while + (and + (< (point) end-hwm) + (progn + ;; Skip over any comments before the next string. + (while (progn + (setq s (parse-partial-sexp (point) end-hwm nil + nil s 'syntax-table)) + (and (< (point) end-hwm) + (or (not (nth 3 s)) + (not (memq (char-before) c-string-delims)))))) + ;; We're at the start of a string. + (and (memq (char-before) c-string-delims) + (not (nth 4 s))))) ; Check we're actually out of the + ; comment. not stuck at EOB + (unless (and (c-major-mode-is 'c++-mode) + (c-maybe-re-mark-raw-string)) + (if (c-unescaped-nls-in-string-p (1- (point))) + (looking-at "\\(\\\\\\(.\\|\n\\)\\|[^\"]\\)*") + (looking-at (cdr (assq (char-before) c-string-innards-re-alist)))) + (cond + ((memq (char-after (match-end 0)) '(?\n ?\r)) + (c-put-syn-tab (1- (point)) '(15)) + (c-put-syn-tab (match-end 0) '(15)) + (setq c-new-BEG (min c-new-BEG (point)) + c-new-END (max c-new-END (match-end 0)))) + ((or (eq (match-end 0) (point-max)) + (eq (char-after (match-end 0)) ?\\)) ; \ at EOB + (c-put-syn-tab (1- (point)) '(15)) + (setq c-new-BEG (min c-new-BEG (point)) + c-new-END (max c-new-END (match-end 0))) ; Do we need c-new-END? + )) + (goto-char (min (1+ (match-end 0)) (point-max)))) + (setq s nil))))) + +(defun c-after-change-escape-NL-in-string (beg end _old_len) + ;; If a backslash has just been inserted into a string, and this quotes an + ;; existing newline, remove the string fence syntax-table text properties + ;; on what has become the tail of the string. + ;; + ;; POINT is undefined both at entry to and exit from this function, the + ;; buffer will have been widened, and match data will have been saved. + ;; + ;; This function is called exclusively as an after-change function via + ;; `c-before-font-lock-functions'. In C++ Mode, it should come before + ;; `c-after-change-unmark-raw-strings' in that lang variable. + (let (lit-start ; Don't calculate this till we have to. + lim) + (when + (and (> end beg) + (memq (char-after end) '(?\n ?\r)) + (c-is-escaped end) + (progn (goto-char end) + (setq lit-start (c-literal-start))) + (memq (char-after lit-start) c-string-delims) + (or (not (c-major-mode-is 'c++-mode)) + (progn + (goto-char lit-start) + (and (not (and (eq (char-before) ?R) + (looking-at c-c++-raw-string-opener-1-re))) + (not (and (eq (char-after) ?\() + (equal (c-get-char-property + (point) 'syntax-table) + '(15)))))) + (save-excursion + (c-beginning-of-macro)))) + (goto-char (1+ end)) ; After the \ + ;; Search forward for EOLL + (setq lim (re-search-forward "\\(\\\\\\(.\\|\n\\)\\|[^\\\n\r]\\)*" + nil t)) + (goto-char (1+ end)) + (when (c-search-forward-char-property-with-value-on-char + 'syntax-table '(15) ?\" lim) + (c-remove-string-fences end) + (c-remove-string-fences (1- (point))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Parsing of quotes. ;; @@ -1086,7 +1607,7 @@ Note that the style variables are always made local to the buffer." (defconst c-maybe-quoted-number-head (concat "\\(0\\(" - "\\([Xx]\\([0-9a-fA-F]\\('[0-9a-fA-F]\\|[0-9a-fA-F]\\)*'?\\)?\\)" + "\\([Xx]\\([[:xdigit:]]\\('[[:xdigit:]]\\|[[:xdigit:]]\\)*'?\\)?\\)" "\\|" "\\([Bb]\\([01]\\('[01]\\|[01]\\)*'?\\)?\\)" "\\|" @@ -1106,7 +1627,7 @@ Note that the style variables are always made local to the buffer." (save-excursion (let ((here (point)) found) - (skip-chars-backward "0-9a-fA-F'") + (skip-chars-backward "[:xdigit:]'") (if (and (memq (char-before) '(?x ?X)) (eq (char-before (1- (point))) ?0)) (backward-char 2)) @@ -1120,7 +1641,7 @@ Note that the style variables are always made local to the buffer." (defconst c-maybe-quoted-number-tail (concat "\\(" - "\\([xX']?[0-9a-fA-F]\\('[0-9a-fA-F]\\|[0-9a-fA-F]\\)*\\)" + "\\([xX']?[[:xdigit:]]\\('[[:xdigit:]]\\|[[:xdigit:]]\\)*\\)" "\\|" "\\([bB']?[01]\\('[01]\\|[01]\\)*\\)" "\\|" @@ -1140,7 +1661,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (defconst c-maybe-quoted-number (concat "\\(0\\(" - "\\([Xx][0-9a-fA-F]\\('[0-9a-fA-F]\\|[0-9a-fA-F]\\)*\\)" + "\\([Xx][[:xdigit:]]\\('[[:xdigit:]]\\|[[:xdigit:]]\\)*\\)" "\\|" "\\([Bb][01]\\('[01]\\|[01]\\)*\\)" "\\|" @@ -1158,9 +1679,9 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (when c-has-quoted-numbers (save-excursion (let ((here (point)) - (bound (progn (skip-chars-forward "0-9a-fA-F'") (point)))) + (bound (progn (skip-chars-forward "[:xdigit:]'") (point)))) (goto-char here) - (when (< (skip-chars-backward "0-9a-fA-F'") 0) + (when (< (skip-chars-backward "[:xdigit:]'") 0) (if (and (memq (char-before) '(?x ?X)) (eq (char-before (1- (point))) ?0)) (backward-char 2)) @@ -1172,7 +1693,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (goto-char (match-beginning 0)) (save-excursion (search-forward "'" (match-end 0) t))))))))) -(defun c-parse-quotes-before-change (beg end) +(defun c-parse-quotes-before-change (_beg _end) ;; This function analyzes 's near the region (c-new-BEG c-new-END), amending ;; those two variables as needed to include 's into that region when they ;; might be syntactically relevant to the change in progress. @@ -1184,7 +1705,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; ;; This function is called exclusively as a before-change function via the ;; variable `c-get-state-before-change-functions'. - (c-save-buffer-state () + (c-save-buffer-state (case-fold-search) (goto-char c-new-BEG) ;; We need to scan for 's from the BO (logical) line. (beginning-of-line) @@ -1200,14 +1721,17 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ((c-quoted-number-head-before-point) (if (>= (point) c-new-BEG) (setq c-new-BEG (match-beginning 0)))) - ((looking-at "\\([^'\\]\\|\\\\.\\)'") + ((looking-at + "\\([^'\\]\\|\\\\\\([0-7]\\{1,3\\}\\|[xuU][[:xdigit:]]+\\|.\\)\\)'") (goto-char (match-end 0)) (if (> (match-end 0) c-new-BEG) (setq c-new-BEG (1- (match-beginning 0))))) - ((or (>= (point) (1- c-new-BEG)) - (and (eq (point) (- c-new-BEG 2)) - (eq (char-after) ?\\))) - (setq c-new-BEG (1- (point)))) + ((looking-at "\\\\'") + (setq c-new-BEG (min c-new-BEG (1- (point)))) + (goto-char (match-end 0))) + ((save-excursion + (not (search-forward "'" c-new-BEG t))) + (setq c-new-BEG (min c-new-BEG (1- (point))))) (t nil))) (goto-char c-new-END) @@ -1226,19 +1750,29 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (goto-char (match-end 0)) (if (> (match-end 0) c-new-END) (setq c-new-END (match-end 0)))) - ((looking-at "\\([^'\\]\\|\\\\.\\)'") + ((looking-at + "\\([^'\\]\\|\\\\\\([0-7]\\{1,3\\}\\|[xuU][[:xdigit:]]+\\|.\\)\\)'") (goto-char (match-end 0)) (if (> (match-end 0) c-new-END) (setq c-new-END (match-end 0)))) + ((looking-at "\\\\'") + (goto-char (match-end 0)) + (setq c-new-END (max c-new-END (point)))) + ((equal (c-get-char-property (1- (point)) 'syntax-table) '(1)) + (when (c-search-forward-char-property-with-value-on-char + 'syntax-table '(1) ?\' (c-point 'eoll)) + (setq c-new-END (max (point) c-new-END)))) (t nil))) ;; Having reached c-new-END, handle any 's after it whose context may be - ;; changed by the current buffer change. + ;; changed by the current buffer change. The idea is to catch + ;; monstrosities like ',',',',',' changing "polarity". (goto-char c-new-END) (cond ((c-quoted-number-tail-after-point) (setq c-new-END (match-end 0))) ((looking-at - "\\(\\\\.\\|.\\)?\\('\\([^'\\]\\|\\\\.\\)\\)*'") + "\\(\\\\\\([0-7]\\{1,3\\}\\|[xuU][[:xdigit:]]+\\|.\\)\\|.\\)?\ +\\('\\([^'\\]\\|\\\\\\([0-7]\\{1,3\\}\\|[xuU][[:xdigit:]]+\\|.\\)\\)\\)*'") (setq c-new-END (match-end 0)))) ;; Remove the '(1) syntax-table property from any "'"s within (c-new-BEG @@ -1247,7 +1781,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (when (c-search-forward-char-property-with-value-on-char 'syntax-table '(1) ?\' c-new-END) (c-invalidate-state-cache (1- (point))) - (c-truncate-semi-nonlit-pos-cache (1- (point))) + (c-truncate-lit-pos-cache (1- (point))) (c-clear-char-property-with-value-on-char (1- (point)) c-new-END 'syntax-table '(1) @@ -1259,7 +1793,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") 'c-digit-separator t ?'))))) -(defun c-parse-quotes-after-change (beg end old-len) +(defun c-parse-quotes-after-change (_beg _end _old-len) ;; This function applies syntax-table properties (value '(1)) and ;; c-digit-separator properties as needed to 's within the range (c-new-BEG ;; c-new-END). This operation is performed even within strings and @@ -1267,33 +1801,37 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; ;; This function is called exclusively as an after-change function via the ;; variable `c-before-font-lock-functions'. - (c-save-buffer-state (num-beg num-end) + (c-save-buffer-state (num-beg num-end case-fold-search) ;; Apply the needed syntax-table and c-digit-separator text properties to ;; quotes. (save-restriction (goto-char c-new-BEG) (while (and (< (point) c-new-END) (search-forward "'" c-new-END 'limit)) - (cond ((and (eq (char-before (1- (point))) ?\\) - ;; Check we've got an odd number of \s, here. - (save-excursion - (backward-char) - (eq (logand (skip-chars-backward "\\\\") 1) 1)))) ; not a real '. + (cond ((c-is-escaped (1- (point)))) ; not a real '. ((c-quoted-number-straddling-point) (setq num-beg (match-beginning 0) num-end (match-end 0)) (c-invalidate-state-cache num-beg) - (c-truncate-semi-nonlit-pos-cache num-beg) + (c-truncate-lit-pos-cache num-beg) (c-put-char-properties-on-char num-beg num-end 'syntax-table '(1) ?') (c-put-char-properties-on-char num-beg num-end 'c-digit-separator t ?') (goto-char num-end)) - ((looking-at "\\([^\\']\\|\\\\.\\)'") ; balanced quoted expression. + ((looking-at + "\\([^\\']\\|\\\\\\([0-7]\\{1,3\\}\\|[xuU][[:xdigit:]]+\\|.\\)\ +\\)'") ; balanced quoted expression. + (goto-char (match-end 0))) + ((looking-at "\\\\'") ; Anomalous construct. + (c-invalidate-state-cache (1- (point))) + (c-truncate-lit-pos-cache (1- (point))) + (c-put-char-properties-on-char (1- (point)) (+ (point) 2) + 'syntax-table '(1) ?') (goto-char (match-end 0))) (t (c-invalidate-state-cache (1- (point))) - (c-truncate-semi-nonlit-pos-cache (1- (point))) + (c-truncate-lit-pos-cache (1- (point))) (c-put-char-property (1- (point)) 'syntax-table '(1)))) ;; Prevent the next `c-quoted-number-straddling-point' getting ;; confused by already processed single quotes. @@ -1322,78 +1860,94 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; (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) - (save-restriction - (save-match-data - (widen) - (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 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 - 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 - (while - (and (/= (skip-chars-backward "^;{}") 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) - (skip-chars-forward "^;{}") ;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)) - ))) - ;; 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))) + ;; 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)) + (unwind-protect + (progn + (c-restore-string-fences (point-min) (point-max)) + (save-restriction + (save-match-data + (widen) + (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 + 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 + (while + (and (/= (skip-chars-backward "^;{}") 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) + (skip-chars-forward "^;{}") ;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)) + ))) + ;; 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) + (c-truncate-lit-pos-cache beg)) + (c-clear-string-fences)))) (defvar c-in-after-change-fontification nil) (make-variable-buffer-local 'c-in-after-change-fontification) @@ -1418,7 +1972,8 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; without an intervening call to `before-change-functions' when reverting ;; the buffer (see bug #24094). Whatever the cause, assume that the entire ;; buffer has changed. - (when (not c-just-done-before-change) + (when (and (not c-just-done-before-change) + (not (c-called-from-text-property-change-p))) (save-restriction (widen) (c-before-change (point-min) (point-max)) @@ -1429,7 +1984,6 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; (c-new-BEG c-new-END) will be the region to fontify. It may become ;; larger than (beg end). (setq c-new-END (- (+ c-new-END (- end beg)) old-len)) - (setq c-old-BEG c-new-BEG c-old-END c-new-END) (unless (c-called-from-text-property-change-p) (setq c-just-done-before-change nil) @@ -1437,43 +1991,85 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; When `combine-after-change-calls' is used we might get calls ;; with regions outside the current narrowing. This has been ;; observed in Emacs 20.7. - (save-restriction - (save-match-data ; c-recognize-<>-arglists changes match-data - (widen) - - (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))))))) + (unwind-protect + (progn + (c-restore-string-fences (point-min) (point-max)) + (save-restriction + (save-match-data ; c-recognize-<>-arglists changes match-data + (widen) + + (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)))) + ;; 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))) + +(defun c-doc-fl-decl-start (pos) + ;; If the line containing POS is in a doc comment continued line (as defined + ;; by `c-doc-line-join-re'), return the position of the first line of the + ;; sequence. Otherwise, return nil. Point has no significance at entry to + ;; and exit from this function. + (when (not (equal c-doc-line-join-re regexp-unmatchable)) + (goto-char pos) + (back-to-indentation) + (and (or (looking-at c-comment-start-regexp) + (memq (c-literal-type (c-literal-limits)) '(c c++))) + (progn + (end-of-line) + (let ((here (point))) + (while (re-search-backward c-doc-line-join-re (c-point 'bopl) t)) + (and (not (eq (point) here)) + (c-point 'bol))))))) + +(defun c-doc-fl-decl-end (pos) + ;; If the line containing POS is continued by a doc comment continuation + ;; marker (as defined by `c-doc-line-join-re), return the position of + ;; the BOL at the end of the sequence. Otherwise, return nil. Point has no + ;; significance at entry to and exit from this function. + (when (not (equal c-doc-line-join-re regexp-unmatchable)) + (goto-char pos) + (back-to-indentation) + (let ((here (point))) + (while (re-search-forward c-doc-line-join-re (c-point 'eonl) t)) + (and (not (eq (point) here)) + (c-point 'bonl))))) (defun c-fl-decl-start (pos) ;; If the beginning of the line containing POS is in the middle of a "local" @@ -1482,6 +2078,9 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; declaration is one which does not start outside of struct braces (and ;; similar) enclosing POS. Brace list braces here are not "similar". ;; + ;; POS being in a literal does not count as being in a declaration (on + ;; pragmatic grounds). + ;; ;; This function is called indirectly from font locking stuff - either from ;; c-after-change (to prepare for after-change font-locking) or from font ;; lock context (etc.) fontification. @@ -1492,83 +2091,91 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") capture-opener bod-lim bo-decl) (goto-char (c-point 'bol new-pos)) - (when lit-start ; Comment or string. - (goto-char lit-start)) - (setq bod-lim (c-determine-limit 500)) - - ;; In C++ Mode, first check if we are within a (possibly nested) lambda - ;; form capture list. - (when (c-major-mode-is 'c++-mode) - (let ((paren-state (c-parse-state)) - opener) + (unless lit-start + (setq bod-lim (c-determine-limit 500)) + + ;; In C++ Mode, first check if we are within a (possibly nested) lambda + ;; form capture list. + (when (c-major-mode-is 'c++-mode) (save-excursion - (while (setq opener (c-pull-open-brace paren-state)) - (goto-char opener) - (if (c-looking-at-c++-lambda-capture-list) - (setq capture-opener (point))))))) + (while (and (c-go-up-list-backward nil bod-lim) + (c-looking-at-c++-lambda-capture-list)) + (setq capture-opener (point))))) - (while - ;; Go to a less nested declaration each time round this loop. - (and - (setq old-pos (point)) - (c-syntactic-skip-backward "^;{}" bod-lim t) - (> (point) bod-lim) - (progn (c-forward-syntactic-ws) - ;; Have we got stuck in a comment at EOB? - (not (and (eobp) - (c-literal-start)))) - (< (point) old-pos) - (progn (setq bo-decl (point)) - (or (not (looking-at c-protection-key)) - (c-forward-keyword-clause 1))) - (progn - ;; Are we looking at a keyword such as "template" or - ;; "typedef" which can decorate a type, or the type itself? - (when (or (looking-at c-prefix-spec-kwds-re) - (c-forward-type t)) - ;; We've found another candidate position. - (setq new-pos (min new-pos bo-decl)) - (goto-char bo-decl)) - t) - ;; Try and go out a level to search again. - (progn - (c-backward-syntactic-ws bod-lim) - (and (> (point) bod-lim) - (or (memq (char-before) '(?\( ?\[)) - (and (eq (char-before) ?\<) - (eq (c-get-char-property - (1- (point)) 'syntax-table) - c-<-as-paren-syntax)) - (and (eq (char-before) ?{) - (save-excursion - (backward-char) - (consp (c-looking-at-or-maybe-in-bracelist)))) - ))) - (not (bobp))) - (backward-char)) ; back over (, [, <. - (when (and capture-opener (< capture-opener new-pos)) - (setq new-pos capture-opener)) - (and (/= new-pos pos) new-pos))) + (while + ;; Go to a less nested declaration each time round this loop. + (and + (setq old-pos (point)) + (let (pseudo) + (while + (progn + (c-syntactic-skip-backward "^;{}" bod-lim t) + (and (eq (char-before) ?}) + (save-excursion + (backward-char) + (setq pseudo (c-cheap-inside-bracelist-p (c-parse-state)))))) + (goto-char pseudo)) + t) + (> (point) bod-lim) + (progn (c-forward-syntactic-ws) + ;; Have we got stuck in a comment at EOB? + (not (and (eobp) + (c-literal-start)))) + (< (point) old-pos) + (progn (setq bo-decl (point)) + (or (not (looking-at c-protection-key)) + (c-forward-keyword-clause 1))) + (progn + ;; Are we looking at a keyword such as "template" or + ;; "typedef" which can decorate a type, or the type itself? + (when (or (looking-at c-prefix-spec-kwds-re) + (c-forward-type t)) + ;; We've found another candidate position. + (setq new-pos (min new-pos bo-decl)) + (goto-char bo-decl)) + t) + ;; Try and go out a level to search again. + (progn + (c-backward-syntactic-ws bod-lim) + (and (> (point) bod-lim) + (or (memq (char-before) '(?\( ?\[)) + (and (eq (char-before) ?\<) + (eq (c-get-char-property + (1- (point)) 'syntax-table) + c-<-as-paren-syntax)) + (and (eq (char-before) ?{) + (save-excursion + (backward-char) + (consp (c-looking-at-or-maybe-in-bracelist)))) + ))) + (not (bobp))) + (backward-char)) ; back over (, [, <. + (when (and capture-opener (< capture-opener new-pos)) + (setq new-pos capture-opener)) + (and (/= new-pos pos) new-pos)))) (defun c-fl-decl-end (pos) ;; If POS is inside a declarator, return the end of the token that follows - ;; the declarator, otherwise return nil. + ;; the declarator, otherwise return nil. POS being in a literal does not + ;; count as being in a declarator (on pragmatic grounds). (goto-char pos) (let ((lit-start (c-literal-start)) - pos1) - (if lit-start (goto-char lit-start)) - (c-backward-syntactic-ws) - (when (setq pos1 (c-on-identifier)) - (goto-char pos1) - (let ((lim (save-excursion - (and (c-beginning-of-macro) - (progn (c-end-of-macro) (point)))))) - (when (and (c-forward-declarator lim) - (or (not (eq (char-after) ?\()) - (c-go-list-forward nil lim)) - (eq (c-forward-token-2 1 nil lim) 0)) - (c-backward-syntactic-ws) - (point)))))) + enclosing-attribute pos1) + (unless lit-start + (c-backward-syntactic-ws) + (when (setq enclosing-attribute (c-slow-enclosing-c++-attribute)) + (goto-char (car enclosing-attribute))) ; Only happens in C++ Mode. + (when (setq pos1 (c-on-identifier)) + (goto-char pos1) + (let ((lim (save-excursion + (and (c-beginning-of-macro) + (progn (c-end-of-macro) (point)))))) + (when (and (c-forward-declarator lim) + (or (not (eq (char-after) ?\()) + (c-go-list-forward nil lim)) + (eq (c-forward-token-2 1 nil lim) 0)) + (c-backward-syntactic-ws) + (point))))))) (defun c-change-expand-fl-region (_beg _end _old-len) ;; Expand the region (c-new-BEG c-new-END) to an after-change font-lock @@ -1581,9 +2188,10 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; and OLD-LEN are not used. (if font-lock-mode (setq c-new-BEG - (or (c-fl-decl-start c-new-BEG) (c-point 'bol c-new-BEG)) + (or (c-fl-decl-start c-new-BEG) (c-doc-fl-decl-start c-new-BEG) + (c-point 'bol c-new-BEG)) c-new-END - (or (c-fl-decl-end c-new-END) + (or (c-fl-decl-end c-new-END) (c-doc-fl-decl-end c-new-END) (c-point 'bonl c-new-END))))) (defun c-context-expand-fl-region (beg end) @@ -1591,8 +2199,10 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; "local" declaration containing BEG (see `c-fl-decl-start') or BOL BEG is ;; in. NEW-END is beginning of the line after the one END is in. (c-save-buffer-state () - (cons (or (c-fl-decl-start beg) (c-point 'bol beg)) - (or (c-fl-decl-end end) (c-point 'bonl (1- end)))))) + (cons (or (c-fl-decl-start beg) (c-doc-fl-decl-start beg) + (c-point 'bol beg)) + (or (c-fl-decl-end end) (c-doc-fl-decl-end end) + (c-point 'bonl (1- end)))))) (defun c-before-context-fl-expand-region (beg end) ;; Expand the region (BEG END) as specified by @@ -1655,8 +2265,12 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; Context (etc.) fontification. (setq new-region (c-before-context-fl-expand-region beg end) new-beg (car new-region) new-end (cdr new-region))) - (funcall (default-value 'font-lock-fontify-region-function) - new-beg new-end verbose))) + (c-save-buffer-state nil + (unwind-protect + (progn (c-restore-string-fences new-beg new-end) + (funcall (default-value 'font-lock-fontify-region-function) + new-beg new-end verbose)) + (c-clear-string-fences))))) (defun c-after-font-lock-init () ;; Put on `font-lock-mode-hook'. This function ensures our after-change @@ -1757,6 +2371,26 @@ This function is called from `c-common-init', once per mode initialization." (c-update-modeline))) +;; Connection with Emacs's electric-pair-mode +(defun c-electric-pair-inhibit-predicate (char) + "Return t to inhibit the insertion of a second copy of CHAR. + +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. + +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))) + (funcall (default-value 'electric-pair-inhibit-predicate) char))) + + ;; Support for C (defvar c-mode-syntax-table @@ -1835,6 +2469,7 @@ Key bindings: (c-common-init 'c-mode) (easy-menu-add c-c-menu) (cc-imenu-init cc-imenu-c-generic-expression) + (add-hook 'flymake-diagnostic-functions 'flymake-cc nil t) (c-run-mode-hooks 'c-mode-common-hook)) (defconst c-or-c++-mode--regexp @@ -1922,6 +2557,7 @@ Key bindings: (c-common-init 'c++-mode) (easy-menu-add c-c++-menu) (cc-imenu-init cc-imenu-c++-generic-expression) + (add-hook 'flymake-diagnostic-functions 'flymake-cc nil t) (c-run-mode-hooks 'c-mode-common-hook)) @@ -2000,7 +2636,7 @@ Key bindings: ;; since it's practically impossible to write a regexp that reliably ;; matches such a construct. Other tools are necessary. (defconst c-Java-defun-prompt-regexp - "^[ \t]*\\(\\(\\(public\\|protected\\|private\\|const\\|abstract\\|synchronized\\|final\\|static\\|threadsafe\\|transient\\|native\\|volatile\\)\\s-+\\)*\\(\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*[][_$.a-zA-Z0-9]+\\|[[a-zA-Z]\\)\\s-*\\)\\s-+\\)\\)?\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*\\s-+\\)\\s-*\\)?\\([_a-zA-Z][^][ \t:;.,{}()=]*\\|\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)\\)\\s-*\\(([^);{}]*)\\)?\\([] \t]*\\)\\(\\s-*\\<throws\\>\\s-*\\(\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)[, \t\n\r\f\v]*\\)+\\)?\\s-*") + "^[ \t]*\\(\\(\\(public\\|protected\\|private\\|const\\|abstract\\|synchronized\\|final\\|static\\|threadsafe\\|transient\\|native\\|volatile\\)\\s-+\\)*\\(\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*[][_$.a-zA-Z0-9]+\\|[[a-zA-Z]\\)\\s-*\\)\\s-+\\)\\)?\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*\\s-+\\)\\s-*\\)?\\([_a-zA-Z][^][ \t:;.,{}()\^?=]*\\|\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)\\)\\s-*\\(([^);{}]*)\\)?\\([] \t]*\\)\\(\\s-*\\<throws\\>\\s-*\\(\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)[, \t\n\r\f\v]*\\)+\\)?\\s-*") (easy-menu-define c-java-menu java-mode-map "Java Mode Commands" (cons "Java" (c-lang-const c-mode-menu java))) diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el index d2c41008711..92ea67128f4 100644 --- a/lisp/progmodes/cc-styles.el +++ b/lisp/progmodes/cc-styles.el @@ -68,7 +68,9 @@ (arglist-close . c-lineup-arglist) (inline-open . 0) (brace-list-open . +) - (brace-list-intro . c-lineup-arglist-intro-after-paren) + (brace-list-intro . (first + c-lineup-2nd-brace-entry-in-arglist + c-lineup-class-decl-init-+ +)) (topmost-intro-cont . (first c-lineup-topmost-intro-cont c-lineup-gnu-DEFUN-intro-cont)))) @@ -95,6 +97,9 @@ (label . 0) (statement-cont . +) (inline-open . 0) + (brace-list-intro . (first + c-lineup-2nd-brace-entry-in-arglist + c-lineup-class-decl-init-+ +)) (inexpr-class . 0)))) ("stroustrup" @@ -104,6 +109,9 @@ (substatement-open . 0) (substatement-label . 0) (label . 0) + (brace-list-intro . (first + c-lineup-2nd-brace-entry-in-arglist + c-lineup-class-decl-init-+ +)) (statement-cont . +)))) ("whitesmith" @@ -194,6 +202,9 @@ (c-offsets-alist . ((substatement-open . 0) (inextern-lang . 0) (arglist-intro . +) + (brace-list-intro . (first + c-lineup-2nd-brace-entry-in-arglist + c-lineup-class-decl-init-+ +)) (knr-argdecl-intro . +))) (c-hanging-braces-alist . ((brace-list-open) (brace-list-intro) @@ -219,6 +230,9 @@ (statement-cont . +) (arglist-intro . c-lineup-arglist-intro-after-paren) (arglist-close . c-lineup-arglist) + (brace-list-intro . (first + c-lineup-2nd-brace-entry-in-arglist + c-lineup-class-decl-init-+ +)) (access-label . 0) (inher-cont . c-lineup-java-inher) (func-decl-cont . c-lineup-java-throws)))) diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el index 30475d0ba60..54d634780ee 100644 --- a/lisp/progmodes/cc-vars.el +++ b/lisp/progmodes/cc-vars.el @@ -563,7 +563,8 @@ variable in a mode hook." (defcustom-c-stylevar c-doc-comment-style '((java-mode . javadoc) (pike-mode . autodoc) - (c-mode . gtkdoc)) + (c-mode . gtkdoc) + (c++-mode . gtkdoc)) "Specifies documentation comment style(s) to recognize. This is primarily used to fontify doc comments and the markup within them, e.g. Javadoc comments. @@ -573,7 +574,7 @@ comment styles: javadoc -- Javadoc style for \"/** ... */\" comments (default in Java mode). autodoc -- Pike autodoc style for \"//! ...\" comments (default in Pike mode). - gtkdoc -- GtkDoc style for \"/** ... **/\" comments (default in C mode). + gtkdoc -- GtkDoc style for \"/** ... **/\" comments (default in C and C++ modes). The value may also be a list of doc comment styles, in which case all of them are recognized simultaneously (presumably with markup cues @@ -1115,7 +1116,7 @@ can always override the use of `c-default-style' by making calls to ;; Anchor pos: At the brace list decl start(*). (brace-list-intro . +) ;; Anchor pos: At the brace list decl start(*). - (brace-list-entry . c-lineup-under-anchor) + (brace-list-entry . 0) ;; Anchor pos: At the first non-ws char after the open paren if ;; the first token is on the same line, otherwise boi at that ;; token. @@ -1210,7 +1211,7 @@ can always override the use of `c-default-style' by making calls to (template-args-cont . (c-lineup-template-args +)) ;; Anchor pos: Boi at the decl start. This might be changed; ;; the logical position is clearly the opening '<'. - (inlambda . c-lineup-inexpr-block) + (inlambda . 0) ;; Anchor pos: None. (lambda-intro-cont . +) ;; Anchor pos: Boi at the lambda start. @@ -1647,8 +1648,11 @@ white space either before or after the operator, but not both." :type 'boolean :group 'c) -(defvar c-noise-macro-with-parens-name-re "\\<\\>") -(defvar c-noise-macro-name-re "\\<\\>") +;; Initialize the next two to a regexp which never matches. +(defvar c-noise-macro-with-parens-name-re regexp-unmatchable) +(make-variable-buffer-local 'c-noise-macro-with-parens-name-re) +(defvar c-noise-macro-name-re regexp-unmatchable) +(make-variable-buffer-local 'c-noise-macro-name-re) (defcustom c-noise-macro-names nil "A list of names of macros which expand to nothing, or compiler extensions @@ -1663,6 +1667,7 @@ this implicitly by reinitializing C/C++/Objc Mode on any buffer)." :type '(repeat :tag "List of names" string) :group 'c) (put 'c-noise-macro-names 'safe-local-variable #'c-string-list-p) +(make-variable-buffer-local 'c-noise-macro-names) (defcustom c-noise-macro-with-parens-names nil "A list of names of macros \(or compiler extensions like \"__attribute__\") @@ -1672,12 +1677,13 @@ These are recognized by CC Mode only in declarations." :type '(repeat :tag "List of names (possibly empty)" string) :group 'c) (put 'c-noise-macro-with-parens-names 'safe-local-variable #'c-string-list-p) +(make-variable-buffer-local 'c-noise-macro-with-parens-names) (defun c-make-noise-macro-regexps () ;; Convert `c-noise-macro-names' and `c-noise-macro-with-parens-names' into ;; `c-noise-macro-name-re' and `c-noise-macro-with-parens-name-re'. (setq c-noise-macro-with-parens-name-re - (cond ((null c-noise-macro-with-parens-names) "\\<\\>") + (cond ((null c-noise-macro-with-parens-names) regexp-unmatchable) ((consp c-noise-macro-with-parens-names) (concat (regexp-opt c-noise-macro-with-parens-names t) "\\([^[:alnum:]_$]\\|$\\)")) @@ -1686,7 +1692,7 @@ These are recognized by CC Mode only in declarations." (t (error "c-make-noise-macro-regexps: \ c-noise-macro-with-parens-names is invalid: %s" c-noise-macro-with-parens-names)))) (setq c-noise-macro-name-re - (cond ((null c-noise-macro-names) "\\<\\>") + (cond ((null c-noise-macro-names) regexp-unmatchable) ((consp c-noise-macro-names) (concat (regexp-opt c-noise-macro-names t) "\\([^[:alnum:]_$]\\|$\\)")) diff --git a/lisp/progmodes/cfengine.el b/lisp/progmodes/cfengine.el index a86cb53ceb9..efe648bc034 100644 --- a/lisp/progmodes/cfengine.el +++ b/lisp/progmodes/cfengine.el @@ -852,8 +852,8 @@ This includes those for cfservd as well as cfagent.") ;; Classes. ("^[ \t]*\\([[:alnum:]_().|!]+\\)::" 1 font-lock-function-name-face) ;; Variables. - ("$(\\([[:alnum:]_]+\\))" 1 font-lock-variable-name-face) - ("${\\([[:alnum:]_]+\\)}" 1 font-lock-variable-name-face) + ("\\$(\\([[:alnum:]_]+\\))" 1 font-lock-variable-name-face) + ("\\${\\([[:alnum:]_]+\\)}" 1 font-lock-variable-name-face) ;; Variable definitions. ("\\_<\\([[:alnum:]_]+\\)[ \t]*=[ \t]*(" 1 font-lock-variable-name-face) ;; File, acl &c in group: { token ... } diff --git a/lisp/progmodes/cmacexp.el b/lisp/progmodes/cmacexp.el index 787d8d47a6f..a081c023079 100644 --- a/lisp/progmodes/cmacexp.el +++ b/lisp/progmodes/cmacexp.el @@ -383,7 +383,8 @@ Optional arg DISPLAY non-nil means show messages in the echo area." (not (member (file-name-nondirectory shell-file-name) msdos-shells))) (eq exit-status 0)) - (zerop (nth 7 (file-attributes (expand-file-name tempname)))) + (zerop (file-attribute-size + (file-attributes (expand-file-name tempname)))) (progn (goto-char (point-min)) ;; Put the messages inside a comment, so they won't get in diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 49b79de5851..4cc1daf4fa6 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -43,23 +43,20 @@ ;;;###autoload (defcustom compilation-mode-hook nil "List of hook functions run by `compilation-mode'." - :type 'hook - :group 'compilation) + :type 'hook) ;;;###autoload (defcustom compilation-start-hook nil "Hook run after starting a new compilation process. The hook is run with one argument, the new process." - :type 'hook - :group 'compilation) + :type 'hook) ;;;###autoload (defcustom compilation-window-height nil "Number of lines in a compilation window. If nil, use Emacs default." :type '(choice (const :tag "Default" nil) - integer) - :group 'compilation) + integer)) (defvar compilation-filter-hook nil "Hook run after `compilation-filter' has inserted a string into the buffer. @@ -80,34 +77,27 @@ If this is buffer-local in the destination buffer, Emacs obeys that value, otherwise it uses the value in the *compilation* buffer. This enables a major-mode to specify its own value.") -(defvar compilation-parse-errors-filename-function nil +(defvar compilation-parse-errors-filename-function #'identity "Function to call to post-process filenames while parsing error messages. It takes one arg FILENAME which is the name of a file as found -in the compilation output, and should return a transformed file name.") +in the compilation output, and should return a transformed file name +or a buffer, the one which was compiled.") +;; Note: the compilation-parse-errors-filename-function need not save the +;; match data. ;;;###autoload -(defvar compilation-process-setup-function nil +(defvar compilation-process-setup-function #'ignore "Function to call to customize the compilation process. This function is called immediately before the compilation process is started. It can be used to set any variables or functions that are used while processing the output of the compilation process.") ;;;###autoload -(defvar compilation-buffer-name-function nil +(defvar compilation-buffer-name-function #'compilation--default-buffer-name "Function to compute the name of a compilation buffer. The function receives one argument, the name of the major mode of the compilation buffer. It should return a string. -If nil, compute the name with `(concat \"*\" (downcase major-mode) \"*\")'.") - -;;;###autoload -(defvar compilation-finish-function nil - "Function to call when a compilation process finishes. -It is called with two arguments: the compilation buffer, and a string -describing how the process finished.") - -(make-obsolete-variable 'compilation-finish-function - "use `compilation-finish-functions', but it works a little differently." - "22.1") +By default, it returns `(concat \"*\" (downcase name-of-mode) \"*\")'.") ;;;###autoload (defvar compilation-finish-functions nil @@ -117,9 +107,33 @@ and a string describing how the process finished.") (defvar compilation-in-progress nil "List of compilation processes now running.") -(or (assq 'compilation-in-progress minor-mode-alist) - (setq minor-mode-alist (cons '(compilation-in-progress " Compiling") - minor-mode-alist))) +(or (assq 'compilation-in-progress mode-line-modes) + (add-to-list 'mode-line-modes + (list 'compilation-in-progress + (propertize "[Compiling] " + 'help-echo "Compiling; mouse-2: Goto Buffer" + 'mouse-face 'mode-line-highlight + 'local-map + (make-mode-line-mouse-map + 'mouse-2 + #'compilation-goto-in-progress-buffer))))) + +(defun compilation-goto-in-progress-buffer () + "Switch to the compilation buffer." + (interactive) + (cond + ((> (length compilation-in-progress) 1) + (switch-to-buffer (completing-read + "Several compilation buffers; switch to: " + (mapcar + (lambda (process) + (buffer-name (process-buffer process))) + compilation-in-progress) + nil t))) + (compilation-in-progress + (switch-to-buffer (process-buffer (car compilation-in-progress)))) + (t + (error "No ongoing compilations")))) (defvar compilation-error "error" "Stem of message to print when no matches are found.") @@ -533,7 +547,7 @@ File = \\(.+\\), Line = \\([0-9]+\\)\\(?:, Column = \\([0-9]+\\)\\)?" "Alist of values for `compilation-error-regexp-alist'.") (defcustom compilation-error-regexp-alist - (mapcar 'car compilation-error-regexp-alist-alist) + (mapcar #'car compilation-error-regexp-alist-alist) "Alist that specifies how to match errors in compiler output. On GNU and Unix, any string is a valid filename, so these matchers must make some common sense assumptions, which catch @@ -560,13 +574,18 @@ FILE can also have the form (FILE FORMAT...), where the FORMATs \(e.g. \"%s.c\") will be applied in turn to the recognized file name, until a file of that name is found. Or FILE can also be a function that returns (FILENAME) or (RELATIVE-FILENAME . DIRNAME). -In the former case, FILENAME may be relative or absolute. +In the former case, FILENAME may be relative or absolute, or it may +be a buffer. LINE can also be of the form (LINE . END-LINE) meaning a range of lines. COLUMN can also be of the form (COLUMN . END-COLUMN) meaning a range of columns starting on LINE and ending on END-LINE, if that matched. +LINE, END-LINE, COL, and END-COL can also be functions of no argument +that return the corresponding line or column number. They can assume REGEXP +has just been matched, and should correspondingly preserve this match data. + TYPE is 2 or nil for a real error or 1 for warning or 0 for info. TYPE can also be of the form (WARNING . INFO). In that case this will be equivalent to 1 if the WARNING'th subexpression matched @@ -587,8 +606,7 @@ listed text properties PROP# are given values VAL# as well." :type '(repeat (choice (symbol :tag "Predefined symbol") (sexp :tag "Error specification"))) :link `(file-link :tag "example file" - ,(expand-file-name "compilation.txt" data-directory)) - :group 'compilation) + ,(expand-file-name "compilation.txt" data-directory))) ;;;###autoload(put 'compilation-directory 'safe-local-variable 'stringp) (defvar compilation-directory nil @@ -648,7 +666,6 @@ If this is buffer-local in the destination buffer, Emacs obeys that value, otherwise it uses the value in the *compilation* buffer. This enables a major-mode to specify its own value." :type 'boolean - :group 'compilation :version "20.4") (defcustom compilation-read-command t @@ -659,15 +676,13 @@ Note that changing this to nil may be a security risk, because a file might define a malicious `compile-command' as a file local variable, and you might not notice. Therefore, `compile-command' is considered unsafe if this variable is nil." - :type 'boolean - :group 'compilation) + :type 'boolean) ;;;###autoload (defcustom compilation-ask-about-save t "Non-nil means \\[compile] asks which buffers to save before compiling. Otherwise, it saves all modified buffers without asking." - :type 'boolean - :group 'compilation) + :type 'boolean) (defcustom compilation-save-buffers-predicate nil "The second argument (PRED) passed to `save-some-buffers' before compiling. @@ -681,17 +696,16 @@ of `my-compilation-root' here." (const :tag "Default (save all file-visiting buffers)" nil) (const :tag "Save all buffers" t) function) - :group 'compilation :version "24.1") ;;;###autoload (defcustom compilation-search-path '(nil) "List of directories to search for source files named in error messages. -Elements should be directory names, not file names of directories. -The value nil as an element means to try the default directory." +Elements should be directory names, not file names of +directories. The value nil as an element means the error +message buffer `default-directory'." :type '(repeat (choice (const :tag "Default" nil) - (string :tag "Directory"))) - :group 'compilation) + (string :tag "Directory")))) ;;;###autoload (defcustom compile-command (purecopy "make -k ") @@ -711,8 +725,7 @@ You might also use mode hooks to specify it in certain modes, like this: (file-name-sans-extension buffer-file-name)))))))) It's often useful to leave a space at the end of the value." - :type 'string - :group 'compilation) + :type 'string) ;;;###autoload(put 'compile-command 'safe-local-variable (lambda (a) (and (stringp a) (or (not (boundp 'compilation-read-command)) compilation-read-command)))) ;;;###autoload @@ -721,7 +734,6 @@ It's often useful to leave a space at the end of the value." This only affects platforms that support asynchronous processes (see `start-process'); synchronous compilation processes never accept input." :type 'boolean - :group 'compilation :version "22.1") ;; A weak per-compilation-buffer hash indexed by (FILENAME . DIRECTORY). Each @@ -734,8 +746,9 @@ This only affects platforms that support asynchronous processes (see Then every error line will have a debug text property with the matcher that fit this line and the match data. Use `describe-text-properties'.") -(defvar compilation-exit-message-function nil "\ -If non-nil, called when a compilation process dies to return a status message. +(defvar compilation-exit-message-function + (lambda (_process-status exit-status msg) (cons msg exit-status)) + "If non-nil, called when a compilation process dies to return a status message. This should be a function of three arguments: process status, exit status, and exit message; it returns a cons (MESSAGE . MODELINE) of the strings to write into the compilation buffer, and to put in its mode line.") @@ -747,7 +760,6 @@ This list is temporarily prepended to `process-environment' prior to starting the compilation process." :type '(repeat (string :tag "ENVVARNAME=VALUE")) :options '(("LANG=C")) - :group 'compilation :version "24.1") ;; History of compile commands. @@ -756,19 +768,16 @@ starting the compilation process." (defface compilation-error '((t :inherit error)) "Face used to highlight compiler errors." - :group 'compilation :version "22.1") (defface compilation-warning '((t :inherit warning)) "Face used to highlight compiler warnings." - :group 'compilation :version "22.1") (defface compilation-info '((t :inherit success)) "Face used to highlight compiler information." - :group 'compilation :version "22.1") ;; The next three faces must be able to stand out against the @@ -780,13 +789,11 @@ starting the compilation process." (((class color) (min-colors 8)) (:foreground "red")) (t (:inverse-video t :weight bold))) "Face for Compilation mode's \"error\" mode line indicator." - :group 'compilation :version "24.3") (defface compilation-mode-line-run '((t :inherit compilation-warning)) "Face for Compilation mode's \"running\" mode line indicator." - :group 'compilation :version "24.3") (defface compilation-mode-line-exit @@ -796,19 +803,16 @@ starting the compilation process." (((class color)) (:foreground "green" :weight bold)) (t (:weight bold))) "Face for Compilation mode's \"exit\" mode line indicator." - :group 'compilation :version "24.3") (defface compilation-line-number '((t :inherit font-lock-keyword-face)) "Face for displaying line numbers in compiler messages." - :group 'compilation :version "22.1") (defface compilation-column-number '((t :inherit font-lock-doc-face)) "Face for displaying column numbers in compiler messages." - :group 'compilation :version "22.1") (defcustom compilation-message-face 'underline @@ -817,7 +821,6 @@ Faces `compilation-error-face', `compilation-warning-face', `compilation-info-face', `compilation-line-face' and `compilation-column-face' get prepended to this, when applicable." :type 'face - :group 'compilation :version "22.1") (defvar compilation-error-face 'compilation-error @@ -850,7 +853,6 @@ 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 - :group 'compilation :version "23.1") (defvar compilation-auto-jump-to-next nil @@ -873,7 +875,6 @@ info, are considered errors." :type '(choice (const :tag "Skip warnings and info" 2) (const :tag "Skip info" 1) (const :tag "No skip" 0)) - :group 'compilation :version "22.1") (defun compilation-set-skip-threshold (level) @@ -897,7 +898,6 @@ Visited messages are ones for which the file, line and column have been jumped to from the current content in the current compilation buffer, even if it was from a different message." :type 'boolean - :group 'compilation :version "22.1") (defun compilation-type (type) @@ -954,10 +954,11 @@ from a different message." ;; FILE-STRUCTURE is a list of ;; ((FILENAME DIRECTORY) FORMATS (LINE LOC ...) ...) -;; FILENAME is a string parsed from an error message. DIRECTORY is a string -;; obtained by following directory change messages. DIRECTORY will be nil for -;; an absolute filename. FORMATS is a list of formats to apply to FILENAME if -;; a file of that name can't be found. +;; FILENAME is a string parsed from an error message, or the buffer which was +;; compiled. DIRECTORY is a string obtained by following directory change +;; messages. DIRECTORY will be nil for an absolute filename or a buffer. +;; FORMATS is a list of formats to apply to FILENAME if a file of that name +;; can't be found. ;; The rest of the list is an alist of elements with LINE as key. The keys ;; are either nil or line numbers. If present, nil comes first, followed by ;; the numbers in decreasing order. The LOCs for each line are again an alist @@ -1134,23 +1135,27 @@ POS and RES.") (setq file '("*unknown*"))))) ;; All of these fields are optional, get them only if we have an index, and ;; it matched some part of the message. - (and line - (setq line (match-string-no-properties line)) - (setq line (string-to-number line))) - (and end-line - (setq end-line (match-string-no-properties end-line)) - (setq end-line (string-to-number end-line))) - (if col - (if (functionp col) - (setq col (funcall col)) - (and - (setq col (match-string-no-properties col)) - (setq col (string-to-number col))))) - (if (and end-col (functionp end-col)) - (setq end-col (funcall end-col)) - (if (and end-col (setq end-col (match-string-no-properties end-col))) - (setq end-col (- (string-to-number end-col) -1)) - (if end-line (setq end-col -1)))) + (setq line + (if (functionp line) (funcall line) + (and line + (setq line (match-string-no-properties line)) + (string-to-number line)))) + (setq end-line + (if (functionp end-line) (funcall end-line) + (and end-line + (setq end-line (match-string-no-properties end-line)) + (string-to-number end-line)))) + (setq col + (if (functionp col) (funcall col) + (and col + (setq col (match-string-no-properties col)) + (string-to-number col)))) + (setq end-col + (or (if (functionp end-col) (funcall end-col) + (and end-col + (setq end-col (match-string-no-properties end-col)) + (- (string-to-number end-col) -1))) + (and end-line -1))) (if (consp type) ; not a static type, check what it is. (setq type (or (and (car type) (match-end (car type)) 1) (and (cdr type) (match-end (cdr type)) 0) @@ -1190,7 +1195,8 @@ just char-counts." "Get the meta-info that will be added as text-properties. LINE, END-LINE, COL, END-COL are integers or nil. TYPE can be 0, 1, or 2, meaning error, warning, or just info. -FILE should be (FILENAME) or (RELATIVE-FILENAME . DIRNAME) or nil. +FILE should be (FILENAME) or (RELATIVE-FILENAME . DIRNAME) or (BUFFER) or +nil. FMTS is a list of format specs for transforming the file name. (See `compilation-error-regexp-alist'.)" (unless file (setq file '("*unknown*"))) @@ -1250,12 +1256,12 @@ FMTS is a list of format specs for transforming the file name. (setq loc (compilation-assq line (compilation--file-struct->loc-tree file-struct))) (setq end-loc - (if end-line + (if end-line (compilation-assq end-col (compilation-assq end-line (compilation--file-struct->loc-tree file-struct))) - (if end-col ; use same line element + (if end-col ; use same line element (compilation-assq end-col loc)))) (setq loc (compilation-assq col loc)) ;; If they are new, make the loc(s) reference the file they point to. @@ -1398,92 +1404,70 @@ to `compilation-error-regexp-alist' if RULES is nil." (if (consp line) (setq end-line (cdr line) line (car line))) (if (consp col) (setq end-col (cdr col) col (car col))) - (if (functionp line) - ;; The old compile.el had here an undocumented hook that - ;; allowed `line' to be a function that computed the actual - ;; error location. Let's do our best. - (progn - (goto-char start) - (while (re-search-forward pat end t) - (save-match-data - (when compilation-debug - (font-lock-append-text-property - (match-beginning 0) (match-end 0) - 'compilation-debug (vector 'functionp item))) - (add-text-properties - (match-beginning 0) (match-end 0) - (compilation--compat-error-properties - (funcall line (cons (match-string file) - (cons default-directory - (nthcdr 4 item))) - (if col (match-string col)))))) - (compilation--put-prop - file 'font-lock-face compilation-error-face))) + (unless (or (null (nth 5 item)) (integerp (nth 5 item))) + (error "HYPERLINK should be an integer: %s" (nth 5 item))) - (unless (or (null (nth 5 item)) (integerp (nth 5 item))) - (error "HYPERLINK should be an integer: %s" (nth 5 item))) + (goto-char start) + (while (re-search-forward pat end t) + (when (setq props (compilation-error-properties + file line end-line col end-col (or type 2) fmt)) - (goto-char start) - (while (re-search-forward pat end t) - (when (setq props (compilation-error-properties - file line end-line col end-col (or type 2) fmt)) - - (when (integerp file) - (let ((this-type (if (consp type) - (compilation-type type) - (or type 2)))) - (compilation--note-type this-type) - - (compilation--put-prop - file 'font-lock-face - (symbol-value (aref [compilation-info-face - compilation-warning-face - compilation-error-face] - this-type))))) - - (compilation--put-prop - line 'font-lock-face compilation-line-face) - (compilation--put-prop - end-line 'font-lock-face compilation-line-face) - - (compilation--put-prop - col 'font-lock-face compilation-column-face) - (compilation--put-prop - end-col 'font-lock-face compilation-column-face) - - ;; Obey HIGHLIGHT. - (dolist (extra-item (nthcdr 6 item)) - (let ((mn (pop extra-item))) - (when (match-beginning mn) - (let ((face (eval (car extra-item)))) - (cond - ((null face)) - ((or (symbolp face) (stringp face)) - (put-text-property - (match-beginning mn) (match-end mn) - 'font-lock-face face)) - ((and (listp face) - (eq (car face) 'face) - (or (symbolp (cadr face)) - (stringp (cadr face)))) - (compilation--put-prop mn 'font-lock-face (cadr face)) - (add-text-properties - (match-beginning mn) (match-end mn) - (nthcdr 2 face))) - (t - (error "Don't know how to handle face %S" - face))))))) - (let ((mn (or (nth 5 item) 0))) - (when compilation-debug - (font-lock-append-text-property - (match-beginning 0) (match-end 0) - 'compilation-debug (vector 'std item props))) - (add-text-properties - (match-beginning mn) (match-end mn) - (cddr props)) + (when (integerp file) + (let ((this-type (if (consp type) + (compilation-type type) + (or type 2)))) + (compilation--note-type this-type) + + (compilation--put-prop + file 'font-lock-face + (symbol-value (aref [compilation-info-face + compilation-warning-face + compilation-error-face] + this-type))))) + + (compilation--put-prop + line 'font-lock-face compilation-line-face) + (compilation--put-prop + end-line 'font-lock-face compilation-line-face) + + (compilation--put-prop + col 'font-lock-face compilation-column-face) + (compilation--put-prop + end-col 'font-lock-face compilation-column-face) + + ;; Obey HIGHLIGHT. + (dolist (extra-item (nthcdr 6 item)) + (let ((mn (pop extra-item))) + (when (match-beginning mn) + (let ((face (eval (car extra-item)))) + (cond + ((null face)) + ((or (symbolp face) (stringp face)) + (put-text-property + (match-beginning mn) (match-end mn) + 'font-lock-face face)) + ((and (listp face) + (eq (car face) 'face) + (or (symbolp (cadr face)) + (stringp (cadr face)))) + (compilation--put-prop mn 'font-lock-face (cadr face)) + (add-text-properties + (match-beginning mn) (match-end mn) + (nthcdr 2 face))) + (t + (error "Don't know how to handle face %S" + face))))))) + (let ((mn (or (nth 5 item) 0))) + (when compilation-debug (font-lock-append-text-property - (match-beginning mn) (match-end mn) - 'font-lock-face (cadr props))))))))) + (match-beginning 0) (match-end 0) + 'compilation-debug (vector 'std item props))) + (add-text-properties + (match-beginning mn) (match-end mn) + (cddr props)) + (font-lock-append-text-property + (match-beginning mn) (match-end mn) + 'font-lock-face (cadr props)))))))) (defvar compilation--parsed -1) (make-variable-buffer-local 'compilation--parsed) @@ -1587,7 +1571,7 @@ If the optional argument `edit-command' is non-nil, the command can be edited." (setq command (compilation-read-command (or (car compilation-arguments) command))) (if compilation-arguments (setcar compilation-arguments command))) - (apply 'compilation-start (or compilation-arguments (list command))))) + (apply #'compilation-start (or compilation-arguments (list command))))) (defcustom compilation-scroll-output nil "Non-nil to scroll the *compilation* buffer window as output appears. @@ -1601,23 +1585,25 @@ point on its location in the *compilation* buffer." :type '(choice (const :tag "No scrolling" nil) (const :tag "Scroll compilation output" t) (const :tag "Stop scrolling at the first error" first-error)) - :version "20.3" - :group 'compilation) + :version "20.3") -(defun compilation-buffer-name (name-of-mode mode-command name-function) +(defun compilation-buffer-name (name-of-mode _mode-command name-function) "Return the name of a compilation buffer to use. If NAME-FUNCTION is non-nil, call it with one argument NAME-OF-MODE to determine the buffer name. Likewise if `compilation-buffer-name-function' is non-nil. -If current buffer has the major mode MODE-COMMAND, +If current buffer has the NAME-OF-MODE major mode, return the name of the current buffer, so that it gets reused. Otherwise, construct a buffer name from NAME-OF-MODE." - (cond (name-function - (funcall name-function name-of-mode)) - (compilation-buffer-name-function - (funcall compilation-buffer-name-function name-of-mode)) - ((eq mode-command major-mode) + (funcall (or name-function + compilation-buffer-name-function + #'compilation--default-buffer-name) + name-of-mode)) + +(defun compilation--default-buffer-name (name-of-mode) + (cond ((or (eq major-mode (intern-soft name-of-mode)) + (eq major-mode (intern-soft (concat name-of-mode "-mode")))) (buffer-name)) (t (concat "*" (downcase name-of-mode) "*")))) @@ -1626,8 +1612,12 @@ Otherwise, construct a buffer name from NAME-OF-MODE." "If t, always kill a running compilation process before starting a new one. If nil, ask to kill it." :type 'boolean - :version "24.3" - :group 'compilation) + :version "24.3") + +(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) @@ -1784,15 +1774,16 @@ Returns the compilation buffer created." (if (fboundp 'make-process) (let ((proc (if (eq mode t) - ;; comint uses `start-file-process'. - (get-buffer-process - (with-no-warnings - (comint-exec - outbuf (downcase mode-name) - (if (file-remote-p default-directory) - "/bin/sh" - shell-file-name) - nil `("-c" ,command)))) + ;; On remote hosts, the local `shell-file-name' + ;; might be useless. + (with-connection-local-variables + ;; comint uses `start-file-process'. + (get-buffer-process + (with-no-warnings + (comint-exec + outbuf (downcase mode-name) + shell-file-name + nil `(,shell-command-switch ,command))))) (start-file-process-shell-command (downcase mode-name) outbuf command)))) ;; Make the buffer's mode line show process state. @@ -1806,11 +1797,11 @@ Returns the compilation buffer created." (when compilation-always-kill (set-process-query-on-exit-flag proc nil)) - (set-process-sentinel proc 'compilation-sentinel) + (set-process-sentinel proc #'compilation-sentinel) (unless (eq mode t) ;; Keep the comint filter, since it's needed for proper ;; handling of the prompts. - (set-process-filter proc 'compilation-filter)) + (set-process-filter proc #'compilation-filter)) ;; Use (point-max) here so that output comes in ;; after the initial text, ;; regardless of where the user sees point. @@ -1821,8 +1812,8 @@ Returns the compilation buffer created." ;; The process may have exited already. (error nil))) (run-hook-with-args 'compilation-start-hook proc) - (setq compilation-in-progress - (cons proc compilation-in-progress))) + (compilation--update-in-progress-mode-line) + (push proc compilation-in-progress)) ;; No asynchronous processes available. (message "Executing `%s'..." command) ;; Fake mode line display as if `start-process' were run. @@ -2095,13 +2086,11 @@ by replacing the first word, e.g., `compilation-scroll-output' from (if (boundp 'byte-compile-bound-variables) (memq (cdr v) byte-compile-bound-variables))) `(set (make-local-variable ',(car v)) ,(cdr v)))) - '(compilation-buffer-name-function - compilation-directory-matcher + '(compilation-directory-matcher compilation-error compilation-error-regexp-alist compilation-error-regexp-alist-alist compilation-error-screen-columns - compilation-finish-function compilation-finish-functions compilation-first-column compilation-mode-font-lock-keywords @@ -2119,7 +2108,7 @@ by replacing the first word, e.g., `compilation-scroll-output' from (let (revert-buffer-function) (revert-buffer ignore-auto noconfirm)) (if (or noconfirm (yes-or-no-p (format "Restart compilation? "))) - (apply 'compilation-start compilation-arguments)))) + (apply #'compilation-start compilation-arguments)))) (defvar compilation-current-error nil "Marker to the location from where the next error will be found. @@ -2155,7 +2144,7 @@ Optional argument MINOR indicates this is called from ;; It's generally preferable to use after-change-functions since they ;; can be subject to combine-after-change-calls, but if we do that, we risk ;; running our hook after font-lock, resulting in incorrect refontification. - (add-hook 'before-change-functions 'compilation--flush-parse nil t) + (add-hook 'before-change-functions #'compilation--flush-parse nil t) ;; Also for minor mode, since it's not permanent-local. (add-hook 'change-major-mode-hook #'compilation--remove-properties nil t) (if minor @@ -2167,7 +2156,7 @@ Optional argument MINOR indicates this is called from (defun compilation--unsetup () ;; Only for minor mode. (font-lock-remove-keywords nil (compilation-mode-font-lock-keywords)) - (remove-hook 'before-change-functions 'compilation--flush-parse t) + (remove-hook 'before-change-functions #'compilation--flush-parse t) (kill-local-variable 'compilation--parsed) (compilation--remove-properties) (font-lock-flush)) @@ -2175,16 +2164,12 @@ Optional argument MINOR indicates this is called from ;;;###autoload (define-minor-mode compilation-shell-minor-mode "Toggle Compilation Shell minor mode. -With a prefix argument ARG, enable Compilation Shell minor mode -if ARG is positive, and disable it otherwise. If called from -Lisp, enable the mode if ARG is omitted or nil. 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'." - nil " Shell-Compile" - :group 'compilation + :lighter " Shell-Compile" (if compilation-shell-minor-mode (compilation-setup t) (compilation--unsetup))) @@ -2192,15 +2177,11 @@ See `compilation-mode'." ;;;###autoload (define-minor-mode compilation-minor-mode "Toggle Compilation minor mode. -With a prefix argument ARG, enable Compilation minor mode if ARG -is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. When Compilation minor mode is enabled, all the error-parsing commands of Compilation major mode are available. See `compilation-mode'." - nil " Compilation" - :group 'compilation + :lighter " Compilation" (if compilation-minor-mode (compilation-setup t) (compilation--unsetup))) @@ -2245,9 +2226,6 @@ commands of Compilation major mode are available. See (force-mode-line-update) (if (and opoint (< opoint omax)) (goto-char opoint)) - (with-no-warnings - (if compilation-finish-function - (funcall compilation-finish-function cur-buffer msg))) (run-hook-with-args 'compilation-finish-functions cur-buffer msg))) ;; Called when compilation process changes state. @@ -2268,7 +2246,8 @@ commands of Compilation major mode are available. See ;; process is dead, we can delete it now. Otherwise it ;; will stay around until M-x list-processes. (delete-process proc))) - (setq compilation-in-progress (delq proc compilation-in-progress))))) + (setq compilation-in-progress (delq proc compilation-in-progress)) + (compilation--update-in-progress-mode-line)))) (defun compilation-filter (proc string) "Process filter for compilation buffers. @@ -2297,6 +2276,8 @@ and runs `compilation-filter-hook'." (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)) ;; (set (make-local-variable 'compilation-buffer-modtime) ;; (current-time)) (run-hooks 'compilation-filter-hook)) @@ -2393,7 +2374,7 @@ looking for the next message." 'compilation-message)) (setq pt (compilation-next-single-property-change pt 'compilation-message nil - (line-end-position))) + (line-end-position))) (or (setq msg (get-text-property pt 'compilation-message)) (setq pt (point))))) (setq last (compilation--loc->file-struct loc)) @@ -2411,7 +2392,7 @@ looking for the next message." "Moved back before first %s" (point-min)))) (goto-char pt) (or msg - (error "No %s here" compilation-error)))) + (user-error "No %s here" compilation-error)))) (defun compilation-previous-error (n) "Move point to the previous error in the compilation buffer. @@ -2513,12 +2494,14 @@ This is the value of `next-error-function' in Compilation buffers." ;; (setq timestamp compilation-buffer-modtime))) ) (with-current-buffer - (apply #'compilation-find-file - marker - (caar (compilation--loc->file-struct loc)) - (cadr (car (compilation--loc->file-struct loc))) - (compilation--file-struct->formats - (compilation--loc->file-struct loc))) + (if (bufferp (caar (compilation--loc->file-struct loc))) + (caar (compilation--loc->file-struct loc)) + (apply #'compilation-find-file + marker + (caar (compilation--loc->file-struct loc)) + (cadr (car (compilation--loc->file-struct loc))) + (compilation--file-struct->formats + (compilation--loc->file-struct loc)))) (let ((screen-columns ;; Obey the compilation-error-screen-columns of the target ;; buffer if its major mode set it buffer-locally. @@ -2597,7 +2580,6 @@ compilation output window; an arrow in the left fringe points to the current message. If nil and there is no left fringe, the message displays at the top of the window; there is no arrow." :type '(choice integer (const :tag "No window scrolling" nil)) - :group 'compilation :version "22.1") (defsubst compilation-set-window (w mk) @@ -2691,7 +2673,7 @@ and overlay is highlighted between MK and END-MK." (numberp next-error-highlight)) ;; We want highlighting: delete overlay on next input. (add-hook 'pre-command-hook - 'compilation-goto-locus-delete-o) + #'compilation-goto-locus-delete-o) ;; We don't want highlighting: delete overlay now. (delete-overlay compilation-highlight-overlay)) ;; We want highlighting for a limited time: @@ -2711,7 +2693,7 @@ and overlay is highlighted between MK and END-MK." (if (timerp next-error-highlight-timer) (cancel-timer next-error-highlight-timer)) (remove-hook 'pre-command-hook - 'compilation-goto-locus-delete-o)) + #'compilation-goto-locus-delete-o)) (defun compilation-find-file (marker filename directory &rest formats) "Find a buffer for file FILENAME. @@ -2830,18 +2812,22 @@ TRUE-DIRNAME is the `file-truename' of DIRNAME, if given." (concat comint-file-name-prefix spec-directory)))))) ;; If compilation-parse-errors-filename-function is - ;; defined, use it to process the filename. - (when compilation-parse-errors-filename-function - (setq filename - (funcall compilation-parse-errors-filename-function - filename))) + ;; defined, use it to process the filename. The result might be a + ;; buffer. + (unless (memq compilation-parse-errors-filename-function + '(nil identity)) + (save-match-data + (setq filename + (funcall compilation-parse-errors-filename-function + filename)))) ;; Some compilers (e.g. Sun's java compiler, reportedly) produce bogus ;; file names like "./bar//foo.c" for file "bar/foo.c"; ;; expand-file-name will collapse these into "/foo.c" and fail to find ;; the appropriate file. So we look for doubled slashes in the file ;; name and fix them. - (setq filename (command-line-normalize-file-name filename)) + (if (stringp filename) + (setq filename (command-line-normalize-file-name filename))) ;; Store it for the possibly unnormalized name (puthash file @@ -2874,29 +2860,6 @@ TRUE-DIRNAME is the `file-truename' of DIRNAME, if given." (defvar compilation-error-list nil) (defvar compilation-old-error-list nil) -(defun compilation--compat-error-properties (err) - "Map old-style error ERR to new-style message." - ;; Old-style structure is (MARKER (FILE DIR) LINE COL) or - ;; (MARKER . MARKER). - (let ((dst (cdr err))) - (if (markerp dst) - `(compilation-message ,(compilation--make-message - (cons nil (compilation--make-cdrloc - nil nil dst)) - 2 nil) - help-echo "mouse-2: visit the source location" - keymap compilation-button-map - mouse-face highlight) - ;; Too difficult to do it by hand: dispatch to the normal code. - (let* ((file (pop dst)) - (line (pop dst)) - (col (pop dst)) - (filename (pop file)) - (dirname (pop file)) - (fmt (pop file))) - (compilation-internal-error-properties - (cons filename dirname) line nil col nil 2 fmt))))) - (defun compilation--compat-parse-errors (limit) (when compilation-parse-errors-function ;; FIXME: We should remove the rest of the compilation keywords diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index f25e24ba717..d5c404c7d2f 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -1,9 +1,10 @@ -;;; cperl-mode.el --- Perl code editing commands for Emacs +;;; cperl-mode.el --- Perl code editing commands for Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1985-1987, 1991-2019 Free Software Foundation, Inc. ;; Author: Ilya Zakharevich ;; Bob Olson +;; Jonathan Rockway <jon@jrock.us> ;; Maintainer: emacs-devel@gnu.org ;; Keywords: languages, Perl @@ -22,10 +23,19 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. -;;; Corrections made by Ilya Zakharevich ilyaz@cpan.org +;; Corrections made by Ilya Zakharevich ilyaz@cpan.org ;;; Commentary: +;; This version of the file contains support for the syntax added by +;; the MooseX::Declare CPAN module, as well as Perl 5.10 keyword +;; support. + +;; The latest version is available from +;; http://github.com/jrockway/cperl-mode +;; +;; (perhaps in the moosex-declare branch) + ;; You can either fine-tune the bells and whistles of this mode or ;; bulk enable them by putting @@ -56,7 +66,7 @@ ;; (define-key global-map [M-S-down-mouse-3] 'imenu) -;;; Font lock bugs as of v4.32: +;;;; Font lock bugs as of v4.32: ;; The following kinds of Perl code erroneously start strings: ;; \$` \$' \$" @@ -65,6 +75,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defvar vc-rcs-header) (defvar vc-sccs-header) @@ -75,37 +87,11 @@ (condition-case nil (require 'man) (error nil)) - (defvar cperl-can-font-lock - (or (featurep 'xemacs) - (and (boundp 'emacs-major-version) - (or window-system - (> emacs-major-version 20))))) - (if cperl-can-font-lock - (require 'font-lock)) (defvar msb-menu-cond) (defvar gud-perldb-history) (defvar font-lock-background-mode) ; not in Emacs (defvar font-lock-display-type) ; ditto (defvar paren-backwards-message) ; Not in newer XEmacs? - (or (fboundp 'defgroup) - (defmacro defgroup (name val doc &rest arr) - nil)) - (or (fboundp 'custom-declare-variable) - (defmacro defcustom (name val doc &rest arr) - `(defvar ,name ,val ,doc))) - (or (and (fboundp 'custom-declare-variable) - (string< "19.31" emacs-version)) ; Checked with 19.30: defface does not work - (defmacro defface (&rest arr) - nil)) - ;; Avoid warning (tmp definitions) - (or (fboundp 'x-color-defined-p) - (defmacro x-color-defined-p (col) - (cond ((fboundp 'color-defined-p) `(color-defined-p ,col)) - ;; XEmacs >= 19.12 - ((fboundp 'valid-color-name-p) `(valid-color-name-p ,col)) - ;; XEmacs 19.11 - ((fboundp 'x-valid-color-name-p) `(x-valid-color-name-p ,col)) - (t '(error "Cannot implement color-defined-p"))))) (defmacro cperl-is-face (arg) ; Takes quoted arg (cond ((fboundp 'find-face) `(find-face ,arg)) @@ -127,31 +113,10 @@ (cperl-make-face ,arg ,descr)) (or (boundp (quote ,arg)) ; We use unquoted variants too (defvar ,arg (quote ,arg) ,descr)))) - (if (featurep 'xemacs) - (defmacro cperl-etags-snarf-tag (file line) - `(progn - (beginning-of-line 2) - (list ,file ,line))) - (defmacro cperl-etags-snarf-tag (file line) - `(etags-snarf-tag))) - (if (featurep 'xemacs) - (defmacro cperl-etags-goto-tag-location (elt) - ;;(progn - ;; (switch-to-buffer (get-file-buffer (elt ,elt 0))) - ;; (set-buffer (get-file-buffer (elt ,elt 0))) - ;; Probably will not work due to some save-excursion??? - ;; Or save-file-position? - ;; (message "Did I get to line %s?" (elt ,elt 1)) - `(goto-line (string-to-int (elt ,elt 1)))) - ;;) - (defmacro cperl-etags-goto-tag-location (elt) - `(etags-goto-tag-location ,elt)))) - -(defvar cperl-can-font-lock - (or (featurep 'xemacs) - (and (boundp 'emacs-major-version) - (or window-system - (> emacs-major-version 20))))) + (defmacro cperl-etags-snarf-tag (_file _line) + '(etags-snarf-tag)) + (defmacro cperl-etags-goto-tag-location (elt) + `(etags-goto-tag-location ,elt))) (defun cperl-choose-color (&rest list) (let (answer) @@ -228,10 +193,10 @@ for constructs with multiline if/unless/while/until/for/foreach condition." :type 'integer :group 'cperl-indentation-details) -;; Is is not unusual to put both things like perl-indent-level and -;; cperl-indent-level in the local variable section of a file. If only +;; It is not unusual to put both things like perl-indent-level and +;; cperl-indent-level in the local variable section of a file. If only ;; one of perl-mode and cperl-mode is in use, a warning will be issued -;; about the variable. Autoload these here, so that no warning is +;; about the variable. Autoload these here, so that no warning is ;; issued when using either perl-mode or cperl-mode. ;;;###autoload(put 'cperl-indent-level 'safe-local-variable 'integerp) ;;;###autoload(put 'cperl-brace-offset 'safe-local-variable 'integerp) @@ -286,6 +251,11 @@ Versions 5.2 ... 5.20 behaved as if this were nil." :type 'boolean :group 'cperl-indentation-details) +(defcustom cperl-indent-subs-specially t + "Non-nil means indent subs that are inside other blocks (hash values, for example) relative to the beginning of the \"sub\" keyword, rather than relative to the statement that contains the declaration." + :type 'boolean + :group 'cperl-indentation-details) + (defcustom cperl-auto-newline nil "Non-nil means automatically newline before and after braces, and after colons and semicolons, inserted in CPerl code. The following @@ -337,14 +307,7 @@ Can be overwritten by `cperl-hairy' if nil." :type '(choice (const null) boolean) :group 'cperl-affected-by-hairy) -(defvar zmacs-regions) ; Avoid warning - -(defcustom cperl-electric-parens-mark - (and window-system - (or (and (boundp 'transient-mark-mode) ; For Emacs - transient-mark-mode) - (and (boundp 'zmacs-regions) ; For XEmacs - zmacs-regions))) +(defcustom cperl-electric-parens-mark window-system "Not-nil means that electric parens look for active mark. Default is yes if there is visual feedback on mark." :type 'boolean @@ -405,13 +368,6 @@ Affects: `cperl-font-lock', `cperl-electric-lbrace-space', :type '(repeat string) :group 'cperl) -;; This became obsolete... -(defvar cperl-vc-header-alist nil) -(make-obsolete-variable - 'cperl-vc-header-alist - "use cperl-vc-rcs-header or cperl-vc-sccs-header instead." - "22.1") - ;; (defcustom cperl-clobber-mode-lists ;; (not ;; (and @@ -458,9 +414,6 @@ Font for POD headers." :type 'face :group 'cperl-faces) -;;; Some double-evaluation happened with font-locks... Needed with 21.2... -(defvar cperl-singly-quote-face (featurep 'xemacs)) - (defcustom cperl-invalid-face 'underline "Face for highlighting trailing whitespace." :type 'face @@ -612,8 +565,7 @@ One should tune up `cperl-close-paren-offset' as well." :group 'cperl-indentation-details) (defcustom cperl-syntaxify-by-font-lock - (and cperl-can-font-lock - (boundp 'parse-sexp-lookup-properties)) + (boundp 'parse-sexp-lookup-properties) "Non-nil means that CPerl uses the `font-lock' routines for syntaxification." :type '(choice (const message) boolean) :group 'cperl-speed) @@ -995,13 +947,6 @@ In regular expressions (including character classes): ;;; Portability stuff: -(defmacro cperl-define-key (emacs-key definition &optional xemacs-key) - `(define-key cperl-mode-map - ,(if xemacs-key - `(if (featurep 'xemacs) ,xemacs-key ,emacs-key) - emacs-key) - ,definition)) - (defvar cperl-del-back-ch (car (append (where-is-internal 'delete-backward-char) (where-is-internal 'backward-delete-char-untabify))) @@ -1010,33 +955,11 @@ In regular expressions (including character classes): (and (vectorp cperl-del-back-ch) (= (length cperl-del-back-ch) 1) (setq cperl-del-back-ch (aref cperl-del-back-ch 0))) -(defun cperl-mark-active () (mark)) ; Avoid undefined warning -(if (featurep 'xemacs) - (progn - ;; "Active regions" are on: use region only if active - ;; "Active regions" are off: use region unconditionally - (defun cperl-use-region-p () - (if zmacs-regions (mark) t))) - (defun cperl-use-region-p () - (if transient-mark-mode mark-active t)) - (defun cperl-mark-active () mark-active)) - -(defsubst cperl-enable-font-lock () - cperl-can-font-lock) - (defun cperl-putback-char (c) ; Emacs 19 (push c unread-command-events)) ; Avoid undefined warning -(if (featurep 'xemacs) - (defun cperl-putback-char (c) ; XEmacs >= 19.12 - (push (eval '(character-to-event c)) unread-command-events))) - -(or (fboundp 'uncomment-region) - (defun uncomment-region (beg end) - (interactive "r") - (comment-region beg end -1))) - (defvar cperl-do-not-fontify + ;; FIXME: This is not doing what it claims! (if (string< emacs-version "19.30") 'fontified 'lazy-lock) @@ -1056,8 +979,6 @@ In regular expressions (including character classes): (defvar cperl-syntax-state nil) (defvar cperl-syntax-done-to nil) -(defvar cperl-emacs-can-parse (> (length (save-excursion - (parse-partial-sexp (point) (point)))) 9)) ;; Make customization possible "in reverse" (defsubst cperl-val (symbol &optional default hairy) @@ -1085,141 +1006,126 @@ versions of Emacs." (put-text-property (point) (match-end 0) 'syntax-type prop))))))) -;;; Probably it is too late to set these guys already, but it can help later: +;; Probably it is too late to set these guys already, but it can help later: -;;;(and cperl-clobber-mode-lists -;;;(setq auto-mode-alist -;;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist )) -;;;(and (boundp 'interpreter-mode-alist) -;;; (setq interpreter-mode-alist (append interpreter-mode-alist -;;; '(("miniperl" . perl-mode)))))) +;;(and cperl-clobber-mode-lists +;;(setq auto-mode-alist +;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist )) +;;(and (boundp 'interpreter-mode-alist) +;; (setq interpreter-mode-alist (append interpreter-mode-alist +;; '(("miniperl" . perl-mode)))))) (eval-when-compile - (mapc (lambda (p) - (condition-case nil - (require p) - (error nil))) - '(imenu easymenu etags timer man info)) - (if (fboundp 'ps-extend-face-list) - (defmacro cperl-ps-extend-face-list (arg) - `(ps-extend-face-list ,arg)) - (defmacro cperl-ps-extend-face-list (arg) - `(error "This version of Emacs has no `ps-extend-face-list'"))) - ;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs, - ;; macros instead of defsubsts don't work on Emacs, so we do the - ;; expansion manually. Any other suggestions? - (require 'cl)) - -(define-abbrev-table 'cperl-mode-abbrev-table - '( - ("if" "if" cperl-electric-keyword :system t) - ("elsif" "elsif" cperl-electric-keyword :system t) - ("while" "while" cperl-electric-keyword :system t) - ("until" "until" cperl-electric-keyword :system t) - ("unless" "unless" cperl-electric-keyword :system t) - ("else" "else" cperl-electric-else :system t) - ("continue" "continue" cperl-electric-else :system t) - ("for" "for" cperl-electric-keyword :system t) - ("foreach" "foreach" cperl-electric-keyword :system t) - ("formy" "formy" cperl-electric-keyword :system t) - ("foreachmy" "foreachmy" cperl-electric-keyword :system t) - ("do" "do" cperl-electric-keyword :system t) - ("=pod" "=pod" cperl-electric-pod :system t) - ("=over" "=over" cperl-electric-pod :system t) - ("=head1" "=head1" cperl-electric-pod :system t) - ("=head2" "=head2" cperl-electric-pod :system t) - ("pod" "pod" cperl-electric-pod :system t) - ("over" "over" cperl-electric-pod :system t) - ("head1" "head1" cperl-electric-pod :system t) - ("head2" "head2" cperl-electric-pod :system t)) - "Abbrev table in use in CPerl mode buffers.") - -(add-hook 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-"))) - -(defvar cperl-mode-map () "Keymap used in CPerl mode.") - -(if cperl-mode-map nil - (setq cperl-mode-map (make-sparse-keymap)) - (cperl-define-key "{" 'cperl-electric-lbrace) - (cperl-define-key "[" 'cperl-electric-paren) - (cperl-define-key "(" 'cperl-electric-paren) - (cperl-define-key "<" 'cperl-electric-paren) - (cperl-define-key "}" 'cperl-electric-brace) - (cperl-define-key "]" 'cperl-electric-rparen) - (cperl-define-key ")" 'cperl-electric-rparen) - (cperl-define-key ";" 'cperl-electric-semi) - (cperl-define-key ":" 'cperl-electric-terminator) - (cperl-define-key "\C-j" 'newline-and-indent) - (cperl-define-key "\C-c\C-j" 'cperl-linefeed) - (cperl-define-key "\C-c\C-t" 'cperl-invert-if-unless) - (cperl-define-key "\C-c\C-a" 'cperl-toggle-auto-newline) - (cperl-define-key "\C-c\C-k" 'cperl-toggle-abbrev) - (cperl-define-key "\C-c\C-w" 'cperl-toggle-construct-fix) - (cperl-define-key "\C-c\C-f" 'auto-fill-mode) - (cperl-define-key "\C-c\C-e" 'cperl-toggle-electric) - (cperl-define-key "\C-c\C-b" 'cperl-find-bad-style) - (cperl-define-key "\C-c\C-p" 'cperl-pod-spell) - (cperl-define-key "\C-c\C-d" 'cperl-here-doc-spell) - (cperl-define-key "\C-c\C-n" 'cperl-narrow-to-here-doc) - (cperl-define-key "\C-c\C-v" 'cperl-next-interpolated-REx) - (cperl-define-key "\C-c\C-x" 'cperl-next-interpolated-REx-0) - (cperl-define-key "\C-c\C-y" 'cperl-next-interpolated-REx-1) - (cperl-define-key "\C-c\C-ha" 'cperl-toggle-autohelp) - (cperl-define-key "\C-c\C-hp" 'cperl-perldoc) - (cperl-define-key "\C-c\C-hP" 'cperl-perldoc-at-point) - (cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound - (cperl-define-key [?\C-\M-\|] 'cperl-lineup - [(control meta |)]) - ;;(cperl-define-key "\M-q" 'cperl-fill-paragraph) - ;;(cperl-define-key "\e;" 'cperl-indent-for-comment) - (cperl-define-key "\177" 'cperl-electric-backspace) - (cperl-define-key "\t" 'cperl-indent-command) - ;; don't clobber the backspace binding: - (cperl-define-key "\C-c\C-hF" 'cperl-info-on-command - [(control c) (control h) F]) - (if (cperl-val 'cperl-clobber-lisp-bindings) - (progn - (cperl-define-key "\C-hf" - ;;(concat (char-to-string help-char) "f") ; does not work - 'cperl-info-on-command - [(control h) f]) - (cperl-define-key "\C-hv" - ;;(concat (char-to-string help-char) "v") ; does not work - 'cperl-get-help - [(control h) v]) - (cperl-define-key "\C-c\C-hf" - ;;(concat (char-to-string help-char) "f") ; does not work - (key-binding "\C-hf") - [(control c) (control h) f]) - (cperl-define-key "\C-c\C-hv" - ;;(concat (char-to-string help-char) "v") ; does not work - (key-binding "\C-hv") - [(control c) (control h) v])) - (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command - [(control c) (control h) f]) - (cperl-define-key "\C-c\C-hv" - ;;(concat (char-to-string help-char) "v") ; does not work - 'cperl-get-help - [(control c) (control h) v])) - (if (and (featurep 'xemacs) - (<= emacs-minor-version 11) (<= emacs-major-version 19)) - (progn - ;; substitute-key-definition is usefulness-deenhanced... - ;;;;;(cperl-define-key "\M-q" 'cperl-fill-paragraph) - (cperl-define-key "\e;" 'cperl-indent-for-comment) - (cperl-define-key "\e\C-\\" 'cperl-indent-region)) + (mapc #'require '(imenu easymenu etags timer man info))) + +(define-abbrev-table 'cperl-mode-electric-keywords-abbrev-table + (mapcar (lambda (x) + (let ((name (car x)) + (fun (cadr x))) + (list name name fun :system t))) + '(("if" cperl-electric-keyword) + ("elsif" cperl-electric-keyword) + ("while" cperl-electric-keyword) + ("until" cperl-electric-keyword) + ("unless" cperl-electric-keyword) + ("else" cperl-electric-else) + ("continue" cperl-electric-else) + ("for" cperl-electric-keyword) + ("foreach" cperl-electric-keyword) + ("formy" cperl-electric-keyword) + ("foreachmy" cperl-electric-keyword) + ("do" cperl-electric-keyword) + ("=pod" cperl-electric-pod) + ("=begin" cperl-electric-pod t) + ("=over" cperl-electric-pod) + ("=head1" cperl-electric-pod) + ("=head2" cperl-electric-pod) + ("pod" cperl-electric-pod) + ("over" cperl-electric-pod) + ("head1" cperl-electric-pod) + ("head2" cperl-electric-pod))) + "Abbrev table for electric keywords. Controlled by `cperl-electric-keywords'." + :case-fixed t + :enable-function (lambda () (cperl-val 'cperl-electric-keywords))) + +(define-abbrev-table 'cperl-mode-abbrev-table () + "Abbrev table in use in CPerl mode buffers." + :parents (list cperl-mode-electric-keywords-abbrev-table)) + +(when (boundp 'edit-var-mode-alist) + ;; FIXME: What package uses this? + (add-to-list 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-")))) + +(defvar cperl-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "{" 'cperl-electric-lbrace) + (define-key map "[" 'cperl-electric-paren) + (define-key map "(" 'cperl-electric-paren) + (define-key map "<" 'cperl-electric-paren) + (define-key map "}" 'cperl-electric-brace) + (define-key map "]" 'cperl-electric-rparen) + (define-key map ")" 'cperl-electric-rparen) + (define-key map ";" 'cperl-electric-semi) + (define-key map ":" 'cperl-electric-terminator) + (define-key map "\C-j" 'newline-and-indent) + (define-key map "\C-c\C-j" 'cperl-linefeed) + (define-key map "\C-c\C-t" 'cperl-invert-if-unless) + (define-key map "\C-c\C-a" 'cperl-toggle-auto-newline) + (define-key map "\C-c\C-k" 'cperl-toggle-abbrev) + (define-key map "\C-c\C-w" 'cperl-toggle-construct-fix) + (define-key map "\C-c\C-f" 'auto-fill-mode) + (define-key map "\C-c\C-e" 'cperl-toggle-electric) + (define-key map "\C-c\C-b" 'cperl-find-bad-style) + (define-key map "\C-c\C-p" 'cperl-pod-spell) + (define-key map "\C-c\C-d" 'cperl-here-doc-spell) + (define-key map "\C-c\C-n" 'cperl-narrow-to-here-doc) + (define-key map "\C-c\C-v" 'cperl-next-interpolated-REx) + (define-key map "\C-c\C-x" 'cperl-next-interpolated-REx-0) + (define-key map "\C-c\C-y" 'cperl-next-interpolated-REx-1) + (define-key map "\C-c\C-ha" 'cperl-toggle-autohelp) + (define-key map "\C-c\C-hp" 'cperl-perldoc) + (define-key map "\C-c\C-hP" 'cperl-perldoc-at-point) + (define-key map "\e\C-q" 'cperl-indent-exp) ; Usually not bound + (define-key map [(control meta ?|)] 'cperl-lineup) + ;;(define-key map "\M-q" 'cperl-fill-paragraph) + ;;(define-key map "\e;" 'cperl-indent-for-comment) + (define-key map "\177" 'cperl-electric-backspace) + (define-key map "\t" 'cperl-indent-command) + ;; don't clobber the backspace binding: + (define-key map [(control ?c) (control ?h) ?F] 'cperl-info-on-command) + (if (cperl-val 'cperl-clobber-lisp-bindings) + (progn + (define-key map [(control ?h) ?f] + ;;(concat (char-to-string help-char) "f") ; does not work + 'cperl-info-on-command) + (define-key map [(control ?h) ?v] + ;;(concat (char-to-string help-char) "v") ; does not work + 'cperl-get-help) + (define-key map [(control ?c) (control ?h) ?f] + ;;(concat (char-to-string help-char) "f") ; does not work + (key-binding "\C-hf")) + (define-key map [(control ?c) (control ?h) ?v] + ;;(concat (char-to-string help-char) "v") ; does not work + (key-binding "\C-hv"))) + (define-key map [(control ?c) (control ?h) ?f] + 'cperl-info-on-current-command) + (define-key map [(control ?c) (control ?h) ?v] + ;;(concat (char-to-string help-char) "v") ; does not work + 'cperl-get-help)) (or (boundp 'fill-paragraph-function) - (substitute-key-definition - 'fill-paragraph 'cperl-fill-paragraph - cperl-mode-map global-map)) + (substitute-key-definition + 'fill-paragraph 'cperl-fill-paragraph + map global-map)) (substitute-key-definition 'indent-sexp 'cperl-indent-exp - cperl-mode-map global-map) + map global-map) (substitute-key-definition 'indent-region 'cperl-indent-region - cperl-mode-map global-map) + map global-map) (substitute-key-definition 'indent-for-comment 'cperl-indent-for-comment - cperl-mode-map global-map))) + map global-map) + map) + "Keymap used in CPerl mode.") (defvar cperl-menu) (defvar cperl-lazy-installed) @@ -1236,7 +1142,7 @@ versions of Emacs." ["Indent expression" cperl-indent-exp t] ["Fill paragraph/comment" fill-paragraph t] "----" - ["Line up a construction" cperl-lineup (cperl-use-region-p)] + ["Line up a construction" cperl-lineup (use-region-p)] ["Invert if/unless/while etc" cperl-invert-if-unless t] ("Regexp" ["Beautify" cperl-beautify-regexp @@ -1264,9 +1170,9 @@ versions of Emacs." ["Insert spaces if needed to fix style" cperl-find-bad-style t] ["Refresh \"hard\" constructions" cperl-find-pods-heres t] "----" - ["Indent region" cperl-indent-region (cperl-use-region-p)] - ["Comment region" cperl-comment-region (cperl-use-region-p)] - ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)] + ["Indent region" cperl-indent-region (use-region-p)] + ["Comment region" cperl-comment-region (use-region-p)] + ["Uncomment region" cperl-uncomment-region (use-region-p)] "----" ["Run" mode-compile (fboundp 'mode-compile)] ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) @@ -1313,7 +1219,7 @@ versions of Emacs." (fboundp 'ps-extend-face-list)] "----" ["Syntaxify region" cperl-find-pods-heres-region - (cperl-use-region-p)] + (use-region-p)] ["Profile syntaxification" cperl-time-fontification t] ["Debug errors in delayed fontification" cperl-emulate-lazy-lock t] ["Debug unwind for syntactic scan" cperl-toggle-set-debug-unwind t] @@ -1323,15 +1229,15 @@ versions of Emacs." ["Class Hierarchy from TAGS" cperl-tags-hier-init t] ;;["Update classes" (cperl-tags-hier-init t) tags-table-list] ("Tags" -;;; ["Create tags for current file" cperl-etags t] -;;; ["Add tags for current file" (cperl-etags t) t] -;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t] -;;; ["Add tags for Perl files in directory" (cperl-etags t t) t] -;;; ["Create tags for Perl files in (sub)directories" -;;; (cperl-etags nil 'recursive) t] -;;; ["Add tags for Perl files in (sub)directories" -;;; (cperl-etags t 'recursive) t]) -;;;; cperl-write-tags (&optional file erase recurse dir inbuffer) + ;; ["Create tags for current file" cperl-etags t] + ;; ["Add tags for current file" (cperl-etags t) t] + ;; ["Create tags for Perl files in directory" (cperl-etags nil t) t] + ;; ["Add tags for Perl files in directory" (cperl-etags t t) t] + ;; ["Create tags for Perl files in (sub)directories" + ;; (cperl-etags nil 'recursive) t] + ;; ["Add tags for Perl files in (sub)directories" + ;; (cperl-etags t 'recursive) t]) + ;; ;;? cperl-write-tags (&optional file erase recurse dir inbuffer) ["Create tags for current file" (cperl-write-tags nil t) t] ["Add tags for current file" (cperl-write-tags) t] ["Create tags for Perl files in directory" @@ -1352,11 +1258,9 @@ versions of Emacs." ["Perldoc on word at point" cperl-perldoc-at-point t] ["View manpage of POD in this file" cperl-build-manpage t] ["Auto-help on" cperl-lazy-install - (and (fboundp 'run-with-idle-timer) - (not cperl-lazy-installed))] + (not cperl-lazy-installed)] ["Auto-help off" cperl-lazy-unstall - (and (fboundp 'run-with-idle-timer) - cperl-lazy-installed)]) + cperl-lazy-installed]) ("Toggle..." ["Auto newline" cperl-toggle-auto-newline t] ["Electric parens" cperl-toggle-electric t] @@ -1383,7 +1287,8 @@ versions of Emacs." ["CPerl mode" (describe-function 'cperl-mode) t] ["CPerl version" (message "The version of master-file for this CPerl is %s-Emacs" - cperl-version) t])))) + cperl-version) + t])))) (error nil)) (autoload 'c-macro-expand "cmacexp" @@ -1391,22 +1296,22 @@ versions of Emacs." The expansion is entirely correct because it uses the C preprocessor." t) -;;; These two must be unwound, otherwise take exponential time +;; These two must be unwound, otherwise take exponential time (defconst cperl-maybe-white-and-comment-rex "[ \t\n]*\\(#[^\n]*\n[ \t\n]*\\)*" "Regular expression to match optional whitespace with interspersed comments. Should contain exactly one group.") -;;; This one is tricky to unwind; still very inefficient... +;; This one is tricky to unwind; still very inefficient... (defconst cperl-white-and-comment-rex "\\([ \t\n]\\|#[^\n]*\n\\)+" "Regular expression to match whitespace with interspersed comments. Should contain exactly one group.") -;;; Is incorporated in `cperl-imenu--function-name-regexp-perl' -;;; `cperl-outline-regexp', `defun-prompt-regexp'. -;;; Details of groups in this may be used in several functions; see comments -;;; near mentioned above variable(s)... -;;; sub($$):lvalue{} sub:lvalue{} Both allowed... +;; Is incorporated in `cperl-imenu--function-name-regexp-perl' +;; `cperl-outline-regexp', `defun-prompt-regexp'. +;; Details of groups in this may be used in several functions; see comments +;; near mentioned above variable(s)... +;; sub($$):lvalue{} sub:lvalue{} Both allowed... (defsubst cperl-after-sub-regexp (named attr) ; 9 groups without attr... "Match the text after `sub' in a subroutine declaration. If NAMED is nil, allows anonymous subroutines. Matches up to the first \":\" @@ -1441,9 +1346,22 @@ the last)." "\\)?" ; END n+6=proto-group )) -;;; Details of groups in this are used in `cperl-imenu--create-perl-index' -;;; and `cperl-outline-level'. -;;;; Was: 2=sub|package; now 2=package-group, 5=package-name 8=sub-name (+3) +;; Tired of editing this in 8 places every time I remember that there +;; is another method-defining keyword +(defvar cperl-sub-keywords + '("sub")) + +(defvar cperl-sub-regexp (regexp-opt cperl-sub-keywords)) + +(defun cperl-char-ends-sub-keyword-p (char) + "Return T if CHAR is the last character of a perl sub keyword." + (cl-loop for keyword in cperl-sub-keywords + when (eq char (aref keyword (1- (length keyword)))) + return t)) + +;; Details of groups in this are used in `cperl-imenu--create-perl-index' +;; and `cperl-outline-level'. +;; Was: 2=sub|package; now 2=package-group, 5=package-name 8=sub-name (+3) (defvar cperl-imenu--function-name-regexp-perl (concat "^\\(" ; 1 = all @@ -1452,7 +1370,8 @@ the last)." cperl-white-and-comment-rex ; 4 = pre-package-name "\\([a-zA-Z_0-9:']+\\)\\)?\\)" ; 5 = package-name "\\|" - "[ \t]*sub" + "[ \t]*" + cperl-sub-regexp (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start cperl-maybe-white-and-comment-rex ; 15=pre-block "\\|" @@ -1624,7 +1543,7 @@ It is possible to show this help automatically after some idle time. This is regulated by variable `cperl-lazy-help-time'. Default with `cperl-hairy' (if the value of `cperl-lazy-help-time' is nil) is 5 secs idle time . It is also possible to switch this on/off from the -menu, or via \\[cperl-toggle-autohelp]. Requires `run-with-idle-timer'. +menu, or via \\[cperl-toggle-autohelp]. Use \\[cperl-lineup] to vertically lineup some construction - put the beginning of the region at the start of construction, and make region @@ -1709,9 +1628,8 @@ or as help on variables `cperl-tips', `cperl-problems', (cperl-val 'cperl-info-on-command-no-prompt)) (progn ;; don't clobber the backspace binding: - (cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f]) - (cperl-define-key "\C-c\C-hf" 'cperl-info-on-command - [(control c) (control h) f]))) + (define-key cperl-mode-map "\C-hf" 'cperl-info-on-current-command) + (define-key cperl-mode-map "\C-c\C-hf" 'cperl-info-on-command))) (setq local-abbrev-table cperl-mode-abbrev-table) (if (cperl-val 'cperl-electric-keywords) (abbrev-mode 1)) @@ -1719,107 +1637,66 @@ or as help on variables `cperl-tips', `cperl-problems', ;; Until Emacs is multi-threaded, we do not actually need it local: (make-local-variable 'cperl-font-lock-multiline-start) (make-local-variable 'cperl-font-locking) - (make-local-variable 'outline-regexp) - ;; (setq outline-regexp imenu-example--function-name-regexp-perl) - (setq outline-regexp cperl-outline-regexp) - (make-local-variable 'outline-level) - (setq outline-level 'cperl-outline-level) - (make-local-variable 'add-log-current-defun-function) - (setq add-log-current-defun-function + (set (make-local-variable 'outline-regexp) cperl-outline-regexp) + (set (make-local-variable 'outline-level) 'cperl-outline-level) + (set (make-local-variable 'add-log-current-defun-function) (lambda () (save-excursion (if (re-search-backward "^sub[ \t]+\\([^({ \t\n]+\\)" nil t) (match-string-no-properties 1))))) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (if (featurep 'xemacs) - (progn - (make-local-variable 'paren-backwards-message) - (set 'paren-backwards-message t))) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'cperl-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline mode-require-final-newline) - (make-local-variable 'comment-start) - (setq comment-start "# ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column cperl-comment-column) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "#+ *") - (make-local-variable 'defun-prompt-regexp) -;;; "[ \t]*sub" -;;; (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start -;;; cperl-maybe-white-and-comment-rex ; 15=pre-block - (setq defun-prompt-regexp - (concat "^[ \t]*\\(sub" - (cperl-after-sub-regexp 'named 'attr-groups) - "\\|" ; per toke.c - "\\(BEGIN\\|CHECK\\|INIT\\|END\\|AUTOLOAD\\|DESTROY\\)" - "\\)" - cperl-maybe-white-and-comment-rex)) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'cperl-comment-indent) + (set (make-local-variable 'paragraph-start) (concat "^$\\|" page-delimiter)) + (set (make-local-variable 'paragraph-separate) paragraph-start) + (set (make-local-variable 'paragraph-ignore-fill-prefix) t) + (set (make-local-variable 'indent-line-function) #'cperl-indent-line) + (set (make-local-variable 'require-final-newline) mode-require-final-newline) + (set (make-local-variable 'comment-start) "# ") + (set (make-local-variable 'comment-end) "") + (set (make-local-variable 'comment-column) cperl-comment-column) + (set (make-local-variable 'comment-start-skip) "#+ *") + +;; "[ \t]*sub" +;; (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start +;; cperl-maybe-white-and-comment-rex ; 15=pre-block + (set (make-local-variable 'defun-prompt-regexp) + (concat "^[ \t]*\\(" + cperl-sub-regexp + (cperl-after-sub-regexp 'named 'attr-groups) + "\\|" ; per toke.c + "\\(BEGIN\\|UNITCHECK\\|CHECK\\|INIT\\|END\\|AUTOLOAD\\|DESTROY\\)" + "\\)" + cperl-maybe-white-and-comment-rex)) + (set (make-local-variable 'comment-indent-function) #'cperl-comment-indent) (and (boundp 'fill-paragraph-function) - (progn - (make-local-variable 'fill-paragraph-function) - (set 'fill-paragraph-function 'cperl-fill-paragraph))) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (make-local-variable 'indent-region-function) - (setq indent-region-function 'cperl-indent-region) - ;;(setq auto-fill-function 'cperl-do-auto-fill) ; Need to switch on and off! - (make-local-variable 'imenu-create-index-function) - (setq imenu-create-index-function - (function cperl-imenu--create-perl-index)) - (make-local-variable 'imenu-sort-function) - (setq imenu-sort-function nil) - (make-local-variable 'vc-rcs-header) - (set 'vc-rcs-header cperl-vc-rcs-header) - (make-local-variable 'vc-sccs-header) - (set 'vc-sccs-header cperl-vc-sccs-header) - (when (featurep 'xemacs) - ;; This one is obsolete... - (make-local-variable 'vc-header-alist) - (set 'vc-header-alist (or cperl-vc-header-alist ; Avoid warning - `((SCCS ,(car cperl-vc-sccs-header)) - (RCS ,(car cperl-vc-rcs-header)))))) + (set (make-local-variable 'fill-paragraph-function) + #'cperl-fill-paragraph)) + (set (make-local-variable 'parse-sexp-ignore-comments) t) + (set (make-local-variable 'indent-region-function) #'cperl-indent-region) + ;;(setq auto-fill-function #'cperl-do-auto-fill) ; Need to switch on and off! + (set (make-local-variable 'imenu-create-index-function) + #'cperl-imenu--create-perl-index) + (set (make-local-variable 'imenu-sort-function) nil) + (set (make-local-variable 'vc-rcs-header) cperl-vc-rcs-header) + (set (make-local-variable 'vc-sccs-header) cperl-vc-sccs-header) (cond ((boundp 'compilation-error-regexp-alist-alist);; xemacs 20.x - (make-local-variable 'compilation-error-regexp-alist-alist) - (set 'compilation-error-regexp-alist-alist + (set (make-local-variable 'compilation-error-regexp-alist-alist) (cons (cons 'cperl (car cperl-compilation-error-regexp-alist)) - (symbol-value 'compilation-error-regexp-alist-alist))) + compilation-error-regexp-alist-alist)) (if (fboundp 'compilation-build-compilation-error-regexp-alist) (let ((f 'compilation-build-compilation-error-regexp-alist)) (funcall f)) (make-local-variable 'compilation-error-regexp-alist) (push 'cperl compilation-error-regexp-alist))) ((boundp 'compilation-error-regexp-alist);; xemacs 19.x - (make-local-variable 'compilation-error-regexp-alist) - (set 'compilation-error-regexp-alist + (set (make-local-variable 'compilation-error-regexp-alist) (append cperl-compilation-error-regexp-alist - (symbol-value 'compilation-error-regexp-alist))))) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - (cond - ((string< emacs-version "19.30") - '(cperl-font-lock-keywords-2 nil nil ((?_ . "w")))) - ((string< emacs-version "19.33") ; Which one to use? - '((cperl-font-lock-keywords - cperl-font-lock-keywords-1 - cperl-font-lock-keywords-2) nil nil ((?_ . "w")))) - (t - '((cperl-load-font-lock-keywords - cperl-load-font-lock-keywords-1 - cperl-load-font-lock-keywords-2) nil nil ((?_ . "w")))))) - (make-local-variable 'cperl-syntax-state) - (setq cperl-syntax-state nil) ; reset syntaxification cache + compilation-error-regexp-alist)))) + (set (make-local-variable 'font-lock-defaults) + '((cperl-load-font-lock-keywords + cperl-load-font-lock-keywords-1 + cperl-load-font-lock-keywords-2) nil nil ((?_ . "w")))) + ;; Reset syntaxification cache. + (set (make-local-variable 'cperl-syntax-state) nil) (if cperl-use-syntax-table-text-property (if (eval-when-compile (fboundp 'syntax-propertize-rules)) (progn @@ -1834,21 +1711,19 @@ or as help on variables `cperl-tips', `cperl-problems', ;; to re-apply them. (setq cperl-syntax-done-to start) (cperl-fontify-syntaxically end)))) - (make-local-variable 'parse-sexp-lookup-properties) ;; Do not introduce variable if not needed, we check it! - (set 'parse-sexp-lookup-properties t) + (set (make-local-variable 'parse-sexp-lookup-properties) t) ;; Fix broken font-lock: (or (boundp 'font-lock-unfontify-region-function) - (set 'font-lock-unfontify-region-function - 'font-lock-default-unfontify-region)) - (unless (featurep 'xemacs) ; Our: just a plug for wrong font-lock - (make-local-variable 'font-lock-unfontify-region-function) - (set 'font-lock-unfontify-region-function ; not present with old Emacs - 'cperl-font-lock-unfontify-region-function)) - (make-local-variable 'cperl-syntax-done-to) - (setq cperl-syntax-done-to nil) ; reset syntaxification cache - (make-local-variable 'font-lock-syntactic-keywords) - (setq font-lock-syntactic-keywords + (setq font-lock-unfontify-region-function + #'font-lock-default-unfontify-region)) + ;; Our: just a plug for wrong font-lock + (set (make-local-variable 'font-lock-unfontify-region-function) + ;; not present with old Emacs + #'cperl-font-lock-unfontify-region-function) + ;; Reset syntaxification cache. + (set (make-local-variable 'cperl-syntax-done-to) nil) + (set (make-local-variable 'font-lock-syntactic-keywords) (if cperl-syntaxify-by-font-lock '((cperl-fontify-syntaxically)) ;; unless font-lock-syntactic-keywords, font-lock (pre-22.1) @@ -1860,54 +1735,43 @@ or as help on variables `cperl-tips', `cperl-problems', (progn (setq cperl-font-lock-multiline t) ; Not localized... (set (make-local-variable 'font-lock-multiline) t)) - (make-local-variable 'font-lock-fontify-region-function) - (set 'font-lock-fontify-region-function ; not present with old Emacs - 'cperl-font-lock-fontify-region-function)) - (make-local-variable 'font-lock-fontify-region-function) - (set 'font-lock-fontify-region-function ; not present with old Emacs - 'cperl-font-lock-fontify-region-function) + (set (make-local-variable 'font-lock-fontify-region-function) + ;; not present with old Emacs + #'cperl-font-lock-fontify-region-function)) + (set (make-local-variable 'font-lock-fontify-region-function) + #'cperl-font-lock-fontify-region-function) (make-local-variable 'cperl-old-style) - (if (boundp 'normal-auto-fill-function) ; 19.33 and later - (set (make-local-variable 'normal-auto-fill-function) - 'cperl-do-auto-fill) - (or (fboundp 'cperl-old-auto-fill-mode) - (progn - (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode)) - (defun auto-fill-mode (&optional arg) - (interactive "P") - (eval '(cperl-old-auto-fill-mode arg)) ; Avoid a warning - (and auto-fill-function (memq major-mode '(perl-mode cperl-mode)) - (setq auto-fill-function 'cperl-do-auto-fill)))))) - (if (cperl-enable-font-lock) - (if (cperl-val 'cperl-font-lock) - (progn (or cperl-faces-init (cperl-init-faces)) - (font-lock-mode 1)))) + (set (make-local-variable 'normal-auto-fill-function) + #'cperl-do-auto-fill) + (if (cperl-val 'cperl-font-lock) + (progn (or cperl-faces-init (cperl-init-faces)) + (font-lock-mode 1))) (set (make-local-variable 'facemenu-add-face-function) - 'cperl-facemenu-add-face-function) ; XXXX What this guy is for??? + #'cperl-facemenu-add-face-function) ; XXXX What this guy is for??? (and (boundp 'msb-menu-cond) (not cperl-msb-fixed) (cperl-msb-fix)) (if (fboundp 'easy-menu-add) (easy-menu-add cperl-menu)) ; A NOP in Emacs. - (run-mode-hooks 'cperl-mode-hook) (if cperl-hook-after-change - (add-hook 'after-change-functions 'cperl-after-change-function nil t)) + (add-hook 'after-change-functions #'cperl-after-change-function nil t)) ;; After hooks since fontification will break this (if cperl-pod-here-scan (or cperl-syntaxify-by-font-lock (progn (or cperl-faces-init (cperl-init-faces-weak)) (cperl-find-pods-heres)))) ;; Setup Flymake - (add-hook 'flymake-diagnostic-functions 'perl-flymake nil t)) + (add-hook 'flymake-diagnostic-functions #'perl-flymake nil t)) ;; Fix for perldb - make default reasonable (defun cperl-db () (interactive) (require 'gud) + ;; FIXME: Use `read-string' or `read-shell-command'? (perldb (read-from-minibuffer "Run perldb (like this): " (if (consp gud-perldb-history) (car gud-perldb-history) - (concat "perl " + (concat "perl -d " (buffer-file-name))) nil nil '(gud-perldb-history . 1)))) @@ -1971,24 +1835,24 @@ or as help on variables `cperl-tips', `cperl-problems', (cperl-make-indent comment-column 1) ; Indent min 1 c))))) -;;;(defun cperl-comment-indent-fallback () -;;; "Is called if the standard comment-search procedure fails. -;;;Point is at start of real comment." -;;; (let ((c (current-column)) target cnt prevc) -;;; (if (= c comment-column) nil -;;; (setq cnt (skip-chars-backward "[ \t]")) -;;; (setq target (max (1+ (setq prevc -;;; (current-column))) ; Else indent at comment column -;;; comment-column)) -;;; (if (= c comment-column) nil -;;; (delete-backward-char cnt) -;;; (while (< prevc target) -;;; (insert "\t") -;;; (setq prevc (current-column))) -;;; (if (> prevc target) (progn (delete-char -1) (setq prevc (current-column)))) -;;; (while (< prevc target) -;;; (insert " ") -;;; (setq prevc (current-column))))))) +;;(defun cperl-comment-indent-fallback () +;; "Is called if the standard comment-search procedure fails. +;;Point is at start of real comment." +;; (let ((c (current-column)) target cnt prevc) +;; (if (= c comment-column) nil +;; (setq cnt (skip-chars-backward " \t")) +;; (setq target (max (1+ (setq prevc +;; (current-column))) ; Else indent at comment column +;; comment-column)) +;; (if (= c comment-column) nil +;; (delete-backward-char cnt) +;; (while (< prevc target) +;; (insert "\t") +;; (setq prevc (current-column))) +;; (if (> prevc target) (progn (delete-char -1) (setq prevc (current-column)))) +;; (while (< prevc target) +;; (insert " ") +;; (setq prevc (current-column))))))) (defun cperl-indent-for-comment () "Substitute for `indent-for-comment' in CPerl." @@ -2024,7 +1888,7 @@ char is \"{\", insert extra newline before only if (interactive "P") (let (insertpos (other-end (if (and cperl-electric-parens-mark - (cperl-mark-active) + (region-active-p) (< (mark) (point))) (mark) nil))) @@ -2096,13 +1960,13 @@ char is \"{\", insert extra newline before only if (cperl-auto-newline cperl-auto-newline) (other-end (or end (if (and cperl-electric-parens-mark - (cperl-mark-active) + (region-active-p) (> (mark) (point))) (save-excursion (goto-char (mark)) (point-marker)) nil))) - pos after) + pos) (and (cperl-val 'cperl-electric-lbrace-space) (eq (preceding-char) ?$) (save-excursion @@ -2132,9 +1996,8 @@ char is \"{\", insert extra newline before only if "Insert an opening parenthesis or a matching pair of parentheses. See `cperl-electric-parens'." (interactive "P") - (let ((beg (point-at-bol)) - (other-end (if (and cperl-electric-parens-mark - (cperl-mark-active) + (let ((other-end (if (and cperl-electric-parens-mark + (region-active-p) (> (mark) (point))) (save-excursion (goto-char (mark)) @@ -2144,7 +2007,6 @@ See `cperl-electric-parens'." (memq last-command-event (append cperl-electric-parens-string nil)) (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) - ;;(not (save-excursion (search-backward "#" beg t))) (if (eq last-command-event ?<) (progn ;; This code is too electric, see Bug#3943. @@ -2169,12 +2031,11 @@ See `cperl-electric-parens'." If not, or if we are not at the end of marking range, would self-insert. Affected by `cperl-electric-parens'." (interactive "P") - (let ((beg (point-at-bol)) - (other-end (if (and cperl-electric-parens-mark + (let ((other-end (if (and cperl-electric-parens-mark (cperl-val 'cperl-electric-parens) (memq last-command-event (append cperl-electric-parens-string nil)) - (cperl-mark-active) + (region-active-p) (< (mark) (point))) (mark) nil)) @@ -2183,7 +2044,6 @@ Affected by `cperl-electric-parens'." (cperl-val 'cperl-electric-parens) (memq last-command-event '( ?\) ?\] ?\} ?\> )) (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) - ;;(not (save-excursion (search-backward "#" beg t))) ) (progn (self-insert-command (prefix-numeric-value arg)) @@ -2223,6 +2083,7 @@ to nil." (save-excursion (or (not (re-search-backward "^=" nil t)) (or (looking-at "=cut") + (looking-at "=end") (and cperl-use-syntax-table-text-property (not (eq (get-text-property (point) 'syntax-type) @@ -2297,7 +2158,7 @@ to nil." (get-text-property (point) 'in-pod) (cperl-after-expr-p nil "{;:") (and (re-search-backward "\\(\\`\n?\\|^\n\\)=\\sw+" (point-min) t) - (not (looking-at "\n*=cut")) + (not (or (looking-at "\n*=cut") (looking-at "\n*=end"))) (or (not cperl-use-syntax-table-text-property) (eq (get-text-property (point) 'syntax-type) 'pod)))))) (progn @@ -2316,7 +2177,7 @@ to nil." nil t)))) ; Only one (progn (forward-word-strictly 1) - (setq name (file-name-base) + (setq name (file-name-base (buffer-file-name)) p (point)) (insert " NAME\n\n" name " - \n\n=head1 SYNOPSIS\n\n\n\n" @@ -2355,6 +2216,7 @@ to nil." beg t))) (save-excursion (or (not (re-search-backward "^=" nil t)) (looking-at "=cut") + (looking-at "=end") (and cperl-use-syntax-table-text-property (not (eq (get-text-property (point) 'syntax-type) @@ -2454,7 +2316,7 @@ If in POD, insert appropriate lines." ;; We are after \n now, so look for the rest (if (looking-at "\\(\\`\n?\\|\n\\)=\\sw+") (progn - (setq cut (looking-at "\\(\\`\n?\\|\n\\)=cut\\>")) + (setq cut (looking-at "\\(\\`\n?\\|\n\\)=\\(cut\\|end\\)\\>")) (setq over (looking-at "\\(\\`\n?\\|\n\\)=over\\>")) t))) (if (and over @@ -2622,11 +2484,10 @@ The relative indentation among the lines of the expression are preserved." Return the amount the indentation changed by." (let ((case-fold-search nil) (pos (- (point-max) (point))) - indent i beg shift-amt) + indent i shift-amt) (setq indent (cperl-calculate-indent parse-data) i indent) (beginning-of-line) - (setq beg (point)) (cond ((or (eq indent nil) (eq indent t)) (setq indent (current-indentation) i nil)) ;;((eq indent t) ; Never? @@ -2653,8 +2514,8 @@ Return the amount the indentation changed by." (zerop shift-amt)) (if (> (- (point-max) pos) (point)) (goto-char (- (point-max) pos))) - ;;;(delete-region beg (point)) - ;;;(indent-to indent) + ;;(delete-region beg (point)) + ;;(indent-to indent) (cperl-make-indent indent) ;; If initial point was within line's indentation, ;; position after the indentation. Else stay at same point in text. @@ -2672,13 +2533,13 @@ Return the amount the indentation changed by." (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:[^:]")))) (defun cperl-get-state (&optional parse-start start-state) - ;; returns list (START STATE DEPTH PRESTART), - ;; START is a good place to start parsing, or equal to - ;; PARSE-START if preset, - ;; STATE is what is returned by `parse-partial-sexp'. - ;; DEPTH is true is we are immediately after end of block - ;; which contains START. - ;; PRESTART is the position basing on which START was found. + "Return list (START STATE DEPTH PRESTART), +START is a good place to start parsing, or equal to +PARSE-START if preset, +STATE is what is returned by `parse-partial-sexp'. +DEPTH is true is we are immediately after end of block +which contains START. +PRESTART is the position basing on which START was found." (save-excursion (let ((start-point (point)) depth state start prestart) (if (and parse-start @@ -2707,17 +2568,17 @@ Return the amount the indentation changed by." (defun cperl-beginning-of-property (p prop &optional lim) "Given that P has a property PROP, find where the property starts. Will not look before LIM." - ;;; XXXX What to do at point-max??? +;;; XXXX What to do at point-max??? (or (previous-single-property-change (cperl-1+ p) prop lim) (point-min)) -;;; (cond ((eq p (point-min)) -;;; p) -;;; ((and lim (<= p lim)) -;;; p) -;;; ((not (get-text-property (1- p) prop)) -;;; p) -;;; (t (or (previous-single-property-change p look-prop lim) -;;; (point-min)))) + ;; (cond ((eq p (point-min)) + ;; p) + ;; ((and lim (<= p lim)) + ;; p) + ;; ((not (get-text-property (1- p) prop)) + ;; p) + ;; (t (or (previous-single-property-change p look-prop lim) + ;; (point-min)))) ) (defun cperl-sniff-for-indent (&optional parse-data) ; was parse-start @@ -2887,6 +2748,8 @@ Will not look before LIM." (cperl-backward-to-noncomment containing-sexp)) ;; Now we get non-label preceding the indent point (if (not (or (eq (1- (point)) containing-sexp) + (and cperl-indent-parens-as-block + (not is-block)) (memq (preceding-char) (append (if is-block " ;{" " ,;{") '(nil))) (and (eq (preceding-char) ?\}) @@ -2962,12 +2825,13 @@ Will not look before LIM." ;; first thing on the line, say in the case of ;; anonymous sub in a hash. (if (and;; Is it a sub in group starting on this line? + cperl-indent-subs-specially (cond ((get-text-property (point) 'attrib-group) (goto-char (cperl-beginning-of-property (point) 'attrib-group))) ((eq (preceding-char) ?b) (forward-sexp -1) - (looking-at "sub\\>"))) + (looking-at (concat cperl-sub-regexp "\\>")))) (setq p (nth 1 ; start of innermost containing list (parse-partial-sexp (point-at-bol) @@ -3001,7 +2865,10 @@ Will not look before LIM." "Alist of indentation rules for CPerl mode. The values mean: nil: do not indent; - number: add this amount of indentation.") + FUNCTION: a function to compute the indentation to use. + Takes a single argument which provides the currently computed indentation + context, and should return the column to which to indent. + NUMBER: add this amount of indentation.") (defun cperl-calculate-indent (&optional parse-data) ; was parse-start "Return appropriate indentation for current line as Perl code. @@ -3020,7 +2887,11 @@ and closing parentheses and brackets." ((vectorp i) (setq what (assoc (elt i 0) cperl-indent-rules-alist)) (cond - (what (cadr what)) ; Load from table + (what + (let ((action (cadr what))) + (cond ((functionp action) (apply action (list i parse-data))) + ((numberp action) (+ action (current-indentation))) + (t action)))) ;; ;; Indenters for regular expressions with //x and qw() ;; @@ -3184,7 +3055,7 @@ and closing parentheses and brackets." (defun cperl-calculate-indent-within-comment () "Return the indentation amount for line, assuming that the current line is to be regarded as part of a block comment." - (let (end star-start) + (let (end) (save-excursion (beginning-of-line) (skip-chars-forward " \t") @@ -3230,12 +3101,12 @@ Returns true if comment is found. In POD will not move the point." (cond ((looking-at "\\(s\\|tr\\)\\>") (or (re-search-forward - "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*" + "\\=\\w+[ \t]*#\\([^\n\\#]\\|\\\\[\\#]\\)*#\\([^\n\\#]\\|\\\\[\\#]\\)*" lim 'move) (setq stop-in t))) ((looking-at "\\(m\\|q\\([qxwr]\\)?\\)\\>") (or (re-search-forward - "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#" + "\\=\\w+[ \t]*#\\([^\n\\#]\\|\\\\[\\#]\\)*#" lim 'move) (setq stop-in t))) (t ; It was fair comment @@ -3442,8 +3313,8 @@ Works before syntax recognition is done." (or now (put-text-property b e 'cperl-postpone (cons type val))) (put-text-property b e type val))) -;;; Here is how the global structures (those which cannot be -;;; recognized locally) are marked: +;; Here is how the global structures (those which cannot be +;; recognized locally) are marked: ;; a) PODs: ;; Start-to-end is marked `in-pod' ==> t ;; Each non-literal part is marked `syntax-type' ==> `pod' @@ -3463,17 +3334,16 @@ Works before syntax recognition is done." ;; (or 0 if declaration); up to `{' or ';': `syntax-type' => `sub-decl'. ;; f) Multiline my/our declaration lists etc: `syntax-type' => `multiline' -;;; In addition, some parts of RExes may be marked as `REx-interpolated' -;;; (value: 0 in //o, 1 if "interpolated variable" is whole-REx, t otherwise). +;; In addition, some parts of RExes may be marked as `REx-interpolated' +;; (value: 0 in //o, 1 if "interpolated variable" is whole-REx, t otherwise). (defun cperl-unwind-to-safe (before &optional end) ;; if BEFORE, go to the previous start-of-line on each step of unwinding - (let ((pos (point)) opos) + (let ((pos (point))) (while (and pos (progn (beginning-of-line) (get-text-property (setq pos (point)) 'syntax-type))) - (setq opos pos - pos (cperl-beginning-of-property pos 'syntax-type)) + (setq pos (cperl-beginning-of-property pos 'syntax-type)) (if (eq pos (point-min)) (setq pos nil)) (if pos @@ -3502,7 +3372,7 @@ Works before syntax recognition is done." (setq end (point))))) (or end pos))))) -;;; These are needed for byte-compile (at least with v19) +;; These are needed for byte-compile (at least with v19) (defvar cperl-nonoverridable-face) (defvar font-lock-variable-name-face) (defvar font-lock-function-name-face) @@ -3517,7 +3387,7 @@ Works before syntax recognition is done." Should be called with the point before leading colon of an attribute." ;; Works *before* syntax recognition is done (or st-l (setq st-l (list nil))) ; Avoid overwriting '() - (let (st b p reset-st after-first (start (point)) start1 end1) + (let (st p reset-st after-first (start (point)) start1 end1) (condition-case b (while (looking-at (concat @@ -3593,18 +3463,18 @@ Should be called with the point before leading colon of an attribute." (defsubst cperl-highlight-charclass (endbracket dashface bsface onec-space) (let ((l '(1 5 7)) ll lle lll ;; 2 groups, the first takes the whole match (include \[trnfabe]) - (singleChar (concat "\\(" "[^\\\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)"))) + (singleChar (concat "\\(" "[^\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([[:xdigit:]][[:xdigit:]]?\\|\\={[[:xdigit:]]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)"))) (while ; look for unescaped - between non-classes (re-search-forward ;; On 19.33, certain simplifications lead ;; to bugs (as in [^a-z] \\| [trnfabe] ) (concat ; 1: SingleChar (include \[trnfabe]) singleChar - ;;"\\(" "[^\\\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)" + ;;"\\(" "[^\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([[:xdigit:]][[:xdigit:]]?\\|\\={[[:xdigit:]]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)" "\\(" ; 3: DASH SingleChar (match optionally) "\\(-\\)" ; 4: DASH singleChar ; 5: SingleChar - ;;"\\(" "[^\\\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)" + ;;"\\(" "[^\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([[:xdigit:]][[:xdigit:]]?\\|\\={[[:xdigit:]]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)" "\\)?" "\\|" "\\(" ; 7: other escapes @@ -3618,7 +3488,8 @@ Should be called with the point before leading colon of an attribute." 'face dashface)) ;; save match data (for looking-at) (setq lll (mapcar (function (lambda (elt) (cons (match-beginning elt) - (match-end elt)))) l)) + (match-end elt)))) + l)) (while lll (setq ll (car lll)) (setq lle (cdr ll) @@ -3636,7 +3507,7 @@ Should be called with the point before leading colon of an attribute." (goto-char endbracket) ; just in case something misbehaves??? t)) -;;; Debugging this may require (setq max-specpdl-size 2000)... +;; Debugging this may require (setq max-specpdl-size 2000)... (defun cperl-find-pods-heres (&optional min max non-inter end ignore-max end-of-here-doc) "Scans the buffer for hard-to-parse Perl constructions. If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify @@ -3746,7 +3617,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob> "\\|" ;; 1+6+2+1+1=11 extra () before this - "\\<sub\\>" ; sub with proto/attr + "\\<" cperl-sub-regexp "\\>" ; sub with proto/attr "\\(" cperl-white-and-comment-rex "\\(::[a-zA-Z_:'0-9]*\\|[a-zA-Z_'][a-zA-Z_:'0-9]*\\)\\)?" ; name @@ -3759,7 +3630,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', "\\|" ;; 1+6+2+1+1+6+1=18 extra () before this (old pack'var syntax; ;; we do not support intervening comments...): - "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'" + "\\(\\<" cperl-sub-regexp "[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'" ;; 1+6+2+1+1+6+1+1=19 extra () before this: "\\|" "__\\(END\\|DATA\\)__" ; __END__ or __DATA__ @@ -3792,14 +3663,6 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', indentable t)) ;; Need to remove face as well... (goto-char min) - ;; 'emx not supported by Emacs since at least 21.1. - (and (featurep 'xemacs) (eq system-type 'emx) - (eq (point) 1) - (let ((case-fold-search t)) - (looking-at "extproc[ \t]")) ; Analogue of #! - (cperl-commentify min - (point-at-eol) - nil)) (while (and (< (point) max) (re-search-forward search max t)) @@ -3834,7 +3697,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', state-point b nil nil state) state-point b) (if (or (nth 3 state) (nth 4 state) - (looking-at "cut\\>")) + (looking-at "\\(cut\\|end\\)\\>")) (if (or (nth 3 state) (nth 4 state) ignore-max) nil ; Doing a chunk only (message "=cut is not preceded by a POD section") @@ -3847,10 +3710,10 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', b1 nil) ; error condition ;; We do not search to max, since we may be called from ;; some hook of fontification, and max is random - (or (re-search-forward "^\n=cut\\>" stop-point 'toend) + (or (re-search-forward "^\n=\\(cut\\|end\\)\\>" stop-point 'toend) (progn (goto-char b) - (if (re-search-forward "\n=cut\\>" stop-point 'toend) + (if (re-search-forward "\n=\\(cut\\|end\\)\\>" stop-point 'toend) (progn (message "=cut is not preceded by an empty line") (setq b1 t) @@ -3957,7 +3820,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (progn (forward-sexp -2) (not - (looking-at "\\(printf?\\|system\\|exec\\|sort\\)\\>"))) + (looking-at "\\(printf?\\|say\\|system\\|exec\\|sort\\)\\>"))) (error t))))))) (error nil))) ; func(<<EOF) (and (not (match-beginning 6)) ; Empty @@ -4141,7 +4004,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (not (memq (preceding-char) '(?$ ?@ ?& ?%))) (looking-at - "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>"))))) + "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\|say\\)\\>"))))) (and (eq (preceding-char) ?.) (eq (char-after (- (point) 2)) ?.)) (bobp)) @@ -4505,7 +4368,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', "\\=[0123456789]*" (1- e) 'to-end)) (and (eq qtag ?x) (re-search-forward - "\\=[0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}" + "\\=[[:xdigit:]][[:xdigit:]]?\\|\\={[[:xdigit:]]+}" (1- e) 'to-end)) (and (memq qtag (append "pPN" nil)) (re-search-forward "\\={[^{}]+}\\|." @@ -4539,14 +4402,14 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (setq REx-subgr-end qtag) ;End smart-highlighted ;; Apparently, I can't put \] into a charclass ;; in m]]: m][\\\]\]] produces [\\]] -;;; POSIX? [:word:] [:^word:] only inside [] -;;; "\\=\\(\\\\.\\|[^][\\\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]") +;;; POSIX? [:word:] [:^word:] only inside [] +;;; "\\=\\(\\\\.\\|[^][\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]") (while ; look for unescaped ] (and argument (re-search-forward (if (eq (char-after b) ?\] ) - "\\=\\(\\\\[^]]\\|[^]\\\\]\\)*\\\\]" - "\\=\\(\\\\.\\|[^]\\\\]\\)*]") + "\\=\\(\\\\[^]]\\|[^]\\]\\)*\\\\]" + "\\=\\(\\\\.\\|[^]\\]\\)*]") (1- e) 'toend)) ;; Is this ] an end of POSIX class? (if (save-excursion @@ -4665,7 +4528,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; Works also if the outside delimiters are (). (or;;(if (eq (char-after b) ?\) ) ;;(re-search-forward - ;; "[^\\\\]\\(\\\\\\\\\\)*\\\\)" + ;; "[^\\]\\(\\\\\\\\\\)*\\\\)" ;; (1- e) 'toend) (search-forward ")" (1- e) 'toend) ;;) @@ -4797,8 +4660,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (setq stop t)))))) ;; Used only in `cperl-calculate-indent'... -(defun cperl-block-p () ; Do not C-M-q ! One string contains ";" ! - ;; Positions is before ?\{. Checks whether it starts a block. +(defun cperl-block-p () + "Point is before ?\\{. Checks whether it starts a block." ;; No save-excursion! This is more a distinguisher of a block/hash ref... (cperl-backward-to-noncomment (point-min)) (or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp @@ -4817,14 +4680,14 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (and (eq (preceding-char) ?b) (progn (forward-sexp -1) - (looking-at "sub[ \t\n\f#]"))))))))) - -;;; What is the difference of (cperl-after-block-p lim t) and (cperl-block-p)? -;;; No save-excursion; condition-case ... In (cperl-block-p) the block -;;; may be a part of an in-statement construct, such as -;;; ${something()}, print {FH} $data. -;;; Moreover, one takes positive approach (looks for else,grep etc) -;;; another negative (looks for bless,tr etc) + (looking-at (concat cperl-sub-regexp "[ \t\n\f#]")))))))))) + +;; What is the difference of (cperl-after-block-p lim t) and (cperl-block-p)? +;; No save-excursion; condition-case ... In (cperl-block-p) the block +;; may be a part of an in-statement construct, such as +;; ${something()}, print {FH} $data. +;; Moreover, one takes positive approach (looks for else,grep etc) +;; another negative (looks for bless,tr etc) (defun cperl-after-block-p (lim &optional pre-block) "Return true if the preceding } (if PRE-BLOCK, following {) delimits a block. Would not look before LIM. Assumes that LIM is a good place to begin a @@ -4846,15 +4709,16 @@ statement would start; thus the block in ${func()} does not count." (save-excursion (forward-sexp -1) ;; else {} but not else::func {} - (or (and (looking-at "\\(else\\|continue\\|grep\\|map\\|BEGIN\\|END\\|CHECK\\|INIT\\)\\>") + (or (and (looking-at "\\(else\\|catch\\|try\\|continue\\|grep\\|map\\|BEGIN\\|END\\|UNITCHECK\\|CHECK\\|INIT\\)\\>") (not (looking-at "\\(\\sw\\|_\\)+::"))) ;; sub f {} (progn (cperl-backward-to-noncomment lim) - (and (eq (preceding-char) ?b) + (and (cperl-char-ends-sub-keyword-p (preceding-char)) (progn (forward-sexp -1) - (looking-at "sub[ \t\n\f#]")))))) + (looking-at + (concat cperl-sub-regexp "[ \t\n\f#]"))))))) ;; What precedes is not word... XXXX Last statement in sub??? (cperl-after-expr-p lim)))) (error nil)))) @@ -4865,7 +4729,7 @@ TEST is the expression to evaluate at the found position. If absent, CHARS is a string that contains good characters to have before us (however, `}' is treated \"smartly\" if it is not in the list)." (let ((lim (or lim (point-min))) - stop p pr) + stop p) (cperl-update-syntaxification (point) (point)) (save-excursion (while (and (not stop) (> (point) lim)) @@ -4940,7 +4804,6 @@ CHARS is a string that contains good characters to have before us (however, (error t)))) (defun cperl-forward-to-end-of-expr (&optional lim) - (let ((p (point)))) (condition-case nil (progn (while (and (< (point) (or lim (point-max))) @@ -4970,7 +4833,7 @@ CHARS is a string that contains good characters to have before us (however, (forward-sexp -1) (not (looking-at - "\\(map\\|grep\\|printf?\\|system\\|exec\\|tr\\|s\\)\\>"))))))) + "\\(map\\|grep\\|say\\|printf?\\|system\\|exec\\|tr\\|s\\)\\>"))))))) (defun cperl-indent-exp () @@ -5006,13 +4869,13 @@ conditional/loop constructs." (if (eq (following-char) ?$ ) ; for my $var (list) (progn (forward-sexp -1) - (if (looking-at "\\(my\\|local\\|our\\)\\>") + (if (looking-at "\\(state\\|my\\|local\\|our\\)\\>") (forward-sexp -1)))) (if (looking-at - (concat "\\(\\elsif\\|if\\|unless\\|while\\|until" + (concat "\\(elsif\\|if\\|unless\\|while\\|until" "\\|for\\(each\\)?\\>\\(\\(" cperl-maybe-white-and-comment-rex - "\\(my\\|local\\|our\\)\\)?" + "\\(state\\|my\\|local\\|our\\)\\)?" cperl-maybe-white-and-comment-rex "\\$[_a-zA-Z0-9]+\\)?\\)\\>")) (progn @@ -5088,7 +4951,7 @@ Returns some position at the last line." ;; Looking at: ;; else { (if (looking-at - "[ \t]*}?[ \t]*\\<\\(\\els\\(e\\|if\\)\\|continue\\|unless\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") + "[ \t]*}?[ \t]*\\<\\(els\\(e\\|if\\)\\|continue\\|unless\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") (progn (forward-word-strictly 1) (delete-horizontal-space) @@ -5097,7 +4960,7 @@ Returns some position at the last line." ;; Looking at: ;; foreach my $var (if (looking-at - "[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)\\(\t*\\|[ \t][ \t]+\\)[^ \t\n]") + "[ \t]*\\<for\\(each\\)?[ \t]+\\(state\\|my\\|local\\|our\\)\\(\t*\\|[ \t][ \t]+\\)[^ \t\n]") (progn (forward-word-strictly 2) (delete-horizontal-space) @@ -5106,7 +4969,7 @@ Returns some position at the last line." ;; Looking at: ;; foreach my $var ( (if (looking-at - "[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)[ \t]*\\$[_a-zA-Z0-9]+\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") + "[ \t]*\\<for\\(each\\)?[ \t]+\\(state\\|my\\|local\\|our\\)[ \t]*\\$[_a-zA-Z0-9]+\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") (progn (forward-sexp 3) (delete-horizontal-space) @@ -5116,7 +4979,7 @@ Returns some position at the last line." ;; Looking at (with or without "}" at start, ending after "({"): ;; } foreach my $var () OR { (if (looking-at - "[ \t]*\\(}[ \t]*\\)?\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|unless\\|while\\|for\\(each\\)?\\(\\([ \t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{") + "[ \t]*\\(}[ \t]*\\)?\\<\\(els\\(e\\|if\\)\\|continue\\|if\\|unless\\|while\\|for\\(each\\)?\\(\\([ \t]+\\(state\\|my\\|local\\|our\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{") (progn (setq ml (match-beginning 8)) ; "(" or "{" after control word (re-search-forward "[({]") @@ -5237,7 +5100,7 @@ Returns some position at the last line." (defvar cperl-update-start) ; Do not need to make them local (defvar cperl-update-end) -(defun cperl-delay-update-hook (beg end old-len) +(defun cperl-delay-update-hook (beg end _old-len) (setq cperl-update-start (min beg (or cperl-update-start (point-max)))) (setq cperl-update-end (max end (or cperl-update-end (point-min))))) @@ -5254,13 +5117,11 @@ conditional/loop constructs." (cperl-update-syntaxification end end) (save-excursion (let (cperl-update-start cperl-update-end (h-a-c after-change-functions)) - (let ((indent-info (if cperl-emacs-can-parse - (list nil nil nil) ; Cannot use '(), since will modify - nil)) - (pm 0) + (let ((indent-info (list nil nil nil) ; Cannot use '(), since will modify + ) after-change-functions ; Speed it up! - st comm old-comm-indent new-comm-indent p pp i empty) - (if h-a-c (add-hook 'after-change-functions 'cperl-delay-update-hook)) + comm old-comm-indent new-comm-indent i empty) + (if h-a-c (add-hook 'after-change-functions #'cperl-delay-update-hook)) (goto-char start) (setq old-comm-indent (and (cperl-to-comment-or-eol) (current-column)) @@ -5269,7 +5130,6 @@ conditional/loop constructs." (setq end (set-marker (make-marker) end)) ; indentation changes pos (or (bolp) (beginning-of-line 2)) (while (and (<= (point) end) (not (eobp))) ; bol to check start - (setq st (point)) (if (or (setq empty (looking-at "[ \t]*\n")) (and (setq comm (looking-at "[ \t]*#")) @@ -5455,10 +5315,10 @@ indentation and initial hashes. Behaves usually outside of comment." (defun cperl-imenu--create-perl-index (&optional regexp) (require 'imenu) ; May be called from TAGS creator (let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '()) - (index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function)) + (index-unsorted-alist '()) (index-meth-alist '()) meth packages ends-ranges p marker is-proto - (prev-pos 0) is-pack index index1 name (end-range 0) package) + is-pack index index1 name (end-range 0) package) (goto-char (point-min)) (cperl-update-syntaxification (point-max) (point-max)) ;; Search for the function @@ -5604,7 +5464,7 @@ indentation and initial hashes. Behaves usually outside of comment." (defun cperl-outline-level () (looking-at outline-regexp) (cond ((not (match-beginning 1)) 0) ; beginning-of-file -;;;; 2=package-group, 5=package-name 8=sub-name 16=head-level + ;; 2=package-group, 5=package-name 8=sub-name 16=head-level ((match-beginning 2) 0) ; package ((match-beginning 8) 1) ; sub ((match-beginning 16) @@ -5627,10 +5487,9 @@ indentation and initial hashes. Behaves usually outside of comment." (if (memq major-mode '(perl-mode cperl-mode)) (progn (or cperl-faces-init (cperl-init-faces))))))) - (if (fboundp 'eval-after-load) - (eval-after-load - "ps-print" - '(or cperl-faces-init (cperl-init-faces))))))) + (eval-after-load + "ps-print" + '(or cperl-faces-init (cperl-init-faces)))))) (defvar cperl-font-lock-keywords-1 nil "Additional expressions to highlight in Perl mode. Minimal set.") @@ -5679,12 +5538,21 @@ indentation and initial hashes. Behaves usually outside of comment." (cons (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" + ;; FIXME: Use regexp-opt. (mapconcat - 'identity - '("if" "until" "while" "elsif" "else" "unless" "for" + #'identity + (append + cperl-sub-keywords + '("if" "until" "while" "elsif" "else" + "given" "when" "default" "break" + "unless" "for" + "try" "catch" "finally" "foreach" "continue" "exit" "die" "last" "goto" "next" - "redo" "return" "local" "exec" "sub" "do" "dump" "use" "our" - "require" "package" "eval" "my" "BEGIN" "END" "CHECK" "INIT") + "redo" "return" "local" "exec" + "do" "dump" + "use" "our" + "require" "package" "eval" "evalbytes" "my" "state" + "BEGIN" "END" "CHECK" "INIT" "UNITCHECK")) "\\|") ; Flow control "\\)\\>") 2) ; was "\\)[ \n\t;():,|&]" ; In what follows we use `type' style @@ -5692,13 +5560,14 @@ indentation and initial hashes. Behaves usually outside of comment." (list (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" - ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm" + ;; FIXME: Use regexp-opt. + ;; "CORE" "__FILE__" "__LINE__" "__SUB__" "abs" "accept" "alarm" ;; "and" "atan2" "bind" "binmode" "bless" "caller" ;; "chdir" "chmod" "chown" "chr" "chroot" "close" ;; "closedir" "cmp" "connect" "continue" "cos" "crypt" ;; "dbmclose" "dbmopen" "die" "dump" "endgrent" ;; "endhostent" "endnetent" "endprotoent" "endpwent" - ;; "endservent" "eof" "eq" "exec" "exit" "exp" "fcntl" + ;; "endservent" "eof" "eq" "exec" "exit" "exp" "fc" "fcntl" ;; "fileno" "flock" "fork" "formline" "ge" "getc" ;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr" ;; "gethostbyname" "gethostent" "getlogin" @@ -5721,7 +5590,7 @@ indentation and initial hashes. Behaves usually outside of comment." ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" ;; "shutdown" "sin" "sleep" "socket" "socketpair" ;; "sprintf" "sqrt" "srand" "stat" "substr" "symlink" - ;; "syscall" "sysopen" "sysread" "system" "syswrite" "tell" + ;; "syscall" "sysopen" "sysread" "sysseek" "system" "syswrite" "tell" ;; "telldir" "time" "times" "truncate" "uc" "ucfirst" ;; "umask" "unlink" "unpack" "utime" "values" "vec" ;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor" @@ -5732,7 +5601,7 @@ indentation and initial hashes. Behaves usually outside of comment." "CORE\\|d\\(ie\\|bm\\(close\\|open\\)\\|ump\\)\\|" "e\\(x\\(p\\|it\\|ec\\)\\|q\\|nd\\(p\\(rotoent\\|went\\)\\|" "hostent\\|servent\\|netent\\|grent\\)\\|of\\)\\|" - "f\\(ileno\\|cntl\\|lock\\|or\\(k\\|mline\\)\\)\\|" + "f\\(ileno\\|c\\(ntl\\)?\\|lock\\|or\\(k\\|mline\\)\\)\\|" "g\\(t\\|lob\\|mtime\\|e\\(\\|t\\(p\\(pid\\|r\\(iority\\|" "oto\\(byn\\(ame\\|umber\\)\\|ent\\)\\)\\|eername\\|w" "\\(uid\\|ent\\|nam\\)\\|grp\\)\\|host\\(by\\(addr\\|name\\)\\|" @@ -5750,12 +5619,12 @@ indentation and initial hashes. Behaves usually outside of comment." "\\(iority\\|otoent\\)\\|went\\|grp\\)\\|hostent\\|s\\(ervent\\|" "ockopt\\)\\|netent\\|grent\\)\\|ek\\(\\|dir\\)\\|lect\\|" "m\\(ctl\\|op\\|get\\)\\|nd\\)\\|h\\(utdown\\|m\\(read\\|ctl\\|" - "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|open\\|tem\\|write\\)\\|" + "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|open\\|tem\\|write\\|seek\\)\\|" "mlink\\)\\|in\\|leep\\|ocket\\(pair\\|\\)\\)\\|t\\(runcate\\|" "ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|" "time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|" "w\\(a\\(rn\\|it\\(pid\\|\\)\\|ntarray\\)\\|rite\\)\\|" - "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\|PACKAGE__\\)" + "x\\(\\|or\\)\\|__\\(FILE\\|LINE\\|PACKAGE\\|SUB\\)__" "\\)\\>") 2 'font-lock-type-face) ;; In what follows we use `other' style ;; for nonoverwritable builtins @@ -5763,27 +5632,28 @@ indentation and initial hashes. Behaves usually outside of comment." (list (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" - ;; "AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "__END__" "chomp" - ;; "chop" "defined" "delete" "do" "each" "else" "elsif" - ;; "eval" "exists" "for" "foreach" "format" "goto" + ;; "AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "UNITCHECK" "__END__" "chomp" + ;; "break" "chop" "default" "defined" "delete" "do" "each" "else" "elsif" + ;; "eval" "evalbytes" "exists" "for" "foreach" "format" "given" "goto" ;; "grep" "if" "keys" "last" "local" "map" "my" "next" - ;; "no" "our" "package" "pop" "pos" "print" "printf" "push" - ;; "q" "qq" "qw" "qx" "redo" "return" "scalar" "shift" - ;; "sort" "splice" "split" "study" "sub" "tie" "tr" + ;; "no" "our" "package" "pop" "pos" "print" "printf" "prototype" "push" + ;; "q" "qq" "qw" "qx" "redo" "return" "say" "scalar" "shift" + ;; "sort" "splice" "split" "state" "study" "sub" "tie" "tr" ;; "undef" "unless" "unshift" "untie" "until" "use" - ;; "while" "y" - "AUTOLOAD\\|BEGIN\\|CHECK\\|cho\\(p\\|mp\\)\\|d\\(e\\(fined\\|lete\\)\\|" - "o\\)\\|DESTROY\\|e\\(ach\\|val\\|xists\\|ls\\(e\\|if\\)\\)\\|" - "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|INIT\\|if\\|keys\\|" + ;; "when" "while" "y" + "AUTOLOAD\\|BEGIN\\|\\(UNIT\\)?CHECK\\|break\\|c\\(atch\\|ho\\(p\\|mp\\)\\)\\|d\\(e\\(f\\(inally\\|ault\\|ined\\)\\|lete\\)\\|" + "o\\)\\|DESTROY\\|e\\(ach\\|val\\(bytes\\)?\\|xists\\|ls\\(e\\|if\\)\\)\\|" + "END\\|for\\(\\|each\\|mat\\)\\|g\\(iven\\|rep\\|oto\\)\\|INIT\\|if\\|keys\\|" "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|our\\|" - "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|" - "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|" - "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|" + "p\\(ackage\\|rototype\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|" + "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(ay\\|pli\\(ce\\|t\\)\\|" + "calar\\|t\\(ate\\|udy\\)\\|ub\\|hift\\|ort\\)\\|t\\(ry?\\|ied?\\)\\|" "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|" - "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually + "wh\\(en\\|ile\\)\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually "\\|[sm]" ; Added manually - "\\)\\>") 2 'cperl-nonoverridable-face) - ;; (mapconcat 'identity + "\\)\\>") + 2 'cperl-nonoverridable-face) + ;; (mapconcat #'identity ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if" ;; "#include" "#define" "#undef") ;; "\\|") @@ -5792,7 +5662,7 @@ indentation and initial hashes. Behaves usually outside of comment." ;; This highlights declarations and definitions differently. ;; We do not try to highlight in the case of attributes: ;; it is already done by `cperl-find-pods-heres' - (list (concat "\\<sub" + (list (concat "\\<" cperl-sub-regexp cperl-white-and-comment-rex ; whitespace/comments "\\([^ \n\t{;()]+\\)" ; 2=name (assume non-anonymous) "\\(" @@ -5814,9 +5684,9 @@ indentation and initial hashes. Behaves usually outside of comment." (if (eq (char-after (cperl-1- (match-end 0))) ?\{ ) 'font-lock-function-name-face 'font-lock-variable-name-face)))) - '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B; + '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-Z_][a-zA-Z_0-9:]*\\)[ \t;]" ; require A if B; 2 font-lock-function-name-face) - '("^[ \t]*format[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t]*=[ \t]*$" + '("^[ \t]*format[ \t]+\\([a-zA-Z_][a-zA-Z_0-9:]*\\)[ \t]*=[ \t]*$" 1 font-lock-function-name-face) (cond ((featurep 'font-lock-extra) '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" @@ -5834,14 +5704,14 @@ indentation and initial hashes. Behaves usually outside of comment." font-lock-string-face t) '("^[ \t]*\\([a-zA-Z0-9_]+[ \t]*:\\)[ \t]*\\($\\|{\\|\\<\\(until\\|while\\|for\\(each\\)?\\|do\\)\\>\\)" 1 font-lock-constant-face) ; labels - '("\\<\\(continue\\|next\\|last\\|redo\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets + '("\\<\\(continue\\|next\\|last\\|redo\\|break\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets 2 font-lock-constant-face) ;; Uncomment to get perl-mode-like vars ;;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face) ;;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)" ;;; (2 (cons font-lock-variable-name-face '(underline)))) (cond ((featurep 'font-lock-extra) - '("^[ \t]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" + '("^[ \t]*\\(state\\|my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" (3 font-lock-variable-name-face) (4 '(another 4 nil ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" @@ -5850,7 +5720,7 @@ indentation and initial hashes. Behaves usually outside of comment." nil t))) ; local variables, multiple (font-lock-anchored ;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var - `(,(concat "\\<\\(my\\|local\\|our\\)" + `(,(concat "\\<\\(state\\|my\\|local\\|our\\)" cperl-maybe-white-and-comment-rex "\\((" cperl-maybe-white-and-comment-rex @@ -5898,54 +5768,47 @@ indentation and initial hashes. Behaves usually outside of comment." 'syntax-type 'multiline)) (setq cperl-font-lock-multiline-start nil))) (3 font-lock-variable-name-face)))) - (t '("^[ \t{}]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" + (t '("^[ \t{}]*\\(state\\|my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" 3 font-lock-variable-name-face))) - '("\\<for\\(each\\)?\\([ \t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*(" + '("\\<for\\(each\\)?\\([ \t]+\\(state\\|my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*(" 4 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))) (setq t-font-lock-keywords-1 - (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock - ;; not yet as of XEmacs 19.12, works with 21.1.11 - (or - (not (featurep 'xemacs)) - (string< "21.1.9" emacs-version) - (and (string< "21.1.10" emacs-version) - (string< emacs-version "21.1.2"))) - '( - ("\\(\\([@%]\\|\\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 - (if (eq (char-after (match-beginning 2)) ?%) - 'cperl-hash-face - 'cperl-array-face) - t) ; arrays and hashes - ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" - 1 - (if (= (- (match-end 2) (match-beginning 2)) 1) - (if (eq (char-after (match-beginning 3)) ?{) - 'cperl-hash-face - 'cperl-array-face) ; arrays and hashes - font-lock-variable-name-face) ; Just to put something - t) - ("\\(@\\|\\$#\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)" - (1 cperl-array-face) - (2 font-lock-variable-name-face)) - ("\\(%\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)" - (1 cperl-hash-face) - (2 font-lock-variable-name-face)) - ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2") - ;;; Too much noise from \s* @s[ and friends - ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)" - ;;(3 font-lock-function-name-face t t) - ;;(4 - ;; (if (cperl-slash-is-regexp) - ;; font-lock-function-name-face 'default) nil t)) - ))) + '( + ("\\(\\([@%]\\|\\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 + (if (eq (char-after (match-beginning 2)) ?%) + 'cperl-hash-face + 'cperl-array-face) + t) ; arrays and hashes + ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" + 1 + (if (= (- (match-end 2) (match-beginning 2)) 1) + (if (eq (char-after (match-beginning 3)) ?{) + 'cperl-hash-face + 'cperl-array-face) ; arrays and hashes + font-lock-variable-name-face) ; Just to put something + t) + ("\\(@\\|\\$#\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)" + (1 cperl-array-face) + (2 font-lock-variable-name-face)) + ("\\(%\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)" + (1 cperl-hash-face) + (2 font-lock-variable-name-face)) +;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2") +;;; Too much noise from \s* @s[ and friends + ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)" + ;;(3 font-lock-function-name-face t t) + ;;(4 + ;; (if (cperl-slash-is-regexp) + ;; font-lock-function-name-face 'default) nil t)) + )) (if cperl-highlight-variables-indiscriminately (setq t-font-lock-keywords-1 (append t-font-lock-keywords-1 - (list '("\\([$*]{?\\sw+\\)" 1 + (list '("\\([$*]{?\\(?:\\sw+\\|::\\)+\\)" 1 font-lock-variable-name-face))))) (setq cperl-font-lock-keywords-1 (if cperl-syntaxify-by-font-lock @@ -6036,13 +5899,6 @@ indentation and initial hashes. Behaves usually outside of comment." ;; Do it the dull way, without choose-color (defvar cperl-guessed-background nil "Display characteristics as guessed by cperl.") - ;; (or (fboundp 'x-color-defined-p) - ;; (defalias 'x-color-defined-p - ;; (cond ((fboundp 'color-defined-p) 'color-defined-p) - ;; ;; XEmacs >= 19.12 - ;; ((fboundp 'valid-color-name-p) 'valid-color-name-p) - ;; ;; XEmacs 19.11 - ;; (t 'x-valid-color-name-p)))) (cperl-force-face font-lock-constant-face "Face for constant and label names") (cperl-force-face font-lock-variable-name-face @@ -6108,15 +5964,7 @@ indentation and initial hashes. Behaves usually outside of comment." (let ((background (if (boundp 'font-lock-background-mode) font-lock-background-mode - 'light)) - (face-list (and (fboundp 'face-list) (face-list)))) -;;;; (fset 'cperl-is-face -;;;; (cond ((fboundp 'find-face) -;;;; (symbol-function 'find-face)) -;;;; (face-list -;;;; (function (lambda (face) (member face face-list)))) -;;;; (t -;;;; (function (lambda (face) (boundp face)))))) + 'light))) (defvar cperl-guessed-background (if (and (boundp 'font-lock-display-type) (eq font-lock-display-type 'grayscale)) @@ -6155,40 +6003,40 @@ indentation and initial hashes. Behaves usually outside of comment." (if (x-color-defined-p "orchid1") "orchid1" "orange"))))) -;;; (if (cperl-is-face 'font-lock-other-emphasized-face) nil -;;; (copy-face 'bold-italic 'font-lock-other-emphasized-face) -;;; (cond -;;; ((eq background 'light) -;;; (set-face-background 'font-lock-other-emphasized-face -;;; (if (x-color-defined-p "lightyellow2") -;;; "lightyellow2" -;;; (if (x-color-defined-p "lightyellow") -;;; "lightyellow" -;;; "light yellow")))) -;;; ((eq background 'dark) -;;; (set-face-background 'font-lock-other-emphasized-face -;;; (if (x-color-defined-p "navy") -;;; "navy" -;;; (if (x-color-defined-p "darkgreen") -;;; "darkgreen" -;;; "dark green")))) -;;; (t (set-face-background 'font-lock-other-emphasized-face "gray90")))) -;;; (if (cperl-is-face 'font-lock-emphasized-face) nil -;;; (copy-face 'bold 'font-lock-emphasized-face) -;;; (cond -;;; ((eq background 'light) -;;; (set-face-background 'font-lock-emphasized-face -;;; (if (x-color-defined-p "lightyellow2") -;;; "lightyellow2" -;;; "lightyellow"))) -;;; ((eq background 'dark) -;;; (set-face-background 'font-lock-emphasized-face -;;; (if (x-color-defined-p "navy") -;;; "navy" -;;; (if (x-color-defined-p "darkgreen") -;;; "darkgreen" -;;; "dark green")))) -;;; (t (set-face-background 'font-lock-emphasized-face "gray90")))) + ;; (if (cperl-is-face 'font-lock-other-emphasized-face) nil + ;; (copy-face 'bold-italic 'font-lock-other-emphasized-face) + ;; (cond + ;; ((eq background 'light) + ;; (set-face-background 'font-lock-other-emphasized-face + ;; (if (x-color-defined-p "lightyellow2") + ;; "lightyellow2" + ;; (if (x-color-defined-p "lightyellow") + ;; "lightyellow" + ;; "light yellow")))) + ;; ((eq background 'dark) + ;; (set-face-background 'font-lock-other-emphasized-face + ;; (if (x-color-defined-p "navy") + ;; "navy" + ;; (if (x-color-defined-p "darkgreen") + ;; "darkgreen" + ;; "dark green")))) + ;; (t (set-face-background 'font-lock-other-emphasized-face "gray90")))) + ;; (if (cperl-is-face 'font-lock-emphasized-face) nil + ;; (copy-face 'bold 'font-lock-emphasized-face) + ;; (cond + ;; ((eq background 'light) + ;; (set-face-background 'font-lock-emphasized-face + ;; (if (x-color-defined-p "lightyellow2") + ;; "lightyellow2" + ;; "lightyellow"))) + ;; ((eq background 'dark) + ;; (set-face-background 'font-lock-emphasized-face + ;; (if (x-color-defined-p "navy") + ;; "navy" + ;; (if (x-color-defined-p "darkgreen") + ;; "darkgreen" + ;; "dark green")))) + ;; (t (set-face-background 'font-lock-emphasized-face "gray90")))) (if (cperl-is-face 'font-lock-variable-name-face) nil (copy-face 'italic 'font-lock-variable-name-face)) (if (cperl-is-face 'font-lock-constant-face) nil @@ -6237,43 +6085,43 @@ Style of printout regulated by the variable `cperl-ps-print-face-properties'." (require 'ps-print) ; To get ps-print-face-extension-alist (let ((ps-print-color-p t) (ps-print-face-extension-alist ps-print-face-extension-alist)) - (cperl-ps-extend-face-list cperl-ps-print-face-properties) + (ps-extend-face-list cperl-ps-print-face-properties) (ps-print-buffer-with-faces file))) -;;; (defun cperl-ps-print-init () -;;; "Initialization of `ps-print' components for faces used in CPerl." -;;; ;; Guard against old versions -;;; (defvar ps-underlined-faces nil) -;;; (defvar ps-bold-faces nil) -;;; (defvar ps-italic-faces nil) -;;; (setq ps-bold-faces -;;; (append '(font-lock-emphasized-face -;;; cperl-array-face -;;; font-lock-keyword-face -;;; font-lock-variable-name-face -;;; font-lock-constant-face -;;; font-lock-reference-face -;;; font-lock-other-emphasized-face -;;; cperl-hash-face) -;;; ps-bold-faces)) -;;; (setq ps-italic-faces -;;; (append '(cperl-nonoverridable-face -;;; font-lock-constant-face -;;; font-lock-reference-face -;;; font-lock-other-emphasized-face -;;; cperl-hash-face) -;;; ps-italic-faces)) -;;; (setq ps-underlined-faces -;;; (append '(font-lock-emphasized-face -;;; cperl-array-face -;;; font-lock-other-emphasized-face -;;; cperl-hash-face -;;; cperl-nonoverridable-face font-lock-type-face) -;;; ps-underlined-faces)) -;;; (cons 'font-lock-type-face ps-underlined-faces)) - - -(if (cperl-enable-font-lock) (cperl-windowed-init)) +;; (defun cperl-ps-print-init () +;; "Initialization of `ps-print' components for faces used in CPerl." +;; ;; Guard against old versions +;; (defvar ps-underlined-faces nil) +;; (defvar ps-bold-faces nil) +;; (defvar ps-italic-faces nil) +;; (setq ps-bold-faces +;; (append '(font-lock-emphasized-face +;; cperl-array-face +;; font-lock-keyword-face +;; font-lock-variable-name-face +;; font-lock-constant-face +;; font-lock-reference-face +;; font-lock-other-emphasized-face +;; cperl-hash-face) +;; ps-bold-faces)) +;; (setq ps-italic-faces +;; (append '(cperl-nonoverridable-face +;; font-lock-constant-face +;; font-lock-reference-face +;; font-lock-other-emphasized-face +;; cperl-hash-face) +;; ps-italic-faces)) +;; (setq ps-underlined-faces +;; (append '(font-lock-emphasized-face +;; cperl-array-face +;; font-lock-other-emphasized-face +;; cperl-hash-face +;; cperl-nonoverridable-face font-lock-type-face) +;; ps-underlined-faces)) +;; (cons 'font-lock-type-face ps-underlined-faces)) + + +(cperl-windowed-init) (defconst cperl-styles-entries '(cperl-indent-level cperl-brace-offset cperl-continued-brace-offset @@ -6484,16 +6332,14 @@ data already), may be restored by `cperl-set-style-back'. Choosing \"Current\" style will not change style, so this may be used for side-effect of memorizing only. Examples in `cperl-style-examples'." (interactive - (let ((list (mapcar (function (lambda (elt) (list (car elt)))) - cperl-style-alist))) - (list (completing-read "Enter style: " list nil 'insist)))) + (list (completing-read "Enter style: " cperl-style-alist nil 'insist))) (or cperl-old-style (setq cperl-old-style (mapcar (function (lambda (name) (cons name (eval name)))) cperl-styles-entries))) - (let ((style (cdr (assoc style cperl-style-alist))) setting str sym) + (let ((style (cdr (assoc style cperl-style-alist))) setting) (while style (setq setting (car style) style (cdr style)) (set (car setting) (cdr setting))))) @@ -6508,6 +6354,7 @@ side-effect of memorizing only. Examples in `cperl-style-examples'." cperl-old-style (cdr cperl-old-style)) (set (car setting) (cdr setting))))) +(defvar perl-dbg-flags) (defun cperl-check-syntax () (interactive) (require 'mode-compile) @@ -6540,8 +6387,7 @@ side-effect of memorizing only. Examples in `cperl-style-examples'." (set-buffer "*info-perl-tmp*") (rename-buffer "*info*") (set-buffer bname))) - (make-local-variable 'window-min-height) - (setq window-min-height 2) + (set (make-local-variable 'window-min-height) 2) (current-buffer))))) (defun cperl-word-at-point (&optional p) @@ -6572,8 +6418,7 @@ Customized by setting variables `cperl-shrink-wrap-info-frame', default read)))) - (let ((buffer (current-buffer)) - (cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///" + (let ((cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///" pos isvar height iniheight frheight buf win fr1 fr2 iniwin not-loner max-height char-height buf-list) (if (string-match "^-[a-zA-Z]$" command) @@ -6671,9 +6516,9 @@ Opens Perl Info buffer if needed." (setq imenu-create-index-function 'imenu-default-create-index-function imenu-prev-index-position-function - 'cperl-imenu-info-imenu-search + #'cperl-imenu-info-imenu-search imenu-extract-index-name-function - 'cperl-imenu-info-imenu-name) + #'cperl-imenu-info-imenu-name) (imenu-choose-buffer-index))))) (and index-item (progn @@ -6699,7 +6544,7 @@ If STEP is nil, `cperl-lineup-step' will be used \(or `cperl-indent-level', if `cperl-lineup-step' is nil). Will not move the position at the start to the left." (interactive "r") - (let (search col tcol seen b) + (let (search col tcol seen) (save-excursion (goto-char end) (end-of-line) @@ -6750,8 +6595,8 @@ in subdirectories too." (interactive) (let ((cmd "etags") (args '("-l" "none" "-r" - ;; 1=fullname 2=package? 3=name 4=proto? 5=attrs? (VERY APPROX!) - "/\\<sub[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/" + ;; 1=fullname 2=package? 3=name 4=proto? 5=attrs? (VERY APPROX!) + "/\\<" cperl-sub-regexp "[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/" "-r" "/\\<package[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\([#;]\\|$\\)/\\1/" "-r" @@ -6805,17 +6650,16 @@ in subdirectories too." (if (cperl-val 'cperl-electric-parens) "" "not "))) (defun cperl-toggle-autohelp () + ;; FIXME: Turn me into a minor mode. Fix menu entries for "Auto-help on" as + ;; well. "Toggle the state of Auto-Help on Perl constructs (put in the message area). Delay of auto-help controlled by `cperl-lazy-help-time'." (interactive) - (if (fboundp 'run-with-idle-timer) - (progn - (if cperl-lazy-installed - (cperl-lazy-unstall) - (cperl-lazy-install)) - (message "Perl help messages will %sbe automatically shown now." - (if cperl-lazy-installed "" "not "))) - (message "Cannot automatically show Perl help messages - run-with-idle-timer missing."))) + (if cperl-lazy-installed + (cperl-lazy-unstall) + (cperl-lazy-install)) + (message "Perl help messages will %sbe automatically shown now." + (if cperl-lazy-installed "" "not "))) (defun cperl-toggle-construct-fix () "Toggle whether `indent-region'/`indent-sexp' fix whitespace too." @@ -6844,7 +6688,8 @@ by CPerl." (interactive "P") (or arg (setq arg (if (eq cperl-syntaxify-by-font-lock - (if backtrace 'backtrace 'message)) 0 1))) + (if backtrace 'backtrace 'message)) + 0 1))) (setq arg (if (> arg 0) (if backtrace 'backtrace 'message) t)) (setq cperl-syntaxify-by-font-lock arg) (message "Debugging messages of syntax unwind %sabled." @@ -6861,9 +6706,8 @@ by CPerl." (auto-fill-mode 0) (if cperl-use-syntax-table-text-property-for-tags (progn - (make-local-variable 'parse-sexp-lookup-properties) ;; Do not introduce variable if not needed, we check it! - (set 'parse-sexp-lookup-properties t)))) + (set (make-local-variable 'parse-sexp-lookup-properties) t)))) ;; Copied from imenu-example--name-and-position. (defvar imenu-use-markers) @@ -6881,7 +6725,7 @@ Does not move point." (defun cperl-xsub-scan () (require 'imenu) (let ((index-alist '()) - (prev-pos 0) index index1 name package prefix) + index index1 name package prefix) (goto-char (point-min)) ;; Search for the function (progn ;;save-match-data @@ -6921,12 +6765,12 @@ Does not move point." (defun cperl-find-tags (ifile xs topdir) (let ((b (get-buffer cperl-tmp-buffer)) ind lst elt pos ret rel - (cperl-pod-here-fontify nil) f file) + (cperl-pod-here-fontify nil) file) (save-excursion (if b (set-buffer b) (cperl-setup-tmp-buf)) (erase-buffer) - (condition-case err + (condition-case nil (setq file (car (insert-file-contents ifile))) (error (if cperl-unreadable-ok nil (if (y-or-n-p @@ -6940,7 +6784,7 @@ Does not move point." (not xs)) (condition-case err ; after __END__ may have garbage (cperl-find-pods-heres nil nil noninteractive) - (error (message "While scanning for syntax: %s" err)))) + (error (message "While scanning for syntax: %S" err)))) (if xs (setq lst (cperl-xsub-scan)) (setq ind (cperl-imenu--create-perl-index)) @@ -6980,7 +6824,7 @@ Does not move point." (number-to-string (1- (elt elt 1))) ; Char pos 0-based "\n") (if (and (string-match "^[_a-zA-Z]+::" (car elt)) - (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]" + (string-match (concat "^" cperl-sub-regexp "[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]") (elt elt 3))) ;; Need to insert the name without package as well (setq lst (cons (cons (substring (elt elt 3) @@ -7037,15 +6881,14 @@ Use as (or topdir (setq topdir default-directory)) (let ((tags-file-name "TAGS") - (case-fold-search (and (featurep 'xemacs) (eq system-type 'emx))) - xs rel tm) + (case-fold-search nil) + xs rel) (save-excursion (cond (inbuffer nil) ; Already there ((file-exists-p tags-file-name) - (if (featurep 'xemacs) - (visit-tags-table-buffer) - (visit-tags-table-buffer tags-file-name))) - (t (set-buffer (find-file-noselect tags-file-name)))) + (visit-tags-table-buffer tags-file-name)) + (t + (set-buffer (find-file-noselect tags-file-name)))) (cond (dir (cond ((eq erase 'ignore)) @@ -7053,7 +6896,7 @@ Use as (erase-buffer) (setq erase 'ignore))) (let ((files - (condition-case err + (condition-case nil (directory-files file t (if recurse nil cperl-scan-files-regexp) t) @@ -7061,8 +6904,9 @@ Use as (if cperl-unreadable-ok nil (if (y-or-n-p (format "Directory %s unreadable. Continue? " file)) - (setq cperl-unreadable-ok t - tm nil) ; Return empty list + (progn + (setq cperl-unreadable-ok t) + nil) ; Return empty list (error "Aborting: unreadable directory %s" file))))))) (mapc (function (lambda (file) @@ -7110,7 +6954,7 @@ Use as "^\\(" "\\(package\\)\\>" "\\|" - "sub\\>[^\n]+::" + cperl-sub-regexp "\\>[^\n]+::" "\\|" "[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::" ; XSUB? "\\|" @@ -7127,10 +6971,9 @@ Use as (defun cperl-tags-hier-fill () ;; Suppose we are in a tag table cooked by cperl. (goto-char 1) - (let (type pack name pos line chunk ord cons1 file str info fileind) + (let (pack name line ord cons1 file info fileind) (while (re-search-forward cperl-tags-hier-regexp-list nil t) - (setq pos (match-beginning 0) - pack (match-beginning 2)) + (setq pack (match-beginning 2)) (beginning-of-line) (if (looking-at (concat "\\([^\n]+\\)" @@ -7182,27 +7025,19 @@ One may build such TAGS files from CPerl mode menu." (or (nthcdr 2 elt) ;; Only in one file (setcdr elt (cdr (nth 1 elt))))))) - pack name cons1 to l1 l2 l3 l4 b) + to l1 l2 l3) ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later! (setq cperl-hierarchy (list l1 l2 l3)) - (if (featurep 'xemacs) ; Not checked - (progn - (or tags-file-name - ;; Does this work in XEmacs? - (call-interactively 'visit-tags-table)) - (message "Updating list of classes...") - (set-buffer (get-file-buffer tags-file-name)) - (cperl-tags-hier-fill)) - (or tags-table-list - (call-interactively 'visit-tags-table)) - (mapc - (function - (lambda (tagsfile) - (message "Updating list of classes... %s" tagsfile) - (set-buffer (get-file-buffer tagsfile)) - (cperl-tags-hier-fill))) - tags-table-list) - (message "Updating list of classes... postprocessing...")) + (or tags-table-list + (call-interactively 'visit-tags-table)) + (mapc + (function + (lambda (tagsfile) + (message "Updating list of classes... %s" tagsfile) + (set-buffer (get-file-buffer tagsfile)) + (cperl-tags-hier-fill))) + tags-table-list) + (message "Updating list of classes... postprocessing...") (mapc remover (car cperl-hierarchy)) (mapc remover (nth 1 cperl-hierarchy)) (setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy)) @@ -7216,10 +7051,9 @@ One may build such TAGS files from CPerl mode menu." (or (nth 2 cperl-hierarchy) (error "No items found")) (setq update -;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy)) + ;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy)) (if (if (fboundp 'display-popup-menus-p) - (let ((f 'display-popup-menus-p)) - (funcall f)) + (display-popup-menus-p) window-system) (x-popup-menu t (nth 2 cperl-hierarchy)) (require 'tmm) @@ -7236,22 +7070,20 @@ One may build such TAGS files from CPerl mode menu." (defun cperl-tags-treeify (to level) ;; cadr of `to' is read-write. On start it is a cons (let* ((regexp (concat "^\\(" (mapconcat - 'identity + #'identity (make-list level "[_a-zA-Z0-9]+") "::") "\\)\\(::\\)?")) (packages (cdr (nth 1 to))) (methods (cdr (nth 2 to))) - l1 head tail cons1 cons2 ord writeto packs recurse - root-packages root-functions ms many_ms same_name ps + l1 head cons1 cons2 ord writeto recurse + root-packages root-functions (move-deeper (function (lambda (elt) (cond ((and (string-match regexp (car elt)) (or (eq ord 1) (match-end 2))) (setq head (substring (car elt) 0 (match-end 1)) - tail (if (match-end 2) (substring (car elt) - (match-end 2))) recurse t) (if (setq cons1 (assoc head writeto)) nil ;; Need to init new head @@ -7278,7 +7110,8 @@ One may build such TAGS files from CPerl mode menu." ;;Now clean up leaders with one child only (mapc (function (lambda (elt) (if (not (and (listp (cdr elt)) - (eq (length elt) 2))) nil + (eq (length elt) 2))) + nil (setcar elt (car (nth 1 elt))) (setcdr elt (cdr (nth 1 elt)))))) (cdr to)) @@ -7303,12 +7136,12 @@ One may build such TAGS files from CPerl mode menu." (sort root-packages (default-value 'imenu-sort-function))) root-packages)))) -;;;(x-popup-menu t -;;; '(keymap "Name1" -;;; ("Ret1" "aa") -;;; ("Head1" "ab" -;;; keymap "Name2" -;;; ("Tail1" "x") ("Tail2" "y")))) +;;(x-popup-menu t +;; '(keymap "Name1" +;; ("Ret1" "aa") +;; ("Head1" "ab" +;; keymap "Name2" +;; ("Tail1" "x") ("Tail2" "y")))) (defun cperl-list-fold (list name limit) (let (list1 list2 elt1 (num 0)) @@ -7329,7 +7162,7 @@ One may build such TAGS files from CPerl mode menu." (nreverse list2)) list1))))) -(defun cperl-menu-to-keymap (menu &optional name) +(defun cperl-menu-to-keymap (menu) (let (list) (cons 'keymap (mapcar @@ -7347,7 +7180,7 @@ One may build such TAGS files from CPerl mode menu." (defvar cperl-bad-style-regexp - (mapconcat 'identity + (mapconcat #'identity '("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign "[-<>=+^&|]+[^- \t\n=+<>~]") ; sign+ char "\\|") @@ -7355,7 +7188,7 @@ One may build such TAGS files from CPerl mode menu." (defvar cperl-not-bad-style-regexp (mapconcat - 'identity + #'identity '("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++ "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used. "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field) @@ -7367,11 +7200,12 @@ One may build such TAGS files from CPerl mode menu." ".->" ; a->b "->" ; a SPACE ->b "\\[-" ; a[-1] - "\\\\[&$@*\\\\]" ; \&func + "\\\\[&$@*\\]" ; \&func "^=" ; =head "\\$." ; $| "<<[a-zA-Z_'\"`]" ; <<FOO, <<'FOO' "||" + "//" "&&" "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text> "-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value @@ -7393,22 +7227,22 @@ Currently it is tuned to C and Perl syntax." (setq last-nonmenu-event 13) ; To disable popup (goto-char (point-min)) (map-y-or-n-p "Insert space here? " - (lambda (arg) (insert " ")) + (lambda (_) (insert " ")) 'cperl-next-bad-style '("location" "locations" "insert a space into") - '((?\C-r (lambda (arg) - (let ((buffer-quit-function - 'exit-recursive-edit)) - (message "Exit with Esc Esc") - (recursive-edit) - t)) ; Consider acted upon + `((?\C-r ,(lambda (_) + (let ((buffer-quit-function + #'exit-recursive-edit)) + (message "Exit with Esc Esc") + (recursive-edit) + t)) ; Consider acted upon "edit, exit with Esc Esc") - (?e (lambda (arg) - (let ((buffer-quit-function - 'exit-recursive-edit)) - (message "Exit with Esc Esc") - (recursive-edit) - t)) ; Consider acted upon + (?e ,(lambda (_) + (let ((buffer-quit-function + #'exit-recursive-edit)) + (message "Exit with Esc Esc") + (recursive-edit) + t)) ; Consider acted upon "edit, exit with Esc Esc")) t) (if found-bad (goto-char found-bad) @@ -7416,7 +7250,7 @@ Currently it is tuned to C and Perl syntax." (message "No appropriate place found")))) (defun cperl-next-bad-style () - (let (p (not-found t) (point (point)) found) + (let (p (not-found t) found) (while (and not-found (re-search-forward cperl-bad-style-regexp nil 'to-end)) (setq p (point)) @@ -7445,14 +7279,14 @@ Currently it is tuned to C and Perl syntax." (defvar cperl-have-help-regexp ;;(concat "\\(" (mapconcat - 'identity + #'identity '("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable "[$@]\\^[a-zA-Z]" ; Special variable "[$@][^ \n\t]" ; Special variable "-[a-zA-Z]" ; File test "\\\\[a-zA-Z0]" ; Special chars "^=[a-z][a-zA-Z0-9_]*" ; POD sections - "[-!&*+,-./<=>?\\\\^|~]+" ; Operator + "[-!&*+,./<=>?\\^|~]+" ; Operator "[a-zA-Z_0-9:]+" ; symbol or number "x=" "#!") @@ -7469,7 +7303,7 @@ Currently it is tuned to C and Perl syntax." ;; Does not save-excursion ;; Get to the something meaningful (or (eobp) (eolp) (forward-char 1)) - (re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]" + (re-search-backward "[-a-zA-Z0-9_:!&*+,./<=>?\\^|~$%@]" (point-at-bol) 'to-beg) ;; (cond @@ -7496,8 +7330,8 @@ Currently it is tuned to C and Perl syntax." (forward-char -1)) ((and (looking-at "\\^") (eq (preceding-char) ?\$)) ; $^I (forward-char -1)) - ((looking-at "[-!&*+,-./<=>?\\\\^|~]") - (skip-chars-backward "-!&*+,-./<=>?\\\\^|~") + ((looking-at "[-!&*+,./<=>?\\^|~]") + (skip-chars-backward "-!&*+,./<=>?\\^|~") (cond ((and (eq (preceding-char) ?\$) (not (eq (char-after (- (point) 2)) ?\$))) ; $- @@ -7545,7 +7379,7 @@ than a line. Your contribution to update/shorten it is appreciated." (defun cperl-describe-perl-symbol (val) "Display the documentation of symbol at point, a Perl operator." (let ((enable-recursive-minibuffers t) - args-file regexp) + regexp) (cond ((string-match "^[&*][a-zA-Z_]" val) (setq val (concat (substring val 0 1) "NAME"))) @@ -7712,6 +7546,7 @@ $~ The name of the current report format. ... = ... Assignment. ... == ... Numeric equality. ... =~ ... Search pattern, substitution, or translation +... ~~ .. Smart match ... > ... Numeric greater than. ... >= ... Numeric greater than or equal to. ... >> ... Bitwise shift right. @@ -7749,6 +7584,7 @@ ARGVOUT Output filehandle with -i flag. BEGIN { ... } Immediately executed (during compilation) piece of code. END { ... } Pseudo-subroutine executed after the script finishes. CHECK { ... } Pseudo-subroutine executed after the script is compiled. +UNITCHECK { ... } INIT { ... } Pseudo-subroutine executed before the script starts running. DATA Input filehandle for what follows after __END__ or __DATA__. accept(NEWSOCKET,GENERICSOCKET) @@ -7756,6 +7592,7 @@ alarm(SECONDS) atan2(X,Y) bind(SOCKET,NAME) binmode(FILEHANDLE) +break Break out of a given/when statement caller[(LEVEL)] chdir(EXPR) chmod(LIST) @@ -7771,6 +7608,7 @@ cos(EXPR) crypt(PLAINTEXT,SALT) dbmclose(%HASH) dbmopen(%HASH,DBNAME,MODE) +default { ... } default case for given/when block defined(EXPR) delete($HASH{KEY}) die(LIST) @@ -7787,6 +7625,7 @@ endservent eof[([FILEHANDLE])] ... eq ... String equality. eval(EXPR) or eval { BLOCK } +evalbytes See eval. exec([TRUENAME] ARGV0, ARGVs) or exec(SHELL_COMMAND_LINE) exit(EXPR) exp(EXPR) @@ -7823,6 +7662,7 @@ getservbyport(PORT,PROTO) getservent getsockname(SOCKET) getsockopt(SOCKET,LEVEL,OPTNAME) +given (EXPR) { [ when (EXPR) { ... } ]+ [ default { ... } ]? } gmtime(EXPR) goto LABEL ... gt ... String greater than. @@ -7883,6 +7723,7 @@ rewinddir(DIRHANDLE) rindex(STR,SUBSTR[,OFFSET]) rmdir(FILENAME) s/PATTERN/REPLACEMENT/gieoxsm +say [FILEHANDLE] [(LIST)] scalar(EXPR) seek(FILEHANDLE,POSITION,WHENCE) seekdir(DIRHANDLE,POS) @@ -7917,6 +7758,7 @@ sprintf(FORMAT,LIST) sqrt(EXPR) srand(EXPR) stat(EXPR|FILEHANDLE|VAR) +state VAR or state (VAR1,...) Introduces a static lexical variable study[(SCALAR)] sub [NAME [(format)]] { BODY } sub NAME [(format)]; sub [(format)] {...} substr(EXPR,OFFSET[,LEN]) @@ -7952,6 +7794,7 @@ x= ... Repetition assignment. y/SEARCHLIST/REPLACEMENTLIST/ ... | ... Bitwise or. ... || ... Logical or. +... // ... Defined-or. ~ ... Unary bitwise complement. #! OS interpreter indicator. If contains `perl', used for options, and -x. AUTOLOAD {...} Shorthand for `sub AUTOLOAD {...}'. @@ -7972,6 +7815,7 @@ chr Converts a number to char with the same ordinal. else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. exists $HASH{KEY} True if the key exists. +fc EXPR Returns the casefolded version of EXPR. format [NAME] = Start of output format. Ended by a single dot (.) on a line. formline PICTURE, LIST Backdoor into \"format\" processing. glob EXPR Synonym of <EXPR>. @@ -7983,6 +7827,7 @@ no PACKAGE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method. not ... Low-precedence synonym for ! - negation. ... or ... Low-precedence synonym for ||. pos STRING Set/Get end-position of the last match over this string, see \\G. +prototype FUNC Returns the prototype of a function as a string, or undef. quotemeta [ EXPR ] Quote regexp metacharacters. qw/WORD1 .../ Synonym of split(\\='\\=', \\='WORD1 ...\\=') readline FH Synonym of <FH>. @@ -8005,6 +7850,8 @@ prototype \\&SUB Returns prototype of the function given a reference. =back End list. =cut Switch from POD to Perl. =pod Switch from Perl to POD. +=begin Switch from Perl6 to POD. +=end Switch from POD to Perl6. ") (defun cperl-switch-to-doc-buffer (&optional interactive) @@ -8027,7 +7874,7 @@ prototype \\&SUB Returns prototype of the function given a reference. ;; The REx is guaranteed to have //x ;; LEVEL shows how many levels deep to go ;; position at enter and at leave is not defined - (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code pos) + (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline pos) (if embed (progn (goto-char b) @@ -8075,7 +7922,7 @@ prototype \\&SUB Returns prototype of the function given a reference. "\\|" ; $ ^ "[$^]" "\\|" ; simple-code simple-code*? - "\\(\\\\.\\|[^][()#|*+?\n]\\)\\([*+{?]\\??\\)?" ; 4 5 + "\\(\\\\.\\|[^][()#|*+?$^\n]\\)\\([*+{?]\\??\\)?" ; 4 5 "\\|" ; Class "\\(\\[\\)" ; 6 "\\|" ; Grouping @@ -8223,8 +8070,8 @@ prototype \\&SUB Returns prototype of the function given a reference. (goto-char (match-end 1)) (re-search-backward "\\s|"))) ; Assume it is scanned already. ;;(forward-char 1) - (let ((b (point)) (e (make-marker)) have-x delim (c (current-column)) - (sub-p (eq (preceding-char) ?s)) s) + (let ((b (point)) (e (make-marker)) have-x delim + (sub-p (eq (preceding-char) ?s))) (forward-sexp 1) (set-marker e (1- (point))) (setq delim (preceding-char)) @@ -8237,7 +8084,7 @@ prototype \\&SUB Returns prototype of the function given a reference. ;; Protect fragile " ", "#" (if have-x nil (goto-char (1+ b)) - (while (re-search-forward "\\(\\=\\|[^\\\\]\\)\\(\\\\\\\\\\)*[ \t\n#]" e t) ; Need to include (?#) too? + (while (re-search-forward "\\(\\=\\|[^\\]\\)\\(\\\\\\\\\\)*[ \t\n#]" e t) ; Need to include (?#) too? (forward-char -1) (insert "\\") (forward-char 1))) @@ -8266,7 +8113,7 @@ We suppose that the regexp is scanned already." (error "Cannot find `(' which starts a group")) (setq done (save-excursion - (skip-chars-backward "\\") + (skip-chars-backward "\\\\") (looking-at "\\(\\\\\\\\\\)*("))) (or done (forward-char -1))))) @@ -8301,7 +8148,7 @@ We suppose that the regexp is scanned already." (cperl-regext-to-level-start) (error ; We are outside outermost group (goto-char (cperl-make-regexp-x)))) - (let ((b (point)) (e (make-marker)) s c) + (let ((b (point)) (e (make-marker))) (forward-sexp 1) (set-marker e (1- (point))) (goto-char (1+ b)) @@ -8513,10 +8360,10 @@ the appropriate statement modifier." (declare-function Man-getpage-in-background "man" (topic)) -;;; By Anthony Foiani <afoiani@uswest.com> -;;; Getting help on modules in C-h f ? -;;; This is a modified version of `man'. -;;; Need to teach it how to lookup functions +;; By Anthony Foiani <afoiani@uswest.com> +;; Getting help on modules in C-h f ? +;; This is a modified version of `man'. +;; Need to teach it how to lookup functions ;;;###autoload (defun cperl-perldoc (word) "Run `perldoc' on WORD." @@ -8535,20 +8382,14 @@ the appropriate statement modifier." (require 'man) (let* ((case-fold-search nil) (is-func (and - (string-match "^[a-z]+$" word) + (string-match "^\\(-[A-Za-z]\\|[a-z]+\\)$" word) (string-match (concat "^" word "\\>") (documentation-property 'cperl-short-docs 'variable-documentation)))) (Man-switches "") (manual-program (if is-func "perldoc -f" "perldoc"))) - (cond - ((featurep 'xemacs) - (let ((Manual-program "perldoc") - (Manual-switches (if is-func (list "-f")))) - (manual-entry word))) - (t - (Man-getpage-in-background word))))) + (Man-getpage-in-background word))) ;;;###autoload (defun cperl-perldoc-at-point () @@ -8561,7 +8402,7 @@ the appropriate statement modifier." :type 'file :group 'cperl) -;;; By Nick Roberts <Nick.Roberts@src.bae.co.uk> (with changes) +;; By Nick Roberts <Nick.Roberts@src.bae.co.uk> (with changes) (defun cperl-pod-to-manpage () "Create a virtual manpage in Emacs from the Perl Online Documentation." (interactive) @@ -8578,19 +8419,14 @@ the appropriate statement modifier." (format (cperl-pod2man-build-command) pod2man-args)) 'Man-bgproc-sentinel))))) -;;; Updated version by him too +;; Updated version by him too (defun cperl-build-manpage () "Create a virtual manpage in Emacs from the POD in the file." (interactive) (require 'man) - (cond - ((featurep 'xemacs) - (let ((Manual-program "perldoc")) - (manual-entry buffer-file-name))) - (t - (let* ((manual-program "perldoc") - (Man-switches "")) - (Man-getpage-in-background buffer-file-name))))) + (let ((manual-program "perldoc") + (Man-switches "")) + (Man-getpage-in-background buffer-file-name))) (defun cperl-pod2man-build-command () "Builds the entire background manpage and cleaning command." @@ -8641,7 +8477,7 @@ a result of qr//, this is not a performance hit), t for the rest." (and (eq (get-text-property beg 'syntax-type) 'string) (setq beg (next-single-property-change beg 'syntax-type nil limit))) (cperl-map-pods-heres - (function (lambda (s e p) + (function (lambda (s _e _p) (if (memq (get-text-property s 'REx-interpolated) skip) t (setq pp s) @@ -8650,27 +8486,27 @@ a result of qr//, this is not a performance hit), t for the rest." (if pp (goto-char pp) (message "No more interpolated REx")))) -;;; Initial version contributed by Trey Belew -(defun cperl-here-doc-spell (&optional beg end) +;; Initial version contributed by Trey Belew +(defun cperl-here-doc-spell () "Spell-check HERE-documents in the Perl buffer. If a region is highlighted, restricts to the region." - (interactive "") - (cperl-pod-spell t beg end)) + (interactive) + (cperl-pod-spell t)) -(defun cperl-pod-spell (&optional do-heres beg end) +(defun cperl-pod-spell (&optional do-heres) "Spell-check POD documentation. If invoked with prefix argument, will do HERE-DOCs instead. If a region is highlighted, restricts to the region." (interactive "P") (save-excursion (let (beg end) - (if (cperl-mark-active) + (if (region-active-p) (setq beg (min (mark) (point)) end (max (mark) (point))) (setq beg (point-min) end (point-max))) (cperl-map-pods-heres (function - (lambda (s e p) + (lambda (s e _p) (if do-heres (setq e (save-excursion (goto-char e) @@ -8699,7 +8535,7 @@ function returns nil." (setq cont (funcall func pos posend prop))) (setq pos posend))))) -;;; Based on code by Masatake YAMATO: +;; Based on code by Masatake YAMATO: (defun cperl-get-here-doc-region (&optional pos pod) "Return HERE document region around the point. Return nil if the point is not in a HERE document region. If POD is non-nil, @@ -8735,7 +8571,7 @@ POS defaults to the point." (push-mark (cdr p) nil t)) ; Message, activate in transient-mode (message "I do not think POS is in POD or a HERE-doc...")))) -(defun cperl-facemenu-add-face-function (face end) +(defun cperl-facemenu-add-face-function (face _end) "A callback to process user-initiated font-change requests. Translates `bold', `italic', and `bold-italic' requests to insertion of corresponding POD directives, and `underline' to C<> POD directive. @@ -8748,7 +8584,7 @@ Such requests are usually bound to M-o LETTER." (italic . "I<") (bold-italic . "B<I<") (underline . "C<"))) - (error "Face %s not configured for cperl-mode" + (error "Face %S not configured for cperl-mode" face)))) (defun cperl-time-fontification (&optional l step lim) @@ -8764,9 +8600,7 @@ start with default arguments, then refine the slowdown regions." (or l (setq l 1)) (or step (setq step 500)) (or lim (setq lim 40)) - (let* ((timems (function (lambda () - (let ((tt (current-time))) - (+ (* 1000 (nth 1 tt)) (/ (nth 2 tt) 1000)))))) + (let* ((timems (function (lambda () (car (encode-time nil 1000))))) (tt (funcall timems)) (c 0) delta tot) (goto-char (point-min)) (forward-line (1- l)) @@ -8811,61 +8645,52 @@ may be used to debug problems with delayed incremental fontification." (setq pos p)))) -(defun cperl-lazy-install ()) ; Avoid a warning -(defun cperl-lazy-unstall ()) ; Avoid a warning - -(if (fboundp 'run-with-idle-timer) - (progn - (defvar cperl-help-shown nil - "Non-nil means that the help was already shown now.") +(defvar cperl-help-shown nil + "Non-nil means that the help was already shown now.") - (defvar cperl-lazy-installed nil - "Non-nil means that the lazy-help handlers are installed now.") +(defvar cperl-lazy-installed nil + "Non-nil means that the lazy-help handlers are installed now.") - (defun cperl-lazy-install () - "Switches on Auto-Help on Perl constructs (put in the message area). +;; FIXME: Use eldoc? +(defun cperl-lazy-install () + "Switch on Auto-Help on Perl constructs (put in the message area). Delay of auto-help controlled by `cperl-lazy-help-time'." - (interactive) - (make-local-variable 'cperl-help-shown) - (if (and (cperl-val 'cperl-lazy-help-time) - (not cperl-lazy-installed)) - (progn - (add-hook 'post-command-hook 'cperl-lazy-hook) - (run-with-idle-timer - (cperl-val 'cperl-lazy-help-time 1000000 5) - t - 'cperl-get-help-defer) - (setq cperl-lazy-installed t)))) - - (defun cperl-lazy-unstall () - "Switches off Auto-Help on Perl constructs (put in the message area). + (interactive) + (make-local-variable 'cperl-help-shown) + (if (and (cperl-val 'cperl-lazy-help-time) + (not cperl-lazy-installed)) + (progn + (add-hook 'post-command-hook #'cperl-lazy-hook) + (run-with-idle-timer + (cperl-val 'cperl-lazy-help-time 1000000 5) + t + #'cperl-get-help-defer) + (setq cperl-lazy-installed t)))) + +(defun cperl-lazy-unstall () + "Switch off Auto-Help on Perl constructs (put in the message area). Delay of auto-help controlled by `cperl-lazy-help-time'." - (interactive) - (remove-hook 'post-command-hook 'cperl-lazy-hook) - (cancel-function-timers 'cperl-get-help-defer) - (setq cperl-lazy-installed nil)) + (interactive) + (remove-hook 'post-command-hook #'cperl-lazy-hook) + (cancel-function-timers #'cperl-get-help-defer) + (setq cperl-lazy-installed nil)) - (defun cperl-lazy-hook () - (setq cperl-help-shown nil)) +(defun cperl-lazy-hook () + (setq cperl-help-shown nil)) - (defun cperl-get-help-defer () - (if (not (memq major-mode '(perl-mode cperl-mode))) nil - (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t)) - (cperl-get-help) - (setq cperl-help-shown t)))) - (cperl-lazy-install))) +(defun cperl-get-help-defer () + (if (not (memq major-mode '(perl-mode cperl-mode))) nil + (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t)) + (cperl-get-help) + (setq cperl-help-shown t)))) +(cperl-lazy-install) ;;; Plug for wrong font-lock: (defun cperl-font-lock-unfontify-region-function (beg end) - (let* ((modified (buffer-modified-p)) (buffer-undo-list t) - (inhibit-read-only t) (inhibit-point-motion-hooks t) - (inhibit-modification-hooks t) - deactivate-mark buffer-file-name buffer-file-truename) - (remove-text-properties beg end '(face nil)) - (if (and (not modified) (buffer-modified-p)) - (set-buffer-modified-p nil)))) + (with-silent-modifications + (remove-text-properties beg end '(face nil)))) (defun cperl-font-lock-fontify-region-function (beg end loudly) "Extends the region to safe positions, then calls the default function. @@ -8897,6 +8722,7 @@ do extra unwind via `cperl-unwind-to-safe'." (font-lock-default-fontify-region beg end loudly)) (defvar cperl-d-l nil) +(defvar edebug-backtrace-buffer) ;FIXME: Why? (defun cperl-fontify-syntaxically (end) ;; Some vars for debugging only ;; (message "Syntaxifying...") @@ -8957,7 +8783,7 @@ do extra unwind via `cperl-unwind-to-safe'." nil) ; Do not iterate ;; Called when any modification is made to buffer text. -(defun cperl-after-change-function (beg end old-len) +(defun cperl-after-change-function (beg _end _old-len) ;; We should have been informed about changes by `font-lock'. Since it ;; does not inform as which calls are deferred, do it ourselves (if cperl-syntax-done-to diff --git a/lisp/progmodes/cpp.el b/lisp/progmodes/cpp.el index d5a8629da02..29988eb14f3 100644 --- a/lisp/progmodes/cpp.el +++ b/lisp/progmodes/cpp.el @@ -568,6 +568,14 @@ You can also use the keyboard accelerators indicated like this: [K]ey." (set-window-start nil start) (goto-char pos))) +(defun cpp-locate-user-emacs-file (file) + (locate-user-emacs-file + ;; Remove initial '.' from file. + (if (eq (aref file 0) ?.) + (substring file 1) + file) + file)) + (defun cpp-edit-load () "Load cpp configuration." (interactive) @@ -576,8 +584,8 @@ You can also use the keyboard accelerators indicated like this: [K]ey." nil) ((file-readable-p cpp-config-file) (load-file cpp-config-file)) - ((file-readable-p (concat "~/" cpp-config-file)) - (load-file cpp-config-file))) + ((file-readable-p (cpp-locate-user-emacs-file cpp-config-file)) + (load-file (cpp-locate-user-emacs-file cpp-config-file)))) (if (derived-mode-p 'cpp-edit-mode) (cpp-edit-reset))) @@ -586,7 +594,10 @@ You can also use the keyboard accelerators indicated like this: [K]ey." (interactive) (require 'pp) (with-current-buffer cpp-edit-buffer - (let ((buffer (find-file-noselect cpp-config-file))) + (let* ((config-file (if (file-writable-p cpp-config-file) + cpp-config-file + (cpp-locate-user-emacs-file cpp-config-file))) + (buffer (find-file-noselect config-file))) (set-buffer buffer) (erase-buffer) (pp (list 'setq 'cpp-known-face @@ -601,7 +612,7 @@ You can also use the keyboard accelerators indicated like this: [K]ey." (list 'quote cpp-unknown-writable)) buffer) (pp (list 'setq 'cpp-edit-list (list 'quote cpp-edit-list)) buffer) - (write-file cpp-config-file)))) + (write-file config-file)))) (defun cpp-edit-home () "Switch back to original buffer." @@ -838,8 +849,8 @@ If that option is nil, don't prints messages. ARGS are the same as for `message'." (when cpp-message-min-time-interval (let ((time (current-time))) - (when (>= (float-time (time-subtract time cpp-progress-time)) - cpp-message-min-time-interval) + (unless (time-less-p cpp-message-min-time-interval + (time-subtract time cpp-progress-time)) (setq cpp-progress-time time) (apply 'message args))))) diff --git a/lisp/progmodes/cwarn.el b/lisp/progmodes/cwarn.el index a95dffd0e9d..9ed9fb3b396 100644 --- a/lisp/progmodes/cwarn.el +++ b/lisp/progmodes/cwarn.el @@ -180,11 +180,7 @@ 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. - -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." +C++ modes are included." :group 'cwarn :lighter cwarn-mode-text (cwarn-font-lock-keywords cwarn-mode) (font-lock-flush)) diff --git a/lisp/progmodes/dcl-mode.el b/lisp/progmodes/dcl-mode.el index 17137cf3036..864074fe191 100644 --- a/lisp/progmodes/dcl-mode.el +++ b/lisp/progmodes/dcl-mode.el @@ -459,7 +459,7 @@ Preloaded with all known option names from dcl-option-alist") ; ("GOSUB" (, (concat dcl-cmd-r ; "GOSUB[ \t]+\\([A-Za-z0-9_$]+\\)")) 5) ; ("CALL" (, (concat dcl-cmd-r "CALL[ \t]+\\([A-Za-z0-9_$]+\\)")) 5))) -; "*Default imenu generic expression for DCL. +; "Default imenu generic expression for DCL. ;The default includes SUBROUTINE labels in the main listing and ;sub-listings for other labels, CALL, GOTO and GOSUB statements. @@ -1580,7 +1580,7 @@ Find the column of the first non-blank character on the line. Returns the column offset." (save-excursion (beginning-of-line) - (re-search-forward "^$[ \t]*" nil t) + (re-search-forward "^\\$[ \t]*" nil t) (current-column))) diff --git a/lisp/progmodes/ebnf-abn.el b/lisp/progmodes/ebnf-abn.el index ff18c968bfa..b00308591f8 100644 --- a/lisp/progmodes/ebnf-abn.el +++ b/lisp/progmodes/ebnf-abn.el @@ -2,8 +2,7 @@ ;; Copyright (C) 2001-2019 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Old-Version: 1.2 ;; Package: ebnf2ps @@ -641,7 +640,7 @@ See documentation for variable `ebnf-abn-lex'." (let* ((char (following-char)) (chars (cond ((or (= char ?B) (= char ?b)) "01") ((or (= char ?D) (= char ?d)) "0-9") - ((or (= char ?X) (= char ?x)) "0-9A-Fa-f") + ((or (= char ?X) (= char ?x)) "[:xdigit:]") (t (error "Invalid terminal value"))))) (forward-char) (or (> (skip-chars-forward chars ebnf-limit) 0) diff --git a/lisp/progmodes/ebnf-bnf.el b/lisp/progmodes/ebnf-bnf.el index ed8419214cc..70dc84519fd 100644 --- a/lisp/progmodes/ebnf-bnf.el +++ b/lisp/progmodes/ebnf-bnf.el @@ -2,8 +2,7 @@ ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Old-Version: 1.10 ;; Package: ebnf2ps diff --git a/lisp/progmodes/ebnf-dtd.el b/lisp/progmodes/ebnf-dtd.el index 735ccbf593d..74ff1f47d16 100644 --- a/lisp/progmodes/ebnf-dtd.el +++ b/lisp/progmodes/ebnf-dtd.el @@ -2,8 +2,7 @@ ;; Copyright (C) 2001-2019 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Old-Version: 1.1 ;; Package: ebnf2ps @@ -325,7 +324,7 @@ ;; /* Character Reference */ ;; ;; CharRef ::= '&#' [0-9]+ ';' -;; | '&#x' [0-9a-fA-F]+ ';' +;; | '&#x' [[:xdigit:]]+ ';' ;; [WFC: Legal Character] ;; ;; @@ -916,9 +915,9 @@ ;;; EntityRef ::= '&' Name ';' ;;; ;;; CharRef ::= '&#' [0-9]+ ';' -;;; | '&#x' [0-9a-fA-F]+ ';' +;;; | '&#x' [[:xdigit:]]+ ';' -;;; "^\\(&\\([A-Za-z_:][-A-Za-z0-9._:]*\\|#\\(x[0-9a-fA-F]+\\|[0-9]+\\)\\);\\|[^<&]\\)*$" +;;; "^\\(&\\([A-Za-z_:][-A-Za-z0-9._:]*\\|#\\(x[[:xdigit:]]+\\|[0-9]+\\)\\);\\|[^<&]\\)*$" (defun ebnf-dtd-attlistdecl () @@ -946,7 +945,7 @@ (setq token (ebnf-dtd-lex))) (or (and (eq token 'string) (string-match - "^\\(&\\([A-Za-z_:][-A-Za-z0-9._:]*\\|#\\(x[0-9a-fA-F]+\\|[0-9]+\\)\\);\\|[^<&]\\)*$" + "^\\(&\\([A-Za-z_:][-A-Za-z0-9._:]*\\|#\\(x[[:xdigit:]]+\\|[0-9]+\\)\\);\\|[^<&]\\)*$" ebnf-dtd-lex)) (error "Invalid default value in ATTLIST declaration")))) (or (eq token 'end-decl) @@ -987,9 +986,9 @@ ;;; EntityRef ::= '&' Name ';' ;;; ;;; CharRef ::= '&#' [0-9]+ ';' -;;; | '&#x' [0-9a-fA-F]+ ';' +;;; | '&#x' [[:xdigit:]]+ ';' -;;; "^\\(%[A-Za-z_:][-A-Za-z0-9._:]*;\\|&\\([A-Za-z_:][-A-Za-z0-9._:]*\\|#\\(x[0-9a-fA-F]+\\|[0-9]+\\)\\);\\|[^%&]\\)*$" +;;; "^\\(%[A-Za-z_:][-A-Za-z0-9._:]*;\\|&\\([A-Za-z_:][-A-Za-z0-9._:]*\\|#\\(x[[:xdigit:]]+\\|[0-9]+\\)\\);\\|[^%&]\\)*$" (defun ebnf-dtd-entitydecl () @@ -1002,7 +1001,7 @@ (setq token (ebnf-dtd-lex)) (if (eq token 'string) (if (string-match - "^\\(%[A-Za-z_:][-A-Za-z0-9._:]*;\\|&\\([A-Za-z_:][-A-Za-z0-9._:]*\\|#\\(x[0-9a-fA-F]+\\|[0-9]+\\)\\);\\|[^%&]\\)*$" + "^\\(%[A-Za-z_:][-A-Za-z0-9._:]*;\\|&\\([A-Za-z_:][-A-Za-z0-9._:]*\\|#\\(x[[:xdigit:]]+\\|[0-9]+\\)\\);\\|[^%&]\\)*$" ebnf-dtd-lex) (setq token (ebnf-dtd-lex)) (error "Invalid ENTITY definition")) @@ -1243,7 +1242,7 @@ See documentation for variable `ebnf-dtd-lex'." (setq ebnf-dtd-lex (if (/= (following-char) ?x) (ebnf-dtd-char-ref "&#" "0-9") (forward-char) - (ebnf-dtd-char-ref "&#x" "0-9a-fA-F"))) + (ebnf-dtd-char-ref "&#x" "[:xdigit:]"))) 'char-ref)) ;; miscellaneous: (, ), [, ], =, |, *, +, >, `,' (t diff --git a/lisp/progmodes/ebnf-ebx.el b/lisp/progmodes/ebnf-ebx.el index 9261280be16..dc1a60f3741 100644 --- a/lisp/progmodes/ebnf-ebx.el +++ b/lisp/progmodes/ebnf-ebx.el @@ -2,8 +2,7 @@ ;; Copyright (C) 2001-2019 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Old-Version: 1.2 ;; Package: ebnf2ps @@ -659,7 +658,7 @@ See documentation for variable `ebnf-ebx-lex'." (or no-error (error "Invalid hexadecimal character")) (forward-char) - (or (> (skip-chars-forward "0-9A-Fa-f" ebnf-limit) 0) + (or (> (skip-chars-forward "[:xdigit:]" ebnf-limit) 0) (error "Invalid hexadecimal character")))) diff --git a/lisp/progmodes/ebnf-iso.el b/lisp/progmodes/ebnf-iso.el index 27457682e8b..dbba87b3efc 100644 --- a/lisp/progmodes/ebnf-iso.el +++ b/lisp/progmodes/ebnf-iso.el @@ -2,8 +2,7 @@ ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Old-Version: 1.9 ;; Package: ebnf2ps diff --git a/lisp/progmodes/ebnf-otz.el b/lisp/progmodes/ebnf-otz.el index 7b9bd33e4e1..291d510020e 100644 --- a/lisp/progmodes/ebnf-otz.el +++ b/lisp/progmodes/ebnf-otz.el @@ -2,8 +2,7 @@ ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Old-Version: 1.0 ;; Package: ebnf2ps diff --git a/lisp/progmodes/ebnf-yac.el b/lisp/progmodes/ebnf-yac.el index c667ed54d8e..e55e01e3e98 100644 --- a/lisp/progmodes/ebnf-yac.el +++ b/lisp/progmodes/ebnf-yac.el @@ -2,8 +2,7 @@ ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Old-Version: 1.4 ;; Package: ebnf2ps @@ -392,7 +391,7 @@ See documentation for variable `ebnf-yac-lex'." (defun ebnf-yac-skip-spaces () (skip-chars-forward (if ebnf-yac-skip-char - "\n\r\t !#$&()*+-.0123456789=?@[\\\\]^_`~" + "-\n\r\t !#$&()*+,.0123456789=?@[\\\\]^_`~" "\n\r\t ") ebnf-limit) (< (point) ebnf-limit)) diff --git a/lisp/progmodes/ebnf2ps.el b/lisp/progmodes/ebnf2ps.el index 770acc987f6..f26ad0a6a89 100644 --- a/lisp/progmodes/ebnf2ps.el +++ b/lisp/progmodes/ebnf2ps.el @@ -1,9 +1,8 @@ -;;; ebnf2ps.el --- translate an EBNF to a syntactic chart on PostScript +;;; ebnf2ps.el --- translate an EBNF to a syntactic chart on PostScript -*- lexical-binding:t -*- ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Version: 4.4 ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre @@ -30,8 +29,7 @@ Vinicius's last change version. When reporting bugs, please also report the version of Emacs, if any, that ebnf2ps was running with. Please send all bug fixes and enhancements to - Vinicius Jose Latorre <viniciusjl@ig.com.br>. -") + Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>.") ;;; Commentary: @@ -1154,6 +1152,7 @@ Please send all bug fixes and enhancements to (require 'ps-print) +(eval-when-compile (require 'cl-lib)) (and (string< ps-print-version "5.2.3") (error "`ebnf2ps' requires `ps-print' package version 5.2.3 or later")) @@ -2047,8 +2046,7 @@ It must be a float between 0.0 (top) and 1.0 (bottom)." (defcustom ebnf-default-width 0.6 - "Specify additional border width over default terminal, non-terminal or -special." + "Additional border width over default terminal, non-terminal or special." :type 'number :version "20" :group 'ebnf2ps) @@ -2252,7 +2250,7 @@ See also `ebnf-print-buffer'." (defun ebnf-print-buffer (&optional filename) "Generate and print a PostScript syntactic chart image of the buffer. -When called with a numeric prefix argument (C-u), prompts the user for +When called with a numeric prefix argument (\\[universal-argument]), prompts the user for the name of a file to save the PostScript image in, instead of sending it to the printer. @@ -2383,6 +2381,7 @@ WARNING: This function does *NOT* ask any confirmation to override existing (ebnf-log-header "(ebnf-eps-buffer)") (ebnf-eps-region (point-min) (point-max))) +(defvar ebnf-eps-executing) ;;;###autoload (defun ebnf-eps-region (from to) @@ -2411,7 +2410,7 @@ WARNING: This function does *NOT* ask any confirmation to override existing ;;;###autoload -(defalias 'ebnf-despool 'ps-despool) +(defalias 'ebnf-despool #'ps-despool) ;;;###autoload @@ -2611,7 +2610,8 @@ See also `ebnf-syntax-buffer'." (defvar ebnf-stack-style nil - "Used in functions `ebnf-reset-style', `ebnf-push-style' and + "Stack of styles. +Used in functions `ebnf-reset-style', `ebnf-push-style' and `ebnf-pop-style'.") @@ -3999,7 +3999,7 @@ See documentation for `ebnf-terminal-shape', `ebnf-non-terminal-shape' and % === end EBNF engine " - "EBNF PostScript prologue") + "EBNF PostScript prologue.") (defconst ebnf-eps-prologue @@ -4276,7 +4276,7 @@ See documentation for `ebnf-terminal-shape', `ebnf-non-terminal-shape' and }bind def " - "EBNF EPS prologue") + "EBNF EPS prologue.") (defconst ebnf-eps-begin @@ -4292,14 +4292,14 @@ end %%EndProlog " - "EBNF EPS begin") + "EBNF EPS begin.") (defconst ebnf-eps-end "#ebnf2ps#end %%EOF " - "EBNF EPS end") + "EBNF EPS end.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -4329,14 +4329,16 @@ end ;; hacked fom `ps-output-string-prim' (ps-print.el) (defun ebnf-eps-string (string) - (let* ((str (string-as-unibyte string)) + (let* ((str string) (len (length str)) (index 0) (new "(") ; insert start-string delimiter start special) ;; Find and quote special characters as necessary for PS - ;; This skips everything except control chars, non-ASCII chars, (, ) and \. - (while (setq start (string-match "[^]-~ -'*-[]" str index)) + ;; This skips everything except control chars, non-ASCII chars, + ;; (, ), \, and DEL. + (while (setq start (string-match "[[:cntrl:][:nonascii:]\177()\\]" + str index)) (setq special (aref str start) new (concat new (substring str index start) @@ -4536,26 +4538,25 @@ end ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; PostScript generation +(defvar ebnf-tree) -(defun ebnf-generate-eps (ebnf-tree) - (let* ((ps-color-p (and ebnf-color-p (ps-color-device))) +(defun ebnf-generate-eps (tree) + (let* ((ebnf-tree tree) + (ps-color-p (and ebnf-color-p (ps-color-device))) (ps-print-color-scale (if ps-color-p (float (car (ps-color-values "white"))) 1.0)) (ebnf-total (length ebnf-tree)) (ebnf-nprod 0) - (old-ps-output (symbol-function 'ps-output)) - (old-ps-output-string (symbol-function 'ps-output-string)) (eps-buffer (get-buffer-create ebnf-eps-buffer-name)) - ebnf-debug-ps error-msg horizontal + ebnf-debug-ps horizontal prod prod-name prod-width prod-height prod-list file-list) - ;; redefines `ps-output' and `ps-output-string' - (defalias 'ps-output 'ebnf-eps-output) - (defalias 'ps-output-string 'ps-output-string-prim) ;; generate EPS file - (save-excursion - (condition-case data - (progn + (unwind-protect + ;; redefines `ps-output' and `ps-output-string' + (cl-letf (((symbol-function 'ps-output) #'ebnf-eps-output) + ((symbol-function 'ps-output-string) #'ps-output-string-prim)) + (save-excursion (while ebnf-tree (setq prod (car ebnf-tree) prod-name (ebnf-node-name prod) @@ -4573,8 +4574,9 @@ end (if (setq prod-list (cdr (assoc prod-name ebnf-eps-production-list))) ;; insert EPS buffer in all buffer associated with production - (ebnf-eps-production-list prod-list 'file-list horizontal - prod-width prod-height eps-buffer) + (ebnf-eps-production-list + prod-list (gv-ref file-list) horizontal + prod-width prod-height eps-buffer) ;; write EPS file for production (ebnf-eps-finish-and-write eps-buffer (ebnf-eps-filename prod-name))) @@ -4584,17 +4586,10 @@ end (setq ebnf-tree (cdr ebnf-tree))) ;; write and kill temporary buffers (ebnf-eps-write-kill-temp file-list t) - (setq file-list nil)) - ;; handler - ((quit error) - (setq error-msg (error-message-string data))))) - ;; restore `ps-output' and `ps-output-string' - (defalias 'ps-output old-ps-output) - (defalias 'ps-output-string old-ps-output-string) - ;; kill temporary buffers - (kill-buffer eps-buffer) - (ebnf-eps-write-kill-temp file-list nil) - (and error-msg (error error-msg)) + (setq file-list nil))) + ;; kill temporary buffers + (kill-buffer eps-buffer) + (ebnf-eps-write-kill-temp file-list nil)) (message " "))) @@ -4610,10 +4605,10 @@ end ;; insert EPS buffer in all buffer associated with production -(defun ebnf-eps-production-list (prod-list file-list-sym horizontal +(defun ebnf-eps-production-list (prod-list file-list-ref horizontal prod-width prod-height eps-buffer) (while prod-list - (add-to-list file-list-sym (car prod-list)) + (cl-pushnew (car prod-list) (gv-deref file-list-ref) :test #'equal) (with-current-buffer (get-buffer-create (concat " *" (car prod-list) "*")) (goto-char (point-max)) (cond @@ -4647,8 +4642,9 @@ end (setq prod-list (cdr prod-list)))) -(defun ebnf-generate (ebnf-tree) - (let* ((ps-color-p (and ebnf-color-p (ps-color-device))) +(defun ebnf-generate (tree) + (let* ((ebnf-tree tree) + (ps-color-p (and ebnf-color-p (ps-color-device))) (ps-print-color-scale (if ps-color-p (float (car (ps-color-values "white"))) 1.0)) @@ -4658,14 +4654,13 @@ end ps-print-begin-page-hook ps-print-begin-column-hook) (ps-generate (current-buffer) (point-min) (point-max) - 'ebnf-generate-postscript))) + #'ebnf-generate-postscript))) -(defvar ebnf-tree nil) (defvar ebnf-direction "R") -(defun ebnf-generate-postscript (from to) +(defun ebnf-generate-postscript (_from _to) (ebnf-begin-file) (if ebnf-horizontal-max-height (ebnf-generate-with-max-height) @@ -5134,7 +5129,7 @@ killed after process termination." (defsubst ebnf-font-background (font) (nth 3 font)) (defsubst ebnf-font-list (font) (nthcdr 4 font)) (defsubst ebnf-font-attributes (font) - (lsh (ps-extension-bit (cdr font)) -2)) + (ash (ps-extension-bit (cdr font)) -2)) (defconst ebnf-font-name-select @@ -5314,9 +5309,9 @@ killed after process termination." "\n%%DocumentNeededResources: font " (or ebnf-fonts-required (setq ebnf-fonts-required - (mapconcat 'identity + (mapconcat #'identity (ps-remove-duplicates - (mapcar 'ebnf-font-name-select + (mapcar #'ebnf-font-name-select (list ebnf-production-font ebnf-terminal-font ebnf-non-terminal-font @@ -5545,7 +5540,7 @@ killed after process termination." (ebnf-log "(ebnf-dimensions tree)") (let ((ebnf-total (length tree)) (ebnf-nprod 0)) - (mapc 'ebnf-production-dimension tree)) + (mapc #'ebnf-production-dimension tree)) tree) @@ -5925,7 +5920,7 @@ killed after process termination." )))) -(defun ebnf-justify (node seq seq-width width last-p) +(defun ebnf-justify (_node seq seq-width width last-p) (let ((term (car (if last-p (last seq) seq)))) (cond ;; adjust empty term diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el index e12434a6689..3faec4959bc 100644 --- a/lisp/progmodes/ebrowse.el +++ b/lisp/progmodes/ebrowse.el @@ -1,4 +1,4 @@ -;;; ebrowse.el --- Emacs C++ class browser & tags facility +;;; ebrowse.el --- Emacs C++ class browser & tags facility -*- lexical-binding:t -*- ;; Copyright (C) 1992-2019 Free Software Foundation, Inc. @@ -233,30 +233,12 @@ Compare items with `eq' or TEST if specified." found)) -(defmacro ebrowse-output (&rest body) - "Eval BODY with a writable current buffer. -Preserve buffer's modified state." - (declare (indent 0) (debug t)) - (let ((modified (make-symbol "--ebrowse-output--"))) - `(let (buffer-read-only (,modified (buffer-modified-p))) - (unwind-protect - (progn ,@body) - (set-buffer-modified-p ,modified))))) - - (defmacro ebrowse-ignoring-completion-case (&rest body) "Eval BODY with `completion-ignore-case' bound to t." (declare (indent 0) (debug t)) `(let ((completion-ignore-case t)) ,@body)) -(defmacro ebrowse-save-selective (&rest body) - "Eval BODY with `selective-display' restored at the end." - (declare (indent 0) (debug t)) - ;; FIXME: Don't use selective-display. - `(let ((selective-display selective-display)) - ,@body)) - (defmacro ebrowse-for-all-trees (spec &rest body) "For all trees in SPEC, eval BODY." (declare (indent 1) (debug ((sexp form) body))) @@ -303,7 +285,7 @@ If a buffer with name NEW-NAME already exists, delete it first." (defun ebrowse-trim-string (string) "Return a copy of STRING with leading white space removed. Replace sequences of newlines with a single space." - (when (string-match "^[ \t\n\r]+" string) + (when (string-match "^[ \t\n]+" string) (setq string (substring string (match-end 0)))) (cl-loop while (string-match "[\n]+" string) finally return string do @@ -688,7 +670,7 @@ MARKED-ONLY non-nil means include marked classes only." "Return a list containing all files mentioned in a tree. MARKED-ONLY non-nil means include marked classes only." (let (list) - (maphash (lambda (file _dummy) (setq list (cons file list))) + (maphash (lambda (file _dummy) (push file list)) (ebrowse-files-table marked-only)) list)) @@ -865,7 +847,7 @@ and TREE is a list of `ebrowse-ts' structures forming the class tree." ;; Read Lisp objects. Temporarily increase `gc-cons-threshold' to ;; prevent a GC that would not free any memory. (let ((gc-cons-threshold 2000000)) - (while (not (progn (skip-chars-forward " \t\n\r") (eobp))) + (while (not (progn (skip-chars-forward " \t\n") (eobp))) (let* ((root (read (current-buffer))) (old-root-ptr (ebrowse-class-in-tree root tree))) (ebrowse-show-progress "Reading data" (null tree)) @@ -907,8 +889,8 @@ Return the buffer created." (ebrowse-redraw-tree) (set-buffer-modified-p nil) (pcase pop - (`switch (switch-to-buffer name)) - (`pop (pop-to-buffer name))) + ('switch (switch-to-buffer name)) + ('pop (pop-to-buffer name))) (current-buffer))) @@ -996,7 +978,6 @@ if for some reason a circle is in the inheritance graph." (ebrowse-qualified-class-name (ebrowse-ts-class (car subclass))) classes) - as next = nil do ;; Replace the subclass tree with the one found in ;; CLASSES if there is already an entry for that class @@ -1096,8 +1077,7 @@ Tree mode key bindings: (set (make-local-variable 'ebrowse--frozen-flag) nil) (setq mode-line-buffer-identification ident) (setq buffer-read-only t) - (setq selective-display t) - (setq selective-display-ellipses t) + (add-to-invisibility-spec '(ebrowse . t)) (set (make-local-variable 'revert-buffer-function) #'ebrowse-revert-tree-buffer-from-file) (set (make-local-variable 'ebrowse--header) header) @@ -1107,7 +1087,7 @@ Tree mode key bindings: (and tree (ebrowse-build-tree-obarray tree))) (set (make-local-variable 'ebrowse--frozen-flag) nil) - (add-hook 'local-write-file-hooks 'ebrowse-write-file-hook-fn nil t) + (add-hook 'write-file-functions #'ebrowse-write-file-hook-fn nil t) (modify-syntax-entry ?_ (char-to-string (char-syntax ?a))) (when tree (ebrowse-redraw-tree) @@ -1184,7 +1164,7 @@ If given a numeric N-TIMES argument, mark that many classes." ;; by a regexp replace over the whole buffer. The reason for this ;; is that classes might have multiple base classes. If this is ;; the case, they are displayed more than once in the tree. - (ebrowse-output + (with-silent-modifications (cl-loop for tree in to-change as regexp = (concat "^.*\\b" @@ -1213,7 +1193,7 @@ If given a numeric N-TIMES argument, mark that many classes." "Display class marker signs in the tree between START and END." (interactive) (save-excursion - (ebrowse-output + (with-silent-modifications (catch 'end (goto-char (point-min)) (dolist (root ebrowse--tree) @@ -1242,8 +1222,8 @@ If given a numeric N-TIMES argument, mark that many classes." With PREFIX, insert that many filenames." (interactive "p") (unless ebrowse--show-file-names-flag - (ebrowse-output - (dotimes (i prefix) + (with-silent-modifications + (dotimes (_ prefix) (let ((tree (ebrowse-tree-at-point)) start file-name-existing) @@ -1393,6 +1373,18 @@ Pop to member buffer if no prefix ARG, to tree buffer otherwise." +;;; Functions to hide/unhide text + +(defun ebrowse--hidden-p (&optional pos) + (eq (get-char-property (or pos (point)) 'invisible) 'ebrowse)) + +(defun ebrowse--hide (start end) + (put-text-property start end 'invisible 'ebrowse)) + +(defun ebrowse--unhide (start end) + ;; FIXME: This also removes other invisible properties! + (remove-text-properties start end '(invisible))) + ;;; Misc tree buffer commands (defun ebrowse-set-tree-indentation () @@ -1418,16 +1410,14 @@ Read a class name from the minibuffer if CLASS is nil." (setf class (completing-read "Goto class: " (ebrowse-tree-obarray-as-alist) nil t))) - (ebrowse-save-selective - (goto-char (point-min)) - (widen) - (setf selective-display nil) - (setq ebrowse--last-regexp (concat "\\b" class "\\b")) - (if (re-search-forward ebrowse--last-regexp nil t) - (progn - (goto-char (match-beginning 0)) - (ebrowse-unhide-base-classes)) - (error "Not found"))))) + (goto-char (point-min)) + (widen) + (setq ebrowse--last-regexp (concat "\\b" class "\\b")) + (if (re-search-forward ebrowse--last-regexp nil t) + (progn + (goto-char (match-beginning 0)) + (ebrowse-unhide-base-classes)) + (error "Not found")))) @@ -1556,7 +1546,7 @@ and possibly kill the viewed buffer." (setq original-frame-configuration ebrowse--frame-configuration exit-action ebrowse--view-exit-action)) ;; Delete the frame in which we viewed. - (mapc 'delete-frame + (mapc #'delete-frame (cl-loop for frame in (frame-list) when (not (assq frame original-frame-configuration)) collect frame)) @@ -1610,17 +1600,15 @@ specifies where to find/view the result." (cond (view (setf ebrowse-temp-position-to-view struc ebrowse-temp-info-to-view info) - (unless (boundp 'view-mode-hook) - (setq view-mode-hook nil)) - (push 'ebrowse-find-pattern view-mode-hook) + (add-hook 'view-mode-hook #'ebrowse-find-pattern) (pcase where - (`other-window (view-file-other-window file)) - (`other-frame (ebrowse-view-file-other-frame file)) + ('other-window (view-file-other-window file)) + ('other-frame (ebrowse-view-file-other-frame file)) (_ (view-file file)))) (t (pcase where - (`other-window (find-file-other-window file)) - (`other-frame (find-file-other-frame file)) + ('other-window (find-file-other-window file)) + ('other-frame (find-file-other-frame file)) (_ (find-file file))) (ebrowse-find-pattern struc info)))) @@ -1676,7 +1664,7 @@ a pattern. To be able to do a search in a viewed buffer, INFO is a list (TREE-HEADER TREE-OR-MEMBER MEMBER-LIST)." (unless position - (pop view-mode-hook) + (remove-hook 'view-mode-hook #'ebrowse-find-pattern) (setf viewing t position ebrowse-temp-position-to-view info ebrowse-temp-info-to-view)) @@ -1685,7 +1673,7 @@ INFO is a list (TREE-HEADER TREE-OR-MEMBER MEMBER-LIST)." (start (ebrowse-bs-point position)) (offset 100) found) - (pcase-let ((`(,header ,class-or-member ,member-list) info)) + (pcase-let ((`(,_header ,class-or-member ,member-list) info)) ;; If no pattern is specified, construct one from the member name. (when (stringp pattern) (setq pattern (concat "^.*" (regexp-quote pattern)))) @@ -1695,9 +1683,9 @@ INFO is a list (TREE-HEADER TREE-OR-MEMBER MEMBER-LIST)." (ebrowse-ms (setf pattern (pcase member-list - ((or `ebrowse-ts-member-variables - `ebrowse-ts-static-variables - `ebrowse-ts-types) + ((or 'ebrowse-ts-member-variables + 'ebrowse-ts-static-variables + 'ebrowse-ts-types) (ebrowse-variable-declaration-regexp (ebrowse-bs-name position))) (_ @@ -1749,7 +1737,7 @@ QUIETLY non-nil means don't display progress messages." (interactive) (or quietly (message "Displaying...")) (save-excursion - (ebrowse-output + (with-silent-modifications (erase-buffer) (ebrowse-draw-tree-fn))) (ebrowse-update-tree-buffer-mode-line) @@ -1816,7 +1804,8 @@ This function may look weird, but this is faster than recursion." (nconc (copy-sequence (ebrowse-ts-subclasses tree)) stack2) stack1 (nconc (make-list (length (ebrowse-ts-subclasses tree)) - (1+ level)) stack1))))) + (1+ level)) + stack1))))) @@ -1844,69 +1833,60 @@ With prefix ARG, expand all sub-trees." "Expand or fold all trees in the buffer. COLLAPSE non-nil means fold them." (interactive "P") - (let ((line-end (if collapse "^\n" "^\r")) - (insertion (if collapse "\r" "\n"))) - (ebrowse-output + (with-silent-modifications + (if (not collapse) + (ebrowse--unhide (point-min) (point-max)) (save-excursion (goto-char (point-min)) - (while (not (progn (skip-chars-forward line-end) (eobp))) - (when (or (not collapse) - (looking-at "\n ")) - (delete-char 1) - (insert insertion)) - (when collapse - (skip-chars-forward "\n "))))))) + (while (progn (end-of-line) (not (eobp))) + (when (looking-at "\n ") + (ebrowse--hide (point) (line-end-position 2))) + (skip-chars-forward "\n ")))))) (defun ebrowse-unhide-base-classes () "Unhide the line the cursor is on and all base classes." - (ebrowse-output + (with-silent-modifications (save-excursion (let (indent last-indent) - (skip-chars-backward "^\r\n") - (when (not (looking-at "[\r\n][^ \t]")) - (skip-chars-forward "\r\n \t") + (forward-line 0) + (when (not (looking-at "\n[^ \t]")) + (skip-chars-forward "\n \t") (while (and (or (null last-indent) ;first time (> indent 1)) ;not root class - (re-search-backward "[\r\n][ \t]*" nil t)) + (re-search-backward "\n[ \t]*" nil t)) (setf indent (- (match-end 0) (match-beginning 0))) (when (or (null last-indent) (< indent last-indent)) (setf last-indent indent) - (when (looking-at "\r") - (delete-char 1) - (insert 10))) - (backward-char 1))))))) + (when (ebrowse--hidden-p) + (ebrowse--unhide (point) (line-end-position 2)))))))))) (defun ebrowse-hide-line (collapse) "Hide/show a single line in the tree. COLLAPSE non-nil means hide." - (save-excursion - (ebrowse-output - (skip-chars-forward "^\r\n") - (delete-char 1) - (insert (if collapse 13 10))))) + (with-silent-modifications + (funcall (if collapse #'ebrowse--hide #'ebrowse--unhide) + (line-end-position) (line-end-position 2)))) (defun ebrowse-collapse-fn (collapse) "Collapse or expand a branch of the tree. COLLAPSE non-nil means collapse the branch." - (ebrowse-output + (with-silent-modifications (save-excursion (beginning-of-line) (skip-chars-forward "> \t") (let ((indentation (current-column))) (while (and (not (eobp)) (save-excursion - (skip-chars-forward "^\r\n") - (goto-char (1+ (point))) + (forward-line 1) (skip-chars-forward "> \t") (> (current-column) indentation))) (ebrowse-hide-line collapse) - (skip-chars-forward "^\r\n") - (goto-char (1+ (point)))))))) + (forward-line 1)))))) ;;; Electric tree selection @@ -2164,7 +2144,7 @@ See `Electric-command-loop' for a description of STATE and CONDITION." ;;;###autoload (define-derived-mode ebrowse-member-mode special-mode "Ebrowse-Members" "Major mode for Ebrowse member buffers." - (mapc 'make-local-variable + (mapc #'make-local-variable '(ebrowse--decl-column ;display column ebrowse--n-columns ;number of short columns ebrowse--column-width ;width of columns above @@ -2587,7 +2567,7 @@ TAGS-FILE is the file name of the BROWSE file." (let ((display-fn (if ebrowse--long-display-flag 'ebrowse-draw-member-long-fn 'ebrowse-draw-member-short-fn))) - (ebrowse-output + (with-silent-modifications (erase-buffer) ;; Show this class (ebrowse-draw-member-buffer-class-line) @@ -2708,7 +2688,7 @@ means the member buffer is standalone. CLASS is its class." (defun ebrowse-draw-member-long-fn (member-list tree) "Display member buffer for MEMBER-LIST in long form. TREE is the class tree of MEMBER-LIST." - (dolist (member-struc (mapcar 'ebrowse-member-display-p member-list)) + (dolist (member-struc (mapcar #'ebrowse-member-display-p member-list)) (when member-struc (let ((name (ebrowse-ms-name member-struc)) (start (point))) @@ -3172,9 +3152,9 @@ EVENT is the mouse event." (2 (ebrowse-find-member-definition)) (1 (pcase (get-text-property (posn-point (event-start event)) 'ebrowse-what) - (`member-name + ('member-name (ebrowse-popup-menu ebrowse-member-name-object-menu event)) - (`class-name + ('class-name (ebrowse-popup-menu ebrowse-member-class-name-object-menu event)) (_ (ebrowse-popup-menu ebrowse-member-buffer-object-menu event)))))) @@ -3189,7 +3169,7 @@ EVENT is the mouse event." (2 (ebrowse-find-member-definition)) (1 (pcase (get-text-property (posn-point (event-start event)) 'ebrowse-what) - (`member-name + ('member-name (ebrowse-view-member-definition 0)))))) @@ -3243,7 +3223,8 @@ from point as default. Value is a list (CLASS-NAME MEMBER-NAME)." (if members (let* ((name (ebrowse-ignoring-completion-case (completing-read prompt members nil nil member-name))) - (completion-result (try-completion name members))) + ;; (completion-result (try-completion name members)) + ) ;; Cannot rely on `try-completion' returning t for exact ;; matches! It returns the name as a string. (unless (gethash name members) @@ -3522,12 +3503,12 @@ KIND is an additional string printed in the buffer." (insert kind) (indent-to 50) (insert (pcase (cl-second info) - (`ebrowse-ts-member-functions "member function") - (`ebrowse-ts-member-variables "member variable") - (`ebrowse-ts-static-functions "static function") - (`ebrowse-ts-static-variables "static variable") - (`ebrowse-ts-friends (if globals-p "define" "friend")) - (`ebrowse-ts-types "type") + ('ebrowse-ts-member-functions "member function") + ('ebrowse-ts-member-variables "member variable") + ('ebrowse-ts-static-functions "static function") + ('ebrowse-ts-static-variables "static variable") + ('ebrowse-ts-friends (if globals-p "define" "friend")) + ('ebrowse-ts-types "type") (_ "unknown")) "\n"))) @@ -3750,6 +3731,7 @@ looks like a function call to the member." ;; Get the member name NAME (class-name is ignored). (let ((name fix-name) class-name regexp) (unless name + (ignore class-name) ;Can't use an underscore to silence the warning :-(! (cl-multiple-value-setq (class-name name) (cl-values-list (ebrowse-tags-read-name header "Find calls of: ")))) ;; Set tags loop form to search for member and begin loop. @@ -3794,14 +3776,13 @@ If VIEW is non-nil, view the position, otherwise find it." (find-file (ebrowse-position-file-name position)) (goto-char (ebrowse-position-point position))) (t - (unwind-protect - (progn - (push (function - (lambda () - (goto-char (ebrowse-position-point position)))) - view-mode-hook) - (view-file (ebrowse-position-file-name position))) - (pop view-mode-hook))))) + (let ((fn (lambda () + (goto-char (ebrowse-position-point position))))) + (unwind-protect + (progn + (add-hook 'view-mode-hook fn) + (view-file (ebrowse-position-file-name position))) + (remove-hook 'view-mode-hook fn)))))) (defun ebrowse-push-position (marker info &optional target) @@ -3904,6 +3885,7 @@ Runs the hook `ebrowse-electric-position-mode-hook'." (setq mode-line-buffer-identification "Electric Position Menu") (when (memq 'mode-name mode-line-format) (setq mode-line-format (copy-sequence mode-line-format)) + ;; FIXME: Why not set `mode-name' to "Positions"? (setcar (memq 'mode-name mode-line-format) "Positions")) (set (make-local-variable 'Helper-return-blurb) "return to buffer editing") (setq truncate-lines t @@ -4023,7 +4005,7 @@ If VIEW is non-nil, view else find source files." (defun ebrowse-write-file-hook-fn () "Write current buffer as a class tree. -Installed on `local-write-file-hooks'." +Added to `write-file-functions'." (ebrowse-save-tree) t) @@ -4050,7 +4032,7 @@ Otherwise, FILE-NAME specifies the file to save the tree in." (erase-buffer) (setf (ebrowse-hs-member-table header) nil) (insert (prin1-to-string header) " ") - (mapc 'ebrowse-save-class tree) + (mapc #'ebrowse-save-class tree) (write-file file-name) (message "Tree written to file `%s'" file-name)) (kill-buffer temp-buffer) @@ -4065,7 +4047,7 @@ Otherwise, FILE-NAME specifies the file to save the tree in." (insert "[ebrowse-ts ") (prin1 (ebrowse-ts-class class)) ;class name (insert "(") ;list of subclasses - (mapc 'ebrowse-save-class (ebrowse-ts-subclasses class)) + (mapc #'ebrowse-save-class (ebrowse-ts-subclasses class)) (insert ")") (dolist (func ebrowse-member-list-accessors) (prin1 (funcall func class)) @@ -4252,12 +4234,12 @@ NUMBER-OF-STATIC-VARIABLES:" (unwind-protect (progn (add-hook 'electric-buffer-menu-mode-hook - 'ebrowse-hack-electric-buffer-menu) + #'ebrowse-hack-electric-buffer-menu) (add-hook 'electric-buffer-menu-mode-hook - 'ebrowse-install-1-to-9-keys) + #'ebrowse-install-1-to-9-keys) (call-interactively 'electric-buffer-list)) (remove-hook 'electric-buffer-menu-mode-hook - 'ebrowse-hack-electric-buffer-menu))) + #'ebrowse-hack-electric-buffer-menu))) ;;; Mouse support @@ -4371,7 +4353,7 @@ EVENT is the mouse event." (pcase (event-click-count event) (1 (pcase property - (`class-name + ('class-name (ebrowse-popup-menu ebrowse-tree-buffer-class-object-menu event)) (_ (ebrowse-popup-menu ebrowse-tree-buffer-object-menu event))))))) @@ -4386,7 +4368,7 @@ EVENT is the mouse event." (property (get-text-property where 'ebrowse-what))) (pcase (event-click-count event) (1 (pcase property - (`class-name + ('class-name (ebrowse-tree-command:show-member-functions))))))) @@ -4399,11 +4381,10 @@ EVENT is the mouse event." (property (get-text-property where 'ebrowse-what))) (pcase (event-click-count event) (2 (pcase property - (`class-name - (let ((collapsed (save-excursion (skip-chars-forward "^\r\n") - (looking-at "\r")))) + ('class-name + (let ((collapsed (ebrowse--hidden-p (line-end-position)))) (ebrowse-collapse-fn (not collapsed)))) - (`mark + ('mark (ebrowse-toggle-mark-at-point 1))))))) @@ -4411,9 +4392,7 @@ EVENT is the mouse event." (provide 'ebrowse) ;; Local variables: -;; eval:(put 'ebrowse-output 'lisp-indent-hook 0) ;; eval:(put 'ebrowse-ignoring-completion-case 'lisp-indent-hook 0) -;; eval:(put 'ebrowse-save-selective 'lisp-indent-hook 0) ;; eval:(put 'ebrowse-for-all-trees 'lisp-indent-hook 1) ;; End: diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index df6d929ab58..36797fc6fdb 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -45,7 +45,7 @@ It has `lisp-mode-abbrev-table' as its parent." "Syntax table used in `emacs-lisp-mode'.") (defvar emacs-lisp-mode-map - (let ((map (make-sparse-keymap "Emacs-Lisp")) + (let ((map (make-sparse-keymap)) (menu-map (make-sparse-keymap "Emacs-Lisp")) (lint-map (make-sparse-keymap)) (prof-map (make-sparse-keymap)) @@ -219,6 +219,18 @@ Comments in the form will be lost." :type 'hook :group 'lisp) +(defun emacs-lisp-set-electric-text-pairs () + "Set `electric-pair-text-pairs' for all `emacs-lisp-mode' buffers." + (defvar electric-pair-text-pairs) + (let ((elisp-pairs (append '((?\` . ?\') (?‘ . ?’)) + electric-pair-text-pairs))) + (save-current-buffer + (dolist (buf (buffer-list)) + (set-buffer buf) + (when (derived-mode-p 'emacs-lisp-mode) + (setq-local electric-pair-text-pairs elisp-pairs))))) + (remove-hook 'electric-pair-mode-hook #'emacs-lisp-set-electric-text-pairs)) + ;;;###autoload (define-derived-mode emacs-lisp-mode prog-mode "Emacs-Lisp" "Major mode for editing Lisp code to run in Emacs. @@ -231,12 +243,12 @@ Blank lines separate paragraphs. Semicolons start comments. (defvar project-vc-external-roots-function) (lisp-mode-variables nil nil 'elisp) (add-hook 'after-load-functions #'elisp--font-lock-flush-elisp-buffers) - (unless noninteractive - (require 'elec-pair) - (defvar electric-pair-text-pairs) - (setq-local electric-pair-text-pairs - (append '((?\` . ?\') (?‘ . ?’)) electric-pair-text-pairs)) - (setq-local electric-quote-string t)) + (if (boundp 'electric-pair-text-pairs) + (setq-local electric-pair-text-pairs + (append '((?\` . ?\') (?‘ . ?’)) + electric-pair-text-pairs)) + (add-hook 'electric-pair-mode-hook #'emacs-lisp-set-electric-text-pairs)) + (setq-local electric-quote-string t) (setq imenu-case-fold-search nil) (add-function :before-until (local 'eldoc-documentation-function) #'elisp-eldoc-documentation-function) @@ -271,14 +283,14 @@ Blank lines separate paragraphs. Semicolons start comments. (unless (setq res (pcase sexp - (`(,(or `let `let*) ,bindings) + (`(,(or 'let 'let*) ,bindings) (let ((vars vars)) (when (eq 'let* (car sexp)) (dolist (binding (cdr (reverse bindings))) (push (or (car-safe binding) binding) vars))) (elisp--local-variables-1 vars (car (cdr-safe (car (last bindings))))))) - (`(,(or `let `let*) ,bindings . ,body) + (`(,(or 'let 'let*) ,bindings . ,body) (let ((vars vars)) (dolist (binding bindings) (push (or (car-safe binding) binding) vars)) @@ -300,7 +312,7 @@ Blank lines separate paragraphs. Semicolons start comments. ;; FIXME: Handle `cond'. (`(,_ . ,_) (elisp--local-variables-1 vars (car (last sexp)))) - (`elisp--witness--lisp (or vars '(nil))) + ('elisp--witness--lisp (or vars '(nil))) (_ nil))) ;; We didn't find the witness in the last element so we try to ;; backtrack to the last-but-one. @@ -488,16 +500,26 @@ functions are annotated with \"<f>\" via the (scan-error pos)))) ;; t if in function position. (funpos (eq (char-before beg) ?\()) - (quoted (elisp--form-quoted-p 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)))) (when (and end (or (not (nth 8 (syntax-ppss))) (memq (char-before beg) '(?` ?‘)))) (let ((table-etc (if (or (not funpos) quoted) - ;; FIXME: We could look at the first element of the list and - ;; use it to provide a more specific completion table in some - ;; cases. E.g. filter out keywords that are not understood by - ;; the macro/function being called. (cond + ;; 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) + (list t obarray + :predicate (lambda (sym) + (get sym 'error-conditions)))) ((elisp--expect-function-p beg) (list nil obarray :predicate #'fboundp @@ -541,7 +563,7 @@ functions are annotated with \"<f>\" via the (pcase parent ;; FIXME: Rather than hardcode special cases here, ;; we should use something like a symbol-property. - (`declare + ('declare (list t (mapcar (lambda (x) (symbol-name (car x))) (delete-dups ;; FIXME: We should include some @@ -549,14 +571,19 @@ functions are annotated with \"<f>\" via the (append macro-declarations-alist defun-declarations-alist nil))))) ; Copy both alists. - ((and (or `condition-case `condition-case-unless-debug) + ((and (or 'condition-case 'condition-case-unless-debug) (guard (save-excursion (ignore-errors (forward-sexp 2) (< (point) beg))))) (list t obarray :predicate (lambda (sym) (get sym 'error-conditions)))) - ((and (or ?\( `let `let*) + ;; `ignore-error' with a list CONDITION parameter. + ('ignore-error + (list t obarray + :predicate (lambda (sym) + (get sym 'error-conditions)))) + ((and (or ?\( 'let 'let*) (guard (save-excursion (goto-char (1- beg)) (when (eq parent ?\() @@ -901,10 +928,11 @@ Semicolons start comments. ;;; Emacs Lisp Byte-Code mode (eval-and-compile - (defconst emacs-list-byte-code-comment-re + (defconst emacs-lisp-byte-code-comment-re (concat "\\(#\\)@\\([0-9]+\\) " ;; Make sure it's a docstring and not a lazy-loaded byte-code. - "\\(?:[^(]\\|([^\"]\\)"))) + "\\(?:[^(]\\|([^\"]\\)") + "Regular expression matching a dynamic doc string comment.")) (defun elisp--byte-code-comment (end &optional _point) "Try to syntactically mark the #@NNN ....^_ docstrings in byte-code files." @@ -913,7 +941,7 @@ Semicolons start comments. (eq (char-after (nth 8 ppss)) ?#)) (let* ((n (save-excursion (goto-char (nth 8 ppss)) - (when (looking-at emacs-list-byte-code-comment-re) + (when (looking-at emacs-lisp-byte-code-comment-re) (string-to-number (match-string 2))))) ;; `maxdiff' tries to make sure the loop below terminates. (maxdiff n)) @@ -939,7 +967,7 @@ Semicolons start comments. (elisp--byte-code-comment end (point)) (funcall (syntax-propertize-rules - (emacs-list-byte-code-comment-re + (emacs-lisp-byte-code-comment-re (1 (prog1 "< b" (elisp--byte-code-comment end (point)))))) start end)) @@ -1131,7 +1159,9 @@ character)." (eval-expression-get-print-arguments eval-last-sexp-arg-internal))) ;; Setup the lexical environment if lexical-binding is enabled. (elisp--eval-last-sexp-print-value - (eval (eval-sexp-add-defvars (elisp--preceding-sexp)) lexical-binding) + (eval (macroexpand-all + (eval-sexp-add-defvars (elisp--preceding-sexp))) + lexical-binding) (if insert-value (current-buffer) t) no-truncate char-print-limit))) (defun elisp--eval-last-sexp-print-value @@ -1164,7 +1194,6 @@ character)." (defun eval-sexp-add-defvars (exp &optional pos) "Prepend EXP with all the `defvar's that precede it in the buffer. POS specifies the starting position where EXP was found and defaults to point." - (setq exp (macroexpand-all exp)) ;Eager macro-expansion. (if (not lexical-binding) exp (save-excursion @@ -1175,10 +1204,11 @@ POS specifies the starting position where EXP was found and defaults to point." "(def\\(?:var\\|const\\|custom\\)[ \t\n]+\\([^; '()\n\t]+\\)" pos t) (let ((var (intern (match-string 1)))) - (and (not (special-variable-p var)) - (save-excursion - (zerop (car (syntax-ppss (match-beginning 0))))) - (push var vars)))) + (unless (or (special-variable-p var) + (syntax-ppss-toplevel-pos + (save-excursion + (syntax-ppss (match-beginning 0))))) + (push var vars)))) `(progn ,@(mapcar (lambda (v) `(defvar ,v)) vars) ,exp))))) (defun eval-last-sexp (eval-last-sexp-arg-internal) @@ -1667,6 +1697,16 @@ Calls REPORT-FN directly." (defvar-local elisp-flymake--byte-compile-process nil "Buffer-local process started for byte-compiling the buffer.") +(defvar elisp-flymake-byte-compile-load-path (list "./") + "Like `load-path' but used by `elisp-flymake-byte-compile'. +The default value contains just \"./\" which includes the default +directory of the buffer being compiled, and nothing else.") + +(put 'elisp-flymake-byte-compile-load-path 'safe-local-variable + (lambda (x) (and (listp x) (catch 'tag + (dolist (path x t) (unless (stringp path) + (throw 'tag nil))))))) + ;;;###autoload (defun elisp-flymake-byte-compile (report-fn &rest _args) "A Flymake backend for elisp byte compilation. @@ -1686,13 +1726,14 @@ current buffer state and calls REPORT-FN when done." (make-process :name "elisp-flymake-byte-compile" :buffer output-buffer - :command (list (expand-file-name invocation-name invocation-directory) - "-Q" - "--batch" - ;; "--eval" "(setq load-prefer-newer t)" ; for testing - "-L" default-directory - "-f" "elisp-flymake--batch-compile-for-flymake" - temp-file) + :command `(,(expand-file-name invocation-name invocation-directory) + "-Q" + "--batch" + ;; "--eval" "(setq load-prefer-newer t)" ; for testing + ,@(mapcan (lambda (path) (list "-L" path)) + elisp-flymake-byte-compile-load-path) + "-f" "elisp-flymake--batch-compile-for-flymake" + ,temp-file) :connection-type 'pipe :sentinel (lambda (proc _event) @@ -1714,9 +1755,9 @@ current buffer state and calls REPORT-FN when done." :explanation (format "byte-compile process %s died" proc)))) (ignore-errors (delete-file temp-file)) - (kill-buffer output-buffer)))))) - :stderr null-device - :noquery t))) + (kill-buffer output-buffer)))) + :stderr " *stderr of elisp-flymake-byte-compile*" + :noquery t))))) (defun elisp-flymake--batch-compile-for-flymake (&optional file) "Helper for `elisp-flymake-byte-compile'. diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index 7d8cf3f8236..a052ad2ce56 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -26,9 +26,17 @@ ;;; Code: +;; The namespacing of this package is a mess: +;; - The file name is "etags", but the "exported" functionality doesn't use +;; this name +;; - Uses "etags-", "tags-", and "tag-" prefixes. +;; - Many functions use "-tag-" or "-tags-", or even "-etags-" not as +;; prefixes but somewhere within the name. + (require 'ring) (require 'button) (require 'xref) +(require 'fileloop) ;;;###autoload (defvar tags-file-name nil @@ -49,7 +57,6 @@ Use the `etags' program to make a tags table file.") "Whether tags operations should be case-sensitive. A value of t means case-insensitive, a value of nil means case-sensitive. Any other value means use the setting of `case-fold-search'." - :group 'etags :type '(choice (const :tag "Case-sensitive" nil) (const :tag "Case-insensitive" t) (other :tag "Use default" default)) @@ -63,7 +70,6 @@ An element that is a directory means the file \"TAGS\" in that directory. To switch to a new list of tags tables, setting this variable is sufficient. If you set this variable, do not also set `tags-file-name'. Use the `etags' program to make a tags table file." - :group 'etags :type '(repeat file)) ;;;###autoload @@ -72,8 +78,7 @@ Use the `etags' program to make a tags table file." "List of extensions tried by etags when `auto-compression-mode' is on. An empty string means search the non-compressed file." :version "24.1" ; added xz - :type '(repeat string) - :group 'etags) + :type '(repeat string)) ;; !!! tags-compression-info-list should probably be replaced by access ;; to directory list and matching jka-compr-compression-info-list. Currently, @@ -91,14 +96,12 @@ An empty string means search the non-compressed file." t means do; nil means don't (always start a new list). Any other value means ask the user whether to add a new tags table to the current list (as opposed to starting a new list)." - :group 'etags :type '(choice (const :tag "Do" t) (const :tag "Don't" nil) (other :tag "Ask" ask-user))) (defcustom tags-revert-without-query nil "Non-nil means reread a TAGS table without querying, if it has changed." - :group 'etags :type 'boolean) (defvar tags-table-computed-list nil @@ -131,7 +134,6 @@ Each element is a list of strings which are file names.") "Hook to be run by \\[find-tag] after finding a tag. See `run-hooks'. The value in the buffer in which \\[find-tag] is done is used, not the value in the buffer \\[find-tag] goes to." - :group 'etags :type 'hook) ;;;###autoload @@ -140,7 +142,6 @@ not the value in the buffer \\[find-tag] goes to." If nil, and the symbol that is the value of `major-mode' has a `find-tag-default-function' property (see `put'), that is used. Otherwise, `find-tag-default' is used." - :group 'etags :type '(choice (const nil) function)) (define-obsolete-variable-alias 'find-tag-marker-ring-length @@ -148,13 +149,11 @@ Otherwise, `find-tag-default' is used." (defcustom tags-tag-face 'default "Face for tags in the output of `tags-apropos'." - :group 'etags :type 'face :version "21.1") (defcustom tags-apropos-verbose nil "If non-nil, print the name of the tags file in the *Tags List* buffer." - :group 'etags :type 'boolean :version "21.1") @@ -175,7 +174,6 @@ Example value: ((\"Emacs Lisp\" Info-goto-emacs-command-node obarray) (\"Common Lisp\" common-lisp-hyperspec common-lisp-hyperspec-obarray) (\"SCWM\" scwm-documentation scwm-obarray))" - :group 'etags :type '(repeat (list (string :tag "Title") function (sexp :tag "Tags to search"))) @@ -209,9 +207,6 @@ use function `tags-table-files' to do so.") (defvar tags-included-tables nil "List of tags tables included by the current tags table.") - -(defvar next-file-list nil - "List of files for \\[next-file] to process.") ;; Hooks for file formats. @@ -274,12 +269,9 @@ buffer-local and set them to nil." (run-hook-with-args-until-success 'tags-table-format-functions)) ;;;###autoload -(defun tags-table-mode () +(define-derived-mode tags-table-mode special-mode "Tags Table" "Major mode for tags table file buffers." - (interactive) - (setq major-mode 'tags-table-mode ;FIXME: Use define-derived-mode. - mode-name "Tags Table" - buffer-undo-list t) + (setq buffer-undo-list t) (initialize-new-tags-table)) ;;;###autoload @@ -331,10 +323,10 @@ file the tag was in." (defun tags-table-check-computed-list () "Compute `tags-table-computed-list' from `tags-table-list' if necessary." - (let ((expanded-list (mapcar 'tags-expand-table-name tags-table-list))) + (let ((expanded-list (mapcar #'tags-expand-table-name tags-table-list))) (or (equal tags-table-computed-list-for expanded-list) ;; The list (or default-directory) has changed since last computed. - (let* ((compute-for (mapcar 'copy-sequence expanded-list)) + (let* ((compute-for (mapcar #'copy-sequence expanded-list)) (tables (copy-sequence compute-for)) ;Mutated in the loop. (computed nil) table-buffer) @@ -354,7 +346,7 @@ file the tag was in." (if (tags-included-tables) ;; Insert the included tables into the list we ;; are processing. - (setcdr tables (nconc (mapcar 'tags-expand-table-name + (setcdr tables (nconc (mapcar #'tags-expand-table-name (tags-included-tables)) (cdr tables)))))) ;; This table is not in core yet. Insert a placeholder @@ -439,25 +431,25 @@ Returns non-nil if it is a valid table." (progn (set-buffer (get-file-buffer file)) (or verify-tags-table-function (tags-table-mode)) - (if (or (verify-visited-file-modtime (current-buffer)) - ;; Decide whether to revert the file. - ;; revert-without-query can say to revert - ;; or the user can say to revert. - (not (or (let ((tail revert-without-query) - (found nil)) - (while tail - (if (string-match (car tail) buffer-file-name) - (setq found t)) - (setq tail (cdr tail))) - found) - tags-revert-without-query - (yes-or-no-p - (format "Tags file %s has changed, read new contents? " - file))))) - (and verify-tags-table-function - (funcall verify-tags-table-function)) + (unless (or (verify-visited-file-modtime (current-buffer)) + ;; Decide whether to revert the file. + ;; revert-without-query can say to revert + ;; or the user can say to revert. + (not (or (let ((tail revert-without-query) + (found nil)) + (while tail + (if (string-match (car tail) buffer-file-name) + (setq found t)) + (setq tail (cdr tail))) + found) + tags-revert-without-query + (yes-or-no-p + (format "Tags file %s has changed, read new contents? " + file))))) (revert-buffer t t) - (tags-table-mode))) + (tags-table-mode)) + (and verify-tags-table-function + (funcall verify-tags-table-function))) (when (file-exists-p file) (let* ((buf (find-file-noselect file)) (newfile (buffer-file-name buf))) @@ -470,7 +462,9 @@ Returns non-nil if it is a valid table." ;; Only change buffer now that we're done using potentially ;; buffer-local variables. (set-buffer buf) - (tags-table-mode))))) + (tags-table-mode) + (and verify-tags-table-function + (funcall verify-tags-table-function)))))) ;; Subroutine of visit-tags-table-buffer. Search the current tags tables ;; for one that has tags for THIS-FILE (or that includes a table that @@ -503,7 +497,7 @@ buffers. If CORE-ONLY is nil, it is ignored." ;; Select the tags table buffer and get the file list up to date. (let ((tags-file-name (car tables))) (visit-tags-table-buffer 'same) - (if (member this-file (mapcar 'expand-file-name + (if (member this-file (mapcar #'expand-file-name (tags-table-files))) ;; Found it. (setq found tables)))) @@ -854,7 +848,7 @@ If no tags table is loaded, do nothing and return nil." (defun find-tag--default () (funcall (or find-tag-default-function (get major-mode 'find-tag-default-function) - 'find-tag-default))) + #'find-tag-default))) (defvar last-tag nil "Last tag found by \\[find-tag].") @@ -1042,7 +1036,8 @@ See documentation of variable `tags-file-name'." (declare (obsolete xref-find-definitions-other-frame "25.1")) (interactive (find-tag-interactive "Find tag other frame: ")) (let ((pop-up-frames t)) - (find-tag-other-window tagname next-p))) + (with-suppressed-warnings ((obsolete find-tag-other-window)) + (find-tag-other-window tagname next-p)))) ;;;###autoload (defun find-tag-regexp (regexp &optional next-p other-window) @@ -1287,7 +1282,7 @@ buffer-local values of tags table format variables." ;; This regexp matches an explicit tag name or the place where ;; it would start. (while (re-search-forward - "[\f\t\n\r()=,; ]?\177\\\(?:\\([^\n\001]+\\)\001\\)?" + "[\f\t\n\r()=,; ]?\177\\(?:\\([^\n\001]+\\)\001\\)?" nil t) (push (prog1 (if (match-beginning 1) ;; There is an explicit tag name. @@ -1651,7 +1646,7 @@ Point should be just after a string that matches TAG." ;; a textual description of the four rules. (and (string-match "^[^ \t()=,;]+$" tag) ;rule #1 ;; Rules #2 and #4, and a check that there's no explicit name. - (looking-at "[ \t()=,;]?\177\\(?:[0-9]+\\)?,\\(?:[0-9]+\\)?$") + (looking-at "[ \t()=,;]?\177[0-9]*,[0-9]*$") (save-excursion (backward-char (1+ (length tag))) (looking-at "[\n \t()=,;]")))) ;rule #3 @@ -1699,18 +1694,14 @@ Point should be just after a string that matches TAG." (let ((bol (point))) (and (search-forward "\177" (line-end-position) t) (re-search-backward re bol t))))) - -(defcustom tags-loop-revert-buffers nil - "Non-nil means tags-scanning loops should offer to reread changed files. -These loops normally read each file into Emacs, but when a file -is already visited, they use the existing buffer. -When this flag is non-nil, they offer to revert the existing buffer -in the case where the file has changed since you visited it." - :type 'boolean - :group 'etags) +(define-obsolete-variable-alias 'tags-loop-revert-buffers 'fileloop-revert-buffers "27.1") ;;;###autoload -(defun next-file (&optional initialize novisit) +(defalias 'next-file 'tags-next-file) +(make-obsolete 'next-file + "use tags-next-file or fileloop-initialize and fileloop-next-file instead" "27.1") +;;;###autoload +(defun tags-next-file (&optional initialize novisit) "Select next file among files in current tags table. A first argument of t (prefix arg, if interactive) initializes to the @@ -1724,71 +1715,39 @@ Value is nil if the file was already visited; if the file was newly read in, the value is the filename." ;; Make the interactive arg t if there was any prefix arg. (interactive (list (if current-prefix-arg t))) - (cond ((not initialize) - ;; Not the first run. - ) - ((eq initialize t) - ;; Initialize the list from the tags table. - (save-excursion - (let ((cbuf (current-buffer))) - ;; Visit the tags table buffer to get its list of files. - (visit-tags-table-buffer) - ;; Copy the list so we can setcdr below, and expand the file - ;; names while we are at it, in this buffer's default directory. - (setq next-file-list (mapcar 'expand-file-name (tags-table-files))) - ;; Iterate over all the tags table files, collecting - ;; a complete list of referenced file names. - (while (visit-tags-table-buffer t cbuf) - ;; Find the tail of the working list and chain on the new - ;; sublist for this tags table. - (let ((tail next-file-list)) - (while (cdr tail) - (setq tail (cdr tail))) - ;; Use a copy so the next loop iteration will not modify the - ;; list later returned by (tags-table-files). - (if tail - (setcdr tail (mapcar 'expand-file-name (tags-table-files))) - (setq next-file-list (mapcar 'expand-file-name - (tags-table-files))))))))) - (t - ;; Initialize the list by evalling the argument. - (setq next-file-list (eval initialize)))) - (unless next-file-list - (and novisit - (get-buffer " *next-file*") - (kill-buffer " *next-file*")) - (user-error "All files processed")) - (let* ((next (car next-file-list)) - (buffer (get-file-buffer next)) - (new (not buffer))) - ;; Advance the list before trying to find the file. - ;; If we get an error finding the file, don't get stuck on it. - (setq next-file-list (cdr next-file-list)) - ;; Optionally offer to revert buffers - ;; if the files have changed on disk. - (and buffer tags-loop-revert-buffers - (not (verify-visited-file-modtime buffer)) - (y-or-n-p - (format - (if (buffer-modified-p buffer) - "File %s changed on disk. Discard your edits? " - "File %s changed on disk. Reread from disk? ") - next)) - (with-current-buffer buffer - (revert-buffer t t))) - (if (not (and new novisit)) - (find-file next) - ;; Like find-file, but avoids random warning messages. - (switch-to-buffer (get-buffer-create " *next-file*")) - (kill-all-local-variables) - (erase-buffer) - (setq new next) - (insert-file-contents new nil)) - new)) + (when initialize ;; Not the first run. + (tags--compat-initialize initialize)) + (fileloop-next-file novisit) + (switch-to-buffer (current-buffer))) +(defun tags--all-files () + (save-excursion + (let ((cbuf (current-buffer)) + (files nil)) + ;; Visit the tags table buffer to get its list of files. + (visit-tags-table-buffer) + ;; Copy the list so we can setcdr below, and expand the file + ;; names while we are at it, in this buffer's default directory. + (setq files (mapcar #'expand-file-name (tags-table-files))) + ;; Iterate over all the tags table files, collecting + ;; a complete list of referenced file names. + (while (visit-tags-table-buffer t cbuf) + ;; Find the tail of the working list and chain on the new + ;; sublist for this tags table. + (let ((tail files)) + (while (cdr tail) + (setq tail (cdr tail))) + ;; Use a copy so the next loop iteration will not modify the + ;; list later returned by (tags-table-files). + (setf (if tail (cdr tail) files) + (mapcar #'expand-file-name (tags-table-files))))) + files))) + +(make-obsolete-variable 'tags-loop-operate 'fileloop-initialize "27.1") (defvar tags-loop-operate nil "Form for `tags-loop-continue' to eval to change one file.") +(make-obsolete-variable 'tags-loop-scan 'fileloop-initialize "27.1") (defvar tags-loop-scan '(user-error "%s" (substitute-command-keys @@ -1806,121 +1765,84 @@ Bind `case-fold-search' during the evaluation, depending on the value of case-fold-search))) (eval form))) +(defun tags--compat-files (files) + (cond + ((eq files t) (tags--all-files)) ;; Initialize the list from the tags table. + ((functionp files) files) + ((stringp (car-safe files)) files) + (t + ;; Backward compatibility <27.1 + ;; Initialize the list by evalling the argument. + (eval files)))) + +(defun tags--compat-initialize (initialize) + (fileloop-initialize + (tags--compat-files initialize) + (if tags-loop-operate + (lambda () (tags-loop-eval tags-loop-operate)) + (lambda () (message "Scanning file %s...found" buffer-file-name) nil)) + (lambda () (tags-loop-eval tags-loop-scan)))) ;;;###autoload (defun tags-loop-continue (&optional first-time) "Continue last \\[tags-search] or \\[tags-query-replace] command. Used noninteractively with non-nil argument to begin such a command (the -argument is passed to `next-file', which see). - -Two variables control the processing we do on each file: the value of -`tags-loop-scan' is a form to be executed on each file to see if it is -interesting (it returns non-nil if so) and `tags-loop-operate' is a form to -evaluate to operate on an interesting file. If the latter evaluates to -nil, we exit; otherwise we scan the next file." +argument is passed to `next-file', which see)." + ;; Two variables control the processing we do on each file: the value of + ;; `tags-loop-scan' is a form to be executed on each file to see if it is + ;; interesting (it returns non-nil if so) and `tags-loop-operate' is a form to + ;; evaluate to operate on an interesting file. If the latter evaluates to + ;; nil, we exit; otherwise we scan the next file. + (declare (obsolete fileloop-continue "27.1")) (interactive) - (let (new - ;; Non-nil means we have finished one file - ;; and should not scan it again. - file-finished - original-point - (messaged nil)) - (while - (progn - ;; Scan files quickly for the first or next interesting one. - ;; This starts at point in the current buffer. - (while (or first-time file-finished - (save-restriction - (widen) - (not (tags-loop-eval tags-loop-scan)))) - ;; If nothing was found in the previous file, and - ;; that file isn't in a temp buffer, restore point to - ;; where it was. - (when original-point - (goto-char original-point)) - - (setq file-finished nil) - (setq new (next-file first-time t)) - - ;; If NEW is non-nil, we got a temp buffer, - ;; and NEW is the file name. - (when (or messaged - (and (not first-time) - (> baud-rate search-slow-speed) - (setq messaged t))) - (message "Scanning file %s..." (or new buffer-file-name))) - - (setq first-time nil) - (setq original-point (if new nil (point))) - (goto-char (point-min))) + (when first-time ;; Backward compatibility. + (tags--compat-initialize first-time)) + (fileloop-continue)) - ;; If we visited it in a temp buffer, visit it now for real. - (if new - (let ((pos (point))) - (erase-buffer) - (set-buffer (find-file-noselect new)) - (setq new nil) ;No longer in a temp buffer. - (widen) - (goto-char pos)) - (push-mark original-point t)) - - (switch-to-buffer (current-buffer)) - - ;; Now operate on the file. - ;; If value is non-nil, continue to scan the next file. - (save-restriction - (widen) - (tags-loop-eval tags-loop-operate))) - (setq file-finished t)) - (and messaged - (null tags-loop-operate) - (message "Scanning file %s...found" buffer-file-name)))) +;; We use it to detect when the last loop was a tags-search. +(defvar tags--last-search-operate-function nil) ;;;###autoload -(defun tags-search (regexp &optional file-list-form) +(defun tags-search (regexp &optional files) "Search through all files listed in tags table for match for REGEXP. Stops when a match is found. To continue searching for next match, use command \\[tags-loop-continue]. -If FILE-LIST-FORM is non-nil, it should be a form that, when -evaluated, will return a list of file names. The search will be -restricted to these files. +If FILES if non-nil should be a list or an iterator returning the files to search. +The search will be restricted to these files. Also see the documentation of the `tags-file-name' variable." (interactive "sTags search (regexp): ") - (if (and (equal regexp "") - (eq (car tags-loop-scan) 're-search-forward) - (null tags-loop-operate)) - ;; Continue last tags-search as if by M-,. - (tags-loop-continue nil) - (setq tags-loop-scan `(re-search-forward ',regexp nil t) - tags-loop-operate nil) - (tags-loop-continue (or file-list-form t)))) + (unless (and (equal regexp "") + ;; FIXME: If some other fileloop operation took place, + ;; rather than search for "", we should repeat the last search! + (eq fileloop--operate-function + tags--last-search-operate-function)) + (fileloop-initialize-search + regexp + (tags--compat-files (or files t)) + tags-case-fold-search) + ;; Store it, so we can detect if some other fileloop operation took + ;; place since the last search! + (setq tags--last-search-operate-function fileloop--operate-function)) + (fileloop-continue)) ;;;###autoload -(defun tags-query-replace (from to &optional delimited file-list-form) +(defun tags-query-replace (from to &optional delimited files) "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 \\[tags-loop-continue]. -Fourth arg FILE-LIST-FORM non-nil means initialize the replacement loop. - -If FILE-LIST-FORM is non-nil, it is a form to evaluate to -produce the list of files to search. - -See also the documentation of the variable `tags-file-name'." +For non-interactive use, superceded by `fileloop-initialize-replace'." + (declare (advertised-calling-convention (from to &optional delimited) "27.1")) (interactive (query-replace-read-args "Tags query replace (regexp)" t t)) - (setq tags-loop-scan `(let ,(unless (equal from (downcase from)) - '((case-fold-search nil))) - (if (re-search-forward ',from nil t) - ;; When we find a match, move back - ;; to the beginning of it so perform-replace - ;; will see it. - (goto-char (match-beginning 0)))) - tags-loop-operate `(perform-replace ',from ',to t t ',delimited - nil multi-query-replace-map)) - (tags-loop-continue (or file-list-form t))) - + (fileloop-initialize-replace + from to + (tags--compat-files (or files t)) + (if (equal from (downcase from)) nil 'default) + delimited) + (fileloop-continue)) + (defun tags-complete-tags-table-file (string predicate what) ; Doc string? (save-excursion ;; If we need to ask for the tag table, allow that. @@ -1977,7 +1899,8 @@ directory specification." (funcall tags-apropos-function regexp)))) (etags-tags-apropos-additional regexp)) (with-current-buffer "*Tags List*" - (eval-and-compile (require 'apropos)) + (require 'apropos) + (declare-function apropos-mode "apropos") (apropos-mode) ;; apropos-mode is derived from fundamental-mode and it kills ;; all local variables. @@ -2007,14 +1930,14 @@ see the doc of that variable if you want to add names to the list." (when tags-table-list (setq desired-point (point-marker)) (setq b (point)) - (princ (mapcar 'abbreviate-file-name tags-table-list) (current-buffer)) + (princ (mapcar #'abbreviate-file-name tags-table-list) (current-buffer)) (make-text-button b (point) 'type 'tags-select-tags-table 'etags-table (car tags-table-list)) (insert "\n")) (while set-list (unless (eq (car set-list) tags-table-list) (setq b (point)) - (princ (mapcar 'abbreviate-file-name (car set-list)) (current-buffer)) + (princ (mapcar #'abbreviate-file-name (car set-list)) (current-buffer)) (make-text-button b (point) 'type 'tags-select-tags-table 'etags-table (car (car set-list))) (insert "\n")) @@ -2028,9 +1951,9 @@ see the doc of that variable if you want to add names to the list." 'etags-table tags-file-name) (insert "\n")) (setq set-list (delete tags-file-name - (apply 'nconc (cons (copy-sequence tags-table-list) - (mapcar 'copy-sequence - tags-table-set-list))))) + (apply #'nconc (cons (copy-sequence tags-table-list) + (mapcar #'copy-sequence + tags-table-set-list))))) (while set-list (setq b (point)) (insert (abbreviate-file-name (car set-list))) @@ -2060,7 +1983,7 @@ see the doc of that variable if you want to add names to the list." (define-derived-mode select-tags-table-mode special-mode "Select Tags Table" "Major mode for choosing a current tags table among those already loaded." - (setq buffer-read-only t)) + ) (defun select-tags-table-select (button) "Select the tags table named on this line." @@ -2147,14 +2070,15 @@ for \\[find-tag] (which see)." (beginning-of-line) (pcase-let* ((tag-info (etags-snarf-tag)) (`(,hint ,line . _) tag-info)) - (unless (eq hint t) ; hint==t if we are in a filename line - (let* ((file (file-of-tag)) - (mark-key (cons file line))) - (unless (gethash mark-key marks) - (let ((loc (xref-make-etags-location - tag-info (expand-file-name file)))) - (push (xref-make hint loc) xrefs) - (puthash mark-key t marks))))))))))) + (let* ((file (file-of-tag)) + (mark-key (cons file line))) + (unless (gethash mark-key marks) + (let ((loc (xref-make-etags-location + tag-info (expand-file-name file)))) + (push (xref-make (if (eq hint t) "(filename match)" hint) + loc) + xrefs) + (puthash mark-key t marks)))))))))) (nreverse xrefs))) (defclass xref-etags-location (xref-location) diff --git a/lisp/progmodes/executable.el b/lisp/progmodes/executable.el index d7985a7c87a..8d206c38413 100644 --- a/lisp/progmodes/executable.el +++ b/lisp/progmodes/executable.el @@ -1,4 +1,4 @@ -;;; executable.el --- base functionality for executable interpreter scripts -*- byte-compile-dynamic: t -*- +;;; executable.el --- base functionality for executable interpreter scripts ;; Copyright (C) 1994-1996, 2000-2019 Free Software Foundation, Inc. diff --git a/lisp/progmodes/f90.el b/lisp/progmodes/f90.el index 94317b3e17b..9de80635e9f 100644 --- a/lisp/progmodes/f90.el +++ b/lisp/progmodes/f90.el @@ -123,7 +123,6 @@ ;; mechanism for treating multi-line directives (continued by \ ). ;; 7) f77 do-loops do 10 i=.. ; ; 10 continue are not correctly indented. ;; You are urged to use f90-do loops (with labels if you wish). -;; 8) The highlighting mode under XEmacs is not as complete as under Emacs. ;; List of user commands ;; f90-previous-statement f90-next-statement @@ -649,7 +648,7 @@ forall\\|block\\|critical\\)\\)\\_>" \\|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_\\)+\\)?\/" + '("\\_<\\(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)) @@ -1847,10 +1846,8 @@ A block is a subroutine, if-endif, etc." (push-mark) (goto-char pos) (setq program (f90-beginning-of-subprogram)) - (if (featurep 'xemacs) - (zmacs-activate-region) - (setq mark-active t - deactivate-mark nil)) + (setq mark-active t + deactivate-mark nil) program)) (defun f90-comment-region (beg-region end-region) @@ -2042,9 +2039,7 @@ If run in the middle of a line, the line is not broken." (goto-char save-point) (set-marker end-region-mark nil) (set-marker save-point nil) - (if (featurep 'xemacs) - (zmacs-deactivate-region) - (deactivate-mark)))) + (deactivate-mark))) (defun f90-indent-subprogram () "Properly indent the subprogram containing point." @@ -2157,9 +2152,7 @@ Like `join-line', but handles F90 syntax." f90-cache-position (point))) (setq f90-cache-position nil) (set-marker end-region-mark nil) - (if (featurep 'xemacs) - (zmacs-deactivate-region) - (deactivate-mark)))) + (deactivate-mark))) (defun f90-fill-paragraph (&optional justify) "In a comment, fill it as a paragraph, else fill the current statement. diff --git a/lisp/progmodes/flymake-cc.el b/lisp/progmodes/flymake-cc.el new file mode 100644 index 00000000000..ecf6e648a7e --- /dev/null +++ b/lisp/progmodes/flymake-cc.el @@ -0,0 +1,146 @@ +;;; flymake-cc.el --- Flymake support for GNU tools for C/C++ -*- lexical-binding: t; -*- + +;; Copyright (C) 2018-2019 Free Software Foundation, Inc. + +;; Author: João Távora <joaotavora@gmail.com> +;; Keywords: languages, c + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Flymake support for C/C++. + +;;; Code: + +(require 'cl-lib) + +(defcustom flymake-cc-command 'flymake-cc-use-special-make-target + "Command used by the `flymake-cc' backend. +A list of strings, or a symbol naming a function that produces one +such list when called with no arguments in the buffer where the +variable `flymake-mode' is active. + +The command should invoke a GNU-style compiler that checks the +syntax of a (Obj)C(++) program passed to it via its standard +input and prints the result on its standard output." + :type '(choice + (symbol :tag "Function") + ((repeat :) string)) + :group 'flymake-cc) + +(defun flymake-cc--make-diagnostics (source) + "Parse GNU-compatible compilation messages in current buffer. +Return a list of Flymake diagnostic objects for the source buffer +SOURCE." + ;; TODO: if you can understand it, use `compilation-mode's regexps + ;; or even some of its machinery here. + ;; + ;; (set (make-local-variable 'compilation-locs) + ;; (make-hash-table :test 'equal :weakness 'value)) + ;; (compilation-parse-errors (point-min) (point-max) + ;; 'gnu 'gcc-include) + ;; (while (next-single-property-change 'compilation-message) + ;; ...) + ;; + ;; For now, this works minimally well. + (cl-loop + while + (search-forward-regexp + "^\\(In file included from \\)?<stdin>:\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?:\n?\\(.*\\): \\(.*\\)$" + nil t) + for msg = (match-string 5) + for (beg . end) = (flymake-diag-region + source + (string-to-number (match-string 2)) + (and (match-string 3) (string-to-number (match-string 3)))) + for type = (if (match-string 1) + :error + (assoc-default + (match-string 4) + '(("error" . :error) + ("note" . :note) + ("warning" . :warning)) + #'string-match + :error)) + collect (flymake-make-diagnostic source beg end type msg))) + +(defun flymake-cc-use-special-make-target () + "Command for checking a file via a CHK_SOURCES Make target." + (unless (executable-find "make") (error "Make not found")) + `("make" + "check-syntax" + ,(format "CHK_SOURCES=-x %s -c -" + (cond ((derived-mode-p 'c++-mode) "c++") + (t "c"))))) + +(defvar-local flymake-cc--proc nil "Internal variable for `flymake-gcc'") + +;; forward declare this to shoosh compiler (instead of requiring +;; flymake-proc) +;; +(defvar flymake-proc-allowed-file-name-masks) + +;;;###autoload +(defun flymake-cc (report-fn &rest _args) + "Flymake backend for GNU-style C compilers. +This backend uses `flymake-cc-command' (which see) to launch a +process that is passed the current buffer's contents via stdin. +REPORT-FN is Flymake's callback." + ;; HACK: XXX: Assuming this backend function is run before it in + ;; `flymake-diagnostic-functions', very hackingly convince the other + ;; backend `flymake-proc-legacy-backend', which is on by default, to + ;; disable itself. + ;; + (setq-local flymake-proc-allowed-file-name-masks nil) + (when (process-live-p flymake-cc--proc) + (kill-process flymake-cc--proc)) + (let ((source (current-buffer))) + (save-restriction + (widen) + (setq + flymake-cc--proc + (make-process + :name "gcc-flymake" + :buffer (generate-new-buffer "*gcc-flymake*") + :command (if (symbolp flymake-cc-command) + (funcall flymake-cc-command) + flymake-cc-command) + :noquery t :connection-type 'pipe + :sentinel + (lambda (p _ev) + (unwind-protect + (when (eq 'exit (process-status p)) + (when (with-current-buffer source (eq p flymake-cc--proc)) + (with-current-buffer (process-buffer p) + (goto-char (point-min)) + (let ((diags + (flymake-cc--make-diagnostics source))) + (if (or diags (zerop (process-exit-status p))) + (funcall report-fn diags) + ;; non-zero exit with no diags is cause + ;; for alarm + (funcall report-fn + :panic :explanation + (buffer-substring + (point-min) (progn (goto-char (point-min)) + (line-end-position))))))))) + (unless (process-live-p p) + ;; (display-buffer (process-buffer p)) ; uncomment to debug + (kill-buffer (process-buffer p))))))) + (process-send-region flymake-cc--proc (point-min) (point-max)) + (process-send-eof flymake-cc--proc)))) + +(provide 'flymake-cc) +;;; flymake-cc.el ends here diff --git a/lisp/progmodes/flymake-proc.el b/lisp/progmodes/flymake-proc.el index 673f83e3396..2d5a47a0797 100644 --- a/lisp/progmodes/flymake-proc.el +++ b/lisp/progmodes/flymake-proc.el @@ -2,9 +2,9 @@ ;; Copyright (C) 2003-2019 Free Software Foundation, Inc. -;; Author: Pavel Kobyakov <pk_at_work@yahoo.com> -;; Maintainer: Leo Liu <sdl.web@gmail.com> -;; Version: 0.3 +;; Author: Pavel Kobyakov <pk_at_work@yahoo.com> +;; Maintainer: João Távora <joaotavora@gmail.com> +;; Version: 1.0 ;; Keywords: c languages tools ;; This file is part of GNU Emacs. @@ -41,6 +41,8 @@ ;;; Code: +(require 'cl-lib) + (require 'flymake) (define-obsolete-variable-alias 'flymake-compilation-prevents-syntax-check @@ -77,6 +79,13 @@ :group 'flymake :type 'integer) +(defcustom flymake-proc-ignored-file-name-regexps '() + "Files syntax checking is forbidden for. +Overrides `flymake-proc-allowed-file-name-masks'." + :group 'flymake + :type '(repeat (regexp)) + :version "27.1") + (define-obsolete-variable-alias 'flymake-allowed-file-name-masks 'flymake-proc-allowed-file-name-masks "26.1") @@ -106,6 +115,7 @@ ;; ("\\.tex\\'" 1) ) "Files syntax checking is allowed for. +Variable `flymake-proc-ignored-file-name-regexps' overrides this variable. This is an alist with elements of the form: REGEXP INIT [CLEANUP [NAME]] REGEXP is a regular expression that matches a file name. @@ -148,6 +158,9 @@ Convert it to Flymake internal format." (setq converted-list (cons (list regexp file line col) converted-list))))) converted-list)) +(define-obsolete-variable-alias 'flymake-err-line-patterns + 'flymake-proc-err-line-patterns "26.1") + (defvar flymake-proc-err-line-patterns ; regexp file-idx line-idx col-idx (optional) text-idx(optional), match-end to end of string is error text (append '( @@ -183,11 +196,10 @@ from compile.el") 'flymake-proc-default-guess "Predicate matching against diagnostic text to detect its type. Takes a single argument, the diagnostic's text and should return -a value suitable for indexing -`flymake-diagnostic-types-alist' (which see). If the returned -value is nil, a type of `:error' is assumed. For some backward -compatibility, if a non-nil value is returned that doesn't -index that alist, a type of `:warning' is assumed. +a diagnostic symbol naming a type. If the returned value is nil, +a type of `:error' is assumed. For some backward compatibility, +if a non-nil value is returned that doesn't name a type, +`:warning' is assumed. Instead of a function, it can also be a string, a regular expression. A match indicates `:warning' type, otherwise @@ -203,17 +215,22 @@ expression. A match indicates `:warning' type, otherwise :error))) (defun flymake-proc--get-file-name-mode-and-masks (file-name) - "Return the corresponding entry from `flymake-proc-allowed-file-name-masks'." + "Return the corresponding entry from `flymake-proc-allowed-file-name-masks'. +If the FILE-NAME matches a regexp from `flymake-proc-ignored-file-name-regexps', +`flymake-proc-allowed-file-name-masks' is not searched." (unless (stringp file-name) (error "Invalid file-name")) - (let ((fnm flymake-proc-allowed-file-name-masks) - (mode-and-masks nil)) - (while (and (not mode-and-masks) fnm) - (if (string-match (car (car fnm)) file-name) - (setq mode-and-masks (cdr (car fnm)))) - (setq fnm (cdr fnm))) - (flymake-log 3 "file %s, init=%s" file-name (car mode-and-masks)) - mode-and-masks)) + (if (cl-find file-name flymake-proc-ignored-file-name-regexps + :test (lambda (fn rex) (string-match rex fn))) + (flymake-log 3 "file %s ignored") + (let ((fnm flymake-proc-allowed-file-name-masks) + (mode-and-masks nil)) + (while (and (not mode-and-masks) fnm) + (if (string-match (car (car fnm)) file-name) + (setq mode-and-masks (cdr (car fnm)))) + (setq fnm (cdr fnm))) + (flymake-log 3 "file %s, init=%s" file-name (car mode-and-masks)) + mode-and-masks))) (defun flymake-proc--get-init-function (file-name) "Return init function to be used for the file." @@ -320,6 +337,9 @@ to the beginning of the list (File.h -> File.cpp moved to top)." (file-name-base file-one)) (not (equal file-one file-two)))) +(define-obsolete-variable-alias 'flymake-check-file-limit + 'flymake-proc-check-file-limit "26.1") + (defvar flymake-proc-check-file-limit 8192 "Maximum number of chars to look at when checking possible master file. Nil means search the entire file.") @@ -495,8 +515,8 @@ Create parent directories as needed." :error)) ((functionp pred) (let ((probe (funcall pred message))) - (cond ((assoc-default probe - flymake-diagnostic-types-alist) + (cond ((and (symbolp probe) + (get probe 'flymake-category)) probe) (probe :warning) @@ -867,7 +887,7 @@ can also be executed interactively independently of (defun flymake-proc--delete-temp-directory (dir-name) "Attempt to delete temp dir created by `flymake-proc-create-temp-with-folder-structure', do not fail on error." (let* ((temp-dir temporary-file-directory) - (suffix (substring dir-name (1+ (length temp-dir))))) + (suffix (substring dir-name (1+ (length (directory-file-name temp-dir)))))) (while (> (length suffix) 0) (setq suffix (directory-file-name suffix)) @@ -1113,7 +1133,7 @@ Use CREATE-TEMP-F for creating temp copy." (let* ((temp-master-file-name (flymake-proc--init-create-temp-source-and-master-buffer-copy 'flymake-proc-get-include-dirs-dot 'flymake-proc-create-temp-inplace '("\\.tex\\'") - "[ \t]*\\in\\(?:put\\|clude\\)[ \t]*{\\(.*%s\\)}"))) + "[ \t]*in\\(?:put\\|clude\\)[ \t]*{\\(.*%s\\)}"))) (when temp-master-file-name (flymake-proc--get-tex-args temp-master-file-name)))) @@ -1133,12 +1153,8 @@ Use CREATE-TEMP-F for creating temp copy." ;;;; -(define-obsolete-variable-alias 'flymake-check-file-limit - 'flymake-proc-check-file-limit "26.1") (define-obsolete-function-alias 'flymake-reformat-err-line-patterns-from-compile-el 'flymake-proc-reformat-err-line-patterns-from-compile-el "26.1") -(define-obsolete-variable-alias 'flymake-err-line-patterns - 'flymake-proc-err-line-patterns "26.1") (define-obsolete-function-alias 'flymake-parse-line 'flymake-proc-parse-line "26.1") (define-obsolete-function-alias 'flymake-get-include-dirs diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 16d97b6ccaf..e8a4334fe96 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -2,9 +2,10 @@ ;; Copyright (C) 2003-2019 Free Software Foundation, Inc. -;; Author: Pavel Kobyakov <pk_at_work@yahoo.com> -;; Maintainer: Leo Liu <sdl.web@gmail.com> -;; Version: 0.3 +;; Author: Pavel Kobyakov <pk_at_work@yahoo.com> +;; Maintainer: João Távora <joaotavora@gmail.com> +;; Version: 1.0.8 +;; Package-Requires: ((emacs "26.1")) ;; Keywords: c languages tools ;; This file is part of GNU Emacs. @@ -14,10 +15,10 @@ ;; 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. +;; 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/>. @@ -34,13 +35,76 @@ ;; results produced by these backends, as well as entry points for ;; backends to hook on to. ;; -;; The main entry points are `flymake-mode' and `flymake-start' +;; The main interactive entry point is the `flymake-mode' minor mode, +;; which periodically and automatically initiates checks as the user +;; is editing the buffer. The variables `flymake-no-changes-timeout', +;; `flymake-start-on-flymake-mode' give finer control over the events +;; triggering a check, as does the interactive command `flymake-start', +;; which immediately starts a check. ;; -;; The docstrings of these variables are relevant to understanding how -;; Flymake works for both the user and the backend programmer: +;; Shortly after each check, a summary of collected diagnostics should +;; appear in the mode-line. If it doesn't, there might not be a +;; suitable Flymake backend for the current buffer's major mode, in +;; which case Flymake will indicate this in the mode-line. The +;; indicator will be `!' (exclamation mark), if all the configured +;; backends errored (or decided to disable themselves) and `?' +;; (question mark) if no backends were even configured. ;; -;; * `flymake-diagnostic-functions' -;; * `flymake-diagnostic-types-alist' +;; For programmers interested in writing a new Flymake backend, the +;; docstring of `flymake-diagnostic-functions', the Flymake manual, +;; and the code of existing backends are probably a good starting +;; point. +;; +;; The user wishing to customize the appearance of error types should +;; set properties on the symbols associated with each diagnostic type. +;; The standard diagnostic symbols are `:error', `:warning' and +;; `:note' (though a specific backend may define and use more). The +;; following properties can be set: +;; +;; * `flymake-bitmap', an image displayed in the fringe according to +;; `flymake-fringe-indicator-position'. The value actually follows +;; the syntax of `flymake-error-bitmap' (which see). It is overridden +;; by any `before-string' overlay property. +;; +;; * `flymake-severity', a non-negative integer specifying the +;; diagnostic's severity. The higher, the more serious. If the +;; overlay property `priority' is not specified, `severity' is used to +;; set it and help sort overlapping overlays. +;; +;; * `flymake-overlay-control', an alist ((OVPROP . VALUE) ...) of +;; further properties used to affect the appearance of Flymake +;; annotations. With the exception of `category' and `evaporate', +;; these properties are applied directly to the created overlay. See +;; Info Node `(elisp)Overlay Properties'. +;; +;; * `flymake-category', a symbol whose property list is considered a +;; default for missing values of any other properties. This is useful +;; to backend authors when creating new diagnostic types that differ +;; from an existing type by only a few properties. The category +;; symbols `flymake-error', `flymake-warning' and `flymake-note' make +;; good candidates for values of this property. +;; +;; For instance, to omit the fringe bitmap displayed for the standard +;; `:note' type, set its `flymake-bitmap' property to nil: +;; +;; (put :note 'flymake-bitmap nil) +;; +;; To change the face for `:note' type, add a `face' entry to its +;; `flymake-overlay-control' property. +;; +;; (push '(face . highlight) (get :note 'flymake-overlay-control)) +;; +;; If you push another alist entry in front, it overrides the previous +;; one. So this effectively removes the face from `:note' +;; diagnostics. +;; +;; (push '(face . nil) (get :note 'flymake-overlay-control)) +;; +;; To erase customizations and go back to the original look for +;; `:note' types: +;; +;; (cl-remf (symbol-plist :note) 'flymake-overlay-control) +;; (cl-remf (symbol-plist :note) 'flymake-bitmap) ;; ;;; Code: @@ -113,14 +177,15 @@ See `flymake-error-bitmap' and `flymake-warning-bitmap'." (const right-fringe) (const :tag "No fringe indicators" nil))) -(defcustom flymake-start-syntax-check-on-newline t - "Start syntax check if newline char was added/removed from the buffer." - :type 'boolean) +(make-obsolete-variable 'flymake-start-syntax-check-on-newline + "can check on newline in post-self-insert-hook" + "27.1") (defcustom flymake-no-changes-timeout 0.5 "Time to wait after last change before automatically checking buffer. If nil, never start checking buffer automatically like this." - :type 'number) + :type '(choice (number :tag "Timeout in seconds") + (const :tag "No check on timeout" nil))) (defcustom flymake-gui-warnings-enabled t "Enables/disables GUI warnings." @@ -132,11 +197,17 @@ If nil, never start checking buffer automatically like this." 'flymake-start-on-flymake-mode "26.1") (defcustom flymake-start-on-flymake-mode t - "Start syntax check when `flymake-mode' is enabled. + "If non-nil, start syntax check when `flymake-mode' is enabled. Specifically, start it when the buffer is actually displayed." :version "26.1" :type 'boolean) +(defcustom flymake-start-on-save-buffer t + "If non-nil, start syntax check when a buffer is saved. +Specifically, start it when the saved buffer is actually displayed." + :version "27.1" + :type 'boolean) + (defcustom flymake-log-level -1 "Obsolete and ignored variable." :type 'integer) @@ -149,6 +220,15 @@ Specifically, start it when the buffer is actually displayed." :version "26.1" :type 'boolean) +(defcustom flymake-suppress-zero-counters :warning + "Control appearance of zero-valued diagnostic counters in mode line. + +If set to t, supress all zero counters. If set to a severity +symbol like `:warning' (the default) suppress zero counters less +severe than that severity, according to `warning-numeric-level'. +If set to nil, don't supress any zero counters." + :type 'symbol) + (when (fboundp 'define-fringe-bitmap) (define-fringe-bitmap 'flymake-double-exclamation-mark (vector #b00000000 @@ -222,18 +302,28 @@ generated it." (cl-defstruct (flymake--diag (:constructor flymake--diag-make)) - buffer beg end type text backend) + buffer beg end type text backend data overlay-properties overlay) ;;;###autoload (defun flymake-make-diagnostic (buffer beg end type - text) + text + &optional data + overlay-properties) "Make a Flymake diagnostic for BUFFER's region from BEG to END. -TYPE is a key to `flymake-diagnostic-types-alist' and TEXT is a -description of the problem detected in this region." - (flymake--diag-make :buffer buffer :beg beg :end end :type type :text text)) +TYPE is a key to symbol and TEXT is a description of the problem +detected in this region. DATA is any object that the caller +wishes to attach to the created diagnostic for later retrieval. + +OVERLAY-PROPERTIES is an an alist of properties attached to the +created diagnostic, overriding the default properties and any +properties of `flymake-overlay-control' of the diagnostic's +type." + (flymake--diag-make :buffer buffer :beg beg :end end + :type type :text text :data data + :overlay-properties overlay-properties)) ;;;###autoload (defun flymake-diagnostics (&optional beg end) @@ -254,9 +344,16 @@ diagnostics at BEG." (flymake--diag-accessor flymake-diagnostic-buffer flymake--diag-buffer buffer) (flymake--diag-accessor flymake-diagnostic-text flymake--diag-text text) (flymake--diag-accessor flymake-diagnostic-type flymake--diag-type type) -(flymake--diag-accessor flymake-diagnostic-beg flymake--diag-beg beg) -(flymake--diag-accessor flymake-diagnostic-end flymake--diag-end end) (flymake--diag-accessor flymake-diagnostic-backend flymake--diag-backend backend) +(flymake--diag-accessor flymake-diagnostic-data flymake--diag-data backend) + +(defun flymake-diagnostic-beg (diag) + "Get Flymake diagnostic DIAG's start position." + (overlay-start (flymake--diag-overlay diag))) + +(defun flymake-diagnostic-end (diag) + "Get Flymake diagnostic DIAG's end position." + (overlay-end (flymake--diag-overlay diag))) (cl-defun flymake--overlays (&key beg end filter compare key) "Get flymake-related overlays. @@ -280,10 +377,6 @@ verify FILTER, a function, and sort them by COMPARE (using KEY)." #'identity)) ovs)))) -(defun flymake-delete-own-overlays (&optional filter) - "Delete all Flymake overlays in BUFFER." - (mapc #'delete-overlay (flymake--overlays :filter filter))) - (defface flymake-error '((((supports :underline (:style wave))) :underline (:style wave :color "Red1")) @@ -333,7 +426,7 @@ region is invalid." (beg) (progn (end-of-line) - (skip-chars-backward " \t\f\t\n" beg) + (skip-chars-backward " \t\f\n" beg) (if (eq (point) beg) (line-beginning-position 2) (point))))) @@ -370,9 +463,25 @@ number of arguments: detailed below; * the remaining arguments are keyword-value pairs in the - form (:KEY VALUE :KEY2 VALUE2...). Currently, Flymake provides - no such arguments, but backend functions must be prepared to - accept and possibly ignore any number of them. + form (:KEY VALUE :KEY2 VALUE2...). + +Currently, Flymake may provide these keyword-value pairs: + +* `:recent-changes', a list of recent changes since the last time + the backend function was called for the buffer. An empty list + indicates that no changes have been reocrded. If it is the + first time that this backend function is called for this + activation of `flymake-mode', then this argument isn't provided + at all (i.e. it's not merely nil). + + Each element is in the form (BEG END TEXT) where BEG and END + are buffer positions, and TEXT is a string containing the text + contained between those positions (if any) after the change was + performed. + +* `:changes-start' and `:changes-end', the minimum and maximum + buffer positions touched by the recent changes. These are only + provided if `:recent-changes' is also provided. Whenever Flymake or the user decides to re-check the buffer, backend functions are called as detailed above and are expected @@ -384,8 +493,9 @@ asynchronous processes or other asynchronous mechanisms. In any case, backend functions are expected to return quickly or signal an error, in which case the backend is disabled. Flymake will not try disabled backends again for any future checks of -this buffer. Certain commands, like turning `flymake-mode' off -and on again, reset the list of disabled backends. +this buffer. To reset the list of disabled backends, turn +`flymake-mode' off and on again, or interactively call +`flymake-start' with a prefix argument. If the function returns, Flymake considers the backend to be \"running\". If it has not done so already, the backend is @@ -396,8 +506,9 @@ pairs in the form (:REPORT-KEY VALUE :REPORT-KEY2 VALUE2...). Currently accepted values for REPORT-ACTION are: * A (possibly empty) list of diagnostic objects created with - `flymake-make-diagnostic', causing Flymake to annotate the - buffer with this information. + `flymake-make-diagnostic', causing Flymake to delete all + previous diagnostic annotations in the buffer and create new + ones from this list. A backend may call REPORT-FN repeatedly in this manner, but only until Flymake considers that the most recently requested @@ -417,76 +528,71 @@ Currently accepted REPORT-KEY arguments are: the situation encountered, if any. * `:force': value should be a boolean suggesting that Flymake - consider the report even if it was somehow unexpected.") - -(defvar flymake-diagnostic-types-alist - `((:error - . ((flymake-category . flymake-error))) - (:warning - . ((flymake-category . flymake-warning))) - (:note - . ((flymake-category . flymake-note)))) - "Alist ((KEY . PROPS)*) of properties of Flymake diagnostic types. -KEY designates a kind of diagnostic can be anything passed as -`:type' to `flymake-make-diagnostic'. - -PROPS is an alist of properties that are applied, in order, to -the diagnostics of the type designated by KEY. The recognized -properties are: - -* Every property pertaining to overlays, except `category' and - `evaporate' (see Info Node `(elisp)Overlay Properties'), used - to affect the appearance of Flymake annotations. - -* `bitmap', an image displayed in the fringe according to - `flymake-fringe-indicator-position'. The value actually - follows the syntax of `flymake-error-bitmap' (which see). It - is overridden by any `before-string' overlay property. - -* `severity', a non-negative integer specifying the diagnostic's - severity. The higher, the more serious. If the overlay - property `priority' is not specified, `severity' is used to set - it and help sort overlapping overlays. - -* `flymake-category', a symbol whose property list is considered - a default for missing values of any other properties. This is - useful to backend authors when creating new diagnostic types - that differ from an existing type by only a few properties.") + consider the report even if it was somehow unexpected. + +* `:region': a cons (BEG . END) of buffer positions indicating + that the report applies to that region only. Specifically, + this means that Flymake will only delete diagnostic annotations + of past reports if they intersect the region by at least one + character.") + +(put 'flymake-diagnostic-functions 'safe-local-variable #'null) + +(put :error 'flymake-category 'flymake-error) +(put :warning 'flymake-category 'flymake-warning) +(put :note 'flymake-category 'flymake-note) + +(defvar flymake-diagnostic-types-alist '() "") +(make-obsolete-variable + 'flymake-diagnostic-types-alist + "Set properties on the diagnostic symbols instead. See Info +Node `(Flymake)Flymake error types'" + "27.1") (put 'flymake-error 'face 'flymake-error) -(put 'flymake-error 'bitmap 'flymake-error-bitmap) +(put 'flymake-error 'flymake-bitmap 'flymake-error-bitmap) (put 'flymake-error 'severity (warning-numeric-level :error)) (put 'flymake-error 'mode-line-face 'compilation-error) (put 'flymake-warning 'face 'flymake-warning) -(put 'flymake-warning 'bitmap 'flymake-warning-bitmap) +(put 'flymake-warning 'flymake-bitmap 'flymake-warning-bitmap) (put 'flymake-warning 'severity (warning-numeric-level :warning)) (put 'flymake-warning 'mode-line-face 'compilation-warning) (put 'flymake-note 'face 'flymake-note) -(put 'flymake-note 'bitmap 'flymake-note-bitmap) +(put 'flymake-note 'flymake-bitmap 'flymake-note-bitmap) (put 'flymake-note 'severity (warning-numeric-level :debug)) (put 'flymake-note 'mode-line-face 'compilation-info) (defun flymake--lookup-type-property (type prop &optional default) - "Look up PROP for TYPE in `flymake-diagnostic-types-alist'. -If TYPE doesn't declare PROP in either -`flymake-diagnostic-types-alist' or in the symbol of its + "Look up PROP for diagnostic TYPE. +If TYPE doesn't declare PROP in its plist or in the symbol of its associated `flymake-category' return DEFAULT." - (let ((alist-probe (assoc type flymake-diagnostic-types-alist))) - (cond (alist-probe - (let* ((alist (cdr alist-probe)) - (prop-probe (assoc prop alist))) - (if prop-probe - (cdr prop-probe) - (if-let* ((cat (assoc-default 'flymake-category alist)) - (plist (and (symbolp cat) - (symbol-plist cat))) - (cat-probe (plist-member plist prop))) - (cadr cat-probe) - default)))) - (t - default)))) + ;; This function also consults `flymake-diagnostic-types-alist' for + ;; backward compatibility. + ;; + (if (plist-member (symbol-plist type) prop) + ;; allow nil values to survive + (get type prop) + (let (alist) + (or + (alist-get + prop (setq + alist + (alist-get type flymake-diagnostic-types-alist))) + (when-let* ((cat (or + (get type 'flymake-category) + (alist-get 'flymake-category alist))) + (plist (and (symbolp cat) + (symbol-plist cat))) + (cat-probe (plist-member plist prop))) + (cadr cat-probe)) + default)))) + +(defun flymake--severity (type) + "Get the severity for diagnostic TYPE." + (flymake--lookup-type-property type 'severity + (warning-numeric-level :error))) (defun flymake--fringe-overlay-spec (bitmap &optional recursed) (if (and (symbolp bitmap) @@ -503,34 +609,41 @@ associated `flymake-category' return DEFAULT." (list bitmap))))))) (defun flymake--highlight-line (diagnostic) - "Highlight buffer with info in DIAGNOSTIC." - (when-let* ((ov (make-overlay - (flymake--diag-beg diagnostic) - (flymake--diag-end diagnostic)))) - ;; First set `category' in the overlay, then copy over every other - ;; property. + "Highlight buffer with info in DIGNOSTIC." + (let ((type (or (flymake--diag-type diagnostic) + :error)) + (ov (make-overlay + (flymake--diag-beg diagnostic) + (flymake--diag-end diagnostic)))) + ;; First set `category' in the overlay ;; - (let ((alist (assoc-default (flymake--diag-type diagnostic) - flymake-diagnostic-types-alist))) - (overlay-put ov 'category (assoc-default 'flymake-category alist)) - (cl-loop for (k . v) in alist - unless (eq k 'category) - do (overlay-put ov k v))) + (overlay-put ov 'category + (flymake--lookup-type-property type 'flymake-category)) + ;; Now "paint" the overlay with all the other non-category + ;; properties. + (cl-loop + for (ov-prop . value) in + (append (reverse + (flymake--diag-overlay-properties diagnostic)) + (reverse ; ensure ealier props override later ones + (flymake--lookup-type-property type 'flymake-overlay-control)) + (alist-get type flymake-diagnostic-types-alist)) + do (overlay-put ov ov-prop value)) ;; Now ensure some essential defaults are set ;; (cl-flet ((default-maybe (prop value) - (unless (or (plist-member (overlay-properties ov) prop) - (let ((cat (overlay-get ov - 'flymake-category))) - (and cat - (plist-member (symbol-plist cat) prop)))) - (overlay-put ov prop value)))) - (default-maybe 'bitmap 'flymake-error-bitmap) + (unless (plist-member (overlay-properties ov) prop) + (overlay-put ov prop (flymake--lookup-type-property + type prop value))))) (default-maybe 'face 'flymake-error) (default-maybe 'before-string (flymake--fringe-overlay-spec - (overlay-get ov 'bitmap))) + (flymake--lookup-type-property + type + 'flymake-bitmap + (alist-get 'bitmap (alist-get type ; backward compat + flymake-diagnostic-types-alist))))) (default-maybe 'help-echo (lambda (window _ov pos) (with-selected-window window @@ -543,7 +656,8 @@ associated `flymake-category' return DEFAULT." ;; Some properties can't be overridden. ;; (overlay-put ov 'evaporate t) - (overlay-put ov 'flymake-diagnostic diagnostic))) + (overlay-put ov 'flymake-diagnostic diagnostic) + ov)) ;; Nothing in Flymake uses this at all any more, so this is just for ;; third-party compatibility. @@ -589,14 +703,24 @@ backend is operating normally.") "Tell if Flymake has running backends in this buffer" (flymake-running-backends)) +;; FIXME: clone of `isearch-intesects-p'! Make this an util. +(defun flymake--intersects-p (start0 end0 start1 end1) + "Return t if regions START0..END0 and START1..END1 intersect." + (or (and (>= start0 start1) (< start0 end1)) + (and (> end0 start1) (<= end0 end1)) + (and (>= start1 start0) (< start1 end0)) + (and (> end1 start0) (<= end1 end0)))) + (cl-defun flymake--handle-report (backend token report-action - &key explanation force + &key explanation force region &allow-other-keys) "Handle reports from BACKEND identified by TOKEN. -BACKEND, REPORT-ACTION and EXPLANATION, and FORCE conform to the calling -convention described in `flymake-diagnostic-functions' (which -see). Optional FORCE says to handle a report even if TOKEN was -not expected." +BACKEND, REPORT-ACTION and EXPLANATION, and FORCE conform to the +calling convention described in +`flymake-diagnostic-functions' (which see). Optional FORCE says +to handle a report even if TOKEN was not expected. REGION is +a (BEG . END) pair of buffer positions indicating that this +report applies to that region." (let* ((state (gethash backend flymake--backend-state)) (first-report (not (flymake--backend-state-reported-p state)))) (setf (flymake--backend-state-reported-p state) t) @@ -628,16 +752,30 @@ not expected." (setq new-diags report-action) (save-restriction (widen) - ;; only delete overlays if this is the first report - (when first-report - (flymake-delete-own-overlays - (lambda (ov) - (eq backend - (flymake--diag-backend - (overlay-get ov 'flymake-diagnostic)))))) + ;; Before adding to backend's diagnostic list, decide if + ;; some or all must be deleted. When deleting, also delete + ;; the associated overlay. + (cond + (region + (cl-loop for diag in (flymake--backend-state-diags state) + for ov = (flymake--diag-overlay diag) + if (or (not (overlay-buffer ov)) + (flymake--intersects-p + (overlay-start ov) (overlay-end ov) + (car region) (cdr region))) + do (delete-overlay ov) + else collect diag into surviving + finally (setf (flymake--backend-state-diags state) + surviving))) + (first-report + (dolist (diag (flymake--backend-state-diags state)) + (delete-overlay (flymake--diag-overlay diag))) + (setf (flymake--backend-state-diags state) nil))) + ;; Now make new ones (mapc (lambda (diag) - (flymake--highlight-line diag) - (setf (flymake--diag-backend diag) backend)) + (let ((overlay (flymake--highlight-line diag))) + (setf (flymake--diag-backend diag) backend + (flymake--diag-overlay diag) overlay))) new-diags) (setf (flymake--backend-state-diags state) (append new-diags (flymake--backend-state-diags state))) @@ -645,7 +783,8 @@ not expected." (flymake-log :debug "backend %s reported %d diagnostics in %.2f second(s)" backend (length new-diags) - (- (float-time) flymake-check-start-time))) + (float-time + (time-since flymake-check-start-time)))) (when (and (get-buffer (flymake--diagnostics-buffer-name)) (get-buffer-window (flymake--diagnostics-buffer-name)) (null (cl-set-difference (flymake-running-backends) @@ -709,14 +848,15 @@ If it is running also stop it." (flymake--backend-state-disabled state) explanation (flymake--backend-state-reported-p state) t))) -(defun flymake--run-backend (backend) - "Run the backend BACKEND, reenabling if necessary." +(defun flymake--run-backend (backend &optional args) + "Run the backend BACKEND, re-enabling if necessary. +ARGS is a keyword-value plist passed to the backend along +with a report function." (flymake-log :debug "Running backend %s" backend) (let ((run-token (cl-gensym "backend-token"))) (flymake--with-backend-state backend state (setf (flymake--backend-state-running state) run-token (flymake--backend-state-disabled state) nil - (flymake--backend-state-diags state) nil (flymake--backend-state-reported-p state) nil)) ;; FIXME: Should use `condition-case-unless-debug' here, but don't ;; for two reasons: (1) that won't let me catch errors from inside @@ -727,11 +867,15 @@ If it is running also stop it." ;; backend) will trigger an annoying backtrace. ;; (condition-case err - (funcall backend - (flymake-make-report-fn backend run-token)) + (apply backend (flymake-make-report-fn backend run-token) + args) (error (flymake--disable-backend backend err))))) +(defvar-local flymake--recent-changes nil + "Recent changes collected by `flymake-after-change-function'.") +(defvar flymake-mode) + (defun flymake-start (&optional deferred force) "Start a syntax check for the current buffer. DEFERRED is a list of symbols designating conditions to wait for @@ -775,20 +919,32 @@ Interactively, with a prefix arg, FORCE is t." (add-hook 'window-configuration-change-hook #'start-on-display 'append 'local)) - (t + (flymake-mode (setq flymake-check-start-time (float-time)) - (run-hook-wrapped - 'flymake-diagnostic-functions - (lambda (backend) - (cond - ((and (not force) - (flymake--with-backend-state backend state - (flymake--backend-state-disabled state))) - (flymake-log :debug "Backend %s is disabled, not starting" - backend)) - (t - (flymake--run-backend backend))) - nil))))))) + (let ((backend-args + (and + flymake--recent-changes + (list :recent-changes + flymake--recent-changes + :changes-start + (cl-reduce + #'min (mapcar #'car flymake--recent-changes)) + :changes-end + (cl-reduce + #'max (mapcar #'cadr flymake--recent-changes)))))) + (setq flymake--recent-changes nil) + (run-hook-wrapped + 'flymake-diagnostic-functions + (lambda (backend) + (cond + ((and (not force) + (flymake--with-backend-state backend state + (flymake--backend-state-disabled state))) + (flymake-log :debug "Backend %s is disabled, not starting" + backend)) + (t + (flymake--run-backend backend backend-args))) + nil)))))))) (defvar flymake-mode-map (let ((map (make-sparse-keymap))) map) @@ -797,28 +953,25 @@ Interactively, with a prefix arg, FORCE is t." ;;;###autoload (define-minor-mode flymake-mode "Toggle Flymake mode on or off. -With a prefix argument ARG, enable Flymake mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'. 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 results. -Flymake performs these checks while the user is editing. The -customization variables `flymake-start-on-flymake-mode', -`flymake-no-changes-timeout' and -`flymake-start-syntax-check-on-newline' determine the exact -circumstances whereupon Flymake decides to initiate a check of -the buffer. +Flymake performs these checks while the user is editing. +The customization variables `flymake-start-on-flymake-mode', +`flymake-no-changes-timeout' determine the exact circumstances +whereupon Flymake decides to initiate a check of the buffer. The commands `flymake-goto-next-error' and `flymake-goto-prev-error' can be used to navigate among Flymake diagnostics annotated in the buffer. The visual appearance of each type of diagnostic can be changed -in the variable `flymake-diagnostic-types-alist'. +by setting properties `flymake-overlay-control', `flymake-bitmap' +and `flymake-severity' on the symbols of diagnostic types (like +`:error', `:warning' and `:note'). Activation or deactivation of backends used by Flymake in each buffer happens via the special hook @@ -838,7 +991,13 @@ special *Flymake log* buffer." :group 'flymake :lighter (add-hook 'after-save-hook 'flymake-after-save-hook nil t) (add-hook 'kill-buffer-hook 'flymake-kill-buffer-hook nil t) + ;; If Flymake happened to be alrady already ON, we must cleanup + ;; existing diagnostic overlays, lest we forget them by blindly + ;; reinitializing `flymake--backend-state' in the next line. + ;; See https://github.com/joaotavora/eglot/issues/223. + (mapc #'delete-overlay (flymake--overlays)) (setq flymake--backend-state (make-hash-table)) + (setq flymake--recent-changes nil) (when flymake-start-on-flymake-mode (flymake-start t))) @@ -849,7 +1008,7 @@ special *Flymake log* buffer." :group 'flymake :lighter (remove-hook 'kill-buffer-hook 'flymake-kill-buffer-hook t) ;;+(remove-hook 'find-file-hook (function flymake-find-file-hook) t) - (flymake-delete-own-overlays) + (mapc #'delete-overlay (flymake--overlays)) (when flymake-timer (cancel-timer flymake-timer) @@ -863,6 +1022,8 @@ Do it only if `flymake-no-changes-timeout' is non-nil." (setq flymake-timer (run-with-idle-timer + ;; This can use encode-time instead of seconds-to-time, + ;; once we can assume Emacs 27 or later. (seconds-to-time flymake-no-changes-timeout) nil (lambda (buffer) @@ -891,15 +1052,14 @@ Do it only if `flymake-no-changes-timeout' is non-nil." (make-obsolete 'flymake-mode-off 'flymake-mode "26.1") (defun flymake-after-change-function (start stop _len) - "Start syntax check for current buffer if it isn't already running." + "Start syntax check for current buffer if it isn't already running. +START and STOP and LEN are as in `after-change-functions'." (let((new-text (buffer-substring start stop))) - (when (and flymake-start-syntax-check-on-newline (equal new-text "\n")) - (flymake-log :debug "starting syntax check as new-line has been seen") - (flymake-start t)) + (push (list start stop new-text) flymake--recent-changes) (flymake--schedule-timer-maybe))) (defun flymake-after-save-hook () - (when flymake-mode + (when flymake-start-on-save-buffer (flymake-log :debug "starting syntax check as buffer was saved") (flymake-start t))) @@ -922,9 +1082,9 @@ arg, skip any diagnostics with a severity less than `:warning'. If `flymake-wrap-around' is non-nil and no more next diagnostics, resumes search from top. -FILTER is a list of diagnostic types found in -`flymake-diagnostic-types-alist', or nil, if no filter is to be -applied." +FILTER is a list of diagnostic types. Only diagnostics with +matching severities matching are considered. If nil (the +default) no filter is applied." ;; TODO: let filter be a number, a severity below which diags are ;; skipped. (interactive (list 1 @@ -938,9 +1098,12 @@ applied." ov 'flymake-diagnostic))) (and diag - (or (not filter) - (memq (flymake--diag-type diag) - filter))))) + (or + (not filter) + (cl-find + (flymake--severity + (flymake--diag-type diag)) + filter :key #'flymake--severity))))) :compare (if (cl-plusp n) #'< #'>) :key #'overlay-start)) (tail (cl-member-if (lambda (ov) @@ -964,10 +1127,10 @@ applied." (funcall (overlay-get target 'help-echo) (selected-window) target (point))))) (interactive - (user-error "No more Flymake errors%s" + (user-error "No more Flymake diagnostics%s" (if filter - (format " of types %s" filter) - "")))))) + (format " of %s severity" + (mapconcat #'symbol-name filter ", ")) "")))))) (defun flymake-goto-prev-error (&optional n filter interactive) "Go to Nth previous Flymake diagnostic that matches FILTER. @@ -978,9 +1141,9 @@ prefix arg, skip any diagnostics with a severity less than If `flymake-wrap-around' is non-nil and no more previous diagnostics, resumes search from bottom. -FILTER is a list of diagnostic types found in -`flymake-diagnostic-types-alist', or nil, if no filter is to be -applied." +FILTER is a list of diagnostic types. Only diagnostics with +matching severities matching are considered. If nil (the +default) no filter is applied." (interactive (list 1 (if current-prefix-arg '(:error :warning)) t)) @@ -990,7 +1153,7 @@ applied." ;;; Mode-line and menu ;;; (easy-menu-define flymake-menu flymake-mode-map "Flymake" - `("Flymake" + '("Flymake" [ "Go to next problem" flymake-goto-next-error t ] [ "Go to previous problem" flymake-goto-prev-error t ] [ "Check now" flymake-start t ] @@ -999,10 +1162,11 @@ applied." [ "Go to log buffer" flymake-switch-to-log-buffer t ] [ "Turn off Flymake" flymake-mode t ])) -(defvar flymake--mode-line-format `(:eval (flymake--mode-line-format))) +(defvar flymake--mode-line-format '(:eval (flymake--mode-line-format))) (put 'flymake--mode-line-format 'risky-local-variable t) + (defun flymake--mode-line-format () "Produce a pretty minor mode indicator." (let* ((known (hash-table-keys flymake--backend-state)) @@ -1038,16 +1202,16 @@ applied." map)) ,@(pcase-let ((`(,ind ,face ,explain) (cond ((null known) - `("?" mode-line "No known backends")) + '("?" mode-line "No known backends")) (some-waiting `("Wait" compilation-mode-line-run ,(format "Waiting for %s running backend(s)" (length some-waiting)))) (all-disabled - `("!" compilation-mode-line-run + '("!" compilation-mode-line-run "All backends disabled")) (t - `(nil nil nil))))) + '(nil nil nil))))) (when ind `((":" (:propertize ,ind @@ -1061,22 +1225,23 @@ applied." ,@(unless (or all-disabled (null known)) (cl-loop - for (type . severity) - in (cl-sort (mapcar (lambda (type) - (cons type (flymake--lookup-type-property - type - 'severity - (warning-numeric-level :error)))) - (cl-union (hash-table-keys diags-by-type) - '(:error :warning))) - #'> - :key #'cdr) + with types = (hash-table-keys diags-by-type) + with _augmented = (cl-loop for extra in '(:error :warning) + do (cl-pushnew extra types + :key #'flymake--severity)) + for type in (cl-sort types #'> :key #'flymake--severity) for diags = (gethash type diags-by-type) for face = (flymake--lookup-type-property type 'mode-line-face 'compilation-error) when (or diags - (>= severity (warning-numeric-level :warning))) + (cond ((eq flymake-suppress-zero-counters t) + nil) + (flymake-suppress-zero-counters + (>= (flymake--severity type) + (warning-numeric-level + flymake-suppress-zero-counters))) + (t t))) collect `(:propertize ,(format "%d" (length diags)) face ,face @@ -1135,8 +1300,8 @@ applied." (with-selected-window (display-buffer (current-buffer) other-window) (goto-char (flymake--diag-beg diag)) - (pulse-momentary-highlight-region (flymake--diag-beg diag) - (flymake--diag-end diag) + (pulse-momentary-highlight-region (flymake-diagnostic-beg diag) + (flymake-diagnostic-end diag) 'highlight)) (current-buffer)))) @@ -1180,14 +1345,14 @@ POS can be a buffer position or a button" "Flymake diagnostics" "A mode for listing Flymake diagnostics." (setq tabulated-list-format - `[("Line" 5 (lambda (l1 l2) - (< (plist-get (car l1) :line) - (plist-get (car l2) :line))) + `[("Line" 5 ,(lambda (l1 l2) + (< (plist-get (car l1) :line) + (plist-get (car l2) :line))) :right-align t) ("Col" 3 nil :right-align t) - ("Type" 8 (lambda (l1 l2) - (< (plist-get (car l1) :severity) - (plist-get (car l2) :severity)))) + ("Type" 8 ,(lambda (l1 l2) + (< (plist-get (car l1) :severity) + (plist-get (car l2) :severity)))) ("Message" 0 t)]) (setq tabulated-list-entries 'flymake--diagnostics-buffer-entries) @@ -1204,9 +1369,9 @@ POS can be a buffer position or a button" (target (or (get-buffer name) (with-current-buffer (get-buffer-create name) (flymake-diagnostics-buffer-mode) - (setq flymake--diagnostics-buffer-source source) (current-buffer))))) (with-current-buffer target + (setq flymake--diagnostics-buffer-source source) (revert-buffer) (display-buffer (current-buffer))))) diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el index d04b00878e1..f01e866f557 100644 --- a/lisp/progmodes/fortran.el +++ b/lisp/progmodes/fortran.el @@ -495,7 +495,7 @@ This is used to fontify fixed-format Fortran comments." ;; `byte-compile', but simple benchmarks indicate that it's probably not ;; worth the trouble (about 0.5% of slow down). (eval ;I hate `eval', but it's hard to avoid it here. - `(syntax-propertize-rules + '(syntax-propertize-rules ("^[CcDd\\*]" (0 "<")) ;; We mark all chars after line-length as "comment-start", rather than ;; just the first one. This is so that a closing ' that's past the @@ -1040,13 +1040,9 @@ With non-nil ARG, uncomments the region." Any other key combination is executed normally." (interactive "*") (insert last-command-event) - (let* ((event (if (fboundp 'next-command-event) ; XEmacs - (next-command-event) - (read-event))) - (char (if (fboundp 'event-to-character) - (event-to-character event) event))) + (let ((event (read-event))) ;; Insert char if not equal to `?', or if abbrev-mode is off. - (if (and abbrev-mode (or (eq char ??) (eq char help-char) + (if (and abbrev-mode (or (eq event ??) (eq event help-char) (memq event help-event-list))) (fortran-abbrev-help) (push event unread-command-events)))) @@ -1279,7 +1275,8 @@ Directive lines are treated as comments." (concat "[ \t]*" (regexp-quote fortran-continuation-string))) (looking-at "[ \t]*$\\| \\{5\\}[^ 0\n]\\|\t[1-9]") - (looking-at (concat "[ \t]*" comment-start-skip))))) + (looking-at (concat "[ \t]*\\(?:" + comment-start-skip "\\)"))))) (cond ((and continue-test (not not-first-statement)) (message "Incomplete continuation statement.")) @@ -1302,7 +1299,8 @@ Directive lines are treated as comments." (or (looking-at fortran-comment-line-start-skip) (looking-at fortran-directive-re) (looking-at "[ \t]*$\\| [^ 0\n]\\|\t[1-9]") - (looking-at (concat "[ \t]*" comment-start-skip))))) + (looking-at (concat "[ \t]*\\(?:" + comment-start-skip "\\)"))))) (if (not not-last-statement) 'last-statement))) @@ -1799,7 +1797,7 @@ non-indentation text within the comment." (goto-char (match-end 0))) (t ;; Move past line number. - (skip-chars-forward "[ \t0-9]"))) + (skip-chars-forward " \t0-9"))) ;; Move past whitespace. (skip-chars-forward " \t") (current-column))) @@ -2056,7 +2054,7 @@ If ALL is nil, only match comments that start in column > 0." (when (<= (point) bos) (move-to-column (1+ fill-column)) ;; What is this doing??? - (or (re-search-forward "[\t\n,'+-/*)=]" eol t) + (or (re-search-forward "[-\t\n,'+/*)=]" eol t) (goto-char bol))) (if (bolp) (re-search-forward "[ \t]" opoint t)) @@ -2150,7 +2148,8 @@ Always returns non-nil (to prevent `fill-paragraph' being called)." (or (looking-at "[ \t]*$") (looking-at fortran-comment-line-start-skip) (and comment-start-skip - (looking-at (concat "[ \t]*" comment-start-skip))))) + (looking-at (concat "[ \t]*\\(?:" + comment-start-skip "\\)"))))) (save-excursion ;; Find beginning of statement. (fortran-next-statement) diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index 69eb29c5eb1..15d47575c78 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -792,7 +792,7 @@ detailed description of this mode. (gud-def gud-tbreak "tbreak %f:%l" "\C-t" "Set temporary breakpoint at current line.") (gud-def gud-jump - (progn (gud-call "tbreak %f:%l") (gud-call "jump %f:%l")) + (progn (gud-call "tbreak %f:%l" arg) (gud-call "jump %f:%l")) "\C-j" "Set execution address to current line.") (gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).") @@ -1140,9 +1140,7 @@ Used by Speedbar." :version "22.2") (define-minor-mode gdb-speedbar-auto-raise - "Minor mode to automatically raise the speedbar for watch expressions. -With prefix argument ARG, automatically raise speedbar if ARG is -positive, otherwise don't automatically raise it." + "Minor mode to automatically raise the speedbar for watch expressions." :global t :group 'gdb :version "22.1") @@ -1375,7 +1373,7 @@ With arg, enter name of variable to be watched in the minibuffer." TEXT is the text of the button we clicked on, a + or - item. TOKEN is data related to this node. INDENT is the current indentation depth." - (cond ((string-match "+" text) ;expand this node + (cond ((string-match "\\+" text) ;expand this node (let* ((var (assoc token gdb-var-list)) (expr (nth 1 var)) (children (nth 2 var))) (if (or (<= (string-to-number children) gdb-max-children) @@ -1745,16 +1743,12 @@ static char *magick[] = { (defvar breakpoint-disabled-icon nil "Icon for disabled breakpoint in display margin.") -(declare-function define-fringe-bitmap "fringe.c" - (bitmap bits &optional height width align)) - -(and (display-images-p) - ;; Bitmap for breakpoint in fringe - (define-fringe-bitmap 'breakpoint - "\x3c\x7e\xff\xff\xff\xff\x7e\x3c") - ;; Bitmap for gud-overlay-arrow in fringe - (define-fringe-bitmap 'hollow-right-triangle - "\xe0\x90\x88\x84\x84\x88\x90\xe0")) +;; Bitmap for breakpoint in fringe +(define-fringe-bitmap 'breakpoint + "\x3c\x7e\xff\xff\xff\xff\x7e\x3c") +;; Bitmap for gud-overlay-arrow in fringe +(define-fringe-bitmap 'hollow-right-triangle + "\xe0\x90\x88\x84\x84\x88\x90\xe0") (defface breakpoint-enabled '((t @@ -1939,10 +1933,10 @@ If NO-PROC is non-nil, do not try to contact the GDB process." ;; gdb-break-list is maintained in breakpoints handler (gdb-get-buffer-create 'gdb-breakpoints-buffer) + (gdb-get-changed-registers) (unless no-proc (gdb-emit-signal gdb-buf-publisher 'update)) - (gdb-get-changed-registers) (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame)) (dolist (var gdb-var-list) (setcar (nthcdr 5 var) nil)) @@ -2720,10 +2714,10 @@ If `default-directory' is remote, full file names are adapted accordingly." (insert "]")))))) (goto-char (point-min)) (insert "{") - (let ((re (concat "\\([[:alnum:]-_]+\\)=\\({\\|\\[\\|\"\"\\|" - gdb--string-regexp "\\)"))) + (let ((re (concat "\\([[:alnum:]-_]+\\)="))) (while (re-search-forward re nil t) - (replace-match "\"\\1\":\\2" nil nil))) + (replace-match "\"\\1\":" nil nil) + (if (eq (char-after) ?\") (forward-sexp) (forward-char)))) (goto-char (point-max)) (insert "}"))) @@ -4159,7 +4153,7 @@ member." (when (not value) (setq value "<complex data type>")) (if (or (not value) - (string-match "\\0x" value)) + (string-match "0x" value)) (add-text-properties 0 (length name) `(mouse-face highlight help-echo "mouse-2: create watch expression" diff --git a/lisp/progmodes/glasses.el b/lisp/progmodes/glasses.el index 9c95951458a..8dcf84a70bf 100644 --- a/lisp/progmodes/glasses.el +++ b/lisp/progmodes/glasses.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. ;; Author: Milan Zamazal <pdm@zamazal.org> -;; Maintainer: Milan Zamazal <pdm@zamazal.org> ;; Keywords: tools ;; This file is part of GNU Emacs. @@ -312,10 +311,9 @@ recognized according to the current value of the variable `glasses-separator'." ;;;###autoload (define-minor-mode glasses-mode "Minor mode for making identifiers likeThis readable. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. When this mode is active, it tries to -add virtual separators (like underscores) at places they belong to." + +When this mode is active, it tries to add virtual +separators (like underscores) at places they belong to." :group 'glasses :lighter " o^o" (save-excursion (save-restriction @@ -326,10 +324,10 @@ add virtual separators (like underscores) at places they belong to." (if glasses-mode (progn (jit-lock-register 'glasses-change) - (add-hook 'local-write-file-hooks + (add-hook 'write-file-functions 'glasses-convert-to-unreadable nil t)) (jit-lock-unregister 'glasses-change) - (remove-hook 'local-write-file-hooks + (remove-hook 'write-file-functions 'glasses-convert-to-unreadable t))))) diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index 8b9a2d86c75..306ae8fd50f 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -29,6 +29,7 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) (require 'compile) (defgroup grep nil @@ -286,6 +287,11 @@ See `compilation-error-screen-columns'" (define-key map [menu-bar grep] (cons "Grep" (make-sparse-keymap "Grep"))) + (define-key map [menu-bar grep grep-find-toggle-abbreviation] + '(menu-item "Toggle command abbreviation" + grep-find-toggle-abbreviation + :help "Toggle showing verbose command options")) + (define-key map [menu-bar grep compilation-separator3] '("----")) (define-key map [menu-bar grep compilation-kill-compilation] '(menu-item "Kill Grep" kill-compilation :help "Kill the currently running grep process")) @@ -308,7 +314,7 @@ See `compilation-error-screen-columns'" (define-key map [menu-bar grep compilation-recompile] '(menu-item "Repeat grep" recompile :help "Run grep again")) - (define-key map [menu-bar grep compilation-separator2] '("----")) + (define-key map [menu-bar grep compilation-separator1] '("----")) (define-key map [menu-bar grep compilation-first-error] '(menu-item "First Match" first-error :help "Restart at the first match, visit corresponding location")) @@ -348,17 +354,6 @@ See `compilation-error-screen-columns'" (defalias 'kill-grep 'kill-compilation) -;;;; TODO --- refine this!! - -;; (defcustom grep-use-compilation-buffer t -;; "When non-nil, grep specific commands update `compilation-last-buffer'. -;; This means that standard compile commands like \\[next-error] and \\[compile-goto-error] -;; can be used to navigate between grep matches (the default). -;; Otherwise, the grep specific commands like \\[grep-next-match] must -;; be used to navigate between grep matches." -;; :type 'boolean -;; :group 'grep) - ;; override compilation-last-buffer (defvar grep-last-buffer nil "The most recent grep buffer. @@ -435,26 +430,67 @@ See `compilation-error-regexp-alist' for format details.") help-echo "Number of matches so far") "]")) +(defcustom grep-find-abbreviate t + "If non-nil, hide part of rgrep/lgrep/zrgrep command line. +The hidden part contains a list of ignored directories and files. +Clicking on the button-like ellipsis unhides the abbreviated part +and reveals the entire command line. The visibility of the +abbreviated part can also be toggled with +`grep-find-toggle-abbreviation'." + :type 'boolean + :version "27.1" + :group 'grep) + +(defcustom grep-search-path '(nil) + "List of directories to search for files named in grep messages. +Elements should be directory names, not file names of +directories. The value nil as an element means the grep messages +buffer `default-directory'." + :group 'grep + :version "27.1" + :type '(repeat (choice (const :tag "Default" nil) + (string :tag "Directory")))) + +(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) + `(face nil display ,ellipsis mouse-face highlight + help-echo "RET, mouse-2: show unabbreviated command" + keymap ,map abbreviated-command t)) + "Properties of button-like ellipsis on part of rgrep command line.") + (defvar grep-mode-font-lock-keywords '(;; Command output lines. (": \\(.+\\): \\(?: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.*" + ("^Grep[/a-zA-Z]* started.*" (0 '(face nil compilation-message nil help-echo nil mouse-face nil) t)) - ("^Grep[/a-zA-z]* finished with \\(?:\\(\\(?:[0-9]+ \\)?matches found\\)\\|\\(no matches found\\)\\).*" + ("^Grep[/a-zA-Z]* finished with \\(?:\\(\\(?:[0-9]+ \\)?match\\(?:es\\)? found\\)\\|\\(no matches found\\)\\).*" (0 '(face nil compilation-message nil help-echo nil mouse-face nil) t) (1 compilation-info-face nil t) (2 compilation-warning-face nil t)) - ("^Grep[/a-zA-z]* \\(exited abnormally\\|interrupt\\|killed\\|terminated\\)\\(?:.*with code \\([0-9]+\\)\\)?.*" + ("^Grep[/a-zA-Z]* \\(exited abnormally\\|interrupt\\|killed\\|terminated\\)\\(?:.*with code \\([0-9]+\\)\\)?.*" (0 '(face nil compilation-message nil help-echo nil mouse-face nil) t) (1 grep-error-face) (2 grep-error-face nil t)) ;; "filename-linenumber-" format is used for context lines in GNU grep, ;; "filename=linenumber=" for lines with function names in "git grep -p". - ("^.+?\\([-=\0]\\)[0-9]+\\([-=]\\).*\n" (0 grep-context-face) + ("^.+?\\([-=\0]\\)[0-9]+\\([-=]\\).*\n" + (0 grep-context-face) (1 (if (eq (char-after (match-beginning 1)) ?\0) - `(face nil display ,(match-string 2)))))) + `(face nil display ,(match-string 2))))) + ;; Hide excessive part of rgrep command + ("^find \\(\\. -type d .*\\\\)\\)" + (1 (if grep-find-abbreviate grep-find-abbreviate-properties + '(face nil abbreviated-command t)))) + ;; Hide excessive part of lgrep command + ("^grep \\( *--exclude.*--exclude[^ ]+\\)" + (1 (if grep-find-abbreviate grep-find-abbreviate-properties + '(face nil abbreviated-command t))))) "Additional things to highlight in grep output. This gets tacked on the end of the generated expressions.") @@ -476,14 +512,24 @@ See `grep-find-use-xargs'. This variable's value takes effect when `grep-compute-defaults' is called.") ;;;###autoload -(defvar grep-find-use-xargs nil +(defcustom grep-find-use-xargs nil "How to invoke find and grep. If `exec', use `find -exec {} ;'. If `exec-plus' use `find -exec {} +'. If `gnu', use `find -print0' and `xargs -0'. +If `gnu-sort', use `find -print0', `sort -z' and `xargs -0'. Any other value means to use `find -print' and `xargs'. -This variable's value takes effect when `grep-compute-defaults' is called.") +This variable's value takes effect when `grep-compute-defaults' is called." + :type '(choice (const :tag "find -exec {} ;" exec) + (const :tag "find -exec {} +" exec-plus) + (const :tag "find -print0 | xargs -0" gnu) + (const :tag "find -print0 | sort -z | xargs -0'" gnu-sort) + string + (const :tag "Not Set" nil)) + :set 'grep-apply-setting + :version "27.1" + :group 'grep) ;; History of grep commands. ;;;###autoload @@ -526,7 +572,10 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'." ;; so the buffer is still unmodified if there is no output. (cond ((and (zerop code) (buffer-modified-p)) (if (> grep-num-matches-found 0) - (cons (format "finished with %d matches found\n" grep-num-matches-found) + (cons (format (ngettext "finished with %d match found\n" + "finished with %d matches found\n" + grep-num-matches-found) + grep-num-matches-found) "matched") '("finished with matches found\n" . "matched"))) ((not (buffer-modified-p)) @@ -608,22 +657,22 @@ This function is called from `compilation-filter-hook'." ;; `grep-command' is already set, so ;; use that for testing. (grep-probe grep-command - `(nil t nil "^English" ,hello-file) + `(nil t nil "^Copyright" ,hello-file) #'call-process-shell-command) ;; otherwise use `grep-program' (grep-probe grep-program - `(nil t nil "-nH" "^English" ,hello-file))) + `(nil t nil "-nH" "^Copyright" ,hello-file))) (progn (goto-char (point-min)) (looking-at (concat (regexp-quote hello-file) - ":[0-9]+:English"))))))))) + ":[0-9]+:Copyright"))))))))) (when (eq grep-use-null-filename-separator 'auto-detect) (setq grep-use-null-filename-separator (with-temp-buffer (let* ((hello-file (expand-file-name "HELLO" data-directory)) - (args `("--null" "-ne" "^English" ,hello-file))) + (args `("--null" "-ne" "^Copyright" ,hello-file))) (if grep-use-null-device (setq args (append args (list null-device))) (push "-H" args)) @@ -632,7 +681,7 @@ This function is called from `compilation-filter-hook'." (goto-char (point-min)) (looking-at (concat (regexp-quote hello-file) - "\0[0-9]+:English")))))))) + "\0[0-9]+:Copyright")))))))) (when (eq grep-highlight-matches 'auto-detect) (setq grep-highlight-matches @@ -678,7 +727,7 @@ This function is called from `compilation-filter-hook'." 'exec-plus) ((and (grep-probe find-program `(nil nil nil ,null-device "-print0")) - (grep-probe xargs-program `(nil nil nil "-0" "echo"))) + (grep-probe xargs-program '(nil nil nil "-0" "echo"))) 'gnu) (t 'exec)))) @@ -690,6 +739,9 @@ This function is called from `compilation-filter-hook'." ;; forward slashes as directory separators. (format "%s . -type f -print0 | \"%s\" -0 %s" find-program xargs-program grep-command)) + ((eq grep-find-use-xargs 'gnu-sort) + (format "%s . -type f -print0 | sort -z | \"%s\" -0 %s" + find-program xargs-program grep-command)) ((memq grep-find-use-xargs '(exec exec-plus)) (let ((cmd0 (format "%s . -type f -exec %s" find-program grep-command)) @@ -714,6 +766,9 @@ This function is called from `compilation-filter-hook'." (cond ((eq grep-find-use-xargs 'gnu) (format "%s <D> <X> -type f <F> -print0 | \"%s\" -0 %s" find-program xargs-program gcmd)) + ((eq grep-find-use-xargs 'gnu-sort) + (format "%s <D> <X> -type f <F> -print0 | sort -z | \"%s\" -0 %s" + find-program xargs-program gcmd)) ((eq grep-find-use-xargs 'exec) (format "%s <D> <X> -type f <F> -exec %s %s %s%s" find-program gcmd quot-braces null quot-scolon)) @@ -799,7 +854,8 @@ This function is called from `compilation-filter-hook'." grep-mode-line-matches) ;; compilation-directory-matcher can't be nil, so we set it to a regexp that ;; can never match. - (set (make-local-variable 'compilation-directory-matcher) '("\\`a\\`")) + (set (make-local-variable 'compilation-directory-matcher) + (list regexp-unmatchable)) (set (make-local-variable 'compilation-process-setup-function) 'grep-process-setup) (set (make-local-variable 'compilation-disable-input) t) @@ -930,8 +986,16 @@ substitution string. Note dynamic scoping of variables.") The pattern can include shell wildcards. As whitespace triggers completion when entering a pattern, including it requires quoting, e.g. `\\[quoted-insert]<space>'." - (let* ((bn (or (buffer-file-name) - (replace-regexp-in-string "<[0-9]+>\\'" "" (buffer-name)))) + (let* ((grep-read-files-function (get major-mode 'grep-read-files)) + (file-name-at-point + (run-hook-with-args-until-success 'file-name-at-point-functions)) + (bn (if grep-read-files-function + (funcall grep-read-files-function) + (or (if (and (stringp file-name-at-point) + (not (file-directory-p file-name-at-point))) + file-name-at-point) + (buffer-file-name) + (replace-regexp-in-string "<[0-9]+>\\'" "" (buffer-name))))) (fn (and bn (stringp bn) (file-name-nondirectory bn))) @@ -1048,6 +1112,7 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (concat command " " null-device) command) '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)))))) @@ -1170,6 +1235,20 @@ to specify a command to run." (shell-quote-argument ")") " -prune -o "))))) +(defun grep-find-toggle-abbreviation () + "Toggle showing the hidden part of rgrep/lgrep/zrgrep command line." + (interactive) + (with-silent-modifications + (let* ((beg (next-single-property-change (point-min) 'abbreviated-command)) + (end (when beg + (next-single-property-change beg 'abbreviated-command)))) + (if end + (if (get-text-property beg 'display) + (remove-list-of-text-properties + beg end '(display help-echo mouse-face help-echo keymap)) + (add-text-properties beg end grep-find-abbreviate-properties)) + (user-error "No abbreviated part to hide/show"))))) + ;;;###autoload (defun zrgrep (regexp &optional files dir confirm template) "Recursively grep for REGEXP in gzipped FILES in tree rooted at DIR. diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index d918dbd5ef9..6b152b7b902 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -378,6 +378,7 @@ we're in the GUD buffer)." (if (not gud-running) ,(if (stringp cmd) `(gud-call ,cmd arg) + ;; 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)))) @@ -544,8 +545,8 @@ required by the caller." nil (if gdb-show-changed-values (or parent (pcase status - (`changed 'font-lock-warning-face) - (`out-of-scope 'shadow) + ('changed 'font-lock-warning-face) + ('out-of-scope 'shadow) (_ t))) t) depth) @@ -565,8 +566,8 @@ required by the caller." nil (if gdb-show-changed-values (or parent (pcase status - (`changed 'font-lock-warning-face) - (`out-of-scope 'shadow) + ('changed 'font-lock-warning-face) + ('out-of-scope 'shadow) (_ t))) t) depth) @@ -677,7 +678,7 @@ The option \"--fullname\" must be included in this value." ;; gud-marker-acc until we receive the rest of it. Since we ;; know the full marker regexp above failed, it's pretty simple to ;; test for marker starts. - (if (string-match "\n\\(\032.*\\)?\\'" gud-marker-acc) + (if (string-match "\\(\n\\)?\\(\032.*\\)?\\'" gud-marker-acc) (progn ;; Everything before the potential marker start can be output. (setq output (concat output (substring gud-marker-acc @@ -771,7 +772,7 @@ the buffer in which this command was invoked." (gud-def gud-cont "cont" "\C-r" "Continue with display.") (gud-def gud-finish "finish" "\C-f" "Finish executing current function.") (gud-def gud-jump - (progn (gud-call "tbreak %f:%l") (gud-call "jump %f:%l")) + (progn (gud-call "tbreak %f:%l" arg) (gud-call "jump %f:%l")) "\C-j" "Set execution address to current line.") (gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).") @@ -1604,8 +1605,12 @@ and source-file directory for your debugger." ;; Last group is for return value, e.g. "> test.py(2)foo()->None" ;; Either file or function name may be omitted: "> <string>(0)?()" +;; +;; We use [:graph:] to be very allowing with regards to which +;; characters we match in the file name shown in the prompt. +;; (Of course, this matches the "<string>" case too.) (defvar gud-pdb-marker-regexp - "^> \\([-a-zA-Z0-9_/.:\\]*\\|<string>\\)(\\([0-9]+\\))\\([a-zA-Z0-9_]*\\|\\?\\|<module>\\)()\\(->[^\n\r]*\\)?[\n\r]") + "^> \\([[:graph:] \\]*\\)(\\([0-9]+\\))\\([a-zA-Z0-9_]*\\|\\?\\|<module>\\)()\\(->[^\n\r]*\\)?[\n\r]") (defvar gud-pdb-marker-regexp-file-group 1) (defvar gud-pdb-marker-regexp-line-group 2) @@ -2236,7 +2241,7 @@ relative to a classpath directory." (split-string ;; Eliminate any subclass references in the class ;; name string. These start with a "$" - (if (string-match "$.*" p) + (if (string-match "\\$.*" p) (replace-match "" t t p) p) "\\.") "/") ".java")) @@ -2604,7 +2609,12 @@ comint mode, which see." file-subst))) (filepart (and file-word (concat "-" (file-name-nondirectory file)))) (existing-buffer (get-buffer (concat "*gud" filepart "*")))) - (switch-to-buffer (concat "*gud" filepart "*")) + (select-window + (display-buffer + (get-buffer-create (concat "*gud" filepart "*")) + '(display-buffer-reuse-window + display-buffer-in-previous-window + display-buffer-same-window display-buffer-pop-up-window))) (when (and existing-buffer (get-buffer-process existing-buffer)) (error "This program is already being debugged")) ;; Set the dir, in case the buffer already existed with a different dir. @@ -3357,10 +3367,7 @@ Treats actions as defuns." ;;;###autoload (define-minor-mode gud-tooltip-mode - "Toggle the display of GUD tooltips. -With a prefix argument ARG, enable the feature if ARG is -positive, and disable it otherwise. If called from Lisp, enable -it if ARG is omitted or nil." + "Toggle the display of GUD tooltips." :global t :group 'gud :group 'tooltip @@ -3395,9 +3402,6 @@ it if ARG is omitted or nil." (kill-local-variable 'gdb-define-alist) (remove-hook 'after-save-hook 'gdb-create-define-alist t)))) -(define-obsolete-variable-alias 'tooltip-gud-modes - 'gud-tooltip-modes "22.1") - (defcustom gud-tooltip-modes '(gud-mode c-mode c++-mode fortran-mode python-mode) "List of modes for which to enable GUD tooltips." @@ -3405,9 +3409,6 @@ it if ARG is omitted or nil." :group 'gud :group 'tooltip) -(define-obsolete-variable-alias 'tooltip-gud-display - 'gud-tooltip-display "22.1") - (defcustom gud-tooltip-display '((eq (tooltip-event-buffer gud-tooltip-event) (marker-buffer gud-overlay-arrow-position))) @@ -3499,8 +3500,6 @@ With arg, dereference expr if ARG is positive, otherwise do not dereference." (message "Dereferencing is now %s." (if gud-tooltip-dereference "on" "off"))) -(define-obsolete-function-alias 'tooltip-gud-toggle-dereference - 'gud-tooltip-dereference "22.1") (defvar tooltip-use-echo-area) (declare-function tooltip-show "tooltip" (text &optional use-echo-area)) (declare-function tooltip-strip-prompt "tooltip" (process output)) @@ -3521,11 +3520,11 @@ With arg, dereference expr if ARG is positive, otherwise do not dereference." (defun gud-tooltip-print-command (expr) "Return a suitable command to print the expression EXPR." (pcase gud-minor-mode - (`gdbmi (concat "-data-evaluate-expression \"" expr "\"")) - (`guiler expr) - (`dbx (concat "print " expr)) - ((or `xdb `pdb) (concat "p " expr)) - (`sdb (concat expr "/")))) + ('gdbmi (concat "-data-evaluate-expression \"" expr "\"")) + ('guiler expr) + ('dbx (concat "print " expr)) + ((or 'xdb 'pdb) (concat "p " expr)) + ('sdb (concat expr "/")))) (declare-function gdb-input "gdb-mi" (command handler &optional trigger)) (declare-function tooltip-expr-to-print "tooltip" (event)) diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el index 442fdedf372..1b06077005c 100644 --- a/lisp/progmodes/hideif.el +++ b/lisp/progmodes/hideif.el @@ -263,9 +263,6 @@ This backup prevents any accidental clearance of `hide-fidef-env' by ;;;###autoload (define-minor-mode hide-ifdef-mode "Toggle features to hide/show #ifdef blocks (Hide-Ifdef mode). -With a prefix argument ARG, enable Hide-Ifdef mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Hide-Ifdef mode is a buffer-local minor mode for use with C and C-like major modes. When enabled, code within #ifdef constructs @@ -543,7 +540,7 @@ that form should be displayed.") (defconst hif-token-regexp (concat (regexp-opt (mapcar 'car hif-token-alist)) - "\\|0x[0-9a-fA-F]+\\.?[0-9a-fA-F]*" + "\\|0x[[:xdigit:]]+\\.?[[:xdigit:]]*" "\\|[0-9]+\\.?[0-9]*" ;; decimal/octal "\\|\\w+")) @@ -598,7 +595,7 @@ that form should be displayed.") ;; 1. postfix 'l', 'll', 'ul' and 'ull' ;; 2. floating number formats (like 1.23e4) ;; 3. 098 is interpreted as octal conversion error - (if (string-match "0x\\([0-9a-fA-F]+\\.?[0-9a-fA-F]*\\)" + (if (string-match "0x\\([[:xdigit:]]+\\.?[[:xdigit:]]*\\)" token) (hif-string-to-number (match-string 1 token) 16)) ;; hex (if (string-match "\\`0[0-9]+\\(\\.[0-9]+\\)?\\'" token) @@ -675,12 +672,7 @@ that form should be displayed.") result)) (nreverse result))) -(defun hif-flatten (l) - "Flatten a tree." - (apply #'nconc - (mapcar (lambda (x) (if (listp x) - (hif-flatten x) - (list x))) l))) +(define-obsolete-function-alias 'hif-flatten #'flatten-tree "27.1") (defun hif-expand-token-list (tokens &optional macroname expand_list) "Perform expansion on TOKENS till everything expanded. @@ -751,7 +743,7 @@ detecting self-reference." expanded)) - (hif-flatten (nreverse expanded))))) + (flatten-tree (nreverse expanded))))) (defun hif-parse-exp (token-list &optional macroname) "Parse the TOKEN-LIST. @@ -1042,16 +1034,12 @@ preprocessing token" (defun hif-shiftleft (a b) (setq a (hif-mathify a)) (setq b (hif-mathify b)) - (if (< a 0) - (ash a b) - (lsh a b))) + (ash a b)) (defun hif-shiftright (a b) (setq a (hif-mathify a)) (setq b (hif-mathify b)) - (if (< a 0) - (ash a (- b)) - (lsh a (- b)))) + (ash a (- b))) (defalias 'hif-multiply (hif-mathify-binop *)) @@ -1173,7 +1161,7 @@ preprocessing token" (setq actual-parms (cdr actual-parms))) ;; Replacement completed, flatten the whole token list - (setq macro-body (hif-flatten macro-body)) + (setq macro-body (flatten-tree macro-body)) ;; Stringification and token concatenation happens here (hif-token-concatenation (hif-token-stringification macro-body))))) @@ -1628,7 +1616,7 @@ not be expanded." ((integerp result) (if (or (= 0 result) (= 1 result)) (message "%S <= `%s'" result exprstring) - (message "%S (0x%x) <= `%s'" result result exprstring))) + (message "%S (%#x) <= `%s'" result result exprstring))) ((null result) (message "%S <= `%s'" 'false exprstring)) ((eq t result) (message "%S <= `%s'" 'true exprstring)) (t (message "%S <= `%s'" result exprstring))) diff --git a/lisp/progmodes/hideshow.el b/lisp/progmodes/hideshow.el index 88f055e3ada..1d62bb58750 100644 --- a/lisp/progmodes/hideshow.el +++ b/lisp/progmodes/hideshow.el @@ -1,4 +1,4 @@ -;;; hideshow.el --- minor mode cmds to selectively display code/comment blocks +;;; hideshow.el --- minor mode cmds to selectively display code/comment blocks -*- lexical-binding:t -*- ;; Copyright (C) 1994-2019 Free Software Foundation, Inc. @@ -37,7 +37,7 @@ ;; hs-show-all C-c @ C-M-s ;; hs-hide-level C-c @ C-l ;; hs-toggle-hiding C-c @ C-c -;; hs-mouse-toggle-hiding [(shift mouse-2)] +;; hs-toggle-hiding [(shift mouse-2)] ;; hs-hide-initial-comment-block ;; ;; Blocks are defined per mode. In c-mode, c++-mode and java-mode, they @@ -55,8 +55,7 @@ ;; Then, add the following to your init file: ;; ;; (load-library "hideshow") -;; (add-hook 'X-mode-hook ; other modes similarly -;; (lambda () (hs-minor-mode 1))) +;; (add-hook 'X-mode-hook #'hs-minor-mode) ; other modes similarly ;; ;; where X = {emacs-lisp,c,c++,perl,...}. You can also manually toggle ;; hideshow minor mode by typing `M-x hs-minor-mode'. After hideshow is @@ -181,8 +180,8 @@ ;; (5) Hideshow interacts badly with Ediff and `vc-diff'. At the moment, the ;; suggested workaround is to turn off hideshow entirely, for example: ;; -;; (add-hook 'ediff-prepare-buffer-hook 'turn-off-hideshow) -;; (add-hook 'vc-before-checkin-hook 'turn-off-hideshow) +;; (add-hook 'ediff-prepare-buffer-hook #'turn-off-hideshow) +;; (add-hook 'vc-before-checkin-hook #'turn-off-hideshow) ;; ;; In the case of `vc-diff', here is a less invasive workaround: ;; @@ -317,7 +316,7 @@ a block), `hs-hide-all', `hs-hide-block' and `hs-hide-level'.") These commands include the toggling commands (when the result is to show a block), `hs-show-all' and `hs-show-block'.") -(defvar hs-set-up-overlay nil +(defvar hs-set-up-overlay #'ignore "Function called with one arg, OV, a newly initialized overlay. Hideshow puts a unique overlay on each range of text to be hidden in the buffer. Here is a simple example of how to use this variable: @@ -329,7 +328,7 @@ in the buffer. Here is a simple example of how to use this variable: (count-lines (overlay-start ov) (overlay-end ov)))))) - (setq hs-set-up-overlay \\='display-code-line-counts) + (setq hs-set-up-overlay #\\='display-code-line-counts) This example shows how to get information from the overlay as well as how to set its `display' property. See `hs-make-overlay' and @@ -355,7 +354,7 @@ Use the command `hs-minor-mode' to toggle or set this variable.") (define-key map "\C-c@\C-t" 'hs-hide-all) (define-key map "\C-c@\C-d" 'hs-hide-block) (define-key map "\C-c@\C-e" 'hs-toggle-hiding) - (define-key map [(shift mouse-2)] 'hs-mouse-toggle-hiding) + (define-key map [(shift mouse-2)] 'hs-toggle-hiding) map) "Keymap for hideshow minor mode.") @@ -410,7 +409,7 @@ element (using `match-beginning') before calling `hs-forward-sexp-func'.") (defvar-local hs-block-end-regexp nil "Regexp for end of block.") -(defvar-local hs-forward-sexp-func 'forward-sexp +(defvar-local hs-forward-sexp-func #'forward-sexp "Function used to do a `forward-sexp'. Should change for Algol-ish modes. For single-character block delimiters -- ie, the syntax table regexp for the character is @@ -418,7 +417,7 @@ either `(' or `)' -- `hs-forward-sexp-func' would just be `forward-sexp'. For other modes such as simula, a more specialized function is necessary.") -(defvar-local hs-adjust-block-beginning nil +(defvar-local hs-adjust-block-beginning #'identity "Function used to tweak the block beginning. The block is hidden from the position returned by this function, as opposed to hiding it from the position returned when searching @@ -575,10 +574,8 @@ and then further adjusted to be at the end of the line." ;; `p' is the point at the end of the block beginning, which ;; may need to be adjusted (save-excursion - (if hs-adjust-block-beginning - (goto-char (funcall hs-adjust-block-beginning - header-end)) - (goto-char header-end)) + (goto-char (funcall (or hs-adjust-block-beginning #'identity) + header-end)) (setq p (line-end-position))) ;; `q' is the point at the end of the block (hs-forward-sexp mdata 1) @@ -657,9 +654,8 @@ If `hs-special-modes-alist' has information associated with the current buffer's major mode, use that. Otherwise, guess start, end and `comment-start' regexps; `forward-sexp' function; and adjust-block-beginning function." - (if (and (boundp 'comment-start) - (boundp 'comment-end) - comment-start comment-end) + (if (and (bound-and-true-p comment-start) + (bound-and-true-p comment-end)) (let* ((lookup (assoc major-mode hs-special-modes-alist)) (start-elem (or (nth 1 lookup) "\\s("))) (if (listp start-elem) @@ -677,8 +673,8 @@ function; and adjust-block-beginning function." (substring c-start-regexp 0 (1- (match-end 0))) c-start-regexp))) - hs-forward-sexp-func (or (nth 4 lookup) 'forward-sexp) - hs-adjust-block-beginning (nth 5 lookup))) + hs-forward-sexp-func (or (nth 4 lookup) #'forward-sexp) + hs-adjust-block-beginning (or (nth 5 lookup) #'identity))) (setq hs-minor-mode nil) (error "%s Mode doesn't support Hideshow Minor Mode" (format-mode-line mode-name)))) @@ -729,13 +725,12 @@ Return point, or nil if original point was not in a block." "Evaluate BODY forms if variable `hs-minor-mode' is non-nil. In the dynamic context of this macro, `inhibit-point-motion-hooks' and `case-fold-search' are both t." + (declare (debug t)) `(when hs-minor-mode (let ((inhibit-point-motion-hooks t) (case-fold-search t)) ,@body))) -(put 'hs-life-goes-on 'edebug-form-spec '(&rest form)) - (defun hs-overlay-at (position) "Return hideshow overlay at POSITION, or nil if none to be found." (let ((overlays (overlays-at position)) @@ -895,24 +890,18 @@ The hook `hs-hide-hook' is run; see `run-hooks'." (message "Hiding blocks ... done")) (run-hooks 'hs-hide-hook))) -(defun hs-toggle-hiding () +(defun hs-toggle-hiding (&optional e) "Toggle hiding/showing of a block. -See `hs-hide-block' and `hs-show-block'." +See `hs-hide-block' and `hs-show-block'. +Argument E should be the event that triggered this action." (interactive) (hs-life-goes-on + (posn-set-point (event-end e)) (if (hs-already-hidden-p) (hs-show-block) (hs-hide-block)))) -(defun hs-mouse-toggle-hiding (e) - "Toggle hiding/showing of a block. -This command should be bound to a mouse key. -Argument E is a mouse event used by `mouse-set-point'. -See `hs-hide-block' and `hs-show-block'." - (interactive "@e") - (hs-life-goes-on - (mouse-set-point e) - (hs-toggle-hiding))) +(define-obsolete-function-alias 'hs-mouse-toggle-hiding #'hs-toggle-hiding "27.1") (defun hs-hide-initial-comment-block () "Hide the first block of comments in a file. @@ -932,9 +921,6 @@ This can be useful if you have huge RCS logs in those comments." ;;;###autoload (define-minor-mode hs-minor-mode "Minor mode to selectively hide/show code and comment blocks. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. When hideshow minor mode is on, the menu bar is augmented with hideshow commands and the hideshow commands are enabled. @@ -942,7 +928,7 @@ The value (hs . t) is added to `buffer-invisibility-spec'. The main commands are: `hs-hide-all', `hs-show-all', `hs-hide-block', `hs-show-block', `hs-hide-level' and `hs-toggle-hiding'. There is also -`hs-hide-initial-comment-block' and `hs-mouse-toggle-hiding'. +`hs-hide-initial-comment-block'. Turning hideshow minor mode off reverts the menu bar and the variables to default values and disables the hideshow commands. @@ -960,7 +946,7 @@ Key bindings: (hs-grok-mode-type) ;; Turn off this mode if we change major modes. (add-hook 'change-major-mode-hook - 'turn-off-hideshow + #'turn-off-hideshow nil t) (easy-menu-add hs-minor-mode-menu) (set (make-local-variable 'line-move-ignore-invisible) t) diff --git a/lisp/progmodes/idlw-complete-structtag.el b/lisp/progmodes/idlw-complete-structtag.el index 8a50b9b5375..2e74b8be175 100644 --- a/lisp/progmodes/idlw-complete-structtag.el +++ b/lisp/progmodes/idlw-complete-structtag.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2001-2019 Free Software Foundation, Inc. ;; Author: Carsten Dominik <dominik@astro.uva.nl> -;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu> +;; Maintainer: emacs-devel@gnu.org ;; Old-Version: 1.2 ;; Keywords: languages ;; Package: idlwave @@ -128,7 +128,7 @@ an up-to-date completion list." ;; x[i+4].name.g*. But it is complicated because we would have ;; to really parse this expression. For now, we allow only ;; substructures, like "aaa.bbb.ccc.ddd" - (skip-chars-backward "[a-zA-Z0-9._$]") + (skip-chars-backward "a-zA-Z0-9._$") (setq start (point)) ;; remember the start of the completion pos. (and (< (point) pos) (not (equal (char-before) ?!)) ; no sysvars diff --git a/lisp/progmodes/idlw-help.el b/lisp/progmodes/idlw-help.el index ec037596e04..c4cf29c1418 100644 --- a/lisp/progmodes/idlw-help.el +++ b/lisp/progmodes/idlw-help.el @@ -2,9 +2,9 @@ ;; Copyright (C) 2000-2019 Free Software Foundation, Inc. ;; -;; Authors: J.D. Smith <jdsmith@as.arizona.edu> +;; Authors: JD Smith <jd.smith@utoledo.edu> ;; Carsten Dominik <dominik@science.uva.nl> -;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu> +;; Maintainer: emacs-devel@gnu.org ;; Package: idlwave ;; This file is part of GNU Emacs. @@ -1181,9 +1181,10 @@ Useful when source code is displayed as help. See the option (with-syntax-table idlwave-mode-syntax-table (set (make-local-variable 'font-lock-defaults) idlwave-font-lock-defaults) - (if (fboundp 'font-lock-ensure) + (if (fboundp 'font-lock-ensure) ; Emacs >= 25.1 (font-lock-ensure) - (font-lock-fontify-buffer)))))) + ;; Silence "interactive use only" warning on Emacs >= 25.1. + (with-no-warnings (font-lock-fontify-buffer))))))) (defun idlwave-help-error (name type class keyword) diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el index 883616cd285..3bd99620d04 100644 --- a/lisp/progmodes/idlw-shell.el +++ b/lisp/progmodes/idlw-shell.el @@ -1,11 +1,11 @@ -;; idlw-shell.el --- run IDL as an inferior process of Emacs. +;; idlw-shell.el --- run IDL as an inferior process of Emacs. -*- lexical-binding:t -*- ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. -;; Authors: J.D. Smith <jdsmith@as.arizona.edu> +;; Authors: JD Smith <jd.smith@utoledo.edu> ;; Carsten Dominik <dominik@astro.uva.nl> ;; Chris Chase <chase@att.com> -;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: processes ;; Package: idlwave @@ -92,7 +92,7 @@ (require 'comint) (require 'idlwave) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defvar idlwave-shell-have-new-custom nil) @@ -601,9 +601,7 @@ TYPE is either 'pro' or 'rinfo', and `idlwave-shell-temp-pro-file' or (setq file (make-temp-name (expand-file-name prefix temp-file-dir))) - (if (featurep 'xemacs) - (write-region "" nil file nil 'silent nil) - (write-region "" nil file nil 'silent nil 'excl)) + (write-region "" nil file nil 'silent nil 'excl) nil) (file-already-exists t)) ;; the file was somehow created by someone else between @@ -667,9 +665,7 @@ the directory stack.") ((eq idlwave-shell-mark-stop-line 'face) ;; Try to use a face. If not possible, arrow will be used anyway ;; So who can display faces? - (when (or (featurep 'xemacs) ; XEmacs can do also ttys - (fboundp 'tty-defined-colors) ; Emacs 21 as well - window-system) ; Window systems always + (when window-system (progn (setq idlwave-shell-stop-line-overlay (make-overlay 1 1)) (overlay-put idlwave-shell-stop-line-overlay @@ -1115,8 +1111,7 @@ IDL has currently stepped.") (setq idlwave-shell-display-wframe (if (eq (selected-frame) idlwave-shell-idl-wframe) (or - (let ((flist (visible-frame-list)) - (frame (selected-frame))) + (let ((flist (visible-frame-list))) (catch 'exit (while flist (if (not (eq (car flist) @@ -1142,7 +1137,7 @@ IDL has currently stepped.") (make-frame idlwave-shell-frame-parameters))))) ;;;###autoload -(defun idlwave-shell (&optional arg quick) +(defun idlwave-shell (&optional arg) "Run an inferior IDL, with I/O through buffer `(idlwave-shell-buffer)'. If buffer exists but shell process is not running, start new IDL. If buffer exists and shell process is running, just switch to the buffer. @@ -1881,10 +1876,10 @@ directory." 'idlwave-shell-filter-directory 'hide 'wait)) -(defun idlwave-shell-retall (&optional arg) +(defun idlwave-shell-retall () "Return from the entire calling stack. Also get rid of widget events in the queue." - (interactive "P") + (interactive) (save-selected-window ;;if (widget_info(/MANAGED))[0] gt 0 then for i=0,n_elements(widget_info(/MANAGED))-1 do widget_control,(widget_info(/MANAGED))[i],/clear_events & (idlwave-shell-send-command "retall" nil @@ -1892,9 +1887,9 @@ Also get rid of widget events in the queue." nil t) (idlwave-shell-display-line nil))) -(defun idlwave-shell-closeall (&optional arg) +(defun idlwave-shell-closeall () "Close all open files." - (interactive "P") + (interactive) (idlwave-shell-send-command "close,/all" nil (idlwave-shell-hide-p 'misc) nil t)) @@ -2157,7 +2152,7 @@ keywords." (if entry (setq idlw-help-link (cdr entry)))) ; setting dynamic variable! (t (error "This should not happen"))))) -(defun idlwave-shell-complete-filename (&optional arg) +(defun idlwave-shell-complete-filename () "Complete a file name at point if after a file name. We assume that we are after a file name when completing one of the args of an executive .run, .rnew or .compile." @@ -2261,12 +2256,12 @@ overlays." (defun idlwave-shell-stack-up () "Display the source code one step up the calling stack." (interactive) - (incf idlwave-shell-calling-stack-index) + (cl-incf idlwave-shell-calling-stack-index) (idlwave-shell-display-level-in-calling-stack 'hide)) (defun idlwave-shell-stack-down () "Display the source code one step down the calling stack." (interactive) - (decf idlwave-shell-calling-stack-index) + (cl-decf idlwave-shell-calling-stack-index) (idlwave-shell-display-level-in-calling-stack 'hide)) (defun idlwave-shell-goto-frame (&optional frame) @@ -2739,10 +2734,9 @@ Runs to the last statement and then steps 1 statement. Use the .out command." (bp-alist idlwave-shell-bp-alist) (orig-func (if (> dir 0) '> '<)) (closer-func (if (> dir 0) '< '>)) - bp got-bp bp-line cur-line) + bp bp-line cur-line) (while (setq bp (pop bp-alist)) (when (string= file (car (car bp))) - (setq got-bp 1) (setq cur-line (nth 1 (car bp))) (if (and (funcall orig-func cur-line orig-bp-line) @@ -2766,35 +2760,21 @@ Runs to the last statement and then steps 1 statement. Use the .out command." (interactive "e") (let* ((drag-track (fboundp 'mouse-drag-track)) (transient-mark-mode t) - (zmacs-regions t) - (tracker (if (featurep 'xemacs) - (if (fboundp - 'default-mouse-track-event-is-with-button) - 'idlwave-xemacs-hack-mouse-track - 'mouse-track) - ;; Emacs 22 no longer completes the drag with - ;; mouse-drag-region, without an additional - ;; event. mouse-drag-track does so. - (if drag-track 'mouse-drag-track 'mouse-drag-region)))) + (tracker + ;; Emacs 22 no longer completes the drag with + ;; mouse-drag-region, without an additional + ;; event. mouse-drag-track does so. + (if drag-track 'mouse-drag-track 'mouse-drag-region))) (funcall tracker event) (idlwave-shell-print (if (idlwave-region-active-p) '(4) nil) ,help ,ev)))) ;; Begin terrible hack section -- XEmacs tests for button2 explicitly ;; on drag events, calling drag-n-drop code if detected. Ughhh... -(defun idlwave-default-mouse-track-event-is-with-button (event n) +(defun idlwave-default-mouse-track-event-is-with-button (_event _n) t) -(defun idlwave-xemacs-hack-mouse-track (event) - (if (featurep 'xemacs) - (let ((oldfunc (symbol-function - 'default-mouse-track-event-is-with-button))) - (unwind-protect - (progn - (fset 'default-mouse-track-event-is-with-button - 'idlwave-default-mouse-track-event-is-with-button) - (mouse-track event)) - (fset 'default-mouse-track-event-is-with-button oldfunc))))) +(define-obsolete-function-alias 'idlwave-xemacs-hack-mouse-track 'ignore "27.1") ;;; End terrible hack section (defun idlwave-shell-mouse-print (event) @@ -3193,22 +3173,20 @@ size(___,/DIMENSIONS)" output-begin output-end buffer)))) (defun idlwave-shell-delete-output-overlay () - (unless (or (eq this-command 'idlwave-shell-mouse-nop) - (eq this-command 'handle-switch-frame)) + (unless (memql this-command '(ignore handle-switch-frame)) (condition-case nil (if idlwave-shell-output-overlay (delete-overlay idlwave-shell-output-overlay)) (error nil)) - (remove-hook 'pre-command-hook 'idlwave-shell-delete-output-overlay))) + (remove-hook 'pre-command-hook #'idlwave-shell-delete-output-overlay))) (defun idlwave-shell-delete-expression-overlay () - (unless (or (eq this-command 'idlwave-shell-mouse-nop) - (eq this-command 'handle-switch-frame)) + (unless (memql this-command '(ignore handle-switch-frame)) (condition-case nil (if idlwave-shell-expression-overlay (delete-overlay idlwave-shell-expression-overlay)) (error nil)) - (remove-hook 'pre-command-hook 'idlwave-shell-delete-expression-overlay))) + (remove-hook 'pre-command-hook #'idlwave-shell-delete-expression-overlay))) (defvar idlwave-shell-bp-alist nil "Alist of breakpoints. @@ -3296,28 +3274,23 @@ Does not work for a region with multiline blocks - use (error nil)))) (defun idlwave-display-buffer (buf not-this-window-p &optional frame) - (if (featurep 'xemacs) - ;; The XEmacs version enforces the frame - (display-buffer buf not-this-window-p frame) - ;; For Emacs, we need to force the frame ourselves. - (let ((this-frame (selected-frame))) - (save-excursion ;; make sure we end up in the same buffer - (if (frame-live-p frame) - (select-frame frame)) - (if (eq this-frame (selected-frame)) - ;; same frame: use display buffer, to make sure the current - ;; window stays. - (display-buffer buf) - ;; different frame - (if (one-window-p) - ;; only window: switch - (progn - (switch-to-buffer buf) - (selected-window)) ; must return the window. - ;; several windows - use display-buffer - (display-buffer buf not-this-window-p))))))) -; (if (not (frame-live-p frame)) (setq frame nil)) -; (display-buffer buf not-this-window-p frame)) + ;; Force the frame ourselves. + (let ((this-frame (selected-frame))) + (save-excursion ;; make sure we end up in the same buffer + (if (frame-live-p frame) + (select-frame frame)) + (if (eq this-frame (selected-frame)) + ;; same frame: use display buffer, to make sure the current + ;; window stays. + (display-buffer buf) + ;; different frame + (if (one-window-p) + ;; only window: switch + (progn + (switch-to-buffer buf) + (selected-window)) ; must return the window. + ;; several windows - use display-buffer + (display-buffer buf not-this-window-p)))))) (defvar idlwave-shell-bp-buffer " *idlwave-shell-bp*" "Scratch buffer for parsing IDL breakpoint lists and other stuff.") @@ -3579,8 +3552,7 @@ considered the new breakpoint if the file name of frame matches." (defvar idlwave-shell-bp-glyph) (defvar idlwave-shell-debug-line-map (make-sparse-keymap)) -(define-key idlwave-shell-debug-line-map - (if (featurep 'xemacs) [button3] [mouse-3]) +(define-key idlwave-shell-debug-line-map [mouse-3] 'idlwave-shell-mouse-active-bp) (defun idlwave-shell-update-bp-overlays () @@ -3591,13 +3563,13 @@ Existing overlays are recycled, in order to minimize consumption." (bp-list idlwave-shell-bp-alist) (use-glyph (and (memq idlwave-shell-mark-breakpoints '(t glyph)) idlwave-shell-bp-glyph)) - ov ov-list bp buf old-buffers win) + ov ov-list bp buf old-buffers) ;; Delete the old overlays from their buffers (if ov-alist (while (setq ov-list (pop ov-alist)) (while (setq ov (pop (cdr ov-list))) - (pushnew (overlay-buffer ov) old-buffers) + (cl-pushnew (overlay-buffer ov) old-buffers) (delete-overlay ov)))) (setq ov-alist idlwave-shell-bp-overlays @@ -3694,60 +3666,33 @@ only for glyphs)." (face (if disabled idlwave-shell-disabled-breakpoint-face idlwave-shell-breakpoint-face))) - (if (featurep 'xemacs) - ;; This is XEmacs - (progn - (when idlwave-shell-breakpoint-popup-menu - (set-extent-property ov 'mouse-face 'highlight) - (set-extent-property ov 'keymap idlwave-shell-debug-line-map)) - - (cond - ;; tty's cannot display glyphs - ((eq (console-type) 'tty) - (set-extent-property ov 'face face)) - - ;; use the glyph - (use-glyph - (let ((glyph (cdr (assq type idlwave-shell-bp-glyph)))) - (if disabled (setq glyph (car glyph)) (setq glyph (nth 1 glyph))) - (set-extent-property ov 'begin-glyph glyph) - (set-extent-property ov 'begin-glyph-layout 'outside-margin))) - - ;; use the face - (idlwave-shell-mark-breakpoints - (set-extent-property ov 'face face)) - - ;; no marking - (t nil)) - (set-extent-priority ov -1)) ; make stop line face prevail - ;; This is Emacs - (when idlwave-shell-breakpoint-popup-menu - (overlay-put ov 'mouse-face 'highlight) - (overlay-put ov 'keymap idlwave-shell-debug-line-map)) - (cond - (window-system - (if use-glyph - (let ((image-props (cdr (assq type idlwave-shell-bp-glyph))) - string) - - (if disabled (setq image-props - (append image-props - (list :conversion 'disabled)))) - (setq string - (propertize "@" - 'display - (list (list 'margin 'left-margin) - image-props))) - (overlay-put ov 'before-string string)) - ;; just the face - (overlay-put ov 'face face))) - - ;; use a face - (idlwave-shell-mark-breakpoints - (overlay-put ov 'face face)) - - ;; No marking - (t nil))) + (when idlwave-shell-breakpoint-popup-menu + (overlay-put ov 'mouse-face 'highlight) + (overlay-put ov 'keymap idlwave-shell-debug-line-map)) + (cond + (window-system + (if use-glyph + (let ((image-props (cdr (assq type idlwave-shell-bp-glyph))) + string) + + (if disabled (setq image-props + (append image-props + (list :conversion 'disabled)))) + (setq string + (propertize "@" + 'display + (list (list 'margin 'left-margin) + image-props))) + (overlay-put ov 'before-string string)) + ;; just the face + (overlay-put ov 'face face))) + + ;; use a face + (idlwave-shell-mark-breakpoints + (overlay-put ov 'face face)) + + ;; No marking + (t nil)) ov)) (defun idlwave-shell-mouse-active-bp (ev) @@ -3798,9 +3743,9 @@ only for glyphs)." (t (message "Unimplemented: %s" select)))))) -(defun idlwave-shell-edit-default-command-line (arg) +(defun idlwave-shell-edit-default-command-line () "Edit the current execute command." - (interactive "P") + (interactive) (setq idlwave-shell-command-line-to-execute (read-string "IDL> " idlwave-shell-command-line-to-execute))) @@ -4057,9 +4002,55 @@ Otherwise, just expand the file name." ;; Keybindings ------------------------------------------------------------ -(defvar idlwave-shell-mode-map (copy-keymap comint-mode-map) +(defvar idlwave-shell-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map comint-mode-map) + + ;;(define-key map "\M-?" 'comint-dynamic-list-completions) + ;;(define-key map "\t" 'comint-dynamic-complete) + + (define-key map "\C-w" 'comint-kill-region) + (define-key map "\t" 'idlwave-shell-complete) + (define-key map "\M-\t" 'idlwave-shell-complete) + (define-key map "\C-c\C-s" 'idlwave-shell) + (define-key map "\C-c?" 'idlwave-routine-info) + (define-key map "\C-g" 'idlwave-keyboard-quit) + (define-key map "\M-?" 'idlwave-context-help) + (define-key map [(control meta ?\?)] + 'idlwave-help-assistant-help-with-topic) + (define-key map "\C-c\C-i" 'idlwave-update-routine-info) + (define-key map "\C-c\C-y" 'idlwave-shell-char-mode-loop) + (define-key map "\C-c\C-x" 'idlwave-shell-send-char) + (define-key map "\C-c=" 'idlwave-resolve) + (define-key map "\C-c\C-v" 'idlwave-find-module) + (define-key map "\C-c\C-k" 'idlwave-kill-autoloaded-buffers) + (define-key map idlwave-shell-prefix-key + 'idlwave-shell-debug-map) + (define-key map [(up)] 'idlwave-shell-up-or-history) + (define-key map [(down)] 'idlwave-shell-down-or-history) + (define-key idlwave-shell-mode-map [(shift mouse-3)] + 'idlwave-mouse-context-help) + map) "Keymap for `idlwave-mode'.") -(defvar idlwave-shell-electric-debug-mode-map (make-sparse-keymap)) + +(defvar idlwave-shell-electric-debug-mode-map + (let ((map (make-sparse-keymap))) + ;; A few extras in the electric debug map + (define-key map " " 'idlwave-shell-step) + (define-key map "+" 'idlwave-shell-stack-up) + (define-key map "=" 'idlwave-shell-stack-up) + (define-key map "-" 'idlwave-shell-stack-down) + (define-key map "_" 'idlwave-shell-stack-down) + (define-key map "e" (lambda () (interactive) (idlwave-shell-print '(16)))) + (define-key map "q" 'idlwave-shell-retall) + (define-key map "t" + (lambda () (interactive) (idlwave-shell-send-command "help,/TRACE"))) + (define-key map [(control ??)] 'idlwave-shell-electric-debug-help) + (define-key map "x" + (lambda (arg) (interactive "P") + (idlwave-shell-print arg nil nil t))) + map)) + (defvar idlwave-shell-mode-prefix-map (make-sparse-keymap)) (fset 'idlwave-shell-mode-prefix-map idlwave-shell-mode-prefix-map) (defvar idlwave-mode-prefix-map (make-sparse-keymap)) @@ -4069,65 +4060,22 @@ Otherwise, just expand the file name." "Define a key in both the shell and buffer mode maps." (define-key idlwave-mode-map key hook) (define-key idlwave-shell-mode-map key hook)) - -;(define-key idlwave-shell-mode-map "\M-?" 'comint-dynamic-list-completions) -;(define-key idlwave-shell-mode-map "\t" 'comint-dynamic-complete) - -(define-key idlwave-shell-mode-map "\C-w" 'comint-kill-region) -(define-key idlwave-shell-mode-map "\t" 'idlwave-shell-complete) -(define-key idlwave-shell-mode-map "\M-\t" 'idlwave-shell-complete) -(define-key idlwave-shell-mode-map "\C-c\C-s" 'idlwave-shell) -(define-key idlwave-shell-mode-map "\C-c?" 'idlwave-routine-info) -(define-key idlwave-shell-mode-map "\C-g" 'idlwave-keyboard-quit) -(define-key idlwave-shell-mode-map "\M-?" 'idlwave-context-help) -(define-key idlwave-shell-mode-map [(control meta ?\?)] - 'idlwave-help-assistant-help-with-topic) -(define-key idlwave-shell-mode-map "\C-c\C-i" 'idlwave-update-routine-info) -(define-key idlwave-shell-mode-map "\C-c\C-y" 'idlwave-shell-char-mode-loop) -(define-key idlwave-shell-mode-map "\C-c\C-x" 'idlwave-shell-send-char) -(define-key idlwave-shell-mode-map "\C-c=" 'idlwave-resolve) -(define-key idlwave-shell-mode-map "\C-c\C-v" 'idlwave-find-module) -(define-key idlwave-shell-mode-map "\C-c\C-k" 'idlwave-kill-autoloaded-buffers) -(define-key idlwave-shell-mode-map idlwave-shell-prefix-key - 'idlwave-shell-debug-map) -(define-key idlwave-shell-mode-map [(up)] 'idlwave-shell-up-or-history) -(define-key idlwave-shell-mode-map [(down)] 'idlwave-shell-down-or-history) (define-key idlwave-mode-map "\C-c\C-y" 'idlwave-shell-char-mode-loop) (define-key idlwave-mode-map "\C-c\C-x" 'idlwave-shell-send-char) ;; The mouse bindings for PRINT and HELP -(idlwave-shell-define-key-both - (if (featurep 'xemacs) - [(shift button2)] - [(shift down-mouse-2)]) - 'idlwave-shell-mouse-print) -(idlwave-shell-define-key-both - (if (featurep 'xemacs) - [(control meta button2)] - [(control meta down-mouse-2)]) - 'idlwave-shell-mouse-help) -(idlwave-shell-define-key-both - (if (featurep 'xemacs) - [(control shift button2)] - [(control shift down-mouse-2)]) - 'idlwave-shell-examine-select) -;; Add this one from the idlwave-mode-map -(define-key idlwave-shell-mode-map - (if (featurep 'xemacs) - [(shift button3)] - [(shift mouse-3)]) - 'idlwave-mouse-context-help) - -;; For Emacs, we need to turn off the button release events. -(defun idlwave-shell-mouse-nop (event) - (interactive "e")) -(unless (featurep 'xemacs) - (idlwave-shell-define-key-both - [(shift mouse-2)] 'idlwave-shell-mouse-nop) - (idlwave-shell-define-key-both - [(shift control mouse-2)] 'idlwave-shell-mouse-nop) - (idlwave-shell-define-key-both - [(control meta mouse-2)] 'idlwave-shell-mouse-nop)) +(idlwave-shell-define-key-both [(shift down-mouse-2)] + 'idlwave-shell-mouse-print) +(idlwave-shell-define-key-both [(control meta down-mouse-2)] + 'idlwave-shell-mouse-help) +(idlwave-shell-define-key-both [(control shift down-mouse-2)] + 'idlwave-shell-examine-select) + +;; We need to turn off the button release events. + +(idlwave-shell-define-key-both [(shift mouse-2)] 'ignore) +(idlwave-shell-define-key-both [(shift control mouse-2)] 'ignore) +(idlwave-shell-define-key-both [(control meta mouse-2)] 'ignore) ;; The following set of bindings is used to bind the debugging keys. @@ -4207,26 +4155,6 @@ Otherwise, just expand the file name." (define-key idlwave-shell-electric-debug-mode-map (char-to-string c2) cmd)))) -;; A few extras in the electric debug map -(define-key idlwave-shell-electric-debug-mode-map " " 'idlwave-shell-step) -(define-key idlwave-shell-electric-debug-mode-map "+" 'idlwave-shell-stack-up) -(define-key idlwave-shell-electric-debug-mode-map "=" 'idlwave-shell-stack-up) -(define-key idlwave-shell-electric-debug-mode-map "-" - 'idlwave-shell-stack-down) -(define-key idlwave-shell-electric-debug-mode-map "_" - 'idlwave-shell-stack-down) -(define-key idlwave-shell-electric-debug-mode-map "e" - (lambda () (interactive) (idlwave-shell-print '(16)))) -(define-key idlwave-shell-electric-debug-mode-map "q" 'idlwave-shell-retall) -(define-key idlwave-shell-electric-debug-mode-map "t" - (lambda () (interactive) (idlwave-shell-send-command "help,/TRACE"))) -(define-key idlwave-shell-electric-debug-mode-map [(control ??)] - 'idlwave-shell-electric-debug-help) -(define-key idlwave-shell-electric-debug-mode-map "x" - (lambda (arg) (interactive "P") - (idlwave-shell-print arg nil nil t))) - - ; Enter the prefix map in two places. (fset 'idlwave-debug-map idlwave-mode-prefix-map) (fset 'idlwave-shell-debug-map idlwave-shell-mode-prefix-map) @@ -4251,49 +4179,35 @@ Otherwise, just expand the file name." (define-minor-mode idlwave-shell-electric-debug-mode "Toggle Idlwave Shell Electric Debug mode. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. When Idlwave Shell Electric Debug mode is enabled, the Idlwave Shell debugging commands are available as single key sequences." - nil " *Debugging*" idlwave-shell-electric-debug-mode-map) - -(add-hook - 'idlwave-shell-electric-debug-mode-on-hook - (lambda () - (set (make-local-variable 'idlwave-shell-electric-debug-read-only) - buffer-read-only) - (setq buffer-read-only t) - (add-to-list 'idlwave-shell-electric-debug-buffers (current-buffer)) - (if idlwave-shell-stop-line-overlay - (overlay-put idlwave-shell-stop-line-overlay 'face - idlwave-shell-electric-stop-line-face)) - (if (facep 'fringe) - (set-face-foreground 'fringe idlwave-shell-electric-stop-color - (selected-frame))))) - -(add-hook - 'idlwave-shell-electric-debug-mode-off-hook - (lambda () - ;; Return to previous read-only state - (setq buffer-read-only (if (boundp 'idlwave-shell-electric-debug-read-only) - idlwave-shell-electric-debug-read-only)) - (setq idlwave-shell-electric-debug-buffers - (delq (current-buffer) idlwave-shell-electric-debug-buffers)) - (if idlwave-shell-stop-line-overlay - (overlay-put idlwave-shell-stop-line-overlay 'face - idlwave-shell-stop-line-face) - (if (facep 'fringe) - (set-face-foreground 'fringe (face-foreground 'default)))))) - -;; easy-mmode defines electric-debug-mode for us, so we need to advise it. -(defadvice idlwave-shell-electric-debug-mode (after print-enter activate) - "Print out an entrance message." - (when idlwave-shell-electric-debug-mode + :lighter " *Debugging*" + (cond + (idlwave-shell-electric-debug-mode + (set (make-local-variable 'idlwave-shell-electric-debug-read-only) + buffer-read-only) + (setq buffer-read-only t) + (add-to-list 'idlwave-shell-electric-debug-buffers (current-buffer)) + (if idlwave-shell-stop-line-overlay + (overlay-put idlwave-shell-stop-line-overlay 'face + idlwave-shell-electric-stop-line-face)) + (if (facep 'fringe) + (set-face-foreground 'fringe idlwave-shell-electric-stop-color + (selected-frame))) (message "Electric Debugging mode entered. Press [C-?] for help, [q] to quit")) - (force-mode-line-update)) + (t + ;; Return to previous read-only state + (setq buffer-read-only (if (boundp 'idlwave-shell-electric-debug-read-only) + idlwave-shell-electric-debug-read-only)) + (setq idlwave-shell-electric-debug-buffers + (delq (current-buffer) idlwave-shell-electric-debug-buffers)) + (if idlwave-shell-stop-line-overlay + (overlay-put idlwave-shell-stop-line-overlay 'face + idlwave-shell-stop-line-face) + (if (facep 'fringe) + (set-face-foreground 'fringe (face-foreground 'default))))))) ;; Turn it off in all relevant buffers (defvar idlwave-shell-electric-debug-buffers nil) @@ -4616,16 +4530,7 @@ static char * file[] = { \" \"};"))) im-cons im) (while (setq im-cons (pop image-alist)) - (setq im (cond ((and (featurep 'xemacs) - (featurep 'xpm)) - (list - (let ((data (cdr im-cons))) - (string-match "#FFFF00000000" data) - (setq data (replace-match "#8F8F8F8F8F8F" t t data)) - (make-glyph data)) - (make-glyph (cdr im-cons)))) - ((and (not (featurep 'xemacs)) - (fboundp 'image-type-available-p) + (setq im (cond ((and (fboundp 'image-type-available-p) (image-type-available-p 'xpm)) (list 'image :type 'xpm :data (cdr im-cons) :ascent 'center)) diff --git a/lisp/progmodes/idlw-toolbar.el b/lisp/progmodes/idlw-toolbar.el index b398ffc210a..aa19ad85806 100644 --- a/lisp/progmodes/idlw-toolbar.el +++ b/lisp/progmodes/idlw-toolbar.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. ;; Author: Carsten Dominik <dominik@astro.uva.nl> -;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: processes ;; Package: idlwave @@ -34,8 +34,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (defun idlwave-toolbar-make-button (image) (if (featurep 'xemacs) (toolbar-make-button-list image) diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el index 6dbc667c674..614d73e23b7 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -2,10 +2,10 @@ ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. -;; Authors: J.D. Smith <jdsmith@as.arizona.edu> +;; Authors: JD Smith <jd.smith@utoledo.edu> ;; Carsten Dominik <dominik@science.uva.nl> ;; Chris Chase <chase@att.com> -;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu> +;; Maintainer: emacs-devel@gnu.org ;; Version: 6.1.22 ;; Keywords: languages @@ -151,7 +151,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'idlw-help) ;; For XEmacs @@ -3690,7 +3690,7 @@ constants - a double quote followed by an octal digit." (save-excursion (forward-char) (re-search-backward (concat "\\(" idlwave-idl-keywords - "\\|[[(*+-/=,^><]\\)\\s-*\\*") limit t)))) + "\\|[-[(*+/=,^><]\\)\\s-*\\*") limit t)))) ;; Statement templates @@ -3898,7 +3898,7 @@ Buffers containing unsaved changes require confirmation before they are killed." (and (or (memq t reasons) (memq (cdr entry) reasons)) (kill-buffer (car entry)) - (incf cnt) + (cl-incf cnt) (setq idlwave-outlawed-buffers (delq entry idlwave-outlawed-buffers))) (setq idlwave-outlawed-buffers @@ -4104,14 +4104,14 @@ blank lines." (idlwave-sint-classes 10 10)))) ;; Make sure these are lists - (loop for entry in entries + (cl-loop for entry in entries for var = (car entry) do (if (not (consp (symbol-value var))) (set var (list nil)))) ;; Reset the system & library hash (when (or (eq what t) (eq what 'syslib) (null (cdr idlwave-sint-routines))) - (loop for entry in entries + (cl-loop for entry in entries for var = (car entry) for size = (nth 1 entry) do (setcdr (symbol-value var) (make-hash-table ':size size ':test 'equal))) @@ -4121,7 +4121,7 @@ blank lines." ;; Reset the buffer & shell hash (when (or (eq what t) (eq what 'bufsh) (null (car idlwave-sint-routines))) - (loop for entry in entries + (cl-loop for entry in entries for var = (car entry) for size = (nth 1 entry) do (setcar (symbol-value var) (make-hash-table ':size size ':test 'equal)))))) @@ -4680,7 +4680,7 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.") (setq pref-list (if (match-string 1 kwd) '("X" "Y" "Z") '("X" "Y")) kwd (substring kwd (match-end 0))) - (loop for x in pref-list do + (cl-loop for x in pref-list do (push (list (concat x kwd) klink) kwds))) (push (list kwd klink) kwds))) @@ -4701,7 +4701,7 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.") (cons (substring name 1) link) (if extra-kws (setq kwds (nconc kwds extra-kws))) (setq kwds (idlwave-rinfo-group-keywords kwds link)) - (loop for idx from 0 to 1 do + (cl-loop for idx from 0 to 1 do (if (aref syntax-vec idx) (push (append (list name (if (eq idx 0) 'pro 'fun) class '(system) @@ -4736,7 +4736,7 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.") ;; Clean up the syntax of routines which are actually aliases by ;; removing the "OR" from the statements (let (syntax entry) - (loop for x in aliases do + (cl-loop for x in aliases do (setq entry (assoc x idlwave-system-routines)) (when entry (while (string-match " +or +" (setq syntax (nth 4 entry))) @@ -4746,7 +4746,7 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.") ;; Duplicate and trim original routine aliases from rinfo list ;; This if for, e.g. OPENR/OPENW/OPENU (let (alias remove-list new parts all-parts) - (loop for x in aliases do + (cl-loop for x in aliases do (when (setq parts (split-string (cdr x) "/")) (setq new (assoc (cdr x) all-parts)) (unless new @@ -4755,30 +4755,30 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.") (setcdr new (delete (car x) (cdr new))))) ;; Add any missing aliases (separate by slashes) - (loop for x in all-parts do + (cl-loop for x in all-parts do (if (cdr x) (push (cons (nth 1 x) (car x)) aliases))) - (loop for x in aliases do + (cl-loop for x in aliases do (when (setq alias (assoc (cdr x) idlwave-system-routines)) (unless (memq alias remove-list) (push alias remove-list)) (setq alias (copy-sequence alias)) (setcar alias (car x)) (push alias idlwave-system-routines))) - (loop for x in remove-list do + (cl-loop for x in remove-list do (delq x idlwave-system-routines)))) (defun idlwave-convert-xml-clean-sysvar-aliases (aliases) ;; Duplicate and trim original routine aliases from rinfo list ;; This if for, e.g. !X, !Y, !Z. (let (alias remove-list) - (loop for x in aliases do + (cl-loop for x in aliases do (when (setq alias (assoc (cdr x) idlwave-system-variables-alist)) (unless (memq alias remove-list) (push alias remove-list)) (setq alias (copy-sequence alias)) (setcar alias (car x)) (push alias idlwave-system-variables-alist))) - (loop for x in remove-list do + (cl-loop for x in remove-list do (delq x idlwave-system-variables-alist)))) @@ -4875,7 +4875,7 @@ Cache to disk for quick recovery." (while rinfo (setq elem (car rinfo) rinfo (cdr rinfo)) - (incf elem-cnt) + (cl-incf elem-cnt) (when (listp elem) (setq type (car elem) props (car (cdr elem))) @@ -5106,7 +5106,7 @@ Cache to disk for quick recovery." "Return the class alist - make it if necessary." (or idlwave-class-alist (let (class) - (loop for x in idlwave-routines do + (cl-loop for x in idlwave-routines do (when (and (setq class (nth 2 x)) (not (assq class idlwave-class-alist))) (push (list class) idlwave-class-alist))) @@ -5240,7 +5240,7 @@ Can run from `after-save-hook'." class (cond ((not (boundp 'idlwave-scanning-lib)) (list 'buffer (buffer-file-name))) -; ((string= (downcase (file-name-base)) +; ((string= (downcase (file-name-base (buffer-file-name)) ; (downcase name)) ; (list 'lib)) ; (t (cons 'lib (file-name-nondirectory (buffer-file-name)))) @@ -5588,7 +5588,7 @@ be set to nil to disable library catalog scanning." (mapcar 'car idlwave-path-alist))) (old-libname "") dir-entry dir catalog all-routines) - (if message-base (message message-base)) + (if message-base (message "%s" message-base)) (while (setq dir (pop dirs)) (catch 'continue (when (file-readable-p @@ -5603,8 +5603,7 @@ be set to nil to disable library catalog scanning." message-base (not (string= idlwave-library-catalog-libname old-libname))) - (message "%s" (concat message-base - idlwave-library-catalog-libname)) + (message "%s%s" message-base idlwave-library-catalog-libname) (setq old-libname idlwave-library-catalog-libname)) (when idlwave-library-catalog-routines (setq all-routines @@ -5618,7 +5617,7 @@ be set to nil to disable library catalog scanning." (setq dir-entry (assoc dir idlwave-path-alist))) (idlwave-path-alist-add-flag dir-entry 'lib))))) (unless no-load (setq idlwave-library-catalog-routines all-routines)) - (if message-base (message (concat message-base "done")))))) + (if message-base (message "%sdone" message-base))))) ;;----- Communicating with the Shell ------------------- @@ -6223,7 +6222,7 @@ If yes, return the index (>=1)." (let (file (cnt 0)) (catch 'exit (while entries - (incf cnt) + (cl-incf cnt) (setq file (idlwave-routine-source-file (nth 3 (car entries)))) (if (and file (idlwave-syslib-p file)) (throw 'exit cnt) @@ -6455,10 +6454,10 @@ ARROW: Location of the arrow" ((string-match "\\`[ \t]*\\(pro\\|function\\)\\>" match-string) nil) - ((string-match "OBJ_NEW([ \t]*['\"]\\([a-zA-Z0-9$_]*\\)?\\'" + ((string-match "OBJ_NEW([ \t]*['\"][a-zA-Z0-9$_]*\\'" match-string) (setq cw 'class)) - ((string-match "\\<inherits\\s-+\\([a-zA-Z0-9$_]*\\)?\\'" + ((string-match "\\<inherits\\s-+[a-zA-Z0-9$_]*\\'" match-string) (setq cw 'class)) ((and func @@ -6520,7 +6519,7 @@ ARROW: Location of the arrow" (progn (up-list -1) t) (error nil)) (setq pos (point)) - (incf cnt) + (cl-incf cnt) (when (and (= (following-char) ?\() (re-search-backward "\\(::\\|\\<\\)\\([a-zA-Z][a-zA-Z0-9$_]*\\)[ \t]*\\=" @@ -7591,7 +7590,7 @@ property indicating the link is added." (case-fold-search t)) (cond ((save-excursion ;; Check if the context is right for system variable - (skip-chars-backward "[a-zA-Z0-9_$]") + (skip-chars-backward "a-zA-Z0-9_$") (equal (char-before) ?!)) (setq idlwave-completion-help-info '(idlwave-complete-sysvar-help)) (idlwave-complete-in-buffer 'sysvar 'sysvar @@ -8190,7 +8189,7 @@ demand _EXTRA in the keyword list." (while (setq re (pop regexps)) (if (string-match re name) (throw 'exit t)))))) - (loop for entry in (idlwave-routines) do + (cl-loop for entry in (idlwave-routines) do (and (nth 2 entry) ; non-nil class (memq (nth 2 entry) super-classes) ; an inherited class (eq (nth 1 entry) type) ; correct type @@ -8399,7 +8398,7 @@ If we do not know about MODULE, just return KEYWORD literally." "") (if (> total 1) "- " "")) entry props) - (incf cnt) + (cl-incf cnt) (when (and all (> cnt idlwave-rinfo-max-source-lines)) ;; No more source lines, please (insert (format @@ -8707,7 +8706,7 @@ can be used to detect possible name clashes during this process." (> (idlwave-count-memq 'lib (nth 2 (car dtwins))) 1) (> (idlwave-count-memq 'user (nth 2 (car dtwins))) 1) (> (idlwave-count-memq 'buffer (nth 2 (car dtwins))) 1)) - (incf cnt) + (cl-incf cnt) (insert (format "\n%s%s" (idlwave-make-full-name (nth 2 routine) (car routine)) @@ -8776,7 +8775,7 @@ routines, and may have been scanned." (cnt 0) source type type-cons file alist syslibp key) (while (setq entry (pop entries)) - (incf cnt) + (cl-incf cnt) (setq source (nth 3 entry) type (car source) type-cons (cons type (nth 3 source)) @@ -9074,7 +9073,7 @@ Assumes that point is at the beginning of the unit as found by ;; Menus - using easymenu.el (defvar idlwave-mode-menu-def - `("IDLWAVE" + '("IDLWAVE" ["PRO/FUNC menu" idlwave-function-menu t] ("Motion" ["Subprogram Start" idlwave-beginning-of-subprogram t] @@ -9151,7 +9150,7 @@ Assumes that point is at the beginning of the unit as found by ["Kill auto-created buffers" idlwave-kill-autoloaded-buffers t] "--" ["Insert TAB character" idlwave-hard-tab t]) - "--" + "--" ("External" ["Start IDL shell" idlwave-shell t] ["Edit file in IDLDE" idlwave-edit-in-idlde t] diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index 9c3f3b3e4f4..161fd5c00b0 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -3,8 +3,8 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. ;; Author: Karl Landstrom <karl.landstrom@brgeight.se> -;; Daniel Colascione <dan.colascione@gmail.com> -;; Maintainer: Daniel Colascione <dan.colascione@gmail.com> +;; Daniel Colascione <dancol@dancol.org> +;; Maintainer: Daniel Colascione <dancol@dancol.org> ;; Version: 9 ;; Date: 2009-07-25 ;; Keywords: languages, javascript @@ -45,14 +45,11 @@ ;;; Code: - (require 'cc-mode) (require 'newcomment) -(require 'thingatpt) ; forward-symbol etc (require 'imenu) (require 'moz nil t) -(require 'json nil t) -(require 'sgml-mode) +(require 'json) (require 'prog-mode) (eval-when-compile @@ -68,7 +65,7 @@ ;;; Constants -(defconst js--name-start-re "[a-zA-Z_$]" +(defconst js--name-start-re (concat "[[:alpha:]_$]") "Regexp matching the start of a JavaScript identifier, without grouping.") (defconst js--stmt-delim-chars "^;{}?:") @@ -574,6 +571,119 @@ then the \".\"s will be lined up: :safe 'booleanp :group 'js) +(defcustom js-jsx-detect-syntax t + "When non-nil, automatically detect whether JavaScript uses JSX. +`js-jsx-syntax' (which see) may be made buffer-local and set to +t. The detection strategy can be customized by adding elements +to `js-jsx-regexps', which see." + :version "27.1" + :type 'boolean + :safe 'booleanp + :group 'js) + +(defcustom js-jsx-syntax nil + "When non-nil, parse JavaScript with consideration for JSX syntax. + +This enables proper font-locking and indentation of code using +Facebook’s “JSX” syntax extension for JavaScript, for use with +Facebook’s “React” library. Font-locking is like sgml-mode. +Indentation is also like sgml-mode, although some indentation +behavior may differ slightly to align more closely with the +conventions of the React developer community. + +When `js-mode' is already enabled, you should call +`js-jsx-enable' to set this variable. + +It is set to be buffer-local (and t) when in `js-jsx-mode'." + :version "27.1" + :type 'boolean + :safe 'booleanp + :group 'js) + +(defcustom js-jsx-align->-with-< t + "When non-nil, “>” will be indented to the opening “<” in JSX. + +When this is enabled, JSX indentation looks like this: + + <element + attr=\"\" + > + </element> + <input + /> + +When this is disabled, JSX indentation looks like this: + + <element + attr=\"\" + > + </element> + <input + />" + :version "27.1" + :type 'boolean + :safe 'booleanp + :group 'js) + +(defcustom js-jsx-indent-level nil + "When non-nil, indent JSX by this value, instead of like JS. + +Let `js-indent-level' be 4. When this variable is also set to +nil, JSX indentation looks like this (consistent): + + return ( + <element> + <element> + Hello World! + </element> + </element> + ) + +Alternatively, when this variable is also set to 2, JSX +indentation looks like this (different): + + return ( + <element> + <element> + Hello World! + </element> + </element> + )" + :version "27.1" + :type 'integer + :safe (lambda (x) (or (null x) (integerp x))) + :group 'js) +;; This is how indentation behaved out-of-the-box until Emacs 27. JSX +;; indentation was controlled with `sgml-basic-offset', which defaults +;; to 2, whereas `js-indent-level' defaults to 4. Users who had the +;; same values configured for both their HTML and JS indentation would +;; luckily get consistent JSX indentation; most others were probably +;; unhappy. I’d be surprised if anyone actually wants different +;; indentation levels, but just in case, here’s a way back to that. + +(defcustom js-jsx-attribute-offset 0 + "Specifies a delta for JSXAttribute indentation. + +Let `js-indent-level' be 2. When this variable is also set to 0, +JSXAttribute indentation looks like this: + + <element + attribute=\"value\"> + </element> + +Alternatively, when this variable is also set to 2, JSXAttribute +indentation looks like this: + + <element + attribute=\"value\"> + </element> + +This variable is like `sgml-attribute-offset'." + :version "27.1" + :type 'integer + :safe 'integerp + :group 'js) + ;;; KeyMap (defvar js-mode-map @@ -624,12 +734,6 @@ then the \".\"s will be lined up: "Parse state at `js--last-parse-pos'.") (make-variable-buffer-local 'js--state-at-last-parse-pos) -(defun js--flatten-list (list) - (cl-loop for item in list - nconc (cond ((consp item) - (js--flatten-list item)) - (item (list item))))) - (defun js--maybe-join (prefix separator suffix &rest list) "Helper function for `js--update-quick-match-re'. If LIST contains any element that is not nil, return its non-nil @@ -637,7 +741,7 @@ elements, separated by SEPARATOR, prefixed by PREFIX, and ended with SUFFIX as with `concat'. Otherwise, if LIST is empty, return nil. If any element in LIST is itself a list, flatten that element." - (setq list (js--flatten-list list)) + (setq list (flatten-tree list)) (when list (concat prefix (mapconcat #'identity list separator) suffix))) @@ -1007,7 +1111,7 @@ BEG defaults to `point-min', meaning to flush the entire cache." Update parsing information up to point, referring to parse, prev-parse-point, goal-point, and open-items bound lexically in the body of `js--ensure-cache'." - `(progn + '(progn (setq goal-point (point)) (goto-char prev-parse-point) (while (progn @@ -1017,7 +1121,7 @@ the body of `js--ensure-cache'." ;; the given depth -- i.e., make sure we're deeper than the target ;; depth. (cl-assert (> (nth 0 parse) - (js--pitem-paren-depth (car open-items)))) + (js--pitem-paren-depth (car open-items)))) (setq parse (parse-partial-sexp prev-parse-point goal-point (js--pitem-paren-depth (car open-items)) @@ -1493,6 +1597,102 @@ point of view of font-lock. It applies highlighting directly with ;; Matcher always "fails" nil) +;; It wouldn’t be sufficient to font-lock JSX with mere regexps, since +;; a JSXElement may be nested inside a JS expression within the +;; boundaries of a parent JSXOpeningElement, and such a hierarchy +;; ought to be fontified like JSX, JS, and JSX respectively: +;; +;; <div attr={void(<div></div>) && void(0)}></div> +;; +;; <div attr={ ← JSX +;; void( ← JS +;; <div></div> ← JSX +;; ) && void(0) ← JS +;; }></div> ← JSX +;; +;; `js-syntax-propertize' unambiguously identifies JSX syntax, +;; including when it’s nested. +;; +;; Using a matcher function for each relevant part, retrieve match +;; data recorded as syntax properties for fontification. + +(defconst js-jsx--font-lock-keywords + `((js-jsx--match-tag-name 0 font-lock-function-name-face t) + (js-jsx--match-attribute-name 0 font-lock-variable-name-face t) + (js-jsx--match-text 0 'default t) ; “Undo” keyword fontification. + (js-jsx--match-tag-beg) + (js-jsx--match-tag-end) + (js-jsx--match-expr)) + "JSX font lock faces and multiline text properties.") + +(defun js-jsx--match-tag-name (limit) + "Match JSXBoundaryElement names, until LIMIT." + (when js-jsx-syntax + (let ((pos (next-single-char-property-change (point) 'js-jsx-tag-name nil limit)) + value) + (when (and pos (> pos (point))) + (goto-char pos) + (or (and (setq value (get-text-property pos 'js-jsx-tag-name)) + (progn (set-match-data value) t)) + (js-jsx--match-tag-name limit)))))) + +(defun js-jsx--match-attribute-name (limit) + "Match JSXAttribute names, until LIMIT." + (when js-jsx-syntax + (let ((pos (next-single-char-property-change (point) 'js-jsx-attribute-name nil limit)) + value) + (when (and pos (> pos (point))) + (goto-char pos) + (or (and (setq value (get-text-property pos 'js-jsx-attribute-name)) + (progn (set-match-data value) t)) + (js-jsx--match-attribute-name limit)))))) + +(defun js-jsx--match-text (limit) + "Match JSXText, until LIMIT." + (when js-jsx-syntax + (let ((pos (next-single-char-property-change (point) 'js-jsx-text nil limit)) + value) + (when (and pos (> pos (point))) + (goto-char pos) + (or (and (setq value (get-text-property pos 'js-jsx-text)) + (progn (set-match-data value) + (put-text-property (car value) (cadr value) 'font-lock-multiline t) + t)) + (js-jsx--match-text limit)))))) + +(defun js-jsx--match-tag-beg (limit) + "Match JSXBoundaryElements from start, until LIMIT." + (when js-jsx-syntax + (let ((pos (next-single-char-property-change (point) 'js-jsx-tag-beg nil limit)) + value) + (when (and pos (> pos (point))) + (goto-char pos) + (or (and (setq value (get-text-property pos 'js-jsx-tag-beg)) + (progn (put-text-property pos (cdr value) 'font-lock-multiline t) t)) + (js-jsx--match-tag-beg limit)))))) + +(defun js-jsx--match-tag-end (limit) + "Match JSXBoundaryElements from end, until LIMIT." + (when js-jsx-syntax + (let ((pos (next-single-char-property-change (point) 'js-jsx-tag-end nil limit)) + value) + (when (and pos (> pos (point))) + (goto-char pos) + (or (and (setq value (get-text-property pos 'js-jsx-tag-end)) + (progn (put-text-property value pos 'font-lock-multiline t) t)) + (js-jsx--match-tag-end limit)))))) + +(defun js-jsx--match-expr (limit) + "Match JSXExpressionContainers, until LIMIT." + (when js-jsx-syntax + (let ((pos (next-single-char-property-change (point) 'js-jsx-expr nil limit)) + value) + (when (and pos (> pos (point))) + (goto-char pos) + (or (and (setq value (get-text-property pos 'js-jsx-expr)) + (progn (put-text-property pos value 'font-lock-multiline t) t)) + (js-jsx--match-expr limit)))))) + (defconst js--font-lock-keywords-3 `( ;; This goes before keywords-2 so it gets used preferentially @@ -1604,7 +1804,10 @@ point of view of font-lock. It applies highlighting directly with (forward-symbol -1) (end-of-line)) '(end-of-line) - '(0 font-lock-variable-name-face)))) + '(0 font-lock-variable-name-face))) + + ;; jsx (when enabled) + ,@js-jsx--font-lock-keywords) "Level three font lock for `js-mode'.") (defun js--inside-pitem-p (pitem) @@ -1730,9 +1933,407 @@ This performs fontification according to `js--class-styles'." 'syntax-table (string-to-syntax "\"/")) (goto-char end))))) +(defconst js--unary-keyword-re + (js--regexp-opt-symbol '("await" "delete" "typeof" "void" "yield")) + "Regexp matching unary operator keywords.") + +(defun js--unary-keyword-p (string) + "Check if STRING is a unary operator keyword in JavaScript." + (string-match-p js--unary-keyword-re string)) + +;; Adding `syntax-multiline' text properties to JSX isn’t sufficient +;; to identify multiline JSX when first typing it. For instance, if +;; the user is typing a JSXOpeningElement for the first time… +;; +;; <div +;; ^ (point) +;; +;; …and the user inserts a line break after the tag name (before the +;; JSXOpeningElement starting on that line has been unambiguously +;; identified as such), then the `syntax-propertize' region won’t be +;; extended backwards to the start of the JSXOpeningElement: +;; +;; <div ← This line wasn’t JSX when last edited. +;; attr=""> ← Despite completing the JSX, the next +;; ^ `syntax-propertize' region wouldn’t magically +;; extend back a few lines. +;; +;; Therefore, to try and recover from this scenario, parse backward +;; from “>” to try and find the start of JSXBoundaryElements, and +;; extend the `syntax-propertize' region there. + +(defun js--syntax-propertize-extend-region (start end) + "Extend the START-END region for propertization, if necessary. +For use by `syntax-propertize-extend-region-functions'." + (if js-jsx-syntax (js-jsx--syntax-propertize-extend-region start end))) + +(defun js-jsx--syntax-propertize-extend-region (start end) + "Extend the START-END region for propertization, if necessary. +If any “>” in the region appears to be the end of a tag starting +before the start of the region, extend region backwards to the +start of that tag so parsing may proceed from that point. +For use by `syntax-propertize-extend-region-functions'." + (let (new-start + forward-sexp-function ; Use the Lisp version. + parse-sexp-lookup-properties) ; Fix backward-sexp error here. + (catch 'stop + (goto-char start) + (while (re-search-forward ">" end t) + (catch 'continue + ;; Check if this is really a right shift bitwise operator + ;; (“>>” or “>>>”). + (unless (or (eq (char-before (1- (point))) ?>) + (eq (char-after) ?>)) + (save-excursion + (backward-char) + (while (progn (if (= (point) (point-min)) (throw 'continue nil)) + (/= (char-before) ?<)) + (skip-chars-backward " \t\n") + (if (= (point) (point-min)) (throw 'continue nil)) + (cond + ((memq (char-before) '(?\" ?\' ?\` ?\})) + (condition-case nil + (backward-sexp) + (scan-error (throw 'continue nil)))) + ((memq (char-before) '(?\/ ?\=)) (backward-char)) + ((looking-back js--dotted-name-re (line-beginning-position) t) + (goto-char (match-beginning 0))) + (t (throw 'continue nil)))) + (when (< (point) start) + (setq new-start (1- (point))) + (throw 'stop nil))))))) + (if new-start (cons new-start end)))) + +;; When applying syntax properties, since `js-syntax-propertize' uses +;; `syntax-propertize-rules' to parse JSXBoundaryElements iteratively +;; and statelessly, whenever we exit such an element, we need to +;; determine the JSX depth. If >0, then we know we to apply syntax +;; properties to JSXText up until the next JSXBoundaryElement occurs. +;; But if the JSX depth is 0, then—importantly—we know to NOT parse +;; the following code as JSXText, rather propertize it as regular JS +;; as long as warranted. +;; +;; Also, when indenting code, we need to know if the code we’re trying +;; to indent is on the 2nd or later line of multiline JSX, in which +;; case the code is indented according to XML-like JSX conventions. +;; +;; For the aforementioned reasons, we find ourselves needing to +;; determine whether point is enclosed in JSX or not; and, if so, +;; where the JSX is. The following functions provide that knowledge. + +(defconst js-jsx--tag-start-re + (concat "\\(" js--dotted-name-re "\\)\\(?:" + ;; Whitespace is only necessary if an attribute implies JSX. + "\\(?:\\s-\\|\n\\)*[{/>]" + "\\|" + "\\(?:\\s-\\|\n\\)+" js--name-start-re + "\\)") + "Regexp unambiguously matching a JSXOpeningElement.") + +(defun js-jsx--matched-tag-type () + "Determine if the last “<” was a JSXBoundaryElement and its type. +Return `close' for a JSXClosingElement/JSXClosingFragment match, +return `self-closing' for some self-closing JSXOpeningElements, +else return `other'." + (cond + ((= (char-after) ?/) (forward-char) 'close) ; JSXClosingElement/JSXClosingFragment + ((= (char-after) ?>) (forward-char) 'other) ; JSXOpeningFragment + ((and (looking-at js-jsx--tag-start-re) ; JSXOpeningElement + (not (js--unary-keyword-p (match-string 1)))) + (goto-char (match-end 0)) + (if (= (char-before) ?/) 'self-closing 'other)))) + +(defconst js-jsx--self-closing-re "/\\s-*>" + "Regexp matching the end of a self-closing JSXOpeningElement.") + +(defun js-jsx--matching-close-tag-pos () + "Return position of the closer of the opener before point. +Assuming a JSXOpeningElement or a JSXOpeningFragment is +immediately before point, find a matching JSXClosingElement or +JSXClosingFragment, skipping over any nested JSXElements to find +the match. Return nil if a match can’t be found." + (let ((tag-stack 1) tag-pos type last-pos pos) + (catch 'stop + (while (and (re-search-forward "<\\s-*" nil t) (not (eobp))) + (when (setq tag-pos (match-beginning 0) + type (js-jsx--matched-tag-type)) + (when last-pos + (setq pos (point)) + (goto-char last-pos) + (while (re-search-forward js-jsx--self-closing-re pos 'move) + (setq tag-stack (1- tag-stack)))) + (if (eq type 'close) + (progn + (setq tag-stack (1- tag-stack)) + (when (= tag-stack 0) + (throw 'stop tag-pos))) + ;; JSXOpeningElements that we know are self-closing aren’t + ;; added to the stack at all (because point is already + ;; past that syntax). + (unless (eq type 'self-closing) + (setq tag-stack (1+ tag-stack)))) + (setq last-pos (point))))))) + +(defun js-jsx--enclosing-tag-pos () + "Return beginning and end of a JSXElement about point. +Look backward for a JSXElement that both starts before point and +also ends at/after point. That may be either a self-closing +JSXElement or a JSXOpeningElement/JSXClosingElement pair." + (let ((start (point)) tag-beg tag-beg-pos tag-end-pos close-tag-pos) + (while + (and + (setq tag-beg (js--backward-text-property 'js-jsx-tag-beg)) + (progn + (setq tag-beg-pos (point) + tag-end-pos (cdr tag-beg)) + (not + (or + (and (eq (car tag-beg) 'self-closing) + (< start tag-end-pos)) + (and (eq (car tag-beg) 'open) + (or (< start tag-end-pos) + (progn + (unless + ;; Try to read a cached close position, + ;; but it might not be available yet. + (setq close-tag-pos + (get-text-property (point) 'js-jsx-close-tag-pos)) + (save-excursion + (goto-char tag-end-pos) + (setq close-tag-pos (js-jsx--matching-close-tag-pos))) + (when close-tag-pos + ;; Cache the close position to make future + ;; searches faster. + (put-text-property + (point) (1+ (point)) + 'js-jsx-close-tag-pos close-tag-pos))) + ;; The JSXOpeningElement may be unclosed, else + ;; the closure must occur at/after the start + ;; point (otherwise, a miscellaneous previous + ;; JSXOpeningElement has been found, so keep + ;; looking backwards for an enclosing one). + (or (not close-tag-pos) (<= start close-tag-pos))))))))) + ;; Don’t return the last tag pos, as it wasn’t enclosing. + (setq tag-beg nil close-tag-pos nil)) + (and tag-beg (list tag-beg-pos tag-end-pos close-tag-pos)))) + +(defun js-jsx--at-enclosing-tag-child-p () + "Return t if point is at an enclosing tag’s child." + (let ((pos (save-excursion (js-jsx--enclosing-tag-pos)))) + (and pos (>= (point) (nth 1 pos))))) + +;; We implement `syntax-propertize-function' logic fully parsing JSX +;; in order to provide very accurate JSX indentation, even in the most +;; complex cases (e.g. to indent JSX within a JS expression within a +;; JSXAttribute…), as over the years users have requested this. Since +;; we find so much information during this parse, we later use some of +;; the useful bits for font-locking, too. +;; +;; Some extra effort is devoted to ensuring that no code which could +;; possibly be valid JS is ever misinterpreted as partial JSX, since +;; that would be regressive. +;; +;; We first parse trying to find the minimum number of components +;; necessary to unambiguously identify a JSXBoundaryElement, even if +;; it is a partial one. If a complete one is parsed, we move on to +;; parse any JSXText. When that’s terminated, we unwind back to the +;; `syntax-propertize-rules' loop so the next JSXBoundaryElement can +;; be parsed, if any, be it an opening or closing one. + +(defun js-jsx--text-range (beg end) + "Identify JSXText within a “>/{/}/<” pair." + (when (> (- end beg) 0) + (save-excursion + (goto-char beg) + (while (and (skip-chars-forward " \t\n" end) (< (point) end)) + ;; Comments and string quotes don’t serve their usual + ;; syntactic roles in JSXText; make them plain punctuation to + ;; negate those roles. + (when (or (= (char-after) ?/) ; comment + (= (syntax-class (syntax-after (point))) 7)) ; string quote + (put-text-property (point) (1+ (point)) 'syntax-table '(1))) + (forward-char))) + ;; Mark JSXText so it can be font-locked as non-keywords. + (put-text-property beg (1+ beg) 'js-jsx-text (list beg end (current-buffer))) + ;; Ensure future propertization beginning from within the + ;; JSXText determines JSXText context from earlier lines. + (put-text-property beg end 'syntax-multiline t))) + +;; In order to respect the end boundary `syntax-propertize-function' +;; sets, care is taken in the following functions to abort parsing +;; whenever that boundary is reached. + +(defun js-jsx--syntax-propertize-tag-text (end) + "Determine if JSXText is before END and propertize it. +Text within an open/close tag pair may be JSXText. Temporarily +interrupt JSXText by JSXExpressionContainers, and terminate +JSXText when another JSXBoundaryElement is encountered. Despite +terminations, all JSXText will be identified once all the +JSXBoundaryElements within an outermost JSXElement’s tree have +been propertized." + (let ((text-beg (point)) + forward-sexp-function) ; Use Lisp version. + (catch 'stop + (while (re-search-forward "[{<]" end t) + (js-jsx--text-range text-beg (1- (point))) + (cond + ((= (char-before) ?{) + (let (expr-beg expr-end) + (condition-case nil + (save-excursion + (backward-char) + (setq expr-beg (point)) + (forward-sexp) + (setq expr-end (point))) + (scan-error nil)) + ;; Recursively propertize the JSXExpressionContainer’s + ;; (possibly-incomplete) expression. + (js-syntax-propertize (1+ expr-beg) (if expr-end (min (1- expr-end) end) end)) + ;; Ensure future propertization beginning from within the + ;; (possibly-incomplete) expression can determine JSXText + ;; context from earlier lines. + (put-text-property expr-beg (1+ expr-beg) 'js-jsx-expr (or expr-end end)) ; font-lock + (put-text-property expr-beg (if expr-end (min expr-end end) end) 'syntax-multiline t) ; syntax-propertize + ;; Exit the JSXExpressionContainer if that’s possible, + ;; else move to the end of the propertized area. + (goto-char (if expr-end (min expr-end end) end)))) + ((= (char-before) ?<) + (backward-char) ; Ensure the next tag can be propertized. + (throw 'stop nil))) + (setq text-beg (point)))))) + +(defconst js-jsx--attribute-name-re (concat js--name-start-re + "\\(?:\\s_\\|\\sw\\|-\\)*") + "Like `js--name-re', but matches “-” as well.") + +(defun js-jsx--syntax-propertize-tag (end) + "Determine if a JSXBoundaryElement is before END and propertize it. +Disambiguate JSX from inequality operators and arrow functions by +testing for syntax only valid as JSX." + (let ((tag-beg (1- (point))) tag-end (type 'open) + name-beg name-match-data expr-attribute-beg unambiguous + forward-sexp-function) ; Use Lisp version. + (catch 'stop + (while (and (< (point) end) + (progn (skip-chars-forward " \t\n" end) + (< (point) end))) + (cond + ((= (char-after) ?>) + ;; Make the closing “>” a close parenthesis. + (put-text-property (point) (1+ (point)) 'syntax-table + (eval-when-compile (string-to-syntax ")<"))) + (forward-char) + (setq unambiguous t) + (throw 'stop nil)) + ;; Handle a JSXSpreadChild (“<Foo {...bar}”) or a + ;; JSXExpressionContainer as a JSXAttribute value + ;; (“<Foo bar={…}”). Check this early in case continuing a + ;; JSXAttribute parse. + ((or (and name-beg (= (char-after) ?{)) + (setq expr-attribute-beg nil)) + (setq unambiguous t) ; JSXExpressionContainer post tag name ⇒ JSX + (when expr-attribute-beg + ;; Remember that this JSXExpressionContainer is part of a + ;; JSXAttribute, as that can affect its expression’s + ;; indentation. + (put-text-property + (point) (1+ (point)) 'js-jsx-expr-attribute expr-attribute-beg) + (setq expr-attribute-beg nil)) + (let (expr-end) + (condition-case nil + (save-excursion + (forward-sexp) + (setq expr-end (point))) + (scan-error nil)) + (forward-char) + (if (>= (point) end) (throw 'stop nil)) + (skip-chars-forward " \t\n" end) + (if (>= (point) end) (throw 'stop nil)) + (if (= (char-after) ?}) (forward-char) ; Shortcut to bail. + ;; Recursively propertize the JSXExpressionContainer’s + ;; expression. + (js-syntax-propertize (point) (if expr-end (min (1- expr-end) end) end)) + ;; Exit the JSXExpressionContainer if that’s possible, + ;; else move to the end of the propertized area. + (goto-char (if expr-end (min expr-end end) end))))) + ((= (char-after) ?/) + ;; Assume a tag is an open tag until a slash is found, then + ;; figure out what type it actually is. + (if (eq type 'open) (setq type (if name-beg 'self-closing 'close))) + (forward-char)) + ((and (not name-beg) (looking-at js--dotted-name-re)) + ;; Don’t match code like “if (i < await foo)” + (if (js--unary-keyword-p (match-string 0)) (throw 'stop nil)) + ;; Save boundaries for later fontification after + ;; unambiguously determining the code is JSX. + (setq name-beg (match-beginning 0) + name-match-data (match-data)) + (goto-char (match-end 0))) + ((and name-beg (looking-at js-jsx--attribute-name-re)) + (setq unambiguous t) ; Non-unary name followed by 2nd name ⇒ JSX + ;; Save JSXAttribute’s name’s match data for font-locking later. + (put-text-property (match-beginning 0) (1+ (match-beginning 0)) + 'js-jsx-attribute-name (match-data)) + (goto-char (match-end 0)) + (if (>= (point) end) (throw 'stop nil)) + (skip-chars-forward " \t\n" end) + (if (>= (point) end) (throw 'stop nil)) + ;; “=” is optional for null-valued JSXAttributes. + (when (= (char-after) ?=) + (forward-char) + (if (>= (point) end) (throw 'stop nil)) + (skip-chars-forward " \t\n" end) + (if (>= (point) end) (throw 'stop nil)) + ;; Skip over strings (if possible). Any + ;; JSXExpressionContainer here will be parsed in the + ;; next iteration of the loop. + (if (memq (char-after) '(?\" ?\' ?\`)) + (progn + ;; Record the string’s position so derived modes + ;; applying syntactic fontification atypically + ;; (e.g. js2-mode) can recognize it as part of JSX. + (put-text-property (point) (1+ (point)) 'js-jsx-string t) + (condition-case nil + (forward-sexp) + (scan-error (throw 'stop nil)))) + ;; Save JSXAttribute’s beginning in case we find a + ;; JSXExpressionContainer as the JSXAttribute’s value which + ;; we should associate with the JSXAttribute. + (setq expr-attribute-beg (match-beginning 0))))) + ;; There is nothing more to check; this either isn’t JSX, or + ;; the tag is incomplete. + (t (throw 'stop nil))))) + (when unambiguous + ;; Save JSXBoundaryElement’s name’s match data for font-locking. + (if name-beg (put-text-property name-beg (1+ name-beg) 'js-jsx-tag-name name-match-data)) + ;; Make the opening “<” an open parenthesis. + (put-text-property tag-beg (1+ tag-beg) 'syntax-table + (eval-when-compile (string-to-syntax "(>"))) + ;; Prevent “out of range” errors when typing at the end of a buffer. + (setq tag-end (if (eobp) (1- (point)) (point))) + ;; Mark beginning and end of tag for font-locking. + (put-text-property tag-beg (1+ tag-beg) 'js-jsx-tag-beg (cons type tag-end)) + (put-text-property tag-end (1+ tag-end) 'js-jsx-tag-end tag-beg) + ;; Use text properties to extend the syntax-propertize region + ;; backward to the beginning of the JSXBoundaryElement in the + ;; future. Typically the closing angle bracket could suggest + ;; extending backward, but that would also involve more rigorous + ;; parsing, and the closing angle bracket may not even exist yet + ;; if the JSXBoundaryElement is still being typed. + (put-text-property tag-beg (1+ tag-end) 'syntax-multiline t)) + (if (js-jsx--at-enclosing-tag-child-p) (js-jsx--syntax-propertize-tag-text end)))) + +(defconst js-jsx--text-properties + (list + 'js-jsx-tag-beg nil 'js-jsx-tag-end nil 'js-jsx-close-tag-pos nil + 'js-jsx-tag-name nil 'js-jsx-attribute-name nil 'js-jsx-string nil + 'js-jsx-text nil 'js-jsx-expr nil 'js-jsx-expr-attribute nil) + "Plist of text properties added by `js-syntax-propertize'.") + (defun js-syntax-propertize (start end) ;; JavaScript allows immediate regular expression objects, written /.../. (goto-char start) + (if js-jsx-syntax (remove-text-properties start end js-jsx--text-properties)) (js-syntax-propertize-regexp end) (funcall (syntax-propertize-rules @@ -1756,7 +2357,8 @@ This performs fontification according to `js--class-styles'." (put-text-property (match-beginning 1) (match-end 1) 'syntax-table (string-to-syntax "\"/")) (js-syntax-propertize-regexp end))))) - ("\\`\\(#\\)!" (1 "< b"))) + ("\\`\\(#\\)!" (1 "< b")) + ("<" (0 (ignore (if js-jsx-syntax (js-jsx--syntax-propertize-tag end)))))) (point) end)) (defconst js--prettify-symbols-alist @@ -1782,6 +2384,11 @@ This performs fontification according to `js--class-styles'." (js--regexp-opt-symbol '("in" "instanceof"))) "Regexp matching operators that affect indentation of continued expressions.") +(defun js-jsx--looking-at-start-tag-p () + "Non-nil if a JSXOpeningElement immediately follows point." + (let ((tag-beg (get-text-property (point) 'js-jsx-tag-beg))) + (and tag-beg (memq (car tag-beg) '(open self-closing))))) + (defun js--looking-at-operator-p () "Return non-nil if point is on a JavaScript operator, other than a comma." (save-match-data @@ -1804,7 +2411,9 @@ This performs fontification according to `js--class-styles'." (js--backward-syntactic-ws) ;; We might misindent some expressions that would ;; return NaN anyway. Shouldn't be a problem. - (memq (char-before) '(?, ?} ?{)))))))) + (memq (char-before) '(?, ?} ?{))))) + ;; “<” isn’t necessarily an operator in JSX. + (not (and js-jsx-syntax (js-jsx--looking-at-start-tag-p)))))) (defun js--find-newline-backward () "Move backward to the nearest newline that is not in a block comment." @@ -1824,6 +2433,10 @@ This performs fontification according to `js--class-styles'." (setq result nil))) result)) +(defun js-jsx--looking-back-at-end-tag-p () + "Non-nil if a JSXClosingElement immediately precedes point." + (get-text-property (point) 'js-jsx-tag-end)) + (defun js--continued-expression-p () "Return non-nil if the current line continues an expression." (save-excursion @@ -1841,12 +2454,19 @@ This performs fontification according to `js--class-styles'." (and (js--find-newline-backward) (progn (skip-chars-backward " \t") - (or (bobp) (backward-char)) - (and (> (point) (point-min)) - (save-excursion (backward-char) (not (looking-at "[/*]/"))) - (js--looking-at-operator-p) - (and (progn (backward-char) - (not (looking-at "+\\+\\|--\\|/[/*]")))))))))) + (and + ;; The “>” at the end of any JSXBoundaryElement isn’t + ;; part of a continued expression. + (not (and js-jsx-syntax (js-jsx--looking-back-at-end-tag-p))) + (progn + (or (bobp) (backward-char)) + (and (> (point) (point-min)) + (save-excursion + (backward-char) + (not (looking-at "[/*]/\\|=>"))) + (js--looking-at-operator-p) + (and (progn (backward-char) + (not (looking-at "\\+\\+\\|--\\|/[/*]")))))))))))) (defun js--skip-term-backward () "Skip a term before point; return t if a term was skipped." @@ -1916,7 +2536,7 @@ the same column as the current line." (save-match-data (when (looking-at "\\s-*\\_<while\\_>") (if (save-excursion - (skip-chars-backward "[ \t\n]*}") + (skip-chars-backward " \t\n}") (looking-at "[ \t\n]*}")) (save-excursion (backward-list) (forward-symbol -1) (looking-at "\\_<do\\_>")) @@ -2072,6 +2692,183 @@ indentation is aligned to that column." (when comma-p (goto-char (1+ declaration-keyword-end)))))))) +(defconst js--line-terminating-arrow-re "=>\\s-*\\(/[/*]\\|$\\)" + "Regexp matching the last \"=>\" (arrow) token on a line. +Whitespace and comments around the arrow are ignored.") + +(defun js--broken-arrow-terminates-line-p () + "Helper function for `js--proper-indentation'. +Return t if the last non-comment, non-whitespace token of the +current line is the \"=>\" token (of an arrow function)." + (let ((from (point))) + (end-of-line) + (re-search-backward js--line-terminating-arrow-re from t))) + +;; When indenting, we want to know if the line is… +;; +;; - within a multiline JSXElement, or +;; - within a string in a JSXBoundaryElement, or +;; - within JSXText, or +;; - within a JSXAttribute’s multiline JSXExpressionContainer. +;; +;; In these cases, special XML-like indentation rules for JSX apply. +;; If JS is nested within JSX, then indentation calculations may be +;; combined, such that JS indentation is “relative” to the JSX’s. +;; +;; Therefore, functions below provide such contextual information, and +;; `js--proper-indentation' may call itself once recursively in order +;; to finish calculating that “relative” JS+JSX indentation. + +(defun js-jsx--context () + "Determine JSX context and move to enclosing JSX." + (let ((pos (point)) + (parse-status (syntax-ppss)) + (enclosing-tag-pos (js-jsx--enclosing-tag-pos))) + (when enclosing-tag-pos + (if (< pos (nth 1 enclosing-tag-pos)) + (if (nth 3 parse-status) + (list 'string (nth 8 parse-status)) + (list 'tag (nth 0 enclosing-tag-pos) (nth 1 enclosing-tag-pos))) + (list 'text (nth 0 enclosing-tag-pos) (nth 2 enclosing-tag-pos)))))) + +(defun js-jsx--contextual-indentation (line context) + "Calculate indentation column for LINE from CONTEXT. +The column calculation is based off of `sgml-calculate-indent'." + (pcase (nth 0 context) + + ('string + ;; Go back to previous non-empty line. + (while (and (> (point) (nth 1 context)) + (zerop (forward-line -1)) + (looking-at "[ \t]*$"))) + (if (> (point) (nth 1 context)) + ;; Previous line is inside the string. + (current-indentation) + (goto-char (nth 1 context)) + (1+ (current-column)))) + + ('tag + ;; Special JSX indentation rule: a “dangling” closing angle + ;; bracket on its own line is indented at the same level as the + ;; opening angle bracket of the JSXElement. Otherwise, indent + ;; JSXAttribute space like SGML. + (if (and + js-jsx-align->-with-< + (progn + (goto-char (nth 2 context)) + (and (= line (line-number-at-pos)) + (looking-back "^\\s-*/?>" (line-beginning-position))))) + (progn + (goto-char (nth 1 context)) + (current-column)) + ;; Indent JSXAttribute space like SGML. + (goto-char (nth 1 context)) + ;; Skip tag name: + (skip-chars-forward " \t") + (skip-chars-forward "^ \t\n") + (skip-chars-forward " \t") + (if (not (eolp)) + (current-column) + ;; This is the first attribute: indent. + (goto-char (+ (nth 1 context) js-jsx-attribute-offset)) + (+ (current-column) (or js-jsx-indent-level js-indent-level))))) + + ('text + ;; Indent to reflect nesting. + (goto-char (nth 1 context)) + (+ (current-column) + ;; The last line isn’t nested, but the rest are. + (if (or (not (nth 2 context)) ; Unclosed. + (< line (line-number-at-pos (nth 2 context)))) + (or js-jsx-indent-level js-indent-level) + 0))) + + )) + +(defun js-jsx--enclosing-curly-pos () + "Return position of enclosing “{” in a “{/}” pair about point." + (let ((parens (reverse (nth 9 (syntax-ppss)))) paren-pos curly-pos) + (while + (and + (setq paren-pos (car parens)) + (not (when (= (char-after paren-pos) ?{) + (setq curly-pos paren-pos))) + (setq parens (cdr parens)))) + curly-pos)) + +(defun js-jsx--goto-outermost-enclosing-curly (limit) + "Set point to enclosing “{” at or closest after LIMIT." + (let (pos) + (while + (and + (setq pos (js-jsx--enclosing-curly-pos)) + (if (>= pos limit) (goto-char pos)) + (> pos limit))))) + +(defun js-jsx--expr-attribute-pos (start limit) + "Look back from START to LIMIT for a JSXAttribute." + (save-excursion + (goto-char start) ; Skip the first curly. + ;; Skip any remaining enclosing curlies until the JSXElement’s + ;; beginning position; the last curly ought to be one of a + ;; JSXExpressionContainer, which may refer to its JSXAttribute’s + ;; beginning position (if it has one). + (js-jsx--goto-outermost-enclosing-curly limit) + (get-text-property (point) 'js-jsx-expr-attribute))) + +(defvar js-jsx--indent-col nil + "Baseline column for JS indentation within JSX.") + +(defvar js-jsx--indent-attribute-line nil + "Line relative to which indentation uses JSX as a baseline.") + +(defun js-jsx--expr-indentation (parse-status pos col) + "Indent using PARSE-STATUS; relative to POS, use base COL. +To indent a JSXExpressionContainer’s expression, calculate the JS +indentation, using JSX indentation as the base column when +indenting relative to the beginning line of the +JSXExpressionContainer’s JSXAttribute (if any)." + (let* ((js-jsx--indent-col col) + (js-jsx--indent-attribute-line + (if pos (line-number-at-pos pos)))) + (js--proper-indentation parse-status))) + +(defun js-jsx--indentation (parse-status) + "Helper function for `js--proper-indentation'. +Return the proper indentation of the current line if it is part +of a JSXElement expression spanning multiple lines; otherwise, +return nil." + (let ((current-line (line-number-at-pos)) + (curly-pos (js-jsx--enclosing-curly-pos)) + nth-context context expr-p beg-line col + forward-sexp-function) ; Use the Lisp version. + ;; Find the immediate context for indentation information, but + ;; keep going to determine that point is at the N+1th line of + ;; multiline JSX. + (save-excursion + (while + (and + (setq nth-context (js-jsx--context)) + (progn + (unless context + (setq context nth-context) + (setq expr-p (and curly-pos (< (point) curly-pos)))) + (setq beg-line (line-number-at-pos)) + (and + (= beg-line current-line) + (or (not curly-pos) (> (point) curly-pos))))))) + ;; When on the second or later line of JSX, indent as JSX, + ;; possibly switching back to JS indentation within + ;; JSXExpressionContainers, possibly using the JSX as a base + ;; column while switching back to JS indentation. + (when (and context (> current-line beg-line)) + (save-excursion + (setq col (js-jsx--contextual-indentation current-line context))) + (if expr-p + (js-jsx--expr-indentation + parse-status (js-jsx--expr-attribute-pos curly-pos (nth 1 context)) col) + col)))) + (defun js--proper-indentation (parse-status) "Return the proper indentation for the current line." (save-excursion @@ -2079,6 +2876,8 @@ indentation is aligned to that column." (cond ((nth 4 parse-status) ; inside comment (js--get-c-offset 'c (nth 8 parse-status))) ((nth 3 parse-status) 0) ; inside string + ((when (and js-jsx-syntax (not js-jsx--indent-col)) + (save-excursion (js-jsx--indentation parse-status)))) ((eq (char-after) ?#) 0) ((save-excursion (js--beginning-of-macro)) 4) ;; Indent array comprehension continuation lines specially. @@ -2102,7 +2901,8 @@ indentation is aligned to that column." (continued-expr-p (js--continued-expression-p))) (goto-char (nth 1 parse-status)) ; go to the opening char (if (or (not js-indent-align-list-continuation) - (looking-at "[({[]\\s-*\\(/[/*]\\|$\\)")) + (looking-at "[({[]\\s-*\\(/[/*]\\|$\\)") + (save-excursion (forward-char) (js--broken-arrow-terminates-line-p))) (progn ; nothing following the opening paren/bracket (skip-syntax-backward " ") (when (eq (char-before) ?\)) (backward-list)) @@ -2114,17 +2914,24 @@ indentation is aligned to that column." (and switch-keyword-p in-switch-p))) (indent - (cond (same-indent-p - (current-column)) - (continued-expr-p - (+ (current-column) (* 2 js-indent-level) - js-expr-indent-offset)) - (t - (+ (current-column) js-indent-level - (pcase (char-after (nth 1 parse-status)) - (?\( js-paren-indent-offset) - (?\[ js-square-indent-offset) - (?\{ js-curly-indent-offset))))))) + (+ + (cond + ((and js-jsx--indent-attribute-line + (eq js-jsx--indent-attribute-line + (line-number-at-pos))) + js-jsx--indent-col) + (t + (current-column))) + (cond (same-indent-p 0) + (continued-expr-p + (+ (* 2 js-indent-level) + js-expr-indent-offset)) + (t + (+ js-indent-level + (pcase (char-after (nth 1 parse-status)) + (?\( js-paren-indent-offset) + (?\[ js-square-indent-offset) + (?\{ js-curly-indent-offset)))))))) (if in-switch-p (+ indent js-switch-indent-offset) indent))) @@ -2140,193 +2947,6 @@ indentation is aligned to that column." (+ js-indent-level js-expr-indent-offset)) (t (prog-first-column))))) -;;; JSX Indentation - -(defsubst js--jsx-find-before-tag () - "Find where JSX starts. - -Assume JSX appears in the following instances: -- Inside parentheses, when returned or as the first argument - to a function, and after a newline -- When assigned to variables or object properties, but only - on a single line -- As the N+1th argument to a function - -This is an optimized version of (re-search-backward \"[(,]\n\" -nil t), except set point to the end of the match. This logic -executes up to the number of lines in the file, so it should be -really fast to reduce that impact." - (let (pos) - (while (and (> (point) (point-min)) - (not (progn - (end-of-line 0) - (when (or (eq (char-before) 40) ; ( - (eq (char-before) 44)) ; , - (setq pos (1- (point)))))))) - pos)) - -(defconst js--jsx-end-tag-re - (concat "</" sgml-name-re ">\\|/>") - "Find the end of a JSX element.") - -(defconst js--jsx-after-tag-re "[),]" - "Find where JSX ends. -This complements the assumption of where JSX appears from -`js--jsx-before-tag-re', which see.") - -(defun js--jsx-indented-element-p () - "Determine if/how the current line should be indented as JSX. - -Return `first' for the first JSXElement on its own line. -Return `nth' for subsequent lines of the first JSXElement. -Return `expression' for an embedded JS expression. -Return `after' for anything after the last JSXElement. -Return nil for non-JSX lines. - -Currently, JSX indentation supports the following styles: - -- Single-line elements (indented like normal JS): - - var element = <div></div>; - -- Multi-line elements (enclosed in parentheses): - - function () { - return ( - <div> - <div></div> - </div> - ); - } - -- Function arguments: - - React.render( - <div></div>, - document.querySelector('.root') - );" - (let ((current-pos (point)) - (current-line (line-number-at-pos)) - last-pos - before-tag-pos before-tag-line - tag-start-pos tag-start-line - tag-end-pos tag-end-line - after-tag-line - parens paren type) - (save-excursion - (and - ;; Determine if we're inside a jsx element - (progn - (end-of-line) - (while (and (not tag-start-pos) - (setq last-pos (js--jsx-find-before-tag))) - (while (forward-comment 1)) - (when (= (char-after) 60) ; < - (setq before-tag-pos last-pos - tag-start-pos (point))) - (goto-char last-pos)) - tag-start-pos) - (progn - (setq before-tag-line (line-number-at-pos before-tag-pos) - tag-start-line (line-number-at-pos tag-start-pos)) - (and - ;; A "before" line which also starts an element begins with js, so - ;; indent it like js - (> current-line before-tag-line) - ;; Only indent the jsx lines like jsx - (>= current-line tag-start-line))) - (cond - ;; Analyze bounds if there are any - ((progn - (while (and (not tag-end-pos) - (setq last-pos (re-search-forward js--jsx-end-tag-re nil t))) - (while (forward-comment 1)) - (when (looking-at js--jsx-after-tag-re) - (setq tag-end-pos last-pos))) - tag-end-pos) - (setq tag-end-line (line-number-at-pos tag-end-pos) - after-tag-line (line-number-at-pos after-tag-line)) - (or (and - ;; Ensure we're actually within the bounds of the jsx - (<= current-line tag-end-line) - ;; An "after" line which does not end an element begins with - ;; js, so indent it like js - (<= current-line after-tag-line)) - (and - ;; Handle another case where there could be e.g. comments after - ;; the element - (> current-line tag-end-line) - (< current-line after-tag-line) - (setq type 'after)))) - ;; They may not be any bounds (yet) - (t)) - ;; Check if we're inside an embedded multi-line js expression - (cond - ((not type) - (goto-char current-pos) - (end-of-line) - (setq parens (nth 9 (syntax-ppss))) - (while (and parens (not type)) - (setq paren (car parens)) - (cond - ((and (>= paren tag-start-pos) - ;; Curly bracket indicates the start of an embedded expression - (= (char-after paren) 123) ; { - ;; The first line of the expression is indented like sgml - (> current-line (line-number-at-pos paren)) - ;; Check if within a closing curly bracket (if any) - ;; (exclusive, as the closing bracket is indented like sgml) - (cond - ((progn - (goto-char paren) - (ignore-errors (let (forward-sexp-function) - (forward-sexp)))) - (< current-line (line-number-at-pos))) - (t))) - ;; Indicate this guy will be indented specially - (setq type 'expression)) - (t (setq parens (cdr parens))))) - t) - (t)) - (cond - (type) - ;; Indent the first jsx thing like js so we can indent future jsx things - ;; like sgml relative to the first thing - ((= current-line tag-start-line) 'first) - ('nth)))))) - -(defmacro js--as-sgml (&rest body) - "Execute BODY as if in sgml-mode." - `(with-syntax-table sgml-mode-syntax-table - (let (forward-sexp-function - parse-sexp-lookup-properties) - ,@body))) - -(defun js--expression-in-sgml-indent-line () - "Indent the current line as JavaScript or SGML (whichever is farther)." - (let* (indent-col - (savep (point)) - ;; Don't whine about errors/warnings when we're indenting. - ;; This has to be set before calling parse-partial-sexp below. - (inhibit-point-motion-hooks t) - (parse-status (save-excursion - (syntax-ppss (point-at-bol))))) - ;; Don't touch multiline strings. - (unless (nth 3 parse-status) - (setq indent-col (save-excursion - (back-to-indentation) - (if (>= (point) savep) (setq savep nil)) - (js--as-sgml (sgml-calculate-indent)))) - (if (null indent-col) - 'noindent - ;; Use whichever indentation column is greater, such that the sgml - ;; column is effectively a minimum - (setq indent-col (max (js--proper-indentation parse-status) - (+ indent-col js-indent-level))) - (if savep - (save-excursion (indent-line-to indent-col)) - (indent-line-to indent-col)))))) - (defun js-indent-line () "Indent the current line as JavaScript." (interactive) @@ -2338,23 +2958,9 @@ Currently, JSX indentation supports the following styles: (when (> offset 0) (forward-char offset))))) (defun js-jsx-indent-line () - "Indent the current line as JSX (with SGML offsets). -i.e., customize JSX element indentation with `sgml-basic-offset', -`sgml-attribute-offset' et al." + "Indent the current line as JavaScript+JSX." (interactive) - (let ((indentation-type (js--jsx-indented-element-p))) - (cond - ((eq indentation-type 'expression) - (js--expression-in-sgml-indent-line)) - ((or (eq indentation-type 'first) - (eq indentation-type 'after)) - ;; Don't treat this first thing as a continued expression (often a "<" or - ;; ">" causes this misinterpretation) - (cl-letf (((symbol-function #'js--continued-expression-p) 'ignore)) - (js-indent-line))) - ((eq indentation-type 'nth) - (js--as-sgml (sgml-indent-line))) - (t (js-indent-line))))) + (let ((js-jsx-syntax t)) (js-indent-line))) ;;; Filling @@ -2362,23 +2968,22 @@ i.e., customize JSX element indentation with `sgml-basic-offset', ;; FIXME: Such redefinitions are bad style. We should try and use some other ;; way to get the same result. -(defadvice c-forward-sws (around js-fill-paragraph activate) - (if js--filling-paragraph - (setq ad-return-value (js--forward-syntactic-ws (ad-get-arg 0))) - ad-do-it)) - -(defadvice c-backward-sws (around js-fill-paragraph activate) - (if js--filling-paragraph - (setq ad-return-value (js--backward-syntactic-ws (ad-get-arg 0))) - ad-do-it)) - -(defadvice c-beginning-of-macro (around js-fill-paragraph activate) - (if js--filling-paragraph - (setq ad-return-value (js--beginning-of-macro (ad-get-arg 0))) - ad-do-it)) - -(defun js-c-fill-paragraph (&optional justify) - "Fill the paragraph with `c-fill-paragraph'." +(defun js--fill-c-advice (js-fun) + (lambda (orig-fun &rest args) + (if js--filling-paragraph + (funcall js-fun (car args)) + (apply orig-fun args)))) + +(advice-add 'c-forward-sws + :around (js--fill-c-advice #'js--forward-syntactic-ws)) +(advice-add 'c-backward-sws + :around (js--fill-c-advice #'js--backward-syntactic-ws)) +(advice-add 'c-beginning-of-macro + :around (js--fill-c-advice #'js--beginning-of-macro)) + +(define-obsolete-function-alias 'js-c-fill-paragraph #'js-fill-paragraph "27.1") +(defun js-fill-paragraph (&optional justify) + "Fill the paragraph for Javascript code." (interactive "*P") (let ((js--filling-paragraph t) (fill-paragraph-function #'c-fill-paragraph)) @@ -2761,8 +3366,8 @@ 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 = (+ (float-time) timeout) - for time-left = (- end-time (float-time)) + 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) @@ -3317,11 +3922,11 @@ 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 + ('atom (cl-second result)) + ('special (intern (cl-second result))) + ('array (mapcar #'js--js-decode-retval (cl-second result))) - (`objid + ('objid (or (gethash (cl-second result) js--js-references) (puthash (cl-second result) @@ -3330,7 +3935,7 @@ If nil, the whole Array is treated as a JS symbol.") :process (inferior-moz-process)) js--js-references))) - (`error (signal 'js-js-error (list (cl-second result)))) + ('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) @@ -3715,8 +4320,8 @@ If one hasn't been set, or if it's stale, prompt for a new one." (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) + ('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: "))) @@ -3725,8 +4330,8 @@ If one hasn't been set, or if it's stale, prompt for a new one." (defun js--js-content-window (context) (with-js (pcase (car context) - (`window (cdr context)) - (`browser (js< (cdr context) + ('window (cdr context)) + ('browser (js< (cdr context) "contentWindow" "wrappedJSObject")) (x (error "Unmatched case in js--js-content-window: %S" x))))) @@ -3846,6 +4451,77 @@ If one hasn't been set, or if it's stale, prompt for a new one." (when temp-name (delete-file temp-name)))))) +;;; Syntax extensions + +(defvar js-syntactic-mode-name t + "If non-nil, print enabled syntaxes in the mode name.") + +(defun js--syntactic-mode-name-part () + "Return a string like “[JSX]” when `js-jsx-syntax' is enabled." + (if js-syntactic-mode-name + (let (syntaxes) + (if js-jsx-syntax (push "JSX" syntaxes)) + (if syntaxes + (concat "[" (mapconcat #'identity syntaxes ",") "]") + "")) + "")) + +(defun js-use-syntactic-mode-name () + "Print enabled syntaxes if `js-syntactic-mode-name' is t. +Modes deriving from `js-mode' should call this to ensure that +their `mode-name' updates to show enabled syntax extensions." + (when (stringp mode-name) + (setq mode-name `(,mode-name (:eval (js--syntactic-mode-name-part)))))) + +(defun js-jsx-enable () + "Enable JSX in the current buffer." + (interactive) + (setq-local js-jsx-syntax t)) + +;; To make discovering and using syntax extensions features easier for +;; users (who might not read the docs), try to safely and +;; automatically enable syntax extensions based on heuristics. + +(defvar js-jsx-regexps + (list "\\_<\\(?:var\\|let\\|const\\|import\\)\\_>.*?React") + "Regexps for detecting JSX in JavaScript buffers. +When `js-jsx-detect-syntax' is non-nil and any of these regexps +match text near the beginning of a JavaScript buffer, +`js-jsx-syntax' (which see) will be made buffer-local and set to +t.") + +(defun js-jsx--detect-and-enable (&optional arbitrarily) + "Detect if JSX is likely to be used, and enable it if so. +Might make `js-jsx-syntax' buffer-local and set it to t. Matches +from the beginning of the buffer, unless optional arg ARBITRARILY +is non-nil. Return t after enabling, nil otherwise." + (when (or (and (buffer-file-name) + (string-match-p "\\.jsx\\'" (buffer-file-name))) + (and js-jsx-detect-syntax + (save-excursion + (unless arbitrarily + (goto-char (point-min))) + (catch 'match + (mapc + (lambda (regexp) + (if (re-search-forward regexp 4000 t) (throw 'match t))) + js-jsx-regexps) + nil)))) + (js-jsx-enable) + t)) + +(defun js-jsx--detect-after-change (beg end _len) + "Detect if JSX is likely to be used after a change. +This function is intended for use in `after-change-functions'." + (when (<= end 4000) + (save-excursion + (goto-char beg) + (beginning-of-line) + (save-restriction + (narrow-to-region (point) end) + (when (js-jsx--detect-and-enable 'arbitrarily) + (remove-hook 'after-change-functions #'js-jsx--detect-after-change t)))))) + ;;; Main Function ;;;###autoload @@ -3861,16 +4537,20 @@ If one hasn't been set, or if it's stale, prompt for a new one." '(font-lock-syntactic-face-function . js-font-lock-syntactic-face-function))) (setq-local syntax-propertize-function #'js-syntax-propertize) + (add-hook 'syntax-propertize-extend-region-functions + #'syntax-propertize-multiline 'append 'local) + (add-hook 'syntax-propertize-extend-region-functions + #'js--syntax-propertize-extend-region 'append 'local) (setq-local prettify-symbols-alist js--prettify-symbols-alist) (setq-local parse-sexp-ignore-comments t) - (setq-local parse-sexp-lookup-properties t) (setq-local which-func-imenu-joiner-function #'js--which-func-joiner) ;; Comments (setq-local comment-start "// ") + (setq-local comment-start-skip "\\(//+\\|/\\*+\\)\\s *") (setq-local comment-end "") - (setq-local fill-paragraph-function #'js-c-fill-paragraph) + (setq-local fill-paragraph-function #'js-fill-paragraph) (setq-local normal-auto-fill-function #'js-do-auto-fill) ;; Parse cache @@ -3879,6 +4559,11 @@ If one hasn't been set, or if it's stale, prompt for a new one." ;; Frameworks (js--update-quick-match-re) + ;; Syntax extensions + (unless (js-jsx--detect-and-enable) + (add-hook 'after-change-functions #'js-jsx--detect-after-change nil t)) + (js-use-syntactic-mode-name) + ;; Imenu (setq imenu-case-fold-search nil) (setq imenu-create-index-function #'js--imenu-create-index) @@ -3889,8 +4574,7 @@ If one hasn't been set, or if it's stale, prompt for a new one." c-paragraph-separate "$" c-block-comment-prefix "* " c-line-comment-starter "//" - c-comment-start-regexp "/[*/]\\|\\s!" - comment-start-skip "\\(//+\\|/\\*+\\)\\s *") + c-comment-start-regexp "/[*/]\\|\\s!") (setq-local comment-line-break-function #'c-indent-new-comment-line) (setq-local c-block-comment-start-regexp "/\\*") (setq-local comment-multi-line t) @@ -3923,19 +4607,33 @@ If one hasn't been set, or if it's stale, prompt for a new one." ;;(syntax-propertize (point-max)) ) -;;;###autoload -(define-derived-mode js-jsx-mode js-mode "JSX" - "Major mode for editing JSX. - -To customize the indentation for this mode, set the SGML offset -variables (`sgml-basic-offset', `sgml-attribute-offset' et al.) -locally, like so: +;; Since we made JSX support available and automatically-enabled in +;; the base `js-mode' (for ease of use), now `js-jsx-mode' simply +;; serves as one other interface to unconditionally enable JSX in +;; buffers, mostly for backwards-compatibility. +;; +;; Since it is probably more common for packages to integrate with +;; `js-mode' than with `js-jsx-mode', it is therefore probably +;; slightly better for users to use one of the many other methods for +;; enabling JSX syntax. But using `js-jsx-mode' can’t be that bad +;; either, so we won’t bother users with an obsoletion warning. - (defun set-jsx-indentation () - (setq-local sgml-basic-offset js-indent-level)) - (add-hook \\='js-jsx-mode-hook #\\='set-jsx-indentation)" +;;;###autoload +(define-derived-mode js-jsx-mode js-mode "JavaScript" + "Major mode for editing JavaScript+JSX. + +Simply makes `js-jsx-syntax' buffer-local and sets it to t. + +`js-mode' may detect and enable support for JSX automatically if +it appears to be used in a JavaScript file. You could also +customize `js-jsx-regexps' to improve that detection; or, you +could set `js-jsx-syntax' to t in your init file, or in a +.dir-locals.el file, or using file variables; or, you could call +`js-jsx-enable' in `js-mode-hook'. You may be better served by +one of the aforementioned options instead of using this mode." :group 'js - (setq-local indent-line-function #'js-jsx-indent-line)) + (js-jsx-enable) + (js-use-syntactic-mode-name)) ;;;###autoload (defalias 'javascript-mode 'js-mode) diff --git a/lisp/progmodes/ld-script.el b/lisp/progmodes/ld-script.el index 6dafb64ed50..8cc7f2d7d7b 100644 --- a/lisp/progmodes/ld-script.el +++ b/lisp/progmodes/ld-script.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2001-2019 Free Software Foundation, Inc. -;; Author: Masatake YAMATO<jet@gyve.org> +;; Author: Masatake YAMATO <yamato@redhat.com> ;; Keywords: languages, faces ;; This file is part of GNU Emacs. diff --git a/lisp/progmodes/m4-mode.el b/lisp/progmodes/m4-mode.el index 7a1f0a86466..98b812f52f6 100644 --- a/lisp/progmodes/m4-mode.el +++ b/lisp/progmodes/m4-mode.el @@ -63,10 +63,9 @@ If m4 is not in your PATH, set this to an absolute file name." ;;(defconst m4-program-options '("--prefix-builtins")) (defvar m4-font-lock-keywords - `( - ("\\(\\_<\\(m4_\\)?dnl\\_>\\).*$" . font-lock-comment-face) + '(("\\(\\_<\\(m4_\\)?dnl\\_>\\).*$" . font-lock-comment-face) ("\\$[*#@0-9]" . font-lock-variable-name-face) - ("\\$\\@" . font-lock-variable-name-face) + ("\\$@" . font-lock-variable-name-face) ("\\$\\*" . font-lock-variable-name-face) ("\\_<\\(m4_\\)?\\(builtin\\|change\\(com\\|quote\\|word\\)\\|d\\(e\\(bug\\(file\\|mode\\)\\|cr\\|f\\(ine\\|n\\)\\)\\|iv\\(ert\\|num\\)\\|nl\\|umpdef\\)\\|e\\(rrprint\\|syscmd\\|val\\)\\|f\\(ile\\|ormat\\)\\|gnu\\|i\\(f\\(def\\|else\\)\\|n\\(c\\(lude\\|r\\)\\|d\\(ex\\|ir\\)\\)\\)\\|l\\(en\\|ine\\)\\|m\\(4\\(exit\\|wrap\\)\\|aketemp\\)\\|p\\(atsubst\\|opdef\\|ushdef\\)\\|regexp\\|s\\(hift\\|include\\|ubstr\\|ys\\(cmd\\|val\\)\\)\\|tra\\(ceo\\(ff\\|n\\)\\|nslit\\)\\|un\\(d\\(efine\\|ivert\\)\\|ix\\)\\)\\_>" . font-lock-keyword-face)) "Default `font-lock-keywords' for M4 mode.") diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el index 7b00857ea95..cffb749c3e8 100644 --- a/lisp/progmodes/make-mode.el +++ b/lisp/progmodes/make-mode.el @@ -343,7 +343,7 @@ not be enclosed in { } or ( )." "List of keywords understood by gmake.") (defconst makefile-bsdmake-statements - `(".elif" ".elifdef" ".elifmake" ".elifndef" ".elifnmake" ".else" ".endfor" + '(".elif" ".elifdef" ".elifmake" ".elifndef" ".elifnmake" ".else" ".endfor" ".endif" ".for" ".if" ".ifdef" ".ifmake" ".ifndef" ".ifnmake" ".undef") "List of keywords understood by BSD make.") @@ -557,6 +557,9 @@ This should identify a `make' command that can handle the `-q' option." :type 'string :group 'makefile) +(defvaralias 'makefile-query-one-target-method + 'makefile-query-one-target-method-function) + (defcustom makefile-query-one-target-method-function 'makefile-query-by-make-minus-q "Function to call to determine whether a make target is up to date. @@ -574,8 +577,6 @@ The function must satisfy this calling convention: makefile, any nonzero integer value otherwise." :type 'function :group 'makefile) -(defvaralias 'makefile-query-one-target-method - 'makefile-query-one-target-method-function) (defcustom makefile-up-to-date-buffer-name "*Makefile Up-to-date overview*" "Name of the Up-to-date overview buffer." @@ -712,6 +713,7 @@ The function must satisfy this calling convention: (modify-syntax-entry ?# "< " st) (modify-syntax-entry ?\n "> " st) (modify-syntax-entry ?= "." st) + (modify-syntax-entry ?$ "." st) st) "Syntax table used in `makefile-mode'.") diff --git a/lisp/progmodes/meta-mode.el b/lisp/progmodes/meta-mode.el index 34b8bbbd399..8d3745be7c9 100644 --- a/lisp/progmodes/meta-mode.el +++ b/lisp/progmodes/meta-mode.el @@ -666,7 +666,7 @@ If the list was changed, sort the list and remove duplicates first." (let ((count 0)) (narrow-to-region (point) (save-excursion - (re-search-forward "[^\\\\\"]%\\|\n\\|\\'" nil t) + (re-search-forward "[^\\\"]%\\|\n\\|\\'" nil t) (backward-char) (point))) (while (re-search-forward "\\<\\sw+\\>\\|(\\|)" nil t) (save-excursion diff --git a/lisp/progmodes/mixal-mode.el b/lisp/progmodes/mixal-mode.el index 2bf758bdaff..a759709b5c8 100644 --- a/lisp/progmodes/mixal-mode.el +++ b/lisp/progmodes/mixal-mode.el @@ -1044,7 +1044,7 @@ EXECUTION-TIME holds info about the time it takes, number or string.") . mixal-font-lock-operation-code-face) (,(regexp-opt mixal-assembly-pseudoinstructions 'words) . mixal-font-lock-assembly-pseudoinstruction-face) - ("^[A-Z0-9a-z]*[ \t]+[A-ZO-9a-z]+[ \t]+\\(=.*=\\)" + ("^[A-Z0-9a-z]*[ \t]+[A-Z0-9a-z]+[ \t]+\\(=.*=\\)" (1 font-lock-constant-face))) "Keyword highlighting specification for `mixal-mode'.") ;; (makunbound 'mixal-font-lock-keywords) @@ -1108,7 +1108,7 @@ Assumes that file has been compiled with debugging support." (set (make-local-variable 'comment-start) "*") (set (make-local-variable 'comment-start-skip) "^\\*[ \t]*") (set (make-local-variable 'font-lock-defaults) - `(mixal-font-lock-keywords)) + '(mixal-font-lock-keywords)) (set (make-local-variable 'syntax-propertize-function) mixal-syntax-propertize-function) ;; might add an indent function in the future diff --git a/lisp/progmodes/modula2.el b/lisp/progmodes/modula2.el index 582e495a2bf..aa412304c59 100644 --- a/lisp/progmodes/modula2.el +++ b/lisp/progmodes/modula2.el @@ -232,11 +232,11 @@ ;; FIXME: "^." are two tokens, not one. (defun m2-smie-forward-token () (pcase (smie-default-forward-token) - (`"VAR" (if (zerop (car (syntax-ppss))) "VAR" "VAR-arg")) - (`"CONST" (if (zerop (car (syntax-ppss))) "CONST" "CONST-arg")) - (`";" (save-excursion (m2-smie-refine-semi))) - (`"OF" (save-excursion (forward-char -2) (m2-smie-refine-of))) - (`":" (save-excursion (forward-char -1) (m2-smie-refine-colon))) + ("VAR" (if (zerop (car (syntax-ppss))) "VAR" "VAR-arg")) + ("CONST" (if (zerop (car (syntax-ppss))) "CONST" "CONST-arg")) + (";" (save-excursion (m2-smie-refine-semi))) + ("OF" (save-excursion (forward-char -2) (m2-smie-refine-of))) + (":" (save-excursion (forward-char -1) (m2-smie-refine-colon))) ;; (`"END" (if (and (looking-at "[ \t\n]*\\(\\(?:\\sw\\|\\s_\\)+\\)") ;; (not (assoc (match-string 1) m2-smie-grammar))) ;; "END-proc" "END")) @@ -244,11 +244,11 @@ (defun m2-smie-backward-token () (pcase (smie-default-backward-token) - (`"VAR" (if (zerop (car (syntax-ppss))) "VAR" "VAR-arg")) - (`"CONST" (if (zerop (car (syntax-ppss))) "CONST" "CONST-arg")) - (`";" (save-excursion (forward-char 1) (m2-smie-refine-semi))) - (`"OF" (save-excursion (m2-smie-refine-of))) - (`":" (save-excursion (m2-smie-refine-colon))) + ("VAR" (if (zerop (car (syntax-ppss))) "VAR" "VAR-arg")) + ("CONST" (if (zerop (car (syntax-ppss))) "CONST" "CONST-arg")) + (";" (save-excursion (forward-char 1) (m2-smie-refine-semi))) + ("OF" (save-excursion (m2-smie-refine-of))) + (":" (save-excursion (m2-smie-refine-colon))) ;; (`"END" (if (and (looking-at "\\sw+[ \t\n]+\\(\\(?:\\sw\\|\\s_\\)+\\)") ;; (not (assoc (match-string 1) m2-smie-grammar))) ;; "END-proc" "END")) @@ -270,16 +270,16 @@ ;; - The inner VAR/TYPE are indented just like the outer VAR/TYPE. ;; - The inner PROCEDURE is not aligned with its VAR/TYPE siblings. (pcase (cons kind token) - (`(:elem . basic) m2-indent) - (`(:after . ":=") (or m2-indent smie-indent-basic)) - (`(:after . ,(or `"CONST" `"VAR" `"TYPE")) + ('(:elem . basic) m2-indent) + ('(:after . ":=") (or m2-indent smie-indent-basic)) + (`(:after . ,(or "CONST" "VAR" "TYPE")) (or m2-indent smie-indent-basic)) ;; (`(:before . ,(or `"VAR" `"TYPE" `"CONST")) ;; (if (smie-rule-parent-p "PROCEDURE") 0)) - (`(:after . ";-block") + ('(:after . ";-block") (if (smie-rule-parent-p "PROCEDURE") (smie-rule-parent (or m2-indent smie-indent-basic)))) - (`(:before . "|") (smie-rule-separator kind)) + ('(:before . "|") (smie-rule-separator kind)) )) ;;;###autoload diff --git a/lisp/progmodes/octave.el b/lisp/progmodes/octave.el index 6caf8d93d3f..b770edb7bcb 100644 --- a/lisp/progmodes/octave.el +++ b/lisp/progmodes/octave.el @@ -170,8 +170,8 @@ parenthetical grouping.") (modify-syntax-entry ?. "." table) (modify-syntax-entry ?\" "\"" table) (modify-syntax-entry ?_ "_" table) - ;; The "b" flag only applies to the second letter of the comstart - ;; and the first letter of the comend, i.e. the "4b" below is ineffective. + ;; The "b" flag only applies to the second letter of the comstart and + ;; the first letter of the comend, i.e. a "4b" below would be ineffective. ;; If we try to put `b' on the single-line comments, we get a similar ;; problem where the % and # chars appear as first chars of the 2-char ;; comend, so the multi-line ender is also turned into style-b. @@ -198,6 +198,7 @@ newline or semicolon after an else or end keyword." (defcustom octave-block-offset 2 "Extra indentation applied to statements in Octave block structures." :type 'integer) +(put 'octave-block-offset 'safe-local-variable 'integerp) (defvar octave-block-comment-start (concat (make-string 2 octave-comment-char) " ") @@ -288,6 +289,7 @@ Non-nil means always go to the next Octave code line after sending." ("methods" exp "endmethods") ("properties" exp "endproperties") ("classdef" exp "endclassdef") + ("spmd" exp "endspmd") )) (bnf-table @@ -442,12 +444,12 @@ Non-nil means always go to the next Octave code line after sending." ;; disadvantages: ;; - changes to octave-block-offset wouldn't take effect immediately. ;; - edebug wouldn't show the use of this variable. - (`(:elem . basic) octave-block-offset) + ('(:elem . basic) octave-block-offset) (`(:list-intro . ,(or "global" "persistent")) t) ;; Since "case" is in the same BNF rules as switch..end, SMIE by default ;; aligns it with "switch". - (`(:before . "case") (if (not (smie-rule-sibling-p)) octave-block-offset)) - (`(:after . ";") + ('(:before . "case") (if (not (smie-rule-sibling-p)) octave-block-offset)) + ('(:after . ";") (if (apply #'smie-rule-parent-p octave--block-offset-keywords) (smie-rule-parent octave-block-offset) ;; For (invalid) code between switch and case. @@ -533,6 +535,27 @@ Non-nil means always go to the next Octave code line after sending." (defvar electric-layout-rules) +;; FIXME: cc-mode.el also adds an entry for .m files, mapping them to +;; objc-mode. We here rely on the fact that loaddefs.el is filled in +;; alphabetical order, so cc-mode.el comes before octave-mode.el, which lets +;; our entry come first! +;;;###autoload (add-to-list 'auto-mode-alist '("\\.m\\'" . octave-maybe-mode)) + +;;;###autoload +(defun octave-maybe-mode () + "Select `octave-mode' if the current buffer seems to hold Octave code." + (if (save-excursion + (with-syntax-table octave-mode-syntax-table + (goto-char (point-min)) + (forward-comment (point-max)) + ;; FIXME: What about Octave files which don't start with "function"? + (looking-at "function"))) + (octave-mode) + (let ((x (rassq 'octave-maybe-mode auto-mode-alist))) + (when x + (let ((auto-mode-alist (remove x auto-mode-alist))) + (set-auto-mode)))))) + ;;;###autoload (define-derived-mode octave-mode prog-mode "Octave" "Major mode for editing Octave code. @@ -639,6 +662,9 @@ mode, include \"-q\" and \"--traditional\"." :type '(repeat string) :version "24.4") +(define-obsolete-variable-alias 'inferior-octave-startup-hook + 'inferior-octave-mode-hook "24.4") + (defcustom inferior-octave-mode-hook nil "Hook to be run when Inferior Octave mode is started." :type 'hook) @@ -693,9 +719,6 @@ mode, include \"-q\" and \"--traditional\"." (defvar inferior-octave-output-string nil) (defvar inferior-octave-receive-in-progress nil) -(define-obsolete-variable-alias 'inferior-octave-startup-hook - 'inferior-octave-mode-hook "24.4") - (defvar inferior-octave-dynamic-complete-functions '(inferior-octave-completion-at-point comint-filename-completion) "List of functions called to perform completion for inferior Octave. @@ -1044,8 +1067,8 @@ directory and makes this the current buffer's default directory." (unless found (goto-char orig)) found)))) (pcase (and buffer-file-name (file-name-extension buffer-file-name)) - (`"cc" (funcall search - "\\_<DEFUN\\(?:_DLD\\)?\\s-*(\\s-*\\(\\(?:\\sw\\|\\s_\\)+\\)" 1)) + ("cc" (funcall search + "\\_<DEFUN\\(?:_DLD\\)?\\s-*(\\s-*\\(\\(?:\\sw\\|\\s_\\)+\\)" 1)) (_ (funcall search octave-function-header-regexp 3))))) (defun octave-function-file-p () @@ -1114,19 +1137,19 @@ q: Don't fix\n" func file)) (read-char-choice "Which name to use? (a/b/q) " '(?a ?b ?q)))))) (pcase c - (`?a (let ((newname (expand-file-name - (concat func (file-name-extension - buffer-file-name t))))) - (when (or (not (file-exists-p newname)) - (yes-or-no-p - (format "Target file %s exists; proceed? " newname))) - (when (file-exists-p buffer-file-name) - (rename-file buffer-file-name newname t)) - (set-visited-file-name newname)))) - (`?b (save-excursion - (goto-char name-start) - (delete-region name-start name-end) - (insert file))))))))) + (?a (let ((newname (expand-file-name + (concat func (file-name-extension + buffer-file-name t))))) + (when (or (not (file-exists-p newname)) + (yes-or-no-p + (format "Target file %s exists; proceed? " newname))) + (when (file-exists-p buffer-file-name) + (rename-file buffer-file-name newname t)) + (set-visited-file-name newname)))) + (?b (save-excursion + (goto-char name-start) + (delete-region name-start name-end) + (insert file))))))))) (defun octave-update-function-file-comment (beg end) "Query replace function names in function file comment." @@ -1165,6 +1188,8 @@ q: Don't fix\n" func file)) "Face used to highlight function comment block.") (eval-when-compile (require 'texinfo)) +;; Undo the effects of texinfo loading tex-mode loading compile. +(declare-function compilation-forget-errors "compile" ()) (defun octave-font-lock-texinfo-comment () (let ((kws @@ -1607,12 +1632,7 @@ code line." (paren-pos (cadr ppss)) (fn (save-excursion (if (and paren-pos - ;; PAREN-POS must be after the prompt - (>= paren-pos - (if (eq (get-buffer-process (current-buffer)) - inferior-octave-process) - (process-mark inferior-octave-process) - (point-min))) + ;; PAREN-POS must be after the prompt. (or (not (eq (get-buffer-process (current-buffer)) inferior-octave-process)) (< (process-mark inferior-octave-process) @@ -1629,11 +1649,11 @@ code line." ;; ;; Return the value according to style. (pcase octave-eldoc-message-style - (`auto (if (< (length oneline) (window-width (minibuffer-window))) + ('auto (if (< (length oneline) (window-width (minibuffer-window))) oneline multiline)) - (`oneline oneline) - (`multiline multiline))))) + ('oneline oneline) + ('multiline multiline))))) (defcustom octave-help-buffer "*Octave Help*" "Buffer name for `octave-help'." @@ -1668,7 +1688,7 @@ code line." (eval-and-compile (require 'help-mode)) ;; Don't highlight `EXAMPLE' as elisp symbols by using a regexp that ;; can never match. - (setq-local help-xref-symbol-regexp "x\\`")) + (setq-local help-xref-symbol-regexp regexp-unmatchable)) (defun octave-help (fn) "Display the documentation of FN." @@ -1778,19 +1798,19 @@ If the environment variable OCTAVE_SRCDIR is set, it is searched first." (defun octave-find-definition-default-filename (name) "Default value for `octave-find-definition-filename-function'." (pcase (file-name-extension name) - (`"oct" + ("oct" (octave-find-definition-default-filename (concat "libinterp/dldfcn/" (file-name-sans-extension (file-name-nondirectory name)) ".cc"))) - (`"cc" + ("cc" (let ((file (or (locate-file name (octave-source-directories)) (locate-file (file-name-nondirectory name) (octave-source-directories))))) (or (and file (file-exists-p file)) (error "File `%s' not found" name)) file)) - (`"mex" + ("mex" (if (yes-or-no-p (format-message "File `%s' may be binary; open? " (file-name-nondirectory name))) name diff --git a/lisp/progmodes/opascal.el b/lisp/progmodes/opascal.el index cfacbe01e10..95589c2add1 100644 --- a/lisp/progmodes/opascal.el +++ b/lisp/progmodes/opascal.el @@ -42,6 +42,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defgroup opascal nil "Major mode for editing OPascal source in Emacs." :version "24.4" @@ -140,17 +142,13 @@ That is, regardless of where in the line point is at the time." opascal-directives) "OPascal4 keywords.") -(defconst opascal-previous-terminators `(semicolon comma) +(defconst opascal-previous-terminators '(semicolon comma) "Expression/statement terminators that denote a previous expression.") (defconst opascal-comments '(comment-single-line comment-multi-line-1 comment-multi-line-2) "Tokens that represent comments.") -(defconst opascal-strings - '(string double-quoted-string) - "Tokens that represent string literals.") - (defconst opascal-whitespace `(space newline ,@opascal-comments) "Tokens that are considered whitespace.") @@ -186,7 +184,7 @@ are followed by an expression.") `(except finally ,@opascal-visibilities) "Statements that mark mid sections of the enclosing block.") -(defconst opascal-end-block-statements `(end until) +(defconst opascal-end-block-statements '(end until) "Statements that end block sections.") (defconst opascal-match-block-statements @@ -210,7 +208,7 @@ are followed by an expression.") '(interface implementation program library package) "Unit sections within which the indent is 0.") -(defconst opascal-use-clauses `(uses requires exports contains) +(defconst opascal-use-clauses '(uses requires exports contains) "Statements that refer to foreign symbols.") (defconst opascal-unit-statements @@ -274,15 +272,17 @@ routine.") (defmacro opascal-save-excursion (&rest forms) ;; Executes the forms such that any movements have no effect, including ;; searches. + (declare (debug t)) `(save-excursion (save-match-data (let ((inhibit-point-motion-hooks t) (deactivate-mark nil)) (progn ,@forms))))) -(defsubst opascal-is (element in-set) - ;; If the element is in the set, the element cdr is returned, otherwise nil. - (memq element in-set)) + +(eval-when-compile + (pcase-defmacro opascal--in (set) + `(pred (pcase--flip memq ,set)))) (defun opascal-string-of (start end) ;; Returns the buffer string from start to end. @@ -393,17 +393,17 @@ routine.") (if (null (nth 8 ppss)) (when (looking-at opascal--literal-start-re) (pcase (char-after) - (`?/ 'comment-single-line) - (`?\{ 'comment-multi-line-1) - (`?\( 'comment-multi-line-2) - (`?\' 'string) - (`?\" 'double-quoted-string))) + (?/ 'comment-single-line) + (?\{ 'comment-multi-line-1) + (?\( 'comment-multi-line-2) + (?\' 'string) + (?\" 'double-quoted-string))) (if (nth 3 ppss) ;String. (if (eq (nth 3 ppss) ?\") 'double-quoted-string 'string) (pcase (nth 7 ppss) - (`2 'comment-single-line) - (`1 'comment-multi-line-2) + (2 'comment-single-line) + (1 'comment-multi-line-2) (_ 'comment-multi-line-1)))))))) (defun opascal-literal-start-pattern (literal-kind) @@ -415,15 +415,6 @@ routine.") (string . "'") (double-quoted-string . "\""))))) -(defun opascal-literal-end-pattern (literal-kind) - ;; Returns the end pattern of the literal kind. - (cdr (assoc literal-kind - '((comment-single-line . "\n") - (comment-multi-line-1 . "}") - (comment-multi-line-2 . "*)") - (string . "'") - (double-quoted-string . "\""))))) - (defun opascal-literal-stop-pattern (literal-kind) ;; Returns the pattern that delimits end of the search for the literal kind. ;; These are regular expressions. @@ -495,7 +486,7 @@ routine.") (let* ((word-image (downcase (opascal-token-string word))) (keyword (intern-soft word-image))) (when (and (or keyword (string= "nil" word-image)) - (opascal-is keyword opascal-keywords)) + (memq keyword opascal-keywords)) (opascal-set-token-kind word keyword)) word)))) @@ -562,7 +553,7 @@ routine.") (let (next-token) (while (progn (setq next-token (opascal-next-token token)) - (opascal-is (opascal-token-kind next-token) '(space newline)))) + (memq (opascal-token-kind next-token) '(space newline)))) next-token)) (defun opascal-group-start (from-token) @@ -608,6 +599,18 @@ routine.") indent (if offset offset 0))) indent)) +(defmacro opascal--scan-non-whitespace-backward (token-var last-var + &rest pcases) + (declare (debug (symbolp symbolp &rest (pcase-PAT body))) + (indent 2)) + `(let ((,token-var ,token-var)) + (while (setq ,token-var (opascal-previous-token ,token-var)) + ,(macroexp-let2 nil kind-var `(opascal-token-kind ,token-var) + `(unless (memq ,kind-var opascal-whitespace) + (pcase ,kind-var + ,@pcases) + ,(when last-var `(setq ,last-var ,token-var))))))) + (defun opascal-line-indent-of (from-token &optional offset &rest terminators) ;; Returns the column of first non-space character on the token's line, plus ;; any offset. We also stop if one of the terminators or an open ( or [ is @@ -616,6 +619,8 @@ routine.") (last-token from-token) (kind nil)) (catch 'done + ;; FIXME: Can't use opascal--scan-non-whitespace-backward here, because + ;; we do need to pay attention to `newline'! (while token (setq kind (opascal-token-kind token)) (cond @@ -623,11 +628,11 @@ routine.") ((eq 'close-group kind) (setq token (opascal-group-start token))) ;; Stop at the beginning of the line or an open group. - ((opascal-is kind '(newline open-group)) (throw 'done nil)) + ((memq kind '(newline open-group)) (throw 'done nil)) ;; Stop at one of the specified terminators. - ((opascal-is kind terminators) (throw 'done nil))) - (unless (opascal-is kind opascal-whitespace) (setq last-token token)) + ((memq kind terminators) (throw 'done nil))) + (unless (memq kind opascal-whitespace) (setq last-token token)) (setq token (opascal-previous-token token)))) (opascal-indent-of last-token offset))) @@ -638,23 +643,25 @@ routine.") (last-token from-token) (kind nil)) (catch 'done + ;; FIXME: Can't use opascal--scan-non-whitespace-backward here, because + ;; we do need to pay attention to `newline'! (while token (setq kind (opascal-token-kind token)) (cond ((and (eq 'colon kind) - (opascal-is (opascal-token-kind last-token) - `(,@opascal-block-statements - ,@opascal-expr-statements))) + (memq (opascal-token-kind last-token) + `(,@opascal-block-statements + ,@opascal-expr-statements))) ;; We hit a label followed by a statement. Indent to the statement. (throw 'done nil)) ;; Skip over ()/[] groups. ((eq 'close-group kind) (setq token (opascal-group-start token))) - ((opascal-is kind `(newline open-group ,@opascal-use-clauses)) + ((memq kind `(newline open-group ,@opascal-use-clauses)) ;; Stop at the beginning of the line, an open group, or a use clause (throw 'done nil))) - (unless (opascal-is kind opascal-whitespace) (setq last-token token)) + (unless (memq kind opascal-whitespace) (setq last-token token)) (setq token (opascal-previous-token token)))) (opascal-indent-of last-token offset))) @@ -671,7 +678,7 @@ routine.") ;; dispinterface), (= interface), (= object), or (= record), and nil ;; otherwise. (if (and (eq 'equals (opascal-token-kind token)) - (opascal-is (opascal-token-kind last-token) opascal-composite-types)) + (memq (opascal-token-kind last-token) opascal-composite-types)) last-token)) (defun opascal-is-simple-class-type (at-token limit-token) @@ -679,7 +686,7 @@ routine.") ;; class of TClass; ;; class (TBaseClass); ;; class; - (when (opascal-is (opascal-token-kind at-token) opascal-class-types) + (when (memq (opascal-token-kind at-token) opascal-class-types) (catch 'done ;; Scan until the semi colon. (let ((token (opascal-next-token at-token)) @@ -695,7 +702,7 @@ routine.") ((eq 'open-group token-kind) (setq token (opascal-group-end token))) ;; Only allow "of" and whitespace, and an identifier - ((opascal-is token-kind `(of word ,@opascal-whitespace))) + ((memq token-kind `(of word ,@opascal-whitespace))) ;; Otherwise we are not in a simple class declaration. ((throw 'done nil))) @@ -703,85 +710,76 @@ routine.") (defun opascal-block-start (from-token &optional stop-on-class) ;; Returns the token that denotes the start of the block. - (let ((token (opascal-previous-token from-token)) - (last-token nil) - (token-kind nil)) + (let ((token from-token) + (last-token nil)) (catch 'done - (while token - (setq token-kind (opascal-token-kind token)) - (cond - ;; Skip over nested blocks. - ((opascal-is token-kind opascal-end-block-statements) - (setq token (opascal-block-start token))) - - ;; Regular block start found. - ((opascal-is token-kind opascal-block-statements) - (throw 'done - ;; As a special case, when a "case" block appears - ;; within a record declaration (to denote a variant - ;; part), the record declaration should be considered - ;; the enclosing block. - (if (eq 'case token-kind) - (let ((enclosing-token - (opascal-block-start token - 'stop-on-class))) - (if - (eq 'record - (opascal-token-kind enclosing-token)) - (if stop-on-class - enclosing-token - (opascal-previous-token enclosing-token)) - token)) - token))) - - ;; A class/record start also begins a block. - ((opascal-composite-type-start token last-token) - (throw 'done (if stop-on-class last-token token))) - ) - (unless (opascal-is token-kind opascal-whitespace) - (setq last-token token)) - (setq token (opascal-previous-token token))) + (opascal--scan-non-whitespace-backward token last-token + ;; Skip over nested blocks. + ((opascal--in opascal-end-block-statements) + (setq token (opascal-block-start token))) + + ;; Case block start found. + ('case + (throw 'done + ;; As a special case, when a "case" block appears + ;; within a record declaration (to denote a variant + ;; part), the record declaration should be considered + ;; the enclosing block. + (let ((enclosing-token + (opascal-block-start token + 'stop-on-class))) + (if (eq 'record + (opascal-token-kind enclosing-token)) + (if stop-on-class + enclosing-token + (opascal-previous-token enclosing-token)) + token)))) + + ;; Regular block start found. + ((opascal--in opascal-block-statements) + (throw 'done token)) + + ;; A class/record start also begins a block. + ((guard (opascal-composite-type-start token last-token)) + (throw 'done (if stop-on-class last-token token))) + ) ;; Start not found. nil))) (defun opascal-else-start (from-else) ;; Returns the token of the if or case statement. - (let ((token (opascal-previous-token from-else)) - (token-kind nil) + (let ((token from-else) (semicolon-count 0)) (catch 'done - (while token - (setq token-kind (opascal-token-kind token)) - (cond - ;; Skip over nested groups. - ((eq 'close-group token-kind) (setq token (opascal-group-start token))) - - ;; Skip over any nested blocks. - ((opascal-is token-kind opascal-end-block-statements) - (setq token (opascal-block-start token))) - - ((eq 'semicolon token-kind) - ;; Semicolon means we are looking for an enclosing if, unless we - ;; are in a case statement. Keep counts of the semicolons and decide - ;; later. - (setq semicolon-count (1+ semicolon-count))) - - ((and (eq 'if token-kind) (= semicolon-count 0)) - ;; We only can match an if when there have been no intervening - ;; semicolons. - (throw 'done token)) - - ((eq 'case token-kind) - ;; We have hit a case statement start. - (throw 'done token))) - (setq token (opascal-previous-token token))) + (opascal--scan-non-whitespace-backward token nil + ;; Skip over nested groups. + ('close-group (setq token (opascal-group-start token))) + + ;; Skip over any nested blocks. + ((opascal--in opascal-end-block-statements) + (setq token (opascal-block-start token))) + + ('semicolon + ;; Semicolon means we are looking for an enclosing if, unless we + ;; are in a case statement. Keep counts of the semicolons and decide + ;; later. + (setq semicolon-count (1+ semicolon-count))) + + ((and 'if (guard (= semicolon-count 0))) + ;; We only can match an if when there have been no intervening + ;; semicolons. + (throw 'done token)) + + ('case + ;; We have hit a case statement start. + (throw 'done token))) ;; No if or case statement found. nil))) (defun opascal-comment-content-start (comment) ;; Returns the point of the first non-space character in the comment. (let ((kind (opascal-token-kind comment))) - (when (opascal-is kind opascal-comments) + (when (memq kind opascal-comments) (opascal-save-excursion (goto-char (+ (opascal-token-start comment) (length (opascal-literal-start-pattern kind)))) @@ -851,7 +849,8 @@ routine.") (opascal-indent-of comment)) ;; Indent according to the comment's content start. - ((opascal-column-of (opascal-comment-content-start comment))))))) + (t + (opascal-column-of (opascal-comment-content-start comment))))))) )) (defun opascal-is-use-clause-end (at-token last-token last-colon from-kind) @@ -861,439 +860,426 @@ routine.") (eq 'comma (opascal-token-kind at-token)) (eq 'semicolon from-kind)) ;; Scan for the uses statement, just to be sure. - (let ((token (opascal-previous-token at-token)) - (token-kind nil)) + (let ((token at-token)) (catch 'done - (while token - (setq token-kind (opascal-token-kind token)) - (cond ((opascal-is token-kind opascal-use-clauses) - (throw 'done t)) - - ;; Whitespace, identifiers, strings, "in" keyword, and commas - ;; are allowed in use clauses. - ((or (opascal-is token-kind '(word comma in newline)) - (opascal-is token-kind opascal-whitespace) - (opascal-is token-kind opascal-strings))) - - ;; Nothing else is. - ((throw 'done nil))) - (setq token (opascal-previous-token token))) + (opascal--scan-non-whitespace-backward token nil + ((opascal--in opascal-use-clauses) + (throw 'done t)) + + ;; Identifiers, strings, "in" keyword, and commas + ;; are allowed in use clauses. + ((or 'word 'comma 'in 'string 'double-quoted-string)) + + ;; Nothing else is. + (_ (throw 'done nil))) nil)))) (defun opascal-is-block-after-expr-statement (token) ;; Returns true if we have a block token trailing an expression delimiter (of ;; presumably an expression statement). - (when (opascal-is (opascal-token-kind token) opascal-block-statements) + (when (memq (opascal-token-kind token) opascal-block-statements) (let ((previous (opascal-previous-token token)) (previous-kind nil)) (while (progn (setq previous-kind (opascal-token-kind previous)) (eq previous-kind 'space)) (setq previous (opascal-previous-token previous))) - (or (opascal-is previous-kind opascal-expr-delimiters) + (or (memq previous-kind opascal-expr-delimiters) (eq previous-kind 'else))))) (defun opascal-previous-indent-of (from-token) ;; Returns the indentation of the previous statement of the token. - (let ((token (opascal-previous-token from-token)) - (token-kind nil) + (let ((token from-token) (from-kind (opascal-token-kind from-token)) (last-colon nil) (last-of nil) (last-token nil)) (catch 'done - (while token - (setq token-kind (opascal-token-kind token)) - (cond - ;; An open ( or [ always is an indent point. - ((eq 'open-group token-kind) - (throw 'done (opascal-open-group-indent token last-token))) - - ;; Skip over any ()/[] groups. - ((eq 'close-group token-kind) (setq token (opascal-group-start token))) - - ((opascal-is token-kind opascal-end-block-statements) - (if (eq 'newline (opascal-token-kind (opascal-previous-token token))) - ;; We can stop at an end token that is right up against the - ;; margin. - (throw 'done 0) - ;; Otherwise, skip over any nested blocks. - (setq token (opascal-block-start token)))) - - ;; Special case: if we encounter a ", word;" then we assume that we - ;; are in some kind of uses clause, and thus indent to column 0. This - ;; works because no other constructs are known to have that form. - ;; This fixes the irritating case of having indents after a uses - ;; clause look like: - ;; uses - ;; someUnit, - ;; someOtherUnit; - ;; // this should be at column 0! - ((opascal-is-use-clause-end token last-token last-colon from-kind) - (throw 'done 0)) - - ;; A previous terminator means we can stop. If we are on a directive, - ;; however, then we are not actually encountering a new statement. - ((and last-token - (opascal-is token-kind opascal-previous-terminators) - (not (opascal-is (opascal-token-kind last-token) - opascal-directives))) - (throw 'done (opascal-stmt-line-indent-of last-token 0))) - - ;; Ignore whitespace. - ((opascal-is token-kind opascal-whitespace)) - - ;; Remember any "of" we encounter, since that affects how we - ;; indent to a case statement within a record declaration - ;; (i.e. a variant part). - ((eq 'of token-kind) - (setq last-of token)) - - ;; Remember any ':' we encounter (until we reach an "of"), - ;; since that affects how we indent to case statements in - ;; general. - ((eq 'colon token-kind) - (unless last-of (setq last-colon token))) - - ;; A case statement delimits a previous statement. We indent labels - ;; specially. - ((eq 'case token-kind) - (throw 'done + (opascal--scan-non-whitespace-backward token last-token + ;; An open ( or [ always is an indent point. + ('open-group + (throw 'done (opascal-open-group-indent token last-token))) + + ;; Skip over any ()/[] groups. + ('close-group (setq token (opascal-group-start token))) + + ((opascal--in opascal-end-block-statements) + (if (eq 'newline (opascal-token-kind (opascal-previous-token token))) + ;; We can stop at an end token that is right up against the + ;; margin. + (throw 'done 0) + ;; Otherwise, skip over any nested blocks. + (setq token (opascal-block-start token)))) + + ;; Special case: if we encounter a ", word;" then we assume that we + ;; are in some kind of uses clause, and thus indent to column 0. This + ;; works because no other constructs are known to have that form. + ;; This fixes the irritating case of having indents after a uses + ;; clause look like: + ;; uses + ;; someUnit, + ;; someOtherUnit; + ;; // this should be at column 0! + ((guard + (opascal-is-use-clause-end token last-token last-colon from-kind)) + (throw 'done 0)) + + ;; A previous terminator means we can stop. If we are on a directive, + ;; however, then we are not actually encountering a new statement. + ((and (guard last-token) + (opascal--in opascal-previous-terminators) + (guard (not (memq (opascal-token-kind last-token) + opascal-directives)))) + (throw 'done (opascal-stmt-line-indent-of last-token 0))) + + ;; Remember any "of" we encounter, since that affects how we + ;; indent to a case statement within a record declaration + ;; (i.e. a variant part). + ('of + (setq last-of token)) + + ;; Remember any ':' we encounter (until we reach an "of"), + ;; since that affects how we indent to case statements in + ;; general. + ('colon + (unless last-of (setq last-colon token))) + + ;; A case statement delimits a previous statement. We indent labels + ;; specially. + ('case + (throw 'done (if last-colon (opascal-line-indent-of last-colon) (opascal-line-indent-of token opascal-case-label-indent)))) - ;; If we are in a use clause then commas mark an enclosing rather than - ;; a previous statement. - ((opascal-is token-kind opascal-use-clauses) - (throw 'done - (if (eq 'comma from-kind) - (if last-token - ;; Indent to first unit in use clause. - (opascal-indent-of last-token) - ;; Indent from use clause keyword. - (opascal-line-indent-of token opascal-indent-level)) - ;; Indent to use clause keyword. - (opascal-line-indent-of token)))) - - ;; Assembly sections always indent in from the asm keyword. - ((eq token-kind 'asm) - (throw 'done (opascal-stmt-line-indent-of token opascal-indent-level))) - - ;; An enclosing statement delimits a previous statement. - ;; We try to use the existing indent of the previous statement, - ;; otherwise we calculate from the enclosing statement. - ((opascal-is token-kind opascal-previous-enclosing-statements) - (throw 'done (if last-token - ;; Otherwise indent to the last token - (opascal-line-indent-of last-token) - ;; Just indent from the enclosing keyword - (opascal-line-indent-of token opascal-indent-level)))) - - ;; A class or record declaration also delimits a previous statement. - ((opascal-composite-type-start token last-token) - (throw - 'done - (if (opascal-is-simple-class-type last-token from-token) - ;; c = class; or c = class of T; are previous statements. - (opascal-line-indent-of token) - ;; Otherwise c = class ... or r = record ... are enclosing - ;; statements. - (opascal-line-indent-of last-token opascal-indent-level)))) - - ;; We have a definite previous statement delimiter. - ((opascal-is token-kind opascal-previous-statements) - (throw 'done (opascal-stmt-line-indent-of token 0))) - ) - (unless (opascal-is token-kind opascal-whitespace) - (setq last-token token)) - (setq token (opascal-previous-token token))) + ;; If we are in a use clause then commas mark an enclosing rather than + ;; a previous statement. + ((opascal--in opascal-use-clauses) + (throw 'done + (if (eq 'comma from-kind) + (if last-token + ;; Indent to first unit in use clause. + (opascal-indent-of last-token) + ;; Indent from use clause keyword. + (opascal-line-indent-of token opascal-indent-level)) + ;; Indent to use clause keyword. + (opascal-line-indent-of token)))) + + ;; Assembly sections always indent in from the asm keyword. + ('asm + (throw 'done (opascal-stmt-line-indent-of token opascal-indent-level))) + + ;; An enclosing statement delimits a previous statement. + ;; We try to use the existing indent of the previous statement, + ;; otherwise we calculate from the enclosing statement. + ((opascal--in opascal-previous-enclosing-statements) + (throw 'done (if last-token + ;; Otherwise indent to the last token + (opascal-line-indent-of last-token) + ;; Just indent from the enclosing keyword + (opascal-line-indent-of token opascal-indent-level)))) + + ;; A class or record declaration also delimits a previous statement. + ((guard (opascal-composite-type-start token last-token)) + (throw + 'done + (if (opascal-is-simple-class-type last-token from-token) + ;; c = class; or c = class of T; are previous statements. + (opascal-line-indent-of token) + ;; Otherwise c = class ... or r = record ... are enclosing + ;; statements. + (opascal-line-indent-of last-token opascal-indent-level)))) + + ;; We have a definite previous statement delimiter. + ((opascal--in opascal-previous-statements) + (throw 'done (opascal-stmt-line-indent-of token 0))) + ) ;; We ran out of tokens. Indent to column 0. 0))) (defun opascal-section-indent-of (section-token) ;; Returns the indentation appropriate for begin/var/const/type/label ;; tokens. - (let* ((token (opascal-previous-token section-token)) - (token-kind nil) + (let* ((token section-token) (last-token nil) (nested-block-count 0) (expr-delimited nil) (last-terminator nil)) (catch 'done - (while token - (setq token-kind (opascal-token-kind token)) - (cond - ;; Always stop at unmatched ( or [. - ((eq token-kind 'open-group) - (throw 'done (opascal-open-group-indent token last-token))) - - ;; Skip over any ()/[] groups. - ((eq 'close-group token-kind) (setq token (opascal-group-start token))) - - ((opascal-is token-kind opascal-end-block-statements) - (if (eq 'newline (opascal-token-kind (opascal-previous-token token))) - ;; We can stop at an end token that is right up against the - ;; margin. - (throw 'done 0) - ;; Otherwise, skip over any nested blocks. - (setq token (opascal-block-start token) - nested-block-count (1+ nested-block-count)))) - - ;; Remember if we have encountered any forward routine declarations. - ((eq 'forward token-kind) - (setq nested-block-count (1+ nested-block-count))) - - ;; Mark the completion of a nested routine traversal. - ((and (opascal-is token-kind opascal-routine-statements) - (> nested-block-count 0)) - (setq nested-block-count (1- nested-block-count))) - - ;; Remember if we have encountered any statement terminators. - ((eq 'semicolon token-kind) (setq last-terminator token)) - - ;; Remember if we have encountered any expression delimiters. - ((opascal-is token-kind opascal-expr-delimiters) - (setq expr-delimited token)) - - ;; Enclosing body statements are delimiting. We indent the compound - ;; bodies specially. - ((and (not last-terminator) - (opascal-is token-kind opascal-body-statements)) - (throw 'done - (opascal-stmt-line-indent-of token opascal-compound-block-indent))) - - ;; An enclosing ":" means a label. - ((and (eq 'colon token-kind) - (opascal-is (opascal-token-kind section-token) - opascal-block-statements) - (not last-terminator) - (not expr-delimited) - (not (eq 'equals (opascal-token-kind last-token)))) - (throw 'done - (opascal-stmt-line-indent-of token opascal-indent-level))) - - ;; Block and mid block tokens are always enclosing - ((opascal-is token-kind opascal-begin-enclosing-tokens) - (throw 'done - (opascal-stmt-line-indent-of token opascal-indent-level))) - - ;; Declaration sections and routines are delimiters, unless they - ;; are part of a nested routine. - ((and (opascal-is token-kind opascal-decl-delimiters) - (= 0 nested-block-count)) - (throw 'done (opascal-line-indent-of token 0))) - - ;; Unit statements mean we indent right to the left. - ((opascal-is token-kind opascal-unit-statements) (throw 'done 0)) - ) - (unless (opascal-is token-kind opascal-whitespace) - (setq last-token token)) - (setq token (opascal-previous-token token))) + (opascal--scan-non-whitespace-backward token last-token + ;; Always stop at unmatched ( or [. + ('open-group + (throw 'done (opascal-open-group-indent token last-token))) + + ;; Skip over any ()/[] groups. + ('close-group (setq token (opascal-group-start token))) + + ((opascal--in opascal-end-block-statements) + (if (eq 'newline (opascal-token-kind (opascal-previous-token token))) + ;; We can stop at an end token that is right up against the + ;; margin. + (throw 'done 0) + ;; Otherwise, skip over any nested blocks. + (setq token (opascal-block-start token) + nested-block-count (1+ nested-block-count)))) + + ;; Remember if we have encountered any forward routine declarations. + ('forward + (setq nested-block-count (1+ nested-block-count))) + + ;; Mark the completion of a nested routine traversal. + ((and (opascal--in opascal-routine-statements) + (guard (> nested-block-count 0))) + (setq nested-block-count (1- nested-block-count))) + + ;; Remember if we have encountered any statement terminators. + ('semicolon (setq last-terminator token)) + + ;; Remember if we have encountered any expression delimiters. + ((opascal--in opascal-expr-delimiters) + (setq expr-delimited token)) + + ;; Enclosing body statements are delimiting. We indent the compound + ;; bodies specially. + ((and (guard (not last-terminator)) + (opascal--in opascal-body-statements)) + (throw 'done + (opascal-stmt-line-indent-of token + opascal-compound-block-indent))) + + ;; An enclosing ":" means a label. + ((and 'colon + (guard (and (memq (opascal-token-kind section-token) + opascal-block-statements) + (not last-terminator) + (not expr-delimited) + (not (eq 'equals + (opascal-token-kind last-token)))))) + (throw 'done + (opascal-stmt-line-indent-of token opascal-indent-level))) + + ;; Block and mid block tokens are always enclosing + ((opascal--in opascal-begin-enclosing-tokens) + (throw 'done + (opascal-stmt-line-indent-of token opascal-indent-level))) + + ;; Declaration sections and routines are delimiters, unless they + ;; are part of a nested routine. + ((and (opascal--in opascal-decl-delimiters) + (guard (= 0 nested-block-count))) + (throw 'done (opascal-line-indent-of token 0))) + + ;; Unit statements mean we indent right to the left. + ((opascal--in opascal-unit-statements) (throw 'done 0)) + ) ;; We ran out of tokens. Indent to column 0. 0))) (defun opascal-enclosing-indent-of (from-token) ;; Returns the indentation offset from the enclosing statement of the token. - (let ((token (opascal-previous-token from-token)) + (let ((token from-token) (from-kind (opascal-token-kind from-token)) - (token-kind nil) (stmt-start nil) (last-token nil) (equals-encountered nil) (before-equals nil) (expr-delimited nil)) (catch 'done - (while token - (setq token-kind (opascal-token-kind token)) - (cond - ;; An open ( or [ always is an indent point. - ((eq 'open-group token-kind) - (throw 'done - (opascal-open-group-indent - token last-token - (if (opascal-is from-kind opascal-binary-ops) - ;; Keep binary operations aligned with the open group. - 0 - opascal-indent-level)))) - - ;; Skip over any ()/[] groups. - ((eq 'close-group token-kind) (setq token (opascal-group-start token))) - - ;; Skip over any nested blocks. - ((opascal-is token-kind opascal-end-block-statements) - (setq token (opascal-block-start token))) - - ;; An expression delimiter affects indentation depending on whether - ;; the point is before or after it. Remember that we encountered one. - ;; Also remember the last encountered token, since if it exists it - ;; should be the actual indent point. - ((opascal-is token-kind opascal-expr-delimiters) - (setq expr-delimited token stmt-start last-token)) - - ;; With a non-delimited expression statement we indent after the - ;; statement's keyword, unless we are on the delimiter itself. - ((and (not expr-delimited) - (opascal-is token-kind opascal-expr-statements)) - (throw 'done - (cond ((opascal-is from-kind opascal-expr-delimiters) - ;; We are indenting a delimiter. Indent to the statement. - (opascal-stmt-line-indent-of token 0)) - - ((and last-token (opascal-is from-kind opascal-binary-ops)) - ;; Align binary ops with the expression. - (opascal-indent-of last-token)) - - (last-token - ;; Indent in from the expression. - (opascal-indent-of last-token opascal-indent-level)) - - ;; Indent in from the statement's keyword. - ((opascal-indent-of token opascal-indent-level))))) - - ;; A delimited case statement indents the label according to - ;; a special rule. - ((eq 'case token-kind) - (throw 'done - (if stmt-start - ;; We are not actually indenting to the case statement, - ;; but are within a label expression. - (opascal-stmt-line-indent-of - stmt-start opascal-indent-level) - ;; Indent from the case keyword. - (opascal-stmt-line-indent-of - token opascal-case-label-indent)))) - - ;; Body expression statements are enclosing. Indent from the - ;; statement's keyword, unless we have a non-block statement following - ;; it. - ((opascal-is token-kind opascal-body-expr-statements) - (throw 'done - (opascal-stmt-line-indent-of - (or stmt-start token) opascal-indent-level))) - - ;; An else statement is enclosing, but it doesn't have an expression. - ;; Thus we take into account last-token instead of stmt-start. - ((eq 'else token-kind) - (throw 'done (opascal-stmt-line-indent-of - (or last-token token) opascal-indent-level))) - - ;; We indent relative to an enclosing declaration section. - ((opascal-is token-kind opascal-decl-sections) - (throw 'done (opascal-indent-of (if last-token last-token token) + (opascal--scan-non-whitespace-backward token last-token + ;; An open ( or [ always is an indent point. + ('open-group + (throw 'done + (opascal-open-group-indent + token last-token + (if (memq from-kind opascal-binary-ops) + ;; Keep binary operations aligned with the open group. + 0 + opascal-indent-level)))) + + ;; Skip over any ()/[] groups. + ('close-group (setq token (opascal-group-start token))) + + ;; Skip over any nested blocks. + ((opascal--in opascal-end-block-statements) + (setq token (opascal-block-start token))) + + ;; An expression delimiter affects indentation depending on whether + ;; the point is before or after it. Remember that we encountered one. + ;; Also remember the last encountered token, since if it exists it + ;; should be the actual indent point. + ((opascal--in opascal-expr-delimiters) + (setq expr-delimited token stmt-start last-token)) + + ;; With a non-delimited expression statement we indent after the + ;; statement's keyword, unless we are on the delimiter itself. + ((and (guard (not expr-delimited)) + (opascal--in opascal-expr-statements)) + (throw 'done + (cond + ((memq from-kind opascal-expr-delimiters) + ;; We are indenting a delimiter. Indent to the statement. + (opascal-stmt-line-indent-of token 0)) + + ((and last-token (memq from-kind opascal-binary-ops)) + ;; Align binary ops with the expression. + (opascal-indent-of last-token)) + + (last-token + ;; Indent in from the expression. + (opascal-indent-of last-token opascal-indent-level)) + + ;; Indent in from the statement's keyword. + ((opascal-indent-of token opascal-indent-level))))) + + ;; A delimited case statement indents the label according to + ;; a special rule. + ('case + (throw 'done + (if stmt-start + ;; We are not actually indenting to the case statement, + ;; but are within a label expression. + (opascal-stmt-line-indent-of + stmt-start opascal-indent-level) + ;; Indent from the case keyword. + (opascal-stmt-line-indent-of + token opascal-case-label-indent)))) + + ;; Body expression statements are enclosing. Indent from the + ;; statement's keyword, unless we have a non-block statement following + ;; it. + ((opascal--in opascal-body-expr-statements) + (throw 'done (opascal-stmt-line-indent-of + (or stmt-start token) opascal-indent-level))) + + ;; An else statement is enclosing, but it doesn't have an expression. + ;; Thus we take into account last-token instead of stmt-start. + ('else + (throw 'done (opascal-stmt-line-indent-of + (or last-token token) opascal-indent-level))) + + ;; We indent relative to an enclosing declaration section, + ;; unless this is within the a delimited expression + ;; (bug#36348). + ((and (guard (not expr-delimited)) + (opascal--in opascal-decl-sections)) + (throw 'done (opascal-indent-of (if last-token last-token token) opascal-indent-level))) - ;; In unit sections we indent right to the left. - ((opascal-is token-kind opascal-unit-sections) - (throw 'done - ;; Handle specially the case of "interface", which can be used - ;; to start either a unit section or an interface definition. - (if (opascal-is token-kind opascal-interface-types) - (progn - ;; Find the previous non-whitespace token. - (while (progn - (setq last-token token - token (opascal-previous-token token) - token-kind (opascal-token-kind token)) - (and token - (opascal-is token-kind - opascal-whitespace)))) - ;; If this token is an equals sign, "interface" is being - ;; used to start an interface definition and we should - ;; treat it as a composite type; otherwise, we should - ;; consider it the start of a unit section. - (if (and token (eq token-kind 'equals)) - (opascal-line-indent-of last-token - opascal-indent-level) - 0)) - 0))) - - ;; A previous terminator means we can stop. - ((opascal-is token-kind opascal-previous-terminators) - (throw 'done - (cond ((and last-token - (eq 'comma token-kind) - (opascal-is from-kind opascal-binary-ops)) - ;; Align binary ops with the expression. - (opascal-indent-of last-token)) - - (last-token - ;; Indent in from the expression. - (opascal-indent-of last-token opascal-indent-level)) - - ;; No enclosing expression; use the previous statement's - ;; indent. - ((opascal-previous-indent-of token))))) - - ;; A block statement after an expression delimiter has its start - ;; column as the expression statement. E.g. - ;; if (a = b) - ;; and (a != c) then begin - ;; //... - ;; end; - ;; Remember it for when we encounter the expression statement start. - ((opascal-is-block-after-expr-statement token) - (throw 'done - (cond (last-token (opascal-indent-of last-token opascal-indent-level)) - - ((+ (opascal-section-indent-of token) opascal-indent-level))))) - - ;; Assembly sections always indent in from the asm keyword. - ((eq token-kind 'asm) - (throw 'done (opascal-stmt-line-indent-of token opascal-indent-level))) - - ;; Stop at an enclosing statement and indent from it. - ((opascal-is token-kind opascal-enclosing-statements) - (throw 'done (opascal-stmt-line-indent-of - (or last-token token) opascal-indent-level))) - - ;; A class/record declaration is also enclosing. - ((opascal-composite-type-start token last-token) - (throw 'done - (opascal-line-indent-of last-token opascal-indent-level))) - - ;; A ":" we indent relative to its line beginning. If we are in a - ;; parameter list, then stop also if we hit a ";". - ((and (eq token-kind 'colon) - (not expr-delimited) - (not (opascal-is from-kind opascal-expr-delimiters)) - (not equals-encountered) - (not (eq from-kind 'equals))) - (throw 'done - (if last-token - (opascal-indent-of last-token opascal-indent-level) - (opascal-line-indent-of token opascal-indent-level 'semicolon)))) - - ;; If the ":" was not processed above and we have token after the "=", - ;; then indent from the "=". Ignore :=, however. - ((and (eq token-kind 'colon) equals-encountered before-equals) - (cond - ;; Ignore binary ops for now. It would do, for example: - ;; val := 1 + 2 - ;; + 3; - ;; which is good, but also - ;; val := Foo - ;; (foo, args) - ;; + 2; - ;; which doesn't look right. - ;;;; Align binary ops with the before token. - ;;((opascal-is from-kind opascal-binary-ops) - ;;(throw 'done (opascal-indent-of before-equals 0))) - - ;; Assignments (:=) we skip over to get a normal indent. - ((eq (opascal-token-kind last-token) 'equals)) - - ;; Otherwise indent in from the equals. - ((throw 'done - (opascal-indent-of before-equals opascal-indent-level))))) - - ;; Remember any "=" we encounter if it has not already been processed. - ((eq token-kind 'equals) - (setq equals-encountered token - before-equals last-token)) - ) - (unless (opascal-is token-kind opascal-whitespace) - (setq last-token token)) - (setq token (opascal-previous-token token))) + ;; In unit sections we indent right to the left. + ;; Handle specially the case of "interface", which can be used + ;; to start either a unit section or an interface definition. + ('interface ;FIXME: Generalize to all `opascal-interface-types'? + (throw 'done + (let (token-kind) + ;; Find the previous non-whitespace token. + (while (progn + (setq last-token token + token (opascal-previous-token token) + token-kind (opascal-token-kind token)) + (and token + (memq token-kind + opascal-whitespace)))) + ;; If this token is an equals sign, "interface" is being + ;; used to start an interface definition and we should + ;; treat it as a composite type; otherwise, we should + ;; consider it the start of a unit section. + (if (and token (eq token-kind 'equals)) + (opascal-line-indent-of last-token + opascal-indent-level) + 0)))) + + ;; In unit sections we indent right to the left. + ((opascal--in opascal-unit-sections) + ;; Note: The `interface' case is handled specially above. + (throw 'done 0)) + + ;; A previous terminator means we can stop. + ((and (opascal--in opascal-previous-terminators) token-kind) + (throw 'done + (cond ((and last-token + (eq 'comma token-kind) + (memq from-kind opascal-binary-ops)) + ;; Align binary ops with the expression. + (opascal-indent-of last-token)) + + (last-token + ;; Indent in from the expression. + (opascal-indent-of last-token opascal-indent-level)) + + ;; No enclosing expression; use the previous statement's + ;; indent. + ((opascal-previous-indent-of token))))) + + ;; A block statement after an expression delimiter has its start + ;; column as the expression statement. E.g. + ;; if (a = b) + ;; and (a != c) then begin + ;; //... + ;; end; + ;; Remember it for when we encounter the expression statement start. + ((guard (opascal-is-block-after-expr-statement token)) + (throw 'done + (cond (last-token + (opascal-indent-of last-token opascal-indent-level)) + + (t (+ (opascal-section-indent-of token) + opascal-indent-level))))) + + ;; Assembly sections always indent in from the asm keyword. + ('asm + (throw 'done (opascal-stmt-line-indent-of token opascal-indent-level))) + + ;; Stop at an enclosing statement and indent from it. + ((opascal--in opascal-enclosing-statements) + (throw 'done (opascal-stmt-line-indent-of + (or last-token token) opascal-indent-level))) + + ;; A class/record declaration is also enclosing. + ((guard (opascal-composite-type-start token last-token)) + (throw 'done + (opascal-line-indent-of last-token opascal-indent-level))) + + ;; A ":" we indent relative to its line beginning. If we are in a + ;; parameter list, then stop also if we hit a ";". + ((and 'colon + (guard (not (or expr-delimited + (memq from-kind opascal-expr-delimiters) + equals-encountered + (eq from-kind 'equals))))) + (throw 'done + (if last-token + (opascal-indent-of last-token opascal-indent-level) + (opascal-line-indent-of token opascal-indent-level + 'semicolon)))) + + ;; If the ":" was not processed above and we have token after the "=", + ;; then indent from the "=". Ignore :=, however. + ((and 'colon (guard (and equals-encountered before-equals))) + (cond + ;; Ignore binary ops for now. It would do, for example: + ;; val := 1 + 2 + ;; + 3; + ;; which is good, but also + ;; val := Foo + ;; (foo, args) + ;; + 2; + ;; which doesn't look right. + + ;; ;; Align binary ops with the before token. + ;;((memq from-kind opascal-binary-ops) + ;;(throw 'done (opascal-indent-of before-equals 0))) + + ;; Assignments (:=) we skip over to get a normal indent. + ((eq (opascal-token-kind last-token) 'equals)) + + ;; Otherwise indent in from the equals. + (t (throw 'done + (opascal-indent-of before-equals opascal-indent-level))))) + + ;; Remember any "=" we encounter if it has not already been processed. + ('equals + (setq equals-encountered token + before-equals last-token)) + ) ;; We ran out of tokens. Indent to column 0. 0))) @@ -1301,9 +1287,12 @@ routine.") ;; Returns the corrected indentation for the current line. (opascal-save-excursion (opascal-progress-start) - ;; Move to the first token on the line. - (beginning-of-line) - (skip-chars-forward opascal-space-chars) + ;; The caller should make sure we're at the first token on the line. + (cl-assert (eql (point) + (save-excursion + (beginning-of-line) + (skip-chars-forward opascal-space-chars) + (point)))) (let* ((token (opascal-current-token)) (token-kind (opascal-token-kind token)) (indent @@ -1311,17 +1300,17 @@ routine.") ;; Indent to the matching start ( or [. (opascal-indent-of (opascal-group-start token))) - ((opascal-is token-kind opascal-unit-statements) 0) + ((memq token-kind opascal-unit-statements) 0) - ((opascal-is token-kind opascal-comments) + ((memq token-kind opascal-comments) ;; In a comment. (opascal-comment-indent-of token)) - ((opascal-is token-kind opascal-decl-matchers) + ((memq token-kind opascal-decl-matchers) ;; Use a previous section/routine's indent. (opascal-section-indent-of token)) - ((opascal-is token-kind opascal-match-block-statements) + ((memq token-kind opascal-match-block-statements) ;; Use the block's indentation. (let ((block-start (opascal-block-start token 'stop-on-class))) @@ -1339,8 +1328,9 @@ routine.") (opascal-stmt-line-indent-of (opascal-else-start token) 0)) ;; Otherwise indent in from enclosing statement. - ((opascal-enclosing-indent-of - (if token token (opascal-token-at (1- (point))))))))) + (t + (opascal-enclosing-indent-of + (or token (opascal-token-at (1- (point))))))))) (opascal-progress-done) indent))) @@ -1349,25 +1339,18 @@ routine.") If before the indent, the point is moved to the indent." (interactive) (save-match-data - (let ((marked-point (point-marker)) ; Maintain our position reliably. - (line-start nil) - (old-indent 0) - (new-indent 0)) - (beginning-of-line) - (setq line-start (point)) - (skip-chars-forward opascal-space-chars) - (setq old-indent (current-column)) - (setq new-indent (opascal-corrected-indentation)) - (if (< marked-point (point)) - ;; If before the indent column, then move to it. - (set-marker marked-point (point))) - ;; Advance our marked point after inserted spaces. - (set-marker-insertion-type marked-point t) - (when (/= old-indent new-indent) - (delete-region line-start (point)) - (insert (make-string new-indent ?\s))) - (goto-char marked-point) - (set-marker marked-point nil)))) + (let ((marked-point (point-marker))) ; Maintain our position reliably. + (beginning-of-line) + (skip-chars-forward opascal-space-chars) + (let ((new-indent (opascal-corrected-indentation))) + (if (< marked-point (point)) + ;; If before the indent column, then move to it. + (set-marker marked-point (point))) + ;; Advance our marked point after inserted spaces. + (set-marker-insertion-type marked-point t) + (indent-line-to new-indent) + (goto-char marked-point) + (set-marker marked-point nil))))) (defvar opascal-mode-abbrev-table nil "Abbrev table in use in OPascal mode buffers.") @@ -1519,7 +1502,7 @@ value of `opascal-tab-always-indents' and the current line position." (setq dir-name (match-string 1 dir-name) recurse t)) ;; Ensure the trailing slash is removed. - (if (string-match "^\\(.+\\)[\\\\/]$" dir-name) + (if (string-match "^\\(.+\\)[\\/]$" dir-name) (setq dir-name (match-string 1 dir-name))) (opascal-search-directory unit dir-name recurse))) @@ -1580,7 +1563,7 @@ An error is raised if not in a comment." (save-restriction (let* ((comment (opascal-current-token)) (comment-kind (opascal-token-kind comment))) - (if (not (opascal-is comment-kind opascal-comments)) + (if (not (memq comment-kind opascal-comments)) (error "Not in a comment") (let* ((start-comment (opascal-comment-block-start comment)) (end-comment (opascal-comment-block-end comment)) @@ -1658,6 +1641,9 @@ An error is raised if not in a comment." "If in a // comment, do a newline, indented such that one is still in the comment block. If not in a // comment, just does a normal newline." (interactive) + (declare + (obsolete "use comment-indent-new-line with comment-multi-line instead" + "27.1")) (let ((comment (opascal-current-token))) (if (not (eq 'comment-single-line (opascal-token-kind comment))) ;; Not in a // comment. Just do the normal newline. @@ -1733,7 +1719,7 @@ comment block. If not in a // comment, just does a normal newline." ;; '("\C-cb" opascal-find-current-body) '("\C-cu" opascal-find-unit) '("\M-q" opascal-fill-comment) - '("\M-j" opascal-new-comment-line) + ;; '("\M-j" opascal-new-comment-line) ;; Debug bindings: (list "\C-c\C-d" opascal-debug-mode-map))) (define-key kmap (car binding) (cadr binding))) @@ -1742,7 +1728,7 @@ comment block. If not in a // comment, just does a normal newline." (define-obsolete-variable-alias 'delphi-mode-hook 'opascal-mode-hook "24.4") ;;;###autoload -(define-obsolete-function-alias 'delphi-mode 'opascal-mode "24.4") +(define-obsolete-function-alias 'delphi-mode #'opascal-mode "24.4") ;;;###autoload (define-derived-mode opascal-mode prog-mode "OPascal" "Major mode for editing OPascal code.\\<opascal-mode-map> diff --git a/lisp/progmodes/pascal.el b/lisp/progmodes/pascal.el index 01ac96f09ae..26fb0a88c53 100644 --- a/lisp/progmodes/pascal.el +++ b/lisp/progmodes/pascal.el @@ -117,7 +117,7 @@ (defconst pascal-beg-block-re "\\<\\(begin\\|case\\|record\\|repeat\\)\\>") (defconst pascal-end-block-re "\\<\\(end\\|until\\)\\>") (defconst pascal-declaration-re "\\<\\(const\\|label\\|type\\|var\\)\\>") -(defconst pascal-progbeg-re "\\<\\program\\>") +(defconst pascal-progbeg-re "\\<program\\>") (defconst pascal-defun-re "\\<\\(function\\|procedure\\|program\\)\\>") (defconst pascal-sub-block-re "\\<\\(if\\|else\\|for\\|while\\|with\\)\\>") (defconst pascal-noindent-re "\\<\\(begin\\|end\\|until\\|else\\)\\>") @@ -510,9 +510,7 @@ This puts the mark at the end, and point at the beginning." (push-mark) (pascal-end-of-defun) (push-mark) - (pascal-beg-of-defun) - (when (featurep 'xemacs) - (zmacs-activate-region))) + (pascal-beg-of-defun)) (defun pascal-comment-area (start end) "Put the region into a Pascal comment.\\<pascal-mode-map> @@ -1403,12 +1401,8 @@ The default is a name found in the buffer around point." map) "Keymap used in Pascal Outline mode.") -(define-obsolete-function-alias 'pascal-outline 'pascal-outline-mode "22.1") (define-minor-mode pascal-outline-mode "Outline-line minor mode for Pascal mode. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. When enabled, portions of the text being edited may be made invisible.\\<pascal-outline-map> diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el index 6cc2ee95d04..7cbd30a0d1d 100644 --- a/lisp/progmodes/perl-mode.el +++ b/lisp/progmodes/perl-mode.el @@ -87,6 +87,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defgroup perl nil "Major mode for editing Perl code." :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) @@ -135,7 +137,7 @@ '(;; Functions (nil "^[ \t]*sub\\s-+\\([-[:alnum:]+_:]+\\)" 1) ;;Variables - ("Variables" "^\\(?:my\\|our\\)\\s-+\\([$@%][-[:alnum:]+_:]+\\)\\s-*=" 1) + ("Variables" "^[ \t]*\\(?:anon\\|argument\\|has\\|local\\|my\\|our\\|state\\|supersede\\)\\s-+\\([$@%][-[:alnum:]+_:]+\\)\\s-*=" 1) ("Packages" "^[ \t]*package\\s-+\\([-[:alnum:]+_:]+\\);" 1) ("Doc sections" "^=head[0-9][ \t]+\\(.*\\)" 1)) "Imenu generic expression for Perl mode. See `imenu-generic-expression'.") @@ -165,7 +167,7 @@ ;; Fontify function and package names in declarations. ("\\<\\(package\\|sub\\)\\>[ \t]*\\(\\sw+\\)?" (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t)) - ("\\<\\(import\\|no\\|require\\|use\\)\\>[ \t]*\\(\\sw+\\)?" + ("\\(^\\|[^$@%&\\]\\)\\<\\(import\\|no\\|require\\|use\\)\\>[ \t]*\\(\\sw+\\)?" (1 font-lock-keyword-face) (2 font-lock-constant-face nil t))) "Subdued level highlighting for Perl mode.") @@ -179,8 +181,9 @@ "BEGIN" "END" "return" "exec" "eval") t) "\\>") ;; - ;; Fontify local and my keywords as types. - ("\\<\\(local\\|my\\)\\>" . font-lock-type-face) + ;; Fontify declarators and prefixes as types. + ("\\<\\(anon\\|argument\\|has\\|local\\|my\\|our\\|state\\|supersede\\)\\>" . font-lock-type-face) ; declarators + ("\\<\\(let\\|temp\\)\\>" . font-lock-type-face) ; prefixes ;; ;; Fontify function, variable and file name references. ("&\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-function-name-face) @@ -320,8 +323,8 @@ (cons (car (string-to-syntax "< c")) ;; Remember the names of heredocs found on this line. (cons (cons (pcase (aref name 0) - (`?\\ (substring name 1)) - ((or `?\" `?\' `?\`) (substring name 1 -1)) + (?\\ (substring name 1)) + ((or ?\" ?\' ?\`) (substring name 1 -1)) (_ name)) indented) (cdr st))))))) @@ -744,8 +747,6 @@ Turning on Perl mode runs the normal hook `perl-mode-hook'." 0 ;Existing comment at bol stays there. comment-column)) -(define-obsolete-function-alias 'electric-perl-terminator - 'perl-electric-terminator "22.1") (defun perl-electric-noindent-p (_char) ;; To reproduce the old behavior, ;, {, }, and : are made electric, but ;; we only want them to be electric at EOL. diff --git a/lisp/progmodes/prog-mode.el b/lisp/progmodes/prog-mode.el index edb32a2d5a4..79fe56aebbf 100644 --- a/lisp/progmodes/prog-mode.el +++ b/lisp/progmodes/prog-mode.el @@ -196,9 +196,6 @@ on the symbol." ;;;###autoload (define-minor-mode prettify-symbols-mode "Toggle Prettify Symbols mode. -With a prefix argument ARG, enable Prettify Symbols mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. When Prettify Symbols mode and font-locking are enabled, symbols are prettified (displayed as composed characters) according to the rules @@ -214,6 +211,9 @@ You can enable this mode locally in desired buffers, or use `global-prettify-symbols-mode' to enable it for all modes that support it." :init-value nil + (when prettify-symbols--keywords + (font-lock-remove-keywords nil prettify-symbols--keywords) + (setq prettify-symbols--keywords nil)) (if prettify-symbols-mode ;; Turn on (when (setq prettify-symbols--keywords (prettify-symbols--make-keywords)) @@ -229,9 +229,6 @@ support it." (font-lock-flush)) ;; Turn off (remove-hook 'post-command-hook #'prettify-symbols--post-command-hook t) - (when prettify-symbols--keywords - (font-lock-remove-keywords nil prettify-symbols--keywords) - (setq prettify-symbols--keywords nil)) (when (memq 'composition font-lock-extra-managed-props) (setq font-lock-extra-managed-props (delq 'composition font-lock-extra-managed-props)) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index d4c13e879bd..4693d07fa86 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -35,7 +35,7 @@ ;; Infrastructure: ;; ;; Function `project-current', to determine the current project -;; instance, and 3 (at the moment) generic functions that act on it. +;; instance, and 5 (at the moment) generic functions that act on it. ;; This list is to be extended in future versions. ;; ;; Utils: @@ -45,8 +45,9 @@ ;; ;; Commands: ;; -;; `project-find-regexp' and `project-or-external-find-regexp' use the -;; current API, and thus will work in any project that has an adapter. +;; `project-find-file', `project-find-regexp' and +;; `project-or-external-find-regexp' use the current API, and thus +;; will work in any project that has an adapter. ;;; TODO: @@ -54,9 +55,6 @@ ;; filenotify.el (if supported) to invalidate. And avoiding caching ;; if it's not available (manual cache invalidation is not nice). ;; -;; * Allow the backend to override the file-listing logic? Maybe also -;; to delegate file name completion to an external tool. -;; ;; * Build tool related functionality. Start with a `project-build' ;; command, which should provide completions on tasks to run, and ;; maybe allow entering some additional arguments. This might @@ -148,6 +146,8 @@ Patterns can match both regular files and directories. To root an entry, start it with `./'. To match directories only, end it with `/'. DIR must be one of `project-roots' or `project-external-roots'." + ;; TODO: Document and support regexp ignores as used by Hg. + ;; TODO: Support whitelist entries. (require 'grep) (defvar grep-find-ignored-files) (nconc @@ -157,37 +157,63 @@ end it with `/'. DIR must be one of `project-roots' or vc-directory-exclusion-list) grep-find-ignored-files)) -(cl-defgeneric project-file-completion-table (project dirs) - "Return a completion table for files in directories DIRS in PROJECT. +(defun project--file-completion-table (all-files) + (lambda (string pred action) + (cond + ((eq action 'metadata) + '(metadata . ((category . project-file)))) + (t + (complete-with-action action all-files string pred))))) + +(cl-defmethod project-roots ((project (head transient))) + (list (cdr project))) + +(cl-defgeneric project-files (project &optional dirs) + "Return a list of files in directories DIRS in PROJECT. DIRS is a list of absolute directories; it should be some subset of the project roots and external roots. The default implementation uses `find-program'. PROJECT is used to find the list of ignores for each directory." - ;; FIXME: Uniquely abbreviate the roots? (require 'xref) - (let ((all-files - (cl-mapcan - (lambda (dir) - (let ((command - (format "%s %s %s -type f -print0" - find-program - (shell-quote-argument - (expand-file-name dir)) - (xref--find-ignores-arguments - (project-ignores project dir) - (expand-file-name dir))))) - (split-string (shell-command-to-string command) "\0" t))) - dirs))) - (lambda (string pred action) - (cond - ((eq action 'metadata) - '(metadata . ((category . project-file)))) - (t - (complete-with-action action all-files string pred)))))) - -(cl-defmethod project-roots ((project (head transient))) - (list (cdr project))) + (cl-mapcan + (lambda (dir) + (project--files-in-directory dir + (project--dir-ignores project dir))) + (or dirs (project-roots project)))) + +(defun project--files-in-directory (dir ignores &optional files) + (require 'find-dired) + (defvar find-name-arg) + (let ((default-directory dir) + (command (format "%s %s %s -type f %s -print0" + find-program + (file-local-name dir) + (xref--find-ignores-arguments + ignores + (expand-file-name dir)) + (if files + (concat (shell-quote-argument "(") + " " find-name-arg " " + (mapconcat + #'shell-quote-argument + (split-string files) + (concat " -o " find-name-arg " ")) + " " + (shell-quote-argument ")"))"") + ))) + (project--remote-file-names + (sort (split-string (shell-command-to-string command) "\0" t) + #'string<)))) + +(defun project--remote-file-names (local-files) + "Return LOCAL-FILES as if they were on the system of `default-directory'." + (let ((remote-id (file-remote-p default-directory))) + (if (not remote-id) + local-files + (mapcar (lambda (file) + (concat remote-id file)) + local-files)))) (defgroup project-vc nil "Project implementation using the VC package." @@ -264,7 +290,10 @@ backend implementation of `project-external-roots'.") entry)) (vc-call-backend backend 'ignore-completion-table root))) (project--value-in-dir 'project-vc-ignores root) - (cl-call-next-method)))) + (mapcar + (lambda (dir) + (concat dir "/")) + vc-directory-exclusion-list)))) (defun project-combine-directories (&rest lists-of-dirs) "Return a sorted and culled list of directory names. @@ -302,6 +331,8 @@ DIRS must contain directory names." (declare-function xref--show-xrefs "xref") (declare-function xref-backend-identifier-at-point "xref") (declare-function xref--find-ignores-arguments "xref") +(declare-function xref--regexp-to-extended "xref") +(declare-function xref--convert-hits "xref") ;;;###autoload (defun project-find-regexp (regexp) @@ -314,11 +345,29 @@ triggers completion when entering a pattern, including it requires quoting, e.g. `\\[quoted-insert]<space>'." (interactive (list (project--read-regexp))) (let* ((pr (project-current t)) - (dirs (if current-prefix-arg - (list (read-directory-name "Base directory: " - nil default-directory t)) - (project-roots pr)))) - (project--find-regexp-in dirs regexp pr))) + (files + (if (not current-prefix-arg) + (project-files pr (project-roots pr)) + (let ((dir (read-directory-name "Base directory: " + nil default-directory t))) + (project--files-in-directory dir + nil + (grep-read-files regexp)))))) + (xref--show-xrefs + (apply-partially #'project--find-regexp-in-files regexp files) + nil))) + +(defun project--dir-ignores (project dir) + (let* ((roots (project-roots project)) + (root (cl-find dir roots :test #'file-in-directory-p))) + (if (not root) + (project-ignores nil nil) ;The defaults. + (let ((ignores (project-ignores project root))) + (if (file-equal-p root dir) + ignores + ;; FIXME: Update the "rooted" ignores to relate to DIR instead. + (cl-delete-if (lambda (str) (string-prefix-p "./" str)) + ignores)))))) ;;;###autoload (defun project-or-external-find-regexp (regexp) @@ -327,29 +376,78 @@ With \\[universal-argument] prefix, you can specify the file name pattern to search for." (interactive (list (project--read-regexp))) (let* ((pr (project-current t)) - (dirs (append - (project-roots pr) - (project-external-roots pr)))) - (project--find-regexp-in dirs regexp pr))) + (files + (project-files pr (append + (project-roots pr) + (project-external-roots pr))))) + (xref--show-xrefs + (apply-partially #'project--find-regexp-in-files regexp files) + nil))) + +(defun project--find-regexp-in-files (regexp files) + (pcase-let* + ((output (get-buffer-create " *project grep output*")) + (`(,grep-re ,file-group ,line-group . ,_) (car grep-regexp-alist)) + (status nil) + (hits nil) + (xrefs nil) + (command (format "xargs -0 grep %s -nHE -e %s" + (if (and case-fold-search + (isearch-no-upper-case-p regexp t)) + "-i" + "") + (shell-quote-argument (xref--regexp-to-extended regexp))))) + (with-current-buffer output + (erase-buffer) + (with-temp-buffer + (insert (mapconcat #'identity files "\0")) + (setq status + (project--process-file-region (point-min) + (point-max) + shell-file-name + output + nil + shell-command-switch + command))) + (goto-char (point-min)) + (when (and (/= (point-min) (point-max)) + (not (looking-at grep-re)) + ;; TODO: Show these matches as well somehow? + (not (looking-at "Binary file .* matches"))) + (user-error "Search failed with status %d: %s" status + (buffer-substring (point-min) (line-end-position)))) + (while (re-search-forward grep-re nil t) + (push (list (string-to-number (match-string line-group)) + (match-string file-group) + (buffer-substring-no-properties (point) (line-end-position))) + hits))) + (setq xrefs (xref--convert-hits (nreverse hits) regexp)) + (unless xrefs + (user-error "No matches for: %s" regexp)) + xrefs)) + +(defun project--process-file-region (start end program + &optional buffer display + &rest args) + ;; FIXME: This branching shouldn't be necessary, but + ;; call-process-region *is* measurably faster, even for a program + ;; doing some actual work (for a period of time). Even though + ;; call-process-region also creates a temp file internally + ;; (http://lists.gnu.org/archive/html/emacs-devel/2019-01/msg00211.html). + (if (not (file-remote-p default-directory)) + (apply #'call-process-region + start end program nil buffer display args) + (let ((infile (make-temp-file "ppfr"))) + (unwind-protect + (progn + (write-region start end infile nil 'silent) + (apply #'process-file program infile buffer display args)) + (delete-file infile))))) (defun project--read-regexp () (let ((id (xref-backend-identifier-at-point (xref-find-backend)))) (read-regexp "Find regexp" (and id (regexp-quote id))))) -(defun project--find-regexp-in (dirs regexp project) - (require 'grep) - (let* ((files (if current-prefix-arg - (grep-read-files regexp) - "*")) - (xrefs (cl-mapcan - (lambda (dir) - (xref-collect-matches regexp files dir - (project-ignores project dir))) - dirs))) - (unless xrefs - (user-error "No matches for: %s" regexp)) - (xref--show-xrefs xrefs nil))) - ;;;###autoload (defun project-find-file () "Visit a file (with completion) in the current project's roots. @@ -372,35 +470,102 @@ recognized." (project-external-roots pr)))) (project-find-file-in (thing-at-point 'filename) dirs pr))) +(defcustom project-read-file-name-function #'project--read-file-cpd-relative + "Function to call to read a file name from a list. +For the arguments list, see `project--read-file-cpd-relative'." + :type '(choice (const :tag "Read with completion from relative names" + project--read-file-cpd-relative) + (const :tag "Read with completion from absolute names" + project--read-file-absolute) + (function :tag "Custom function" nil)) + :version "27.1") + +(defun project--read-file-cpd-relative (prompt + all-files &optional predicate + hist default) + "Read a file name, prompting with PROMPT. +ALL-FILES is a list of possible file name completions. +PREDICATE, HIST, and DEFAULT have the same meaning as in +`completing-read'." + (let* ((common-parent-directory + (let ((common-prefix (try-completion "" all-files))) + (if (> (length common-prefix) 0) + (file-name-directory common-prefix)))) + (cpd-length (length common-parent-directory)) + (prompt (if (zerop cpd-length) + prompt + (concat prompt (format " in %s" common-parent-directory)))) + (substrings (mapcar (lambda (s) (substring s cpd-length)) all-files)) + (new-collection (project--file-completion-table substrings)) + (res (project--completing-read-strict prompt + new-collection + predicate + hist default))) + (concat common-parent-directory res))) + +(defun project--read-file-absolute (prompt + all-files &optional predicate + hist default) + (project--completing-read-strict prompt + (project--file-completion-table all-files) + predicate + hist default)) + (defun project-find-file-in (filename dirs project) "Complete FILENAME in DIRS in PROJECT and visit the result." - (let* ((table (project-file-completion-table project dirs)) - (file (project--completing-read-strict - "Find file" table nil nil - filename))) + (let* ((all-files (project-files project dirs)) + (file (funcall project-read-file-name-function + "Find file" all-files nil nil + filename))) (if (string= file "") (user-error "You didn't specify the file") (find-file file)))) (defun project--completing-read-strict (prompt collection &optional predicate - hist default inherit-input-method) + hist default) ;; Tried both expanding the default before showing the prompt, and ;; removing it when it has no matches. Neither seems natural ;; enough. Removal is confusing; early expansion makes the prompt ;; too long. - (let* ((new-prompt (if default + (let* ((new-prompt (if (and default (not (string-equal default ""))) (format "%s (default %s): " prompt default) (format "%s: " prompt))) (res (completing-read new-prompt collection predicate t - nil hist default inherit-input-method))) - (if (and (equal res default) - (not (test-completion res collection predicate))) - (completing-read (format "%s: " prompt) - collection predicate t res hist nil - inherit-input-method) - res))) + nil ;; initial-input + hist default))) + (when (and (equal res default) + (not (test-completion res collection predicate))) + (setq res + (completing-read (format "%s: " prompt) + collection predicate t res hist nil))) + res)) + +(declare-function fileloop-continue "fileloop" ()) + +;;;###autoload +(defun project-search (regexp) + "Search for REGEXP in all the files of the project. +Stops when a match is found. +To continue searching for next match, use command \\[fileloop-continue]." + (interactive "sSearch (regexp): ") + (fileloop-initialize-search + regexp (project-files (project-current t)) 'default) + (fileloop-continue)) + +;;;###autoload +(defun project-query-replace-regexp (from to) + "Search for REGEXP in all the files of the project. +Stops when a match is found. +To continue searching for next match, use command \\[fileloop-continue]." + (interactive + (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) + (fileloop-continue)) (provide 'project) ;;; project.el ends here diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el index 8f75344912c..780eff2d8a0 100644 --- a/lisp/progmodes/prolog.el +++ b/lisp/progmodes/prolog.el @@ -942,21 +942,21 @@ This is really kludgy, and unneeded (i.e. obsolete) in Emacs>=24." (defun prolog-smie-rules (kind token) (pcase (cons kind token) - (`(:elem . basic) prolog-indent-width) + ('(:elem . basic) prolog-indent-width) ;; The list of arguments can never be on a separate line! (`(:list-intro . ,_) t) ;; When we don't know how to indent an empty line, assume the most ;; likely token will be ";". - (`(:elem . empty-line-token) ";") - (`(:after . ".") '(column . 0)) ;; To work around smie-closer-alist. + ('(:elem . empty-line-token) ";") + ('(:after . ".") '(column . 0)) ;; To work around smie-closer-alist. ;; Allow indentation of if-then-else as: ;; ( test ;; -> thenrule ;; ; elserule ;; ) - (`(:before . ,(or `"->" `";")) + (`(:before . ,(or "->" ";")) (and (smie-rule-bolp) (smie-rule-parent-p "(") (smie-rule-parent 0))) - (`(:after . ,(or `"->" `"*->")) + (`(:after . ,(or "->" "*->")) ;; We distinguish ;; ;; (a -> @@ -977,7 +977,7 @@ This is really kludgy, and unneeded (i.e. obsolete) in Emacs>=24." (smie-indent-backward-token) (smie-rule-bolp)))) prolog-indent-width)) - (`(:after . ";") + ('(:after . ";") ;; Align with same-line comment as in: ;; ; %% Toto ;; foo @@ -989,7 +989,7 @@ This is really kludgy, and unneeded (i.e. obsolete) in Emacs>=24." ;; Only do it for small offsets, since the comment may actually be ;; an "end-of-line" comment at comment-column! (if (<= offset prolog-indent-width) offset)))) - (`(:after . ",") + ('(:after . ",") ;; Special indent for: ;; foopredicate(x) :- !, ;; toto. @@ -998,7 +998,7 @@ This is really kludgy, and unneeded (i.e. obsolete) in Emacs>=24." (smie-indent-backward-token) ;Skip ! (equal ":-" (car (smie-indent-backward-token)))) (smie-rule-parent prolog-indent-width))) - (`(:after . ":-") + ('(:after . ":-") (if (bolp) (save-excursion (smie-indent-forward-token) @@ -1007,7 +1007,7 @@ This is really kludgy, and unneeded (i.e. obsolete) in Emacs>=24." prolog-indent-width (min prolog-indent-width (current-column)))) prolog-indent-width)) - (`(:after . "-->") prolog-indent-width))) + ('(:after . "-->") prolog-indent-width))) ;;------------------------------------------------------------------- @@ -1071,7 +1071,7 @@ VERSION is of the format (Major . Minor)" ;; Supposedly, ISO-Prolog wants \NNN\ for octal and \xNNN\ for hexadecimal ;; escape sequences in atoms, so be careful not to let the terminating \ ;; escape a subsequent quote. - ("\\\\[x0-7][0-9a-fA-F]*\\(\\\\\\)" (1 "_")) + ("\\\\[x0-7][[:xdigit:]]*\\(\\\\\\)" (1 "_")) ))) (defun prolog-mode-variables () @@ -2826,7 +2826,7 @@ STRING should be given if the last search was by `string-match' on STRING." (progn (if (and (eq prolog-system 'mercury) (looking-at - (format ":-[ \t]*\\(pred\\|mode\\)[ \t]+\\(%s+\\)" + (format ":-[ \t]*\\(pred\\|mode\\)[ \t]+\\(\\(?:%s\\)+\\)" prolog-atom-regexp))) ;; Skip predicate declarations (progn @@ -2950,7 +2950,7 @@ objects (relevant only if `prolog-system' is set to `sicstus')." (predname (if (looking-at prolog-atom-char-regexp) (progn - (skip-chars-forward "^ (\\.") + (skip-chars-forward "^ (.") (buffer-substring op (point))) "")) (arity 0)) @@ -3247,11 +3247,11 @@ the following comma and whitespace, if any." (defun prolog-post-self-insert () (pcase last-command-event - (`?_ (prolog-electric--underscore)) - (`?- (prolog-electric--dash)) - (`?: (prolog-electric--colon)) - ((or `?\( `?\; `?>) (prolog-electric--if-then-else)) - (`?. (prolog-electric--dot)))) + (?_ (prolog-electric--underscore)) + (?- (prolog-electric--dash)) + (?: (prolog-electric--colon)) + ((or ?\( ?\; ?>) (prolog-electric--if-then-else)) + (?. (prolog-electric--dot)))) (defun prolog-find-term (functor arity &optional prefix) "Go to the position at the start of the next occurrence of a term. diff --git a/lisp/progmodes/ps-mode.el b/lisp/progmodes/ps-mode.el index 381286ccb40..b589cab9c25 100644 --- a/lisp/progmodes/ps-mode.el +++ b/lisp/progmodes/ps-mode.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1999, 2001-2019 Free Software Foundation, Inc. ;; Author: Peter Kleiweg <p.c.j.kleiweg@rug.nl> -;; Maintainer: Peter Kleiweg <p.c.j.kleiweg@rug.nl> ;; Created: 20 Aug 1997 ;; Version: 1.1i ;; Keywords: PostScript, languages @@ -458,9 +457,9 @@ If nil, use `temporary-file-directory'." (defun ps-mode-smie-rules (kind token) (pcase (cons kind token) - (`(:after . "<") (when (smie-rule-next-p "<") 0)) - (`(:elem . basic) ps-mode-tab) - (`(:close-all . ">") t) + ('(:after . "<") (when (smie-rule-next-p "<") 0)) + ('(:elem . basic) ps-mode-tab) + ('(:close-all . ">") t) (`(:list-intro . ,_) t))) ;;;###autoload @@ -725,24 +724,18 @@ Only one `%' is removed, and it has to be in the first column." (defun ps-mode-octal-region (begin end) "Change 8-bit characters to octal codes in region." - (interactive "r") - (if buffer-read-only - (progn - (ding) - (message "Buffer is read only")) - (save-excursion - (let (endm i) - (setq endm (make-marker)) - (set-marker endm end) - (goto-char begin) - (setq i 0) - (while (re-search-forward "[\200-\377]" (marker-position endm) t) - (setq i (1+ i)) - (backward-char) - (insert (format "\\%03o" (string-to-char (string-make-unibyte (buffer-substring (point) (1+ (point))))))) - (delete-char 1)) - (message "%d change%s made" i (if (= i 1) "" "s")) - (set-marker endm nil))))) + (interactive "*r") + (save-excursion + (let ((endm (copy-marker end)) + (i 0)) + (goto-char begin) + (while (re-search-forward "[\200-\377]" (marker-position endm) t) + (setq i (1+ i)) + (replace-match (format "\\%03o" + (multibyte-char-to-unibyte (char-before))) + t t)) + (message "%d change%s made" i (if (= i 1) "" "s")) + (set-marker endm nil)))) ;; Cookbook. @@ -952,11 +945,11 @@ This mode is invoked from `ps-mode' and should not be called directly." (delete-process "ps-run")) (erase-buffer) (setq command (append command init-file)) - (insert (mapconcat 'identity command " ") "\n") - (apply 'make-comint "ps-run" (car command) nil (cdr command)) + (insert (mapconcat #'identity command " ") "\n") + (apply #'make-comint "ps-run" (car command) nil (cdr command)) (with-current-buffer "*ps-run*" (use-local-map ps-run-mode-map) - (setq comint-prompt-regexp ps-run-prompt)) + (setq-local comint-prompt-regexp ps-run-prompt)) (select-window oldwin))) (defun ps-run-quit () diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 8e7d9f23b0e..14b65669c4b 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -4,7 +4,7 @@ ;; Author: Fabián E. Gallina <fgallina@gnu.org> ;; URL: https://github.com/fgallina/python.el -;; Version: 0.25.2 +;; Version: 0.26.1 ;; Package-Requires: ((emacs "24.1") (cl-lib "1.0")) ;; Maintainer: emacs-devel@gnu.org ;; Created: Jul 2010 @@ -287,9 +287,20 @@ ;;; 24.x Compat -(unless (fboundp 'prog-first-column) - (defun prog-first-column () - 0)) +(eval-and-compile + (unless (fboundp 'prog-first-column) + (defun prog-first-column () + 0)) + (unless (fboundp 'file-local-name) + (defun file-local-name (file) + "Return the local name component of FILE. +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 file 'localname) file)))) + +;; In Emacs 24.3 and earlier, `define-derived-mode' does not define +;; the hook variable, it only puts documentation on the symbol. +(defvar inferior-python-mode-hook) ;;; Bindings @@ -331,7 +342,7 @@ (substitute-key-definition 'complete-symbol 'completion-at-point map global-map) (easy-menu-define python-menu map "Python Mode menu" - `("Python" + '("Python" :help "Python-specific Features" ["Shift region left" python-indent-shift-left :active mark-active :help "Shift region left by a single indentation step"] @@ -427,7 +438,7 @@ (* ?\\ ?\\) (any ?\' ?\"))) (* ?\\ ?\\) ;; Match single or triple quotes of any kind. - (group (or "\"" "\"\"\"" "'" "'''"))))) + (group (or "\"\"\"" "\"" "'''" "'"))))) (coding-cookie . ,(rx line-start ?# (* space) (or ;; # coding=<encoding name> @@ -458,13 +469,13 @@ This variant of `rx' supports common Python named REGEXPS." (eval-and-compile (defun python-syntax--context-compiler-macro (form type &optional syntax-ppss) (pcase type - (`'comment + (''comment `(let ((ppss (or ,syntax-ppss (syntax-ppss)))) (and (nth 4 ppss) (nth 8 ppss)))) - (`'string + (''string `(let ((ppss (or ,syntax-ppss (syntax-ppss)))) (and (nth 3 ppss) (nth 8 ppss)))) - (`'paren + (''paren `(nth 1 (or ,syntax-ppss (syntax-ppss)))) (_ form)))) @@ -475,9 +486,9 @@ character address of the specified TYPE." (declare (compiler-macro python-syntax--context-compiler-macro)) (let ((ppss (or syntax-ppss (syntax-ppss)))) (pcase type - (`comment (and (nth 4 ppss) (nth 8 ppss))) - (`string (and (nth 3 ppss) (nth 8 ppss))) - (`paren (nth 1 ppss)) + ('comment (and (nth 4 ppss) (nth 8 ppss))) + ('string (and (nth 3 ppss) (nth 8 ppss))) + ('paren (nth 1 ppss)) (_ nil)))) (defun python-syntax-context-type (&optional syntax-ppss) @@ -515,9 +526,19 @@ The type returned can be `comment', `string' or `paren'." font-lock-string-face) font-lock-comment-face)) -(defvar python-font-lock-keywords - ;; Keywords - `(,(rx symbol-start +(defvar python-font-lock-keywords-level-1 + `((,(rx symbol-start "def" (1+ space) (group (1+ (or word ?_)))) + (1 font-lock-function-name-face)) + (,(rx symbol-start "class" (1+ space) (group (1+ (or word ?_)))) + (1 font-lock-type-face))) + "Font lock keywords to use in python-mode for level 1 decoration. + +This is the minimum decoration level, including function and +class declarations.") + +(defvar python-font-lock-keywords-level-2 + `(,@python-font-lock-keywords-level-1 + ,(rx symbol-start (or "and" "del" "from" "not" "while" "as" "elif" "global" "or" "with" "assert" "else" "if" "pass" "yield" "break" "except" "import" "class" @@ -537,12 +558,35 @@ The type returned can be `comment', `string' or `paren'." ;; Extra: "self") symbol-end) - ;; functions - (,(rx symbol-start "def" (1+ space) (group (1+ (or word ?_)))) - (1 font-lock-function-name-face)) - ;; classes - (,(rx symbol-start "class" (1+ space) (group (1+ (or word ?_)))) - (1 font-lock-type-face)) + ;; Builtins + (,(rx symbol-start + (or + "abs" "all" "any" "bin" "bool" "callable" "chr" "classmethod" + "compile" "complex" "delattr" "dict" "dir" "divmod" "enumerate" + "eval" "filter" "float" "format" "frozenset" "getattr" "globals" + "hasattr" "hash" "help" "hex" "id" "input" "int" "isinstance" + "issubclass" "iter" "len" "list" "locals" "map" "max" "memoryview" + "min" "next" "object" "oct" "open" "ord" "pow" "print" "property" + "range" "repr" "reversed" "round" "set" "setattr" "slice" "sorted" + "staticmethod" "str" "sum" "super" "tuple" "type" "vars" "zip" + "__import__" + ;; Python 2: + "basestring" "cmp" "execfile" "file" "long" "raw_input" "reduce" + "reload" "unichr" "unicode" "xrange" "apply" "buffer" "coerce" + "intern" + ;; Python 3: + "ascii" "breakpoint" "bytearray" "bytes" "exec" + ;; Extra: + "__all__" "__doc__" "__name__" "__package__") + symbol-end) . font-lock-builtin-face)) + "Font lock keywords to use in python-mode for level 2 decoration. + +This is the medium decoration level, including everything in +`python-font-lock-keywords-level-1', as well as keywords and +builtins.") + +(defvar python-font-lock-keywords-maximum-decoration + `(,@python-font-lock-keywords-level-2 ;; Constants (,(rx symbol-start (or @@ -585,27 +629,6 @@ The type returned can be `comment', `string' or `paren'." "VMSError" "WindowsError" ) symbol-end) . font-lock-type-face) - ;; Builtins - (,(rx symbol-start - (or - "abs" "all" "any" "bin" "bool" "callable" "chr" "classmethod" - "compile" "complex" "delattr" "dict" "dir" "divmod" "enumerate" - "eval" "filter" "float" "format" "frozenset" "getattr" "globals" - "hasattr" "hash" "help" "hex" "id" "input" "int" "isinstance" - "issubclass" "iter" "len" "list" "locals" "map" "max" "memoryview" - "min" "next" "object" "oct" "open" "ord" "pow" "print" "property" - "range" "repr" "reversed" "round" "set" "setattr" "slice" "sorted" - "staticmethod" "str" "sum" "super" "tuple" "type" "vars" "zip" - "__import__" - ;; Python 2: - "basestring" "cmp" "execfile" "file" "long" "raw_input" "reduce" - "reload" "unichr" "unicode" "xrange" "apply" "buffer" "coerce" - "intern" - ;; Python 3: - "ascii" "bytearray" "bytes" "exec" - ;; Extra: - "__all__" "__doc__" "__name__" "__package__") - symbol-end) . font-lock-builtin-face) ;; assignments ;; support for a = b = c = 5 (,(lambda (limit) @@ -629,22 +652,41 @@ The type returned can be `comment', `string' or `paren'." (goto-char (match-end 1)) (python-syntax-context 'paren))) res)) - (1 font-lock-variable-name-face nil nil)))) + (1 font-lock-variable-name-face nil nil))) + "Font lock keywords to use in python-mode for maximum decoration. + +This decoration level includes everything in +`python-font-lock-keywords-level-2', as well as constants, +decorators, exceptions, and assignments.") + +(defvar python-font-lock-keywords + '(python-font-lock-keywords-level-1 ; When `font-lock-maximum-decoration' is nil. + python-font-lock-keywords-level-1 ; When `font-lock-maximum-decoration' is 1. + python-font-lock-keywords-level-2 ; When `font-lock-maximum-decoration' is 2. + python-font-lock-keywords-maximum-decoration ; When `font-lock-maximum-decoration' + ; is more than 1, or t (which it is, + ; by default). + ) + "List of font lock keyword specifications to use in python-mode. + +Which one will be chosen depends on the value of +`font-lock-maximum-decoration'.") + (defconst python-syntax-propertize-function (syntax-propertize-rules - ((python-rx string-delimiter) + ((rx (or "\"\"\"" "'''")) (0 (ignore (python-syntax-stringify)))))) +(define-obsolete-variable-alias 'python--prettify-symbols-alist + 'python-prettify-symbols-alist "26.1") + (defvar python-prettify-symbols-alist '(("lambda" . ?λ) ("and" . ?∧) ("or" . ?∨)) "Value for `prettify-symbols-alist' in `python-mode'.") -(define-obsolete-variable-alias 'python--prettify-symbols-alist - 'python-prettify-symbols-alist "26.1") - (defsubst python-syntax-count-quotes (quote-char &optional point limit) "Count number of quotes around point (max is 3). QUOTE-CHAR is the quote char to count. Optional argument POINT is @@ -659,35 +701,27 @@ is used to limit the scan." (defun python-syntax-stringify () "Put `syntax-table' property correctly on single/triple quotes." - (let* ((num-quotes (length (match-string-no-properties 1))) - (ppss (prog2 - (backward-char num-quotes) - (syntax-ppss) - (forward-char num-quotes))) - (string-start (and (not (nth 4 ppss)) (nth 8 ppss))) - (quote-starting-pos (- (point) num-quotes)) - (quote-ending-pos (point)) - (num-closing-quotes - (and string-start - (python-syntax-count-quotes - (char-before) string-start quote-starting-pos)))) - (cond ((and string-start (= num-closing-quotes 0)) - ;; This set of quotes doesn't match the string starting - ;; kind. Do nothing. + (let* ((ppss (save-excursion (backward-char 3) (syntax-ppss))) + (string-start (and (eq t (nth 3 ppss)) (nth 8 ppss))) + (quote-starting-pos (- (point) 3)) + (quote-ending-pos (point))) + (cond ((or (nth 4 ppss) ;Inside a comment + (and string-start + ;; Inside of a string quoted with different triple quotes. + (not (eql (char-after string-start) + (char-after quote-starting-pos))))) + ;; Do nothing. nil) - ((not string-start) + ((nth 5 ppss) + ;; The first quote is escaped, so it's not part of a triple quote! + (goto-char (1+ quote-starting-pos))) + ((null string-start) ;; This set of quotes delimit the start of a string. (put-text-property quote-starting-pos (1+ quote-starting-pos) 'syntax-table (string-to-syntax "|"))) - ((= num-quotes num-closing-quotes) + (t ;; This set of quotes delimit the end of a string. (put-text-property (1- quote-ending-pos) quote-ending-pos - 'syntax-table (string-to-syntax "|"))) - ((> num-quotes num-closing-quotes) - ;; This may only happen whenever a triple quote is closing - ;; a single quoted string. Add string delimiter syntax to - ;; all three quotes. - (put-text-property quote-starting-pos quote-ending-pos 'syntax-table (string-to-syntax "|")))))) (defvar python-mode-syntax-table @@ -1036,12 +1070,18 @@ possibilities can be narrowed to specific indentation points." (`(,(or :after-line :after-comment :inside-string - :after-backslash - :inside-paren-at-closing-paren - :inside-paren-at-closing-nested-paren) . ,start) + :after-backslash) . ,start) ;; Copy previous indentation. (goto-char start) (current-indentation)) + (`(,(or :inside-paren-at-closing-paren + :inside-paren-at-closing-nested-paren) . ,start) + (goto-char (+ 1 start)) + (if (looking-at "[ \t]*\\(?:#\\|$\\)") + ;; Copy previous indentation. + (current-indentation) + ;; Align with opening paren. + (current-column))) (`(:inside-docstring . ,start) (let* ((line-indentation (current-indentation)) (base-indent (progn @@ -1292,16 +1332,17 @@ the line will be re-indented automatically if needed." (not (equal ?: (char-before (1- (point))))) (not (python-syntax-comment-or-string-p))) ;; Just re-indent dedenters - (let ((dedenter-pos (python-info-dedenter-statement-p)) - (current-pos (point))) + (let ((dedenter-pos (python-info-dedenter-statement-p))) (when dedenter-pos - (save-excursion - (goto-char dedenter-pos) - (python-indent-line) - (unless (= (line-number-at-pos dedenter-pos) - (line-number-at-pos current-pos)) - ;; Reindent region if this is a multiline statement - (python-indent-region dedenter-pos current-pos))))))))) + (let ((start (copy-marker dedenter-pos)) + (end (point-marker))) + (save-excursion + (goto-char start) + (python-indent-line) + (unless (= (line-number-at-pos start) + (line-number-at-pos end)) + ;; Reindent region if this is a multiline statement + (python-indent-region start end)))))))))) ;;; Mark @@ -1474,7 +1515,7 @@ nested definitions." (defun python-nav-beginning-of-statement () "Move to start of current statement." (interactive "^") - (back-to-indentation) + (forward-line 0) (let* ((ppss (syntax-ppss)) (context-point (or @@ -1489,6 +1530,7 @@ nested definitions." (python-info-line-ends-backslash-p)) (forward-line -1) (python-nav-beginning-of-statement)))) + (back-to-indentation) (point-marker)) (defun python-nav-end-of-statement (&optional noend) @@ -1506,9 +1548,10 @@ of the statement." ;; are somehow out of whack. This has been ;; observed when using `syntax-ppss' during ;; narrowing. - (cl-assert (> string-start last-string-end) + (cl-assert (>= string-start last-string-end) :show-args - "Overlapping strings detected") + "\ +Overlapping strings detected (start=%d, last-end=%d)") (goto-char string-start) (if (python-syntax-context 'paren) ;; Ended up inside a paren, roll again. @@ -1966,7 +2009,7 @@ position, else returns nil." It should not contain a caret (^) at the beginning." :type 'string) -(defcustom python-shell-prompt-block-regexp "\\.\\.\\. " +(defcustom python-shell-prompt-block-regexp "\\.\\.\\.:? " "Regular expression matching block input prompt of Python shell. It should not contain a caret (^) at the beginning." :type 'string) @@ -2147,7 +2190,7 @@ of `exec-path'." (defun python-shell-tramp-refresh-process-environment (vec env) "Update VEC's process environment with ENV." ;; Stolen from `tramp-open-connection-setup-interactive-shell'. - (let ((env (append (when (fboundp #'tramp-get-remote-locale) + (let ((env (append (when (fboundp 'tramp-get-remote-locale) ;; Emacs<24.4 compat. (list (tramp-get-remote-locale vec))) (copy-sequence env))) @@ -2830,10 +2873,12 @@ process buffer for a list of commands.)" (y-or-n-p "Make dedicated process? ") (= (prefix-numeric-value current-prefix-arg) 4)) (list (python-shell-calculate-command) nil t))) - (get-buffer-process - (python-shell-make-comint - (or cmd (python-shell-calculate-command)) - (python-shell-get-process-name dedicated) show))) + (let ((buffer + (python-shell-make-comint + (or cmd (python-shell-calculate-command)) + (python-shell-get-process-name dedicated) show))) + (pop-to-buffer buffer) + (get-buffer-process buffer))) (defun run-python-internal () "Run an inferior Internal Python process. @@ -2911,11 +2956,17 @@ be asked for their values." "Instead call `python-shell-get-process' and create one if returns nil." "25.1") +(define-obsolete-variable-alias + 'python-buffer 'python-shell-internal-buffer "24.3") + (defvar python-shell-internal-buffer nil "Current internal shell buffer for the current buffer. This is really not necessary at all for the code to work but it's there for compatibility with CEDET.") +(define-obsolete-variable-alias + 'python-preoutput-result 'python-shell-internal-last-output "24.3") + (defvar python-shell-internal-last-output nil "Last output captured by the internal shell. This is really not necessary at all for the code to work but it's @@ -2931,12 +2982,6 @@ there for compatibility with CEDET.") (define-obsolete-function-alias 'python-proc 'python-shell-internal-get-or-create-process "24.3") -(define-obsolete-variable-alias - 'python-buffer 'python-shell-internal-buffer "24.3") - -(define-obsolete-variable-alias - 'python-preoutput-result 'python-shell-internal-last-output "24.3") - (defun python-shell--save-temp-file (string) (let* ((temporary-file-directory (if (file-remote-p default-directory) @@ -3151,9 +3196,12 @@ t when called interactively." (beginning-of-line 1)) (> (current-indentation) 0))) (when (not arg) - (while (and (forward-line -1) - (looking-at (python-rx decorator)))) - (forward-line 1)) + (while (and + (eq (forward-line -1) 0) + (if (looking-at (python-rx decorator)) + t + (forward-line 1) + nil)))) (point-marker)) (progn (or (python-nav-end-of-defun) @@ -3184,10 +3232,10 @@ t when called interactively." (insert-file-contents (or temp-file-name file-name)) (python-info-encoding))) - (file-name (expand-file-name (file-local-name file-name))) + (file-name (file-local-name (expand-file-name file-name))) (temp-file-name (when temp-file-name - (expand-file-name - (file-local-name temp-file-name))))) + (file-local-name (expand-file-name + temp-file-name))))) (python-shell-send-string (format (concat @@ -3967,11 +4015,11 @@ JUSTIFY should be used (if applicable) as in `fill-paragraph'." ;; is NIL means to not add any newlines for start or end ;; of docstring. See `python-fill-docstring-style' for a ;; graphic idea of each style. - (`django (cons 1 1)) - (`onetwo (and multi-line-p (cons 1 2))) - (`pep-257 (and multi-line-p (cons nil 2))) - (`pep-257-nn (and multi-line-p (cons nil 1))) - (`symmetric (and multi-line-p (cons 1 1))))) + ('django (cons 1 1)) + ('onetwo (and multi-line-p (cons 1 2))) + ('pep-257 (and multi-line-p (cons nil 2))) + ('pep-257-nn (and multi-line-p (cons nil 1))) + ('symmetric (and multi-line-p (cons 1 1))))) (fill-paragraph-function)) (save-restriction (narrow-to-region str-start-pos str-end-pos) @@ -5192,9 +5240,10 @@ be used." (defcustom python-flymake-msg-alist '(("\\(^redefinition\\|.*unused.*\\|used$\\)" . :warning)) "Alist used to associate messages to their types. -Each element should be a cons-cell (REGEXP . TYPE), where TYPE must be -one defined in the variable `flymake-diagnostic-types-alist'. -For example, when using `flake8' a possible configuration could be: +Each element should be a cons-cell (REGEXP . TYPE), where TYPE +should be a diagnostic type symbol like `:error', `:warning' or +`:note'. For example, when using `flake8' a possible +configuration could be: ((\"\\(^redefinition\\|.*unused.*\\|used$\\)\" . :warning) (\"^E999\" . :error) @@ -5203,7 +5252,7 @@ For example, when using `flake8' a possible configuration could be: By default messages are considered errors." :version "26.1" :group 'python-flymake - :type `(alist :key-type (regexp) + :type '(alist :key-type (regexp) :value-type (symbol))) (defvar-local python--flymake-proc nil) @@ -5287,6 +5336,7 @@ REPORT-FN is Flymake's callback function." (save-excursion (insert (make-string 2 last-command-event))))) (defvar electric-indent-inhibit) +(defvar prettify-symbols-alist) ;;;###autoload (define-derived-mode python-mode prog-mode "Python" @@ -5306,7 +5356,7 @@ REPORT-FN is Flymake's callback function." 'python-nav-forward-sexp) (set (make-local-variable 'font-lock-defaults) - '(python-font-lock-keywords + `(,python-font-lock-keywords nil nil nil nil (font-lock-syntactic-face-function . python-font-lock-syntactic-face-function))) @@ -5329,6 +5379,7 @@ REPORT-FN is Flymake's callback function." (set (make-local-variable 'paragraph-start) "\\s-*$") (set (make-local-variable 'fill-paragraph-function) #'python-fill-paragraph) + (set (make-local-variable 'fill-indent-according-to-mode) t) ; Bug#36056. (set (make-local-variable 'beginning-of-defun-function) #'python-nav-beginning-of-defun) @@ -5364,7 +5415,7 @@ REPORT-FN is Flymake's callback function." (add-to-list 'hs-special-modes-alist - `(python-mode + '(python-mode "\\s-*\\_<\\(?:def\\|class\\)\\_>" ;; Use the empty string as end regexp so it doesn't default to ;; "\\s)". This way parens at end of defun are properly hidden. @@ -5382,7 +5433,7 @@ REPORT-FN is Flymake's callback function." (1+ (/ (current-indentation) python-indent-offset)))) (set (make-local-variable 'prettify-symbols-alist) - python--prettify-symbols-alist) + python-prettify-symbols-alist) (python-skeleton-add-menu-items) diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el index bc9979ae997..340c689f02e 100644 --- a/lisp/progmodes/ruby-mode.el +++ b/lisp/progmodes/ruby-mode.el @@ -39,6 +39,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defgroup ruby nil "Major mode for editing Ruby code." :prefix "ruby-" @@ -106,7 +108,7 @@ "Regexp to match the beginning of a heredoc.") (defconst ruby-expression-expansion-re - "\\(?:[^\\]\\|\\=\\)\\(\\\\\\\\\\)*\\(#\\({[^}\n\\\\]*\\(\\\\.[^}\n\\\\]*\\)*}\\|\\(\\$\\|@\\|@@\\)\\(\\w\\|_\\)+\\|\\$[^a-zA-Z \n]\\)\\)")) + "\\(?:[^\\]\\|\\=\\)\\(\\\\\\\\\\)*\\(#\\({[^}\n\\]*\\(\\\\.[^}\n\\]*\\)*}\\|\\(\\$\\|@\\|@@\\)\\(\\w\\|_\\)+\\|\\$[^a-zA-Z \n]\\)\\)")) (defun ruby-here-doc-end-match () "Return a regexp to find the end of a heredoc. @@ -153,6 +155,7 @@ This should only be called after matching against `ruby-here-doc-beg-re'." (define-key map (kbd "M-C-n") 'ruby-end-of-block) (define-key map (kbd "C-c {") 'ruby-toggle-block) (define-key map (kbd "C-c '") 'ruby-toggle-string-quotes) + (define-key map (kbd "C-c C-f") 'ruby-find-library-file) map) "Keymap used in Ruby mode.") @@ -215,19 +218,16 @@ This should only be called after matching against `ruby-here-doc-beg-re'." (defcustom ruby-indent-tabs-mode nil "Indentation can insert tabs in Ruby mode if this is non-nil." :type 'boolean - :group 'ruby :safe 'booleanp) (defcustom ruby-indent-level 2 "Indentation of Ruby statements." :type 'integer - :group 'ruby :safe 'integerp) (defcustom ruby-comment-column (default-value 'comment-column) "Indentation column of comments." :type 'integer - :group 'ruby :safe 'integerp) (defconst ruby-alignable-keywords '(if while unless until begin case for def) @@ -255,8 +255,7 @@ the statement: qux end -Only has effect when `ruby-use-smie' is t. -" +Only has effect when `ruby-use-smie' is t." :type `(choice (const :tag "None" nil) (const :tag "All" t) @@ -264,7 +263,6 @@ Only has effect when `ruby-use-smie' is t. (choice ,@(mapcar (lambda (kw) (list 'const kw)) ruby-alignable-keywords)))) - :group 'ruby :safe 'listp :version "24.4") @@ -276,7 +274,6 @@ of its parent. Only has effect when `ruby-use-smie' is t." :type 'boolean - :group 'ruby :safe 'booleanp :version "24.4") @@ -285,7 +282,6 @@ Only has effect when `ruby-use-smie' is t." Also ignores spaces after parenthesis when `space'. Only has effect when `ruby-use-smie' is nil." :type 'boolean - :group 'ruby :safe 'booleanp) ;; FIXME Woefully under documented. What is the point of the last t?. @@ -300,14 +296,12 @@ Only has effect when `ruby-use-smie' is nil." (cons character (choice (const nil) (const t))) (const t) ; why? - ))) - :group 'ruby) + )))) (defcustom ruby-deep-indent-paren-style 'space "Default deep indent style. Only has effect when `ruby-use-smie' is nil." - :type '(choice (const t) (const nil) (const space)) - :group 'ruby) + :type '(choice (const t) (const nil) (const space))) (defcustom ruby-encoding-map '((us-ascii . nil) ;; Do not put coding: us-ascii @@ -317,8 +311,7 @@ Only has effect when `ruby-use-smie' is nil." "Alist to map encoding name from Emacs to Ruby. Associating an encoding name with nil means it needs not be explicitly declared in magic comment." - :type '(repeat (cons (symbol :tag "From") (symbol :tag "To"))) - :group 'ruby) + :type '(repeat (cons (symbol :tag "From") (symbol :tag "To")))) (defcustom ruby-insert-encoding-magic-comment t "Insert a magic Ruby encoding comment upon save if this is non-nil. @@ -335,14 +328,12 @@ even if it's not required." (const :tag "Emacs Style" emacs) (const :tag "Ruby Style" ruby) (const :tag "Custom Style" custom)) - :group 'ruby :version "24.4") (defcustom ruby-custom-encoding-magic-comment-template "# encoding: %s" "A custom encoding comment template. It is used when `ruby-encoding-magic-comment-style' is set to `custom'." :type 'string - :group 'ruby :version "24.4") (defcustom ruby-use-encoding-map t @@ -527,6 +518,9 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." ((ruby-smie--opening-pipe-p) "opening-|") ((ruby-smie--closing-pipe-p) "closing-|") (t tok))) + ((string-match "\\`[^|]+|\\'" tok) + (forward-char -1) + (substring tok 0 -1)) ((and (equal tok "") (looking-at "\\\\\n")) (goto-char (match-end 0)) (ruby-smie--forward-token)) ((equal tok "do") @@ -569,6 +563,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." ((ruby-smie--opening-pipe-p) "opening-|") ((ruby-smie--closing-pipe-p) "closing-|") (t tok))) + ((string-match-p "\\`[^|]+|\\'" tok) "closing-|") ((string-match-p "\\`|[*&]\\'" tok) (forward-char 1) (substring tok 1)) @@ -596,12 +591,12 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." (defun ruby-smie-rules (kind token) (pcase (cons kind token) - (`(:elem . basic) ruby-indent-level) + ('(:elem . basic) ruby-indent-level) ;; "foo" "bar" is the concatenation of the two strings, so the second ;; should be aligned with the first. - (`(:elem . args) (if (looking-at "\\s\"") 0)) + ('(:elem . args) (if (looking-at "\\s\"") 0)) ;; (`(:after . ",") (smie-rule-separator kind)) - (`(:before . ";") + ('(:before . ";") (cond ((smie-rule-parent-p "def" "begin" "do" "class" "module" "for" "while" "until" "unless" @@ -611,7 +606,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." ;; For (invalid) code between switch and case. ;; (if (smie-parent-p "switch") 4) )) - (`(:before . ,(or `"(" `"[" `"{")) + (`(:before . ,(or "(" "[" "{")) (cond ((and (equal token "{") (not (smie-rule-prev-p "(" "{" "[" "," "=>" "=" "return" ";")) @@ -638,7 +633,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." (forward-char -1)) (smie-indent-virtual)) (t (smie-rule-parent)))))) - (`(:after . ,(or `"(" "[" "{")) + (`(:after . ,(or "(" "[" "{")) ;; FIXME: Shouldn't this be the default behavior of ;; `smie-indent-after-keyword'? (save-excursion @@ -648,20 +643,20 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." ;; because we want to reject hanging tokens at bol, too. (unless (or (eolp) (forward-comment 1)) (cons 'column (current-column))))) - (`(:before . " @ ") + ('(:before . " @ ") (save-excursion (skip-chars-forward " \t") (cons 'column (current-column)))) - (`(:before . "do") (ruby-smie--indent-to-stmt)) - (`(:before . ".") + ('(:before . "do") (ruby-smie--indent-to-stmt)) + ('(:before . ".") (if (smie-rule-sibling-p) (and ruby-align-chained-calls 0) (smie-backward-sexp ".") (cons 'column (+ (current-column) ruby-indent-level)))) - (`(:before . ,(or `"else" `"then" `"elsif" `"rescue" `"ensure")) + (`(:before . ,(or "else" "then" "elsif" "rescue" "ensure")) (smie-rule-parent)) - (`(:before . "when") + ('(:before . "when") ;; Align to the previous `when', but look up the virtual ;; indentation of `case'. (if (smie-rule-sibling-p) 0 (smie-rule-parent))) @@ -678,7 +673,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." (if (ruby-smie--indent-to-stmt-p token) (ruby-smie--indent-to-stmt) (cons 'column (current-column))))) - (`(:before . "iuwu-mod") + ('(:before . "iuwu-mod") (smie-rule-parent ruby-indent-level)) )) @@ -740,7 +735,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." (back-to-indentation) (narrow-to-region (point) end) (smie-forward-sexp)) - (while (and (setq state (apply 'ruby-parse-partial end state)) + (while (and (setq state (apply #'ruby-parse-partial end state)) (>= (nth 2 state) 0) (< (point) end)))))) (defun ruby-mode-variables () @@ -750,7 +745,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." (smie-setup ruby-smie-grammar #'ruby-smie-rules :forward-token #'ruby-smie--forward-token :backward-token #'ruby-smie--backward-token) - (setq-local indent-line-function 'ruby-indent-line)) + (setq-local indent-line-function #'ruby-indent-line)) (setq-local comment-start "# ") (setq-local comment-end "") (setq-local comment-column ruby-comment-column) @@ -766,9 +761,9 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." The style of the comment is controlled by `ruby-encoding-magic-comment-style'." (let ((encoding-magic-comment-template (pcase ruby-encoding-magic-comment-style - (`ruby "# coding: %s") - (`emacs "# -*- coding: %s -*-") - (`custom + ('ruby "# coding: %s") + ('emacs "# -*- coding: %s -*-") + ('custom ruby-custom-encoding-magic-comment-template)))) (insert (format encoding-magic-comment-template encoding) @@ -935,9 +930,9 @@ Can be one of `heredoc', `modifier', `expr-qstr', `expr-re'." (goto-char (match-end 0)) (not (looking-at "\\s_"))) ((eq option 'expr-qstr) - (looking-at "[a-zA-Z][a-zA-z0-9_]* +%[^ \t]")) + (looking-at "[a-zA-Z][a-zA-Z0-9_]* +%[^ \t]")) ((eq option 'expr-re) - (looking-at "[a-zA-Z][a-zA-z0-9_]* +/[^ \t]")) + (looking-at "[a-zA-Z][a-zA-Z0-9_]* +/[^ \t]")) (t nil))))))))) (defun ruby-forward-string (term &optional end no-error expand) @@ -985,6 +980,7 @@ delimiter." ((eq c ?\( ) ruby-deep-arglist))) (defun ruby-parse-partial (&optional end in-string nest depth pcol indent) + ;; FIXME: Document why we can't just use parse-partial-sexp. "TODO: document throughout function body." (or depth (setq depth 0)) (or indent (setq indent 0)) @@ -1052,7 +1048,7 @@ delimiter." ((looking-at "\\?") ;skip ?char (cond ((and (ruby-expr-beg) - (looking-at "?\\(\\\\C-\\|\\\\M-\\)*\\\\?.")) + (looking-at "\\?\\(\\\\C-\\|\\\\M-\\)*\\\\?.")) (goto-char (match-end 0))) (t (goto-char pnt)))) @@ -1159,7 +1155,7 @@ delimiter." (state (list in-string nest depth pcol indent))) ;; parse the rest of the line (while (and (> line-end-position (point)) - (setq state (apply 'ruby-parse-partial + (setq state (apply #'ruby-parse-partial line-end-position state)))) (setq in-string (car state) nest (nth 1 state) @@ -1196,7 +1192,7 @@ delimiter." (save-restriction (narrow-to-region (point) end) (while (and (> end (point)) - (setq state (apply 'ruby-parse-partial end state)))))) + (setq state (apply #'ruby-parse-partial end state)))))) (list (nth 0 state) ; in-string (car (nth 1 state)) ; nest (nth 2 state) ; depth @@ -1495,7 +1491,7 @@ With ARG, do it many times. Negative ARG means move backward." (cond ((looking-at "\\?\\(\\\\[CM]-\\)*\\\\?\\S ") (goto-char (match-end 0))) ((progn - (skip-chars-forward ",.:;|&^~=!?\\+\\-\\*") + (skip-chars-forward "-,.:;|&^~=!?+*") (looking-at "\\s(")) (goto-char (scan-sexps (point) 1))) ((and (looking-at (concat "\\<\\(" ruby-block-beg-re @@ -1538,20 +1534,20 @@ With ARG, do it many times. Negative ARG means move forward." (let ((i (or arg 1))) (condition-case nil (while (> i 0) - (skip-chars-backward " \t\n,.:;|&^~=!?\\+\\-\\*") + (skip-chars-backward "- \t\n,.:;|&^~=!?+*") (forward-char -1) (cond ((looking-at "\\s)") (goto-char (scan-sexps (1+ (point)) -1)) (pcase (char-before) - (`?% (forward-char -1)) - ((or `?q `?Q `?w `?W `?r `?x) + (?% (forward-char -1)) + ((or ?q ?Q ?w ?W ?r ?x) (if (eq (char-before (1- (point))) ?%) (forward-char -2)))) nil) ((looking-at "\\s\"\\|\\\\\\S_") (let ((c (char-to-string (char-before (match-end 0))))) (while (and (search-backward c) - (eq (logand (skip-chars-backward "\\") 1) + (eq (logand (skip-chars-backward "\\\\") 1) 1)))) nil) ((looking-at "\\s.\\|\\s\\") @@ -1561,13 +1557,13 @@ With ARG, do it many times. Negative ARG means move forward." (forward-char 1) (while (progn (forward-word-strictly -1) (pcase (char-before) - (`?_ t) - (`?. (forward-char -1) t) - ((or `?$ `?@) + (?_ t) + (?. (forward-char -1) t) + ((or ?$ ?@) (forward-char -1) (and (eq (char-before) (char-after)) (forward-char -1))) - (`?: + (?: (forward-char -1) (eq (char-before) :))))) (if (looking-at ruby-block-end-re) @@ -1619,7 +1615,7 @@ See `add-log-current-defun-function'." (concat "^[ \t]*" re "[ \t]+" "\\(" ;; \\. and :: for class methods - "\\([A-Za-z_]" ruby-symbol-re "*\\|\\.\\|::" "\\)" + "\\([A-Za-z_]" ruby-symbol-re "*[?!]?\\|\\.\\|::" "\\)" "+\\)"))) (definition-re (funcall make-definition-re ruby-defun-beg-re)) (module-re (funcall make-definition-re "\\(class\\|module\\)"))) @@ -1694,7 +1690,8 @@ See `add-log-current-defun-function'." (when (eq (char-before) ?\}) (delete-char -1) (when (save-excursion - (skip-chars-backward " \t") + (let ((n (skip-chars-backward " \t"))) + (if (< n 0) (delete-char (- n)))) (not (bolp))) (insert "\n")) (insert "end") @@ -1799,14 +1796,36 @@ If the result is do-end block, it will always be multiline." (buffer-substring-no-properties (1+ min) (1- max)))) (setq content (if (equal string-quote "'") - (replace-regexp-in-string "\\\\\"" "\"" (replace-regexp-in-string "\\(\\`\\|[^\\\\]\\)'" "\\1\\\\'" content)) - (replace-regexp-in-string "\\\\'" "'" (replace-regexp-in-string "\\(\\`\\|[^\\\\]\\)\"" "\\1\\\\\"" content)))) + (replace-regexp-in-string "\\\\\"" "\"" (replace-regexp-in-string "\\(\\`\\|[^\\]\\)'" "\\1\\\\'" content)) + (replace-regexp-in-string "\\\\'" "'" (replace-regexp-in-string "\\(\\`\\|[^\\]\\)\"" "\\1\\\\\"" content)))) (let ((orig-point (point))) (delete-region min max) (insert (format "%s%s%s" string-quote content string-quote)) (goto-char orig-point))))) +(defun ruby-find-library-file (&optional feature-name) + "Visit a library file denoted by FEATURE-NAME. +FEATURE-NAME is a relative file name, file extension is optional. +This commands delegates to 'gem which', which searches both +installed gems and the standard library. When called +interactively, defaults to the feature name in the 'require' +statement around point." + (interactive) + (unless feature-name + (let ((init (save-excursion + (forward-line 0) + (when (looking-at "require [\"']\\(.*\\)[\"']") + (match-string 1))))) + (setq feature-name (read-string "Feature name: " init)))) + (let ((out + (substring + (shell-command-to-string (concat "gem which " feature-name)) + 0 -1))) + (if (string-match-p "\\`ERROR" out) + (user-error "%s" out) + (find-file out)))) + (eval-and-compile (defconst ruby-percent-literal-beg-re "\\(%\\)[qQrswWxIi]?\\([[:punct:]]\\)" @@ -1872,7 +1891,7 @@ It will be properly highlighted even when the call omits parens.") ("^[ \t]*def +\\(`\\)" (1 "_")) ;; Ternary operator colon followed by opening paren or bracket ;; (semi-important for indentation). - ("\\(:\\)\\(?:[\({]\\|\\[[^]]\\)" + ("\\(:\\)\\(?:[({]\\|\\[[^]]\\)" (1 (string-to-syntax "."))) ;; Regular expressions. Start with matching unescaped slash. ("\\(?:\\=\\|[^\\]\\)\\(?:\\\\\\\\\\)*\\(/\\)" @@ -2033,13 +2052,6 @@ It will be properly highlighted even when the call omits parens.") context))) t))) -(defvar ruby-font-lock-syntax-table - (let ((tbl (make-syntax-table ruby-mode-syntax-table))) - (modify-syntax-entry ?_ "w" tbl) - tbl) - "The syntax table to use for fontifying Ruby mode buffers. -See `font-lock-syntax-table'.") - (defconst ruby-font-lock-keyword-beg-re "\\(?:^\\|[^.@$:]\\|\\.\\.\\)") (defconst ruby-font-lock-keywords @@ -2190,7 +2202,7 @@ See `font-lock-syntax-table'.") font-lock-constant-face) nil t)) ;; Special globals. - (,(concat "\\$\\(?:[:\"!@;,/\\._><\\$?~=*&`'+0-9]\\|-[0adFiIlpvw]\\|" + (,(concat "\\$\\(?:[:\"!@;,/._><\\$?~=*&`'+0-9]\\|-[0adFiIlpvw]\\|" (regexp-opt '("LOAD_PATH" "LOADED_FEATURES" "PROGRAM_NAME" "ERROR_INFO" "ERROR_POSITION" "FS" "FIELD_SEPARATOR" @@ -2218,7 +2230,8 @@ See `font-lock-syntax-table'.") ;; Conversion methods on Kernel. (,(concat ruby-font-lock-keyword-beg-re (regexp-opt '("Array" "Complex" "Float" "Hash" - "Integer" "Rational" "String") 'symbols)) + "Integer" "Rational" "String") + 'symbols)) (1 font-lock-builtin-face)) ;; Expression expansion. (ruby-match-expression-expansion @@ -2299,7 +2312,7 @@ See `font-lock-syntax-table'.") :command command :sentinel (lambda (proc _event) - (when (eq 'exit (process-status proc)) + (when (and (eq 'exit (process-status proc)) (buffer-live-p source)) (unwind-protect (if (with-current-buffer source (eq proc ruby--flymake-proc)) (with-current-buffer (process-buffer proc) @@ -2311,36 +2324,44 @@ See `font-lock-syntax-table'.") (process-send-eof ruby--flymake-proc)))) (defcustom ruby-flymake-use-rubocop-if-available t - "Non-nil to use the Rubocop Flymake backend. -Only takes effect if Rubocop is installed." + "Non-nil to use the RuboCop Flymake backend. +Only takes effect if RuboCop is installed. + +If there is no Rubocop config file, Rubocop will be passed a flag +'--lint' to only show syntax errors and important problems." :version "26.1" :type 'boolean - :group 'ruby :safe 'booleanp) (defcustom ruby-rubocop-config ".rubocop.yml" "Configuration file for `ruby-flymake-rubocop'." :version "26.1" :type 'string - :group 'ruby :safe 'stringp) (defun ruby-flymake-rubocop (report-fn &rest _args) - "Rubocop backend for Flymake." + "RuboCop backend for Flymake." (unless (executable-find "rubocop") (error "Cannot find the rubocop executable")) (let ((command (list "rubocop" "--stdin" buffer-file-name "--format" "emacs" "--cache" "false" ; Work around a bug in old version. "--display-cop-names")) + (default-directory default-directory) config-dir) (when buffer-file-name (setq config-dir (locate-dominating-file buffer-file-name ruby-rubocop-config)) - (when config-dir + (if (not config-dir) + (setq command (append command '("--lint"))) (setq command (append command (list "--config" (expand-file-name ruby-rubocop-config - config-dir))))) + config-dir)))) + (when (ruby-flymake-rubocop--use-bundler-p config-dir) + (setq command (append '("bundle" "exec") command)) + ;; In case of a project with multiple nested subprojects, + ;; each one with a Gemfile. + (setq default-directory config-dir))) (ruby-flymake--helper "rubocop-flymake" @@ -2352,7 +2373,7 @@ Only takes effect if Rubocop is installed." (when (eq (process-exit-status proc) 127) ;; Not sure what to do in this case. Maybe ideally we'd ;; switch back to ruby-flymake-simple. - (flymake-log :warning "Rubocop returned status 127: %s" + (flymake-log :warning "RuboCop returned status 127: %s" (buffer-string))) (goto-char (point-min)) (cl-loop @@ -2378,6 +2399,13 @@ Only takes effect if Rubocop is installed." into diags finally (funcall report-fn diags))))))) +(defun ruby-flymake-rubocop--use-bundler-p (dir) + (let ((file (expand-file-name "Gemfile" dir))) + (and (file-exists-p file) + (with-temp-buffer + (insert-file-contents file) + (re-search-forward "^ *gem ['\"]rubocop['\"]" nil t))))) + (defun ruby-flymake-auto (report-fn &rest args) (apply (if (and ruby-flymake-use-rubocop-if-available @@ -2392,18 +2420,17 @@ Only takes effect if Rubocop is installed." "Major mode for editing Ruby code." (ruby-mode-variables) - (setq-local imenu-create-index-function 'ruby-imenu-create-index) - (setq-local add-log-current-defun-function 'ruby-add-log-current-method) - (setq-local beginning-of-defun-function 'ruby-beginning-of-defun) - (setq-local end-of-defun-function 'ruby-end-of-defun) + (setq-local imenu-create-index-function #'ruby-imenu-create-index) + (setq-local add-log-current-defun-function #'ruby-add-log-current-method) + (setq-local beginning-of-defun-function #'ruby-beginning-of-defun) + (setq-local end-of-defun-function #'ruby-end-of-defun) - (add-hook 'after-save-hook 'ruby-mode-set-encoding nil 'local) - (add-hook 'electric-indent-functions 'ruby--electric-indent-p nil 'local) - (add-hook 'flymake-diagnostic-functions 'ruby-flymake-auto nil 'local) + (add-hook 'after-save-hook #'ruby-mode-set-encoding nil 'local) + (add-hook 'electric-indent-functions #'ruby--electric-indent-p nil 'local) + (add-hook 'flymake-diagnostic-functions #'ruby-flymake-auto nil 'local) - (setq-local font-lock-defaults '((ruby-font-lock-keywords) nil nil)) - (setq-local font-lock-keywords ruby-font-lock-keywords) - (setq-local font-lock-syntax-table ruby-font-lock-syntax-table) + (setq-local font-lock-defaults '((ruby-font-lock-keywords) nil nil + ((?_ . "w")))) (setq-local syntax-propertize-function #'ruby-syntax-propertize)) diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el index 62f521ee94a..507a4c7085d 100644 --- a/lisp/progmodes/scheme.el +++ b/lisp/progmodes/scheme.el @@ -433,7 +433,7 @@ that variable's value is a string." ;; (make-regexp '("case" "cond" "else" "if" "lambda" ;; "let" "let*" "letrec" "and" "or" "map" "with-mode")) "and\\|c\\(ase\\|ond\\)\\|else\\|if\\|" - "l\\(ambda\\|et\\(\\|*\\|rec\\)\\)\\|map\\|or\\|with-mode" + "l\\(ambda\\|et\\(\\|\\*\\|rec\\)\\)\\|map\\|or\\|with-mode" "\\)\\>") 1) ;; DSSSL syntax diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index 035dd50771e..aad38b94d76 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -345,7 +345,7 @@ naming the shell." :group 'sh-script) (defcustom sh-imenu-generic-expression - `((sh + '((sh . ((nil ;; function FOO ;; function FOO() @@ -578,6 +578,7 @@ This is buffer-local in every such buffer.") :group 'sh-script) (defcustom sh-assignment-regexp + ;; The "\\[.+\\]" matches the "[index]" in "arrayvar[index]=value". `((csh . "\\<\\([[:alnum:]_]+\\)\\(\\[.+\\]\\)?[ \t]*[-+*/%^]?=") ;; actually spaces are only supported in let/(( ... )) (ksh88 . ,(concat "\\<\\([[:alnum:]_]+\\)\\(\\[.+\\]\\)?" @@ -959,8 +960,8 @@ See `sh-feature'.") ;; ((...)) or $((...)) or $[...] or ${...}. Nested ;; parenthesis can occur inside the first of these forms, so ;; parse backward recursively. - (`?\( (eq ?\( (char-before))) - ((or `?\{ `?\[) (eq ?\$ (char-before)))) + (?\( (eq ?\( (char-before))) + ((or ?\{ ?\[) (eq ?\$ (char-before)))) (sh--inside-noncommand-expression (1- (point)))))))) (defun sh-font-lock-open-heredoc (start string eol) @@ -1022,7 +1023,7 @@ subshells can nest." ;; unescape " inside a $( ... ) construct. (pcase (char-after) (?\' (pcase state - (`double-quote nil) + ('double-quote nil) (_ (forward-char 1) ;; FIXME: mark skipped double quotes as punctuation syntax. (let ((spos (point))) @@ -1035,12 +1036,12 @@ subshells can nest." 'syntax-table '(1))))))))) (?\\ (forward-char 1)) (?\" (pcase state - (`double-quote (setq state (pop states))) + ('double-quote (setq state (pop states))) (_ (push state states) (setq state 'double-quote))) (if state (put-text-property (point) (1+ (point)) 'syntax-table '(1)))) (?\` (pcase state - (`backquote (setq state (pop states))) + ('backquote (setq state (pop states))) (_ (push state states) (setq state 'backquote)))) (?\$ (if (not (eq (char-after (1+ (point))) ?\()) nil @@ -1048,10 +1049,10 @@ subshells can nest." (pcase state (_ (push state states) (setq state 'code))))) (?\( (pcase state - (`double-quote nil) + ('double-quote nil) (_ (push state states) (setq state 'code)))) (?\) (pcase state - (`double-quote nil) + ('double-quote nil) (_ (setq state (pop states))))) (_ (error "Internal error in sh-font-lock-quoted-subshell"))) (forward-char 1)) @@ -1141,7 +1142,13 @@ subshells can nest." ;; metacharacters. The list of special chars is taken from ;; the single-unix spec of the shell command language (under ;; `quoting') but with `$' removed. - ("\\(?:[^|&;<>()`\\\"' \t\n]\\|\\${\\)\\(#+\\)" (1 "_")) + ("\\(?:[^|&;<>(`\\\"' \t\n]\\|\\${\\)\\(#+\\)" (1 "_")) + ;; In addition, `#' at the beginning of closed parentheses + ;; does not start a comment if the parentheses are not isolated + ;; by metacharacters, excluding [()]. + ;; (e.g. `foo(#q/)' and `(#b)foo' in zsh) + ("[^|&;<>(`\\\"' \t\n](\\(#+\\)" (1 "_")) + ("(\\(#\\)[^)]+?)[^|&;<>)`\\\"' \t\n]" (1 "_")) ;; In a '...' the backslash is not escaping. ("\\(\\\\\\)'" (1 (sh-font-lock-backslash-quote))) ;; Make sure $@ and $? are correctly recognized as sexps. @@ -1601,7 +1608,7 @@ with your script for an edit-interpret-debug cycle." (setq-local comint-prompt-regexp "^[ \t]*") (setq-local imenu-case-fold-search nil) (setq font-lock-defaults - `((sh-font-lock-keywords + '((sh-font-lock-keywords sh-font-lock-keywords-1 sh-font-lock-keywords-2) nil nil ((?/ . "w") (?~ . "w") (?. . "w") (?- . "w") (?_ . "w")) nil @@ -1619,9 +1626,9 @@ with your script for an edit-interpret-debug cycle." (setq-local defun-prompt-regexp (concat "^\\(" - "\\(function[ \t]\\)?[ \t]*[[:alnum:]]+[ \t]*([ \t]*)" + "\\(function[ \t]\\)?[ \t]*[[:alnum:]_]+[ \t]*([ \t]*)" "\\|" - "function[ \t]+[[:alnum:]]+[ \t]*\\(([ \t]*)\\)?" + "function[ \t]+[[:alnum:]_]+[ \t]*\\(([ \t]*)\\)?" "\\)[ \t]*")) (setq-local add-log-current-defun-function #'sh-current-defun-name) (add-hook 'completion-at-point-functions @@ -2035,10 +2042,10 @@ May return nil if the line should not be treated as continued." (defun sh-smie-sh-rules (kind token) (pcase (cons kind token) - (`(:elem . basic) sh-basic-offset) - (`(:after . "case-)") (- (sh-var-value 'sh-indent-for-case-alt) + ('(:elem . basic) sh-basic-offset) + ('(:after . "case-)") (- (sh-var-value 'sh-indent-for-case-alt) (sh-var-value 'sh-indent-for-case-label))) - (`(:before . ,(or `"(" `"{" `"[" "while" "if" "for" "case")) + (`(:before . ,(or "(" "{" "[" "while" "if" "for" "case")) (if (not (smie-rule-prev-p "&&" "||" "|")) (when (smie-rule-hanging-p) (smie-rule-parent)) @@ -2047,11 +2054,11 @@ May return nil if the line should not be treated as continued." `(column . ,(smie-indent-virtual))))) ;; FIXME: Maybe this handling of ;; should be made into ;; a smie-rule-terminator function that takes the substitute ";" as arg. - (`(:before . ,(or `";;" `";&" `";;&")) + (`(:before . ,(or ";;" ";&" ";;&")) (if (and (smie-rule-bolp) (looking-at ";;?&?[ \t]*\\(#\\|$\\)")) (cons 'column (smie-indent-keyword ";")) (smie-rule-separator kind))) - (`(:after . ,(or `";;" `";&" `";;&")) + (`(:after . ,(or ";;" ";&" ";;&")) (with-demoted-errors (smie-backward-sexp token) (cons 'column @@ -2062,26 +2069,26 @@ May return nil if the line should not be treated as continued." (smie-rule-bolp)))) (current-column) (smie-indent-calculate))))) - (`(:before . ,(or `"|" `"&&" `"||")) + (`(:before . ,(or "|" "&&" "||")) (unless (smie-rule-parent-p token) (smie-backward-sexp token) `(column . ,(+ (funcall smie-rules-function :elem 'basic) (smie-indent-virtual))))) ;; Attempt at backward compatibility with the old config variables. - (`(:before . "fi") (sh-var-value 'sh-indent-for-fi)) - (`(:before . "done") (sh-var-value 'sh-indent-for-done)) - (`(:after . "else") (sh-var-value 'sh-indent-after-else)) - (`(:after . "if") (sh-var-value 'sh-indent-after-if)) - (`(:before . "then") (sh-var-value 'sh-indent-for-then)) - (`(:before . "do") (sh-var-value 'sh-indent-for-do)) - (`(:after . "do") + ('(:before . "fi") (sh-var-value 'sh-indent-for-fi)) + ('(:before . "done") (sh-var-value 'sh-indent-for-done)) + ('(:after . "else") (sh-var-value 'sh-indent-after-else)) + ('(:after . "if") (sh-var-value 'sh-indent-after-if)) + ('(:before . "then") (sh-var-value 'sh-indent-for-then)) + ('(:before . "do") (sh-var-value 'sh-indent-for-do)) + ('(:after . "do") (sh-var-value (if (smie-rule-hanging-p) 'sh-indent-after-loop-construct 'sh-indent-after-do))) ;; sh-indent-after-done: aligned completely differently. - (`(:after . "in") (sh-var-value 'sh-indent-for-case-label)) + ('(:after . "in") (sh-var-value 'sh-indent-for-case-label)) ;; sh-indent-for-continuation: Line continuations are handled differently. - (`(:after . ,(or `"(" `"{" `"[")) + (`(:after . ,(or "(" "{" "[")) (if (not (looking-at ".[ \t]*[^\n \t#]")) (sh-var-value 'sh-indent-after-open) (goto-char (1- (match-end 0))) @@ -2244,16 +2251,16 @@ Point should be before the newline." (defun sh-smie-rc-rules (kind token) (pcase (cons kind token) - (`(:elem . basic) sh-basic-offset) + ('(:elem . basic) sh-basic-offset) ;; (`(:after . "case") (or sh-basic-offset smie-indent-basic)) - (`(:after . ";") + ('(:after . ";") (if (smie-rule-parent-p "case") (smie-rule-parent (sh-var-value 'sh-indent-after-case)))) - (`(:before . "{") + ('(:before . "{") (save-excursion (when (sh-smie--rc-after-special-arg-p) `(column . ,(current-column))))) - (`(:before . ,(or `"(" `"{" `"[")) + (`(:before . ,(or "(" "{" "[")) (if (smie-rule-hanging-p) (smie-rule-parent))) ;; FIXME: SMIE parses "if (exp) cmd" as "(if ((exp) cmd))" so "cmd" is ;; treated as an arg to (exp) by default, which indents it all wrong. @@ -2262,7 +2269,7 @@ Point should be before the newline." ;; rule we have is the :list-intro hack, which we use here to align "cmd" ;; with "(exp)", which is rarely the right thing to do, but is better ;; than nothing. - (`(:list-intro . ,(or `"for" `"if" `"while")) t) + (`(:list-intro . ,(or "for" "if" "while")) t) ;; sh-indent-after-switch: handled implicitly by the default { rule. )) @@ -2392,7 +2399,6 @@ whose value is the shell name (don't quote it)." (funcall mksym "rules") :forward-token (funcall mksym "forward-token") :backward-token (funcall mksym "backward-token"))) - (setq-local parse-sexp-lookup-properties t) (unless sh-use-smie (setq-local sh-kw-alist (sh-feature sh-kw)) (let ((regexp (sh-feature sh-kws-for-done))) @@ -2906,8 +2912,7 @@ STRING This is ignored for the purposes of calculating (setq align-point (point)))) (or (bobp) (forward-char -1)) - ;; FIXME: This charset looks too much like a regexp. --Stef - (skip-chars-forward "[a-z0-9]*?") + (skip-chars-forward "*0-9?[]a-z") ) ((string-match "[])}]" x) (setq x (sh-safe-forward-sexp -1)) @@ -4336,6 +4341,7 @@ option followed by a colon `:' if the option accepts an argument." t) (match-string 1)))))) +(put 'sh-assignment 'delete-selection t) (defun sh-maybe-here-document (arg) "Insert self. Without prefix, following unquoted `<' inserts here document. diff --git a/lisp/progmodes/simula.el b/lisp/progmodes/simula.el index 3bbf4e0aa24..9fc6d54faf3 100644 --- a/lisp/progmodes/simula.el +++ b/lisp/progmodes/simula.el @@ -4,8 +4,7 @@ ;; Inc. ;; Author: Hans Henrik Eriksen <hhe@ifi.uio.no> -;; Maintainer: simula-mode@ifi.uio.no -;; (above email addresses invalid as of April 2008) +;; Maintainer: emacs-devel@gnu.org ;; Adapted-By: ESR ;; Keywords: languages diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 36382640de5..2d33b3130cd 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -213,7 +213,7 @@ ;; Drew Adams <drew.adams@oracle.com> -- Emacs 20 support ;; Harald Maier <maierh@myself.com> -- sql-send-string ;; Stefan Monnier <monnier@iro.umontreal.ca> -- font-lock corrections; -;; code polish +;; code polish; on-going guidance and mentorship ;; Paul Sleigh <bat@flurf.net> -- MySQL keyword enhancement ;; Andrew Schein <andrew@andrewschein.com> -- sql-port bug ;; Ian Bjorhovde <idbjorh@dataproxy.com> -- db2 escape newlines @@ -221,6 +221,9 @@ ;; Roman Scherer <roman.scherer@nugg.ad> -- Connection documentation ;; Mark Wilkinson <wilkinsonmr@gmail.com> -- file-local variables ignored ;; Simen Heggestøyl <simenheg@gmail.com> -- Postgres database completion +;; Robert Cochran <robert-emacs@cochranmail.com> -- MariaDB support +;; Alex Harsanyi <alexharsanyi@gmail.com> -- sql-indent package and support +;; Roy Mathew <rmathew8@gmail.com> -- bug in `sql-send-string' ;; @@ -235,6 +238,7 @@ (require 'custom) (require 'thingatpt) (require 'view) +(eval-when-compile (require 'subr-x)) ; string-empty-p (defvar font-lock-keyword-face) (defvar font-lock-set-defaults) @@ -344,7 +348,8 @@ file. Since that is a plaintext file, this could be dangerous." (const :format "" :completion) (sexp :tag ":completion") (const :format "" :must-match) - (symbol :tag ":must-match"))) + (restricted-sexp + :match-alternatives (listp stringp)))) (const port))) ;; SQL Product support @@ -415,6 +420,21 @@ file. Since that is a plaintext file, this could be dangerous." :prompt-regexp "^SQL>" :prompt-length 4) + (mariadb + :name "MariaDB" + :free-software t + :font-lock sql-mode-mariadb-font-lock-keywords + :sqli-program sql-mariadb-program + :sqli-options sql-mariadb-options + :sqli-login sql-mariadb-login-params + :sqli-comint-func sql-comint-mariadb + :list-all "SHOW TABLES;" + :list-table "DESCRIBE %s;" + :prompt-regexp "^MariaDB \\[.*]> " + :prompt-cont-regexp "^ [\"'`-]> " + :syntax-alist ((?# . "< b")) + :input-filter sql-remove-tabs-filter) + (ms :name "Microsoft" :font-lock sql-mode-ms-font-lock-keywords @@ -423,6 +443,7 @@ file. Since that is a plaintext file, this could be dangerous." :sqli-login sql-ms-login-params :sqli-comint-func sql-comint-ms :prompt-regexp "^[0-9]*>" + :prompt-cont-regexp "^[0-9]*>" :prompt-length 5 :syntax-alist ((?@ . "_")) :terminator ("^go" . "go")) @@ -458,7 +479,7 @@ file. Since that is a plaintext file, this could be dangerous." :prompt-cont-regexp "^\\(?:[ ][ ][1-9]\\|[ ][1-9][0-9]\\|[1-9][0-9]\\{2\\}\\)[ ]\\{2\\}" :statement sql-oracle-statement-starters :syntax-alist ((?$ . "_") (?# . "_")) - :terminator ("\\(^/\\|;\\)$" . "/") + :terminator ("\\(^/\\|;\\)" . "/") :input-filter sql-placeholders-filter) (postgres @@ -476,7 +497,7 @@ file. Since that is a plaintext file, this could be dangerous." :prompt-length 5 :prompt-cont-regexp "^[[:alnum:]_]*[-(][#>] " :input-filter sql-remove-tabs-filter - :terminator ("\\(^\\s-*\\\\g$\\|;\\)" . "\\g")) + :terminator ("\\(^\\s-*\\\\g\\|;\\)" . "\\g")) (solid :name "Solid" @@ -501,8 +522,7 @@ file. Since that is a plaintext file, this could be dangerous." :completion-object sql-sqlite-completion-object :prompt-regexp "^sqlite> " :prompt-length 8 - :prompt-cont-regexp "^ \\.\\.\\.> " - :terminator ";") + :prompt-cont-regexp "^ \\.\\.\\.> ") (sybase :name "Sybase" @@ -691,6 +711,8 @@ making new SQLi sessions." :version "24.1" :group 'SQL) +(defvaralias 'sql-dialect 'sql-product) + (defcustom sql-product 'ansi "Select the SQL database product used. This allows highlighting buffers properly when you open them." @@ -703,7 +725,145 @@ This allows highlighting buffers properly when you open them." sql-product-alist)) :group 'SQL :safe 'symbolp) -(defvaralias 'sql-dialect 'sql-product) + +;; SQL indent support + +(defcustom sql-use-indent-support t + "If non-nil then use the SQL indent support features of sql-indent. +The `sql-indent' package in ELPA provides indentation support for +SQL statements with easy customizations to support varied layout +requirements. + +The package must be available to be loaded and activated." + :group 'SQL + :link '(url-link "https://elpa.gnu.org/packages/sql-indent.html") + :type 'booleanp + :version "27.1") + +(defun sql-indent-enable () + "Enable `sqlind-minor-mode' if available and requested." + (when (fboundp 'sqlind-minor-mode) + (sqlind-minor-mode (if sql-use-indent-support +1 -1)))) + +;; Secure Password wallet + +(require 'auth-source) + +(defun sql-auth-source-search-wallet (wallet product user server database port) + "Read auth source WALLET to locate the USER secret. +Sets `auth-sources' to WALLET and uses `auth-source-search' to locate the entry. +The DATABASE and SERVER are concatenated with a slash between them as the +host key." + (let* ((auth-sources wallet) + host + secret h-secret sd-secret) + + ;; product + (setq product (symbol-name product)) + + ;; user + (setq user (unless (string-empty-p user) user)) + + ;; port + (setq port + (when (and port (numberp port) (not (zerop port))) + (number-to-string port))) + + ;; server + (setq server (unless (string-empty-p server) server)) + + ;; database + (setq database (unless (string-empty-p database) database)) + + ;; host + (setq host (if server + (if database + (concat server "/" database) + server) + database)) + + ;; Perform search + (dolist (s (auth-source-search :max 1000)) + (when (and + ;; Is PRODUCT specified, in the enty, and they are equal + (if product + (if (plist-member s :product) + (equal (plist-get s :product) product) + t) + t) + ;; Is USER specified, in the entry, and they are equal + (if user + (if (plist-member s :user) + (equal (plist-get s :user) user) + t) + t) + ;; Is PORT specified, in the entry, and they are equal + (if port + (if (plist-member s :port) + (equal (plist-get s :port) port) + t) + t)) + ;; Is HOST specified, in the entry, and they are equal + ;; then the H-SECRET list + (if (and host + (plist-member s :host) + (equal (plist-get s :host) host)) + (push s h-secret) + ;; Are SERVER and DATABASE specified, present, and equal + ;; then the SD-SECRET list + (if (and server + (plist-member s :server) + database + (plist-member s :database) + (equal (plist-get s :server) server) + (equal (plist-get s :database) database)) + (push s sd-secret) + ;; Is SERVER specified, in the entry, and they are equal + ;; then the base SECRET list + (if (and server + (plist-member s :server) + (equal (plist-get s :server) server)) + (push s secret) + ;; Is DATABASE specified, in the entry, and they are equal + ;; then the base SECRET list + (if (and database + (plist-member s :database) + (equal (plist-get s :database) database)) + (push s secret))))))) + (setq secret (or h-secret sd-secret secret)) + + ;; If we found a single secret, return the password + (when (= 1 (length secret)) + (setq secret (car secret)) + (if (plist-member secret :secret) + (plist-get secret :secret) + nil)))) + +(defcustom sql-password-wallet + (let (wallet w) + (dolist (ext '(".json.gpg" ".gpg" ".json" "") wallet) + (unless wallet + (setq w (locate-user-emacs-file (concat "sql-wallet" ext) + (concat ".sql-wallet" ext))) + (when (file-exists-p w) + (setq wallet w))))) + "Identification of the password wallet. +See `sql-password-search-wallet-function' to understand how this value +is used to locate the password wallet." + :type `(plist-get (symbol-plist 'auth-sources) 'custom-type) + :group 'SQL + :version "27.1") + +(defvar sql-password-search-wallet-function #'sql-auth-source-search-wallet + "Function to handle the lookup of the database password. +The specified function will be called as: + (wallet-func WALLET PRODUCT USER SERVER DATABASE PORT) + +It is expected to return either a string containing the password, +a function returning the password, or nil, If you want to support +another format of password file, then implement a different +search wallet function and identify the location of the password +store with `sql-password-wallet'.") ;; misc customization of sql.el behavior @@ -759,16 +919,20 @@ Globally should be set to nil; it will be non-nil in `sql-mode', (defvar sql-login-delay 7.5 ;; Secs "Maximum number of seconds you are willing to wait for a login connection.") -(defcustom sql-pop-to-buffer-after-send-region nil - "When non-nil, pop to the buffer SQL statements are sent to. +(defvaralias 'sql-pop-to-buffer-after-send-region 'sql-display-sqli-buffer-function) -After a call to `sql-sent-string', `sql-send-region', -`sql-send-paragraph' or `sql-send-buffer', the window is split -and the SQLi buffer is shown. If this variable is not nil, that -buffer's window will be selected by calling `pop-to-buffer'. If -this variable is nil, that buffer is shown using -`display-buffer'." - :type 'boolean +(defcustom sql-display-sqli-buffer-function #'display-buffer + "Function to be called to display a SQLi buffer after `sql-send-*'. + +When set to a function, it will be called to display the buffer. +When set to t, the default function `pop-to-buffer' will be +called. If not set, no attempt will be made to display the +buffer." + + :type '(choice (const :tag "Default" t) + (const :tag "No display" nil) + (function :tag "Display Buffer function")) + :version "27.1" :group 'SQL) ;; imenu support for sql-mode. @@ -788,7 +952,7 @@ this variable is nil, that buffer is shown using This is used to set `imenu-generic-expression' when SQL mode is entered. Subsequent changes to `sql-imenu-generic-expression' will -not affect existing SQL buffers because imenu-generic-expression is +not affect existing SQL buffers because `imenu-generic-expression' is a local variable.") ;; history file @@ -828,15 +992,17 @@ commands when the input history is read, as if you had set ;; The usual hooks -(defcustom sql-interactive-mode-hook '() +(defcustom sql-interactive-mode-hook '(sql-indent-enable) "Hook for customizing `sql-interactive-mode'." :type 'hook - :group 'SQL) + :group 'SQL + :version "27.1") -(defcustom sql-mode-hook '() +(defcustom sql-mode-hook '(sql-indent-enable) "Hook for customizing `sql-mode'." :type 'hook - :group 'SQL) + :group 'SQL + :version "27.1") (defcustom sql-set-sqli-hook '() "Hook for reacting to changes of `sql-buffer'. @@ -953,10 +1119,19 @@ Starts `sql-interactive-mode' after doing some setup." :version "26.1" :group 'SQL) +;; Customization for MariaDB + +;; MariaDB is a drop-in replacement for MySQL, so just make the +;; MariaDB variables aliases of the MySQL ones. + +(defvaralias 'sql-mariadb-program 'sql-mysql-program) +(defvaralias 'sql-mariadb-options 'sql-mysql-options) +(defvaralias 'sql-mariadb-login-params 'sql-mysql-login-params) + ;; Customization for MySQL (defcustom sql-mysql-program "mysql" - "Command to start mysql by TcX. + "Command to start mysql by Oracle. Starts `sql-interactive-mode' after doing some setup." :type 'file @@ -1045,6 +1220,11 @@ Starts `sql-interactive-mode' after doing some setup." ;; Customization for Microsoft +;; Microsoft documentation seems to indicate that ISQL and OSQL are +;; going away and being replaced by SQLCMD. If anyone has experience +;; using SQLCMD, modified product configuration and feedback on its +;; use would be greatly appreciated. + (defcustom sql-ms-program "osql" "Command to start osql by Microsoft. @@ -1103,8 +1283,11 @@ add your name with a \"-U\" prefix (such as \"-Umark\") to the list." (when (executable-find sql-postgres-program) (let ((res '())) (ignore-errors - (dolist (row (process-lines sql-postgres-program "-ltX")) - (when (string-match "^ \\([[:alnum:]-_]+\\) +|.*" row) + (dolist (row (process-lines sql-postgres-program + "--list" + "--no-psqlrc" + "--tuples-only")) + (when (string-match "^ \\([^ |]+\\) +|.*" row) (push (match-string 1 row) res)))) (nreverse res)))) @@ -1237,7 +1420,17 @@ specified, it's `sql-product' or `sql-connection' must match." (or (not product) (eq product sql-product)) (or (not connection) - (eq connection sql-connection))))))) + (and (stringp connection) + (string= connection sql-connection)))))))) + +(defun sql-is-sqli-buffer-p (buffer) + "Return non-nil if buffer is a SQLi buffer." + (when buffer + (setq buffer (get-buffer buffer)) + (and buffer + (buffer-live-p buffer) + (with-current-buffer buffer + (derived-mode-p 'sql-interactive-mode))))) ;; Keymap for sql-interactive-mode. @@ -2312,75 +2505,148 @@ regular expressions are created during compilation by calling the function `regexp-opt'. Therefore, take a look at the source before you define your own `sql-mode-solid-font-lock-keywords'.") +(defvaralias 'sql-mode-mariadb-font-lock-keywords 'sql-mode-mysql-font-lock-keywords + "MariaDB is SQL compatible with MySQL.") + (defvar sql-mode-mysql-font-lock-keywords (eval-when-compile (list ;; MySQL Functions (sql-font-lock-keywords-builder 'font-lock-builtin-face nil -"ascii" "avg" "bdmpolyfromtext" "bdmpolyfromwkb" "bdpolyfromtext" -"bdpolyfromwkb" "benchmark" "bin" "bit_and" "bit_length" "bit_or" -"bit_xor" "both" "cast" "char_length" "character_length" "coalesce" -"concat" "concat_ws" "connection_id" "conv" "convert" "count" -"curdate" "current_date" "current_time" "current_timestamp" "curtime" -"elt" "encrypt" "export_set" "field" "find_in_set" "found_rows" "from" +"acos" "adddate" "addtime" "aes_decrypt" "aes_encrypt" "area" +"asbinary" "ascii" "asin" "astext" "aswkb" "aswkt" "atan" "atan2" +"avg" "bdmpolyfromtext" "bdmpolyfromwkb" "bdpolyfromtext" +"bdpolyfromwkb" "benchmark" "bin" "binlog_gtid_pos" "bit_and" +"bit_count" "bit_length" "bit_or" "bit_xor" "both" "boundary" "buffer" +"cast" "ceil" "ceiling" "centroid" "character_length" "char_length" +"charset" "coalesce" "coercibility" "column_add" "column_check" +"column_create" "column_delete" "column_exists" "column_get" +"column_json" "column_list" "compress" "concat" "concat_ws" +"connection_id" "conv" "convert" "convert_tz" "convexhull" "cos" "cot" +"count" "crc32" "crosses" "cume_dist" "cume_dist" "curdate" +"current_date" "current_time" "current_timestamp" "curtime" "date_add" +"datediff" "date_format" "date_sub" "dayname" "dayofmonth" "dayofweek" +"dayofyear" "decode" "decode_histogram" "degrees" "dense_rank" +"dense_rank" "des_decrypt" "des_encrypt" "dimension" "disjoint" "div" +"elt" "encode" "encrypt" "endpoint" "envelope" "exp" "export_set" +"exteriorring" "extractvalue" "field" "find_in_set" "floor" "format" +"found_rows" "from" "from_base64" "from_days" "from_unixtime" "geomcollfromtext" "geomcollfromwkb" "geometrycollectionfromtext" "geometrycollectionfromwkb" "geometryfromtext" "geometryfromwkb" -"geomfromtext" "geomfromwkb" "get_lock" "group_concat" "hex" "ifnull" -"instr" "interval" "isnull" "last_insert_id" "lcase" "leading" -"length" "linefromtext" "linefromwkb" "linestringfromtext" -"linestringfromwkb" "load_file" "locate" "lower" "lpad" "ltrim" -"make_set" "master_pos_wait" "max" "mid" "min" "mlinefromtext" -"mlinefromwkb" "mpointfromtext" "mpointfromwkb" "mpolyfromtext" -"mpolyfromwkb" "multilinestringfromtext" "multilinestringfromwkb" +"geometryn" "geometrytype" "geomfromtext" "geomfromwkb" "get_format" +"get_lock" "glength" "greatest" "group_concat" "hex" "ifnull" +"inet6_aton" "inet6_ntoa" "inet_aton" "inet_ntoa" "instr" +"interiorringn" "intersects" "interval" "isclosed" "isempty" +"is_free_lock" "is_ipv4" "is_ipv4_compat" "is_ipv4_mapped" "is_ipv6" +"isnull" "isring" "issimple" "is_used_lock" "json_array" +"json_array_append" "json_array_insert" "json_compact" "json_contains" +"json_contains_path" "json_depth" "json_detailed" "json_exists" +"json_extract" "json_insert" "json_keys" "json_length" "json_loose" +"json_merge" "json_object" "json_query" "json_quote" "json_remove" +"json_replace" "json_search" "json_set" "json_type" "json_unquote" +"json_valid" "json_value" "lag" "last_day" "last_insert_id" "lastval" +"last_value" "last_value" "lcase" "lead" "leading" "least" "length" +"linefromtext" "linefromwkb" "linestringfromtext" "linestringfromwkb" +"ln" "load_file" "locate" "log" "log10" "log2" "lower" "lpad" "ltrim" +"makedate" "make_set" "maketime" "master_gtid_wait" "master_pos_wait" +"max" "mbrcontains" "mbrdisjoint" "mbrequal" "mbrintersects" +"mbroverlaps" "mbrtouches" "mbrwithin" "md5" "median" +"mid" "min" "mlinefromtext" "mlinefromwkb" "monthname" +"mpointfromtext" "mpointfromwkb" "mpolyfromtext" "mpolyfromwkb" +"multilinestringfromtext" "multilinestringfromwkb" "multipointfromtext" "multipointfromwkb" "multipolygonfromtext" -"multipolygonfromwkb" "now" "nullif" "oct" "octet_length" "ord" -"pointfromtext" "pointfromwkb" "polyfromtext" "polyfromwkb" -"polygonfromtext" "polygonfromwkb" "position" "quote" "rand" -"release_lock" "repeat" "replace" "reverse" "rpad" "rtrim" "soundex" -"space" "std" "stddev" "substring" "substring_index" "sum" "sysdate" -"trailing" "trim" "ucase" "unix_timestamp" "upper" "user" "variance" +"multipolygonfromwkb" "name_const" "nextval" "now" "nth_value" "ntile" +"ntile" "nullif" "numgeometries" "numinteriorrings" "numpoints" "oct" +"octet_length" "old_password" "ord" "percentile_cont" +"percentile_disc" "percent_rank" "percent_rank" "period_add" +"period_diff" "pi" "pointfromtext" "pointfromwkb" "pointn" +"pointonsurface" "polyfromtext" "polyfromwkb" "polygonfromtext" +"polygonfromwkb" "position" "pow" "power" "quote" "radians" +"rand" "rank" "rank" "regexp" "regexp_instr" "regexp_replace" +"regexp_substr" "release_lock" "repeat" "replace" "reverse" "rlike" +"row_number" "row_number" "rpad" "rtrim" "sec_to_time" "setval" "sha" +"sha1" "sha2" "sign" "sin" "sleep" "soundex" "space" +"spider_bg_direct_sql" "spider_copy_tables" "spider_direct_sql" +"spider_flush_table_mon_cache" "sqrt" "srid" "st_area" "startpoint" +"st_asbinary" "st_astext" "st_aswkb" "st_aswkt" "st_boundary" +"st_buffer" "st_centroid" "st_contains" "st_convexhull" "st_crosses" +"std" "stddev" "stddev_pop" "stddev_samp" "st_difference" +"st_dimension" "st_disjoint" "st_distance" "st_endpoint" "st_envelope" +"st_equals" "st_exteriorring" "st_geomcollfromtext" +"st_geomcollfromwkb" "st_geometrycollectionfromtext" +"st_geometrycollectionfromwkb" "st_geometryfromtext" +"st_geometryfromwkb" "st_geometryn" "st_geometrytype" +"st_geomfromtext" "st_geomfromwkb" "st_interiorringn" +"st_intersection" "st_intersects" "st_isclosed" "st_isempty" +"st_isring" "st_issimple" "st_length" "st_linefromtext" +"st_linefromwkb" "st_linestringfromtext" "st_linestringfromwkb" +"st_numgeometries" "st_numinteriorrings" "st_numpoints" "st_overlaps" +"st_pointfromtext" "st_pointfromwkb" "st_pointn" "st_pointonsurface" +"st_polyfromtext" "st_polyfromwkb" "st_polygonfromtext" +"st_polygonfromwkb" "strcmp" "st_relate" "str_to_date" "st_srid" +"st_startpoint" "st_symdifference" "st_touches" "st_union" "st_within" +"st_x" "st_y" "subdate" "substr" "substring" "substring_index" +"subtime" "sum" "sysdate" "tan" "timediff" "time_format" +"timestampadd" "timestampdiff" "time_to_sec" "to_base64" "to_days" +"to_seconds" "touches" "trailing" "trim" "ucase" "uncompress" +"uncompressed_length" "unhex" "unix_timestamp" "updatexml" "upper" +"user" "utc_date" "utc_time" "utc_timestamp" "uuid" "uuid_short" +"variance" "var_pop" "var_samp" "version" "weekday" +"weekofyear" "weight_string" "within" ) ;; MySQL Keywords (sql-font-lock-keywords-builder 'font-lock-keyword-face nil -"action" "add" "after" "against" "all" "alter" "and" "as" "asc" -"auto_increment" "avg_row_length" "bdb" "between" "by" "cascade" -"case" "change" "character" "check" "checksum" "close" "collate" -"collation" "column" "columns" "comment" "committed" "concurrent" -"constraint" "create" "cross" "data" "database" "default" -"delay_key_write" "delayed" "delete" "desc" "directory" "disable" -"distinct" "distinctrow" "do" "drop" "dumpfile" "duplicate" "else" "elseif" -"enable" "enclosed" "end" "escaped" "exists" "fields" "first" "for" -"force" "foreign" "from" "full" "fulltext" "global" "group" "handler" -"having" "heap" "high_priority" "if" "ignore" "in" "index" "infile" -"inner" "insert" "insert_method" "into" "is" "isam" "isolation" "join" -"key" "keys" "last" "left" "level" "like" "limit" "lines" "load" -"local" "lock" "low_priority" "match" "max_rows" "merge" "min_rows" -"mode" "modify" "mrg_myisam" "myisam" "natural" "next" "no" "not" -"null" "offset" "oj" "on" "open" "optionally" "or" "order" "outer" -"outfile" "pack_keys" "partial" "password" "prev" "primary" -"procedure" "quick" "raid0" "raid_type" "read" "references" "rename" -"repeatable" "restrict" "right" "rollback" "rollup" "row_format" -"savepoint" "select" "separator" "serializable" "session" "set" -"share" "show" "sql_big_result" "sql_buffer_result" "sql_cache" -"sql_calc_found_rows" "sql_no_cache" "sql_small_result" "starting" -"straight_join" "striped" "table" "tables" "temporary" "terminated" -"then" "to" "transaction" "truncate" "type" "uncommitted" "union" -"unique" "unlock" "update" "use" "using" "values" "when" "where" -"with" "write" "xor" +"accessible" "action" "add" "after" "against" "all" "alter" "analyze" +"and" "as" "asc" "auto_increment" "avg_row_length" "bdb" "between" +"body" "by" "cascade" "case" "change" "character" "check" "checksum" +"close" "collate" "collation" "column" "columns" "comment" "committed" +"concurrent" "condition" "constraint" "create" "cross" "data" +"database" "databases" "default" "delayed" "delay_key_write" "delete" +"desc" "directory" "disable" "distinct" "distinctrow" "do" "drop" +"dual" "dumpfile" "duplicate" "else" "elseif" "elsif" "enable" +"enclosed" "end" "escaped" "exists" "exit" "explain" "fields" "first" +"for" "force" "foreign" "from" "full" "fulltext" "global" "group" +"handler" "having" "heap" "high_priority" "history" "if" "ignore" +"ignore_server_ids" "in" "index" "infile" "inner" "insert" +"insert_method" "into" "is" "isam" "isolation" "join" "key" "keys" +"kill" "last" "leave" "left" "level" "like" "limit" "linear" "lines" +"load" "local" "lock" "long" "loop" "low_priority" +"master_heartbeat_period" "master_ssl_verify_server_cert" "match" +"max_rows" "maxvalue" "merge" "min_rows" "mode" "modify" "mrg_myisam" +"myisam" "natural" "next" "no" "not" "no_write_to_binlog" "null" +"offset" "oj" "on" "open" "optimize" "optionally" "or" "order" "outer" +"outfile" "over" "package" "pack_keys" "partial" "partition" +"password" "period" "prev" "primary" "procedure" "purge" "quick" +"raid0" "raid_type" "raise" "range" "read" "read_write" "references" +"release" "rename" "repeatable" "require" "resignal" "restrict" +"returning" "right" "rollback" "rollup" "row_format" "rowtype" +"savepoint" "schemas" "select" "separator" "serializable" "session" +"set" "share" "show" "signal" "slow" "spatial" "sql_big_result" +"sql_buffer_result" "sql_cache" "sql_calc_found_rows" "sql_no_cache" +"sql_small_result" "ssl" "starting" "straight_join" "striped" +"system_time" "table" "tables" "temporary" "terminated" "then" "to" +"transaction" "truncate" "type" "uncommitted" "undo" "union" "unique" +"unlock" "update" "use" "using" "values" "versioning" "when" "where" +"while" "window" "with" "write" "xor" ) ;; MySQL Data Types (sql-font-lock-keywords-builder 'font-lock-type-face nil -"bigint" "binary" "bit" "blob" "bool" "boolean" "char" "curve" "date" -"datetime" "dec" "decimal" "double" "enum" "fixed" "float" "geometry" -"geometrycollection" "int" "integer" "line" "linearring" "linestring" -"longblob" "longtext" "mediumblob" "mediumint" "mediumtext" +"bigint" "binary" "bit" "blob" "bool" "boolean" "byte" "char" "curve" +"date" "datetime" "day" "day_hour" "day_microsecond" "day_minute" +"day_second" "dec" "decimal" "double" "enum" "fixed" "float" "float4" +"float8" "geometry" "geometrycollection" "hour" "hour_microsecond" +"hour_minute" "hour_second" "int" "int1" "int2" "int3" "int4" "int8" +"integer" "json" "line" "linearring" "linestring" "longblob" +"longtext" "mediumblob" "mediumint" "mediumtext" "microsecond" +"middleint" "minute" "minute_microsecond" "minute_second" "month" "multicurve" "multilinestring" "multipoint" "multipolygon" "multisurface" "national" "numeric" "point" "polygon" "precision" -"real" "smallint" "surface" "text" "time" "timestamp" "tinyblob" -"tinyint" "tinytext" "unsigned" "varchar" "year" "year2" "year4" -"zerofill" +"quarter" "real" "second" "second_microsecond" "signed" "smallint" +"surface" "text" "time" "timestamp" "tinyblob" "tinyint" "tinytext" +"unsigned" "varbinary" "varchar" "varcharacter" "week" "year" "year2" +"year4" "year_month" "zerofill" ))) "MySQL SQL keywords used by font-lock. @@ -2474,7 +2740,7 @@ highlighting rules in SQL mode.") nil 'require-match init 'sql-product-history init)))) -(defun sql-add-product (product display &rest plist) +(defun sql-add-product (product display &optional plist) "Add support for a database product in `sql-mode'. Add PRODUCT to `sql-product-alist' which enables `sql-mode' to @@ -2531,15 +2797,38 @@ list. See `sql-add-product' to add new products. The FEATURE argument must be a plist keyword accepted by `sql-product-alist'." - (let* ((p (assoc product sql-product-alist)) - (v (plist-get (cdr p) feature))) + (let* ((p (assoc product sql-product-alist)) ;; (PRODUCT :f v ...) + (v (plist-member (cdr p) feature))) ;; (:FEATURE value ...) or null + (if p - (if (and - (member feature sql-indirect-features) - (symbolp v)) - (set v newvalue) - (setcdr p (plist-put (cdr p) feature newvalue))) - (error "`%s' is not a known product; use `sql-add-product' to add it first." product)))) + (if (member feature sql-indirect-features) ; is indirect + (if v + (if (car (cdr v)) + (if (symbolp (car (cdr v))) + ;; Indirect reference + (set (car (cdr v)) newvalue) + ;; indirect is not a symbol + (error "The value of `%s' for `%s' is not a symbol" feature product)) + ;; keyword present, set the indirect variable name + (if (symbolp newvalue) + (if (cdr v) + (setf (car (cdr v)) newvalue) + (setf (cdr v) (list newvalue))) + (error "The indirect variable of `%s' for `%s' must be a symbol" feature product))) + ;; not present; insert list + (setq v (list feature newvalue)) + (setf (cdr (cdr v)) (cdr p)) + (setf (cdr p) v)) + ;; Not an indirect feature + (if v + (if (cdr v) + (setf (car (cdr v)) newvalue) + (setf (cdr v) (list newvalue))) + ;; no value; insert into the list + (setq v (list feature newvalue)) + (setf (cdr (cdr v)) (cdr p)) + (setf (cdr p) v))) + (error "`%s' is not a known product; use `sql-add-product' to add it first" product)))) (defun sql-get-product-feature (product feature &optional fallback not-indirect) "Lookup FEATURE associated with a SQL PRODUCT. @@ -2567,7 +2856,7 @@ See `sql-product-alist' for a list of products and supported features." (member feature sql-indirect-features) (not not-indirect) (symbolp v)) - (symbol-value v) + (eval v) v)) (error "`%s' is not a known product; use `sql-add-product' to add it first." product) nil))) @@ -2712,18 +3001,52 @@ adds a fontification pattern to fontify identifiers ending in ;; Save product setting and fontify. (setq sql-product product) (sql-highlight-product)) +(defalias 'sql-set-dialect 'sql-set-product) - -;;; Compatibility functions - -(if (not (fboundp 'comint-line-beginning-position)) - ;; comint-line-beginning-position is defined in Emacs 21 - (defun comint-line-beginning-position () - "Return the buffer position of the beginning of the line, after any prompt. -The prompt is assumed to be any text at the beginning of the line -matching the regular expression `comint-prompt-regexp', a buffer -local variable." - (save-excursion (comint-bol nil) (point)))) +(defun sql-buffer-hidden-p (buf) + "Is the buffer hidden?" + (string-prefix-p " " + (cond + ((stringp buf) + (when (get-buffer buf) + buf)) + ((bufferp buf) + (buffer-name buf)) + (t nil)))) + +(defun sql-display-buffer (buf) + "Display a SQLi buffer based on `sql-display-sqli-buffer-function'. + +If BUF is hidden or `sql-display-sqli-buffer-function' is nil, +then the buffer will not be displayed. Otherwise the BUF is +displayed." + (unless (sql-buffer-hidden-p buf) + (cond + ((eq sql-display-sqli-buffer-function t) + (pop-to-buffer buf)) + ((not sql-display-sqli-buffer-function) + nil) + ((functionp sql-display-sqli-buffer-function) + (funcall sql-display-sqli-buffer-function buf)) + (t + (message "Invalid setting of `sql-display-sqli-buffer-function'") + (pop-to-buffer buf))))) + +(defun sql-make-progress-reporter (buf message &optional min-value max-value current-value min-change min-time) + "Make a progress reporter if BUF is not hidden." + (unless (or (sql-buffer-hidden-p buf) + (not sql-display-sqli-buffer-function)) + (make-progress-reporter message min-value max-value current-value min-change min-time))) + +(defun sql-progress-reporter-update (reporter &optional value) + "Report progress of an operation in the echo area." + (when reporter + (progress-reporter-update reporter value))) + +(defun sql-progress-reporter-done (reporter) + "Print reporter’s message followed by word \"done\" in echo area." + (when reporter + (progress-reporter-done reporter))) ;;; SMIE support @@ -2756,12 +3079,12 @@ local variable." ;;; Motion Functions (defun sql-statement-regexp (prod) - (let* ((ansi-stmt (sql-get-product-feature 'ansi :statement)) + (let* ((ansi-stmt (or (sql-get-product-feature 'ansi :statement) "select")) (prod-stmt (sql-get-product-feature prod :statement))) (concat "^\\<" (if prod-stmt - ansi-stmt - (concat "\\(" ansi-stmt "\\|" prod-stmt "\\)")) + (concat "\\(" ansi-stmt "\\|" prod-stmt "\\)") + ansi-stmt) "\\>"))) (defun sql-beginning-of-statement (arg) @@ -2797,7 +3120,7 @@ local variable." (defun sql-end-of-statement (arg) "Move to the end of the current SQL statement." (interactive "p") - (let ((term (sql-get-product-feature sql-product :terminator)) + (let ((term (or (sql-get-product-feature sql-product :terminator) ";")) (re-search (if (> 0 arg) 're-search-backward 're-search-forward)) (here (point)) (n 0)) @@ -2917,11 +3240,11 @@ appended to the SQLi buffer without disturbing your SQL buffer.") "Return a docstring for `sql-help' listing loaded SQL products." (let ((doc sql--help-docstring)) ;; Insert FREE software list - (when (string-match "^\\(\\s-*\\)[\\\\][\\\\]FREE\\s-*$" doc 0) + (when (string-match "^\\(\\s-*\\)[\\][\\]FREE\\s-*$" doc 0) (setq doc (replace-match (sql-help-list-products (match-string 1 doc) t) t t doc 0))) ;; Insert non-FREE software list - (when (string-match "^\\(\\s-*\\)[\\\\][\\\\]NONFREE\\s-*$" doc 0) + (when (string-match "^\\(\\s-*\\)[\\][\\]NONFREE\\s-*$" doc 0) (setq doc (replace-match (sql-help-list-products (match-string 1 doc) nil) t t doc 0))) doc)) @@ -2952,7 +3275,12 @@ regexp pattern specified in its value. The `:completion' property prompts for a string specified by its value. (The property value is used as the PREDICATE argument to -`completing-read'.)" +`completing-read'.) + +For both `:file' and `:completion', there can also be a +`:must-match' property that controls REQUIRE-MATCH parameter to +`completing-read'." + (set-default symbol (let* ((default (plist-get plist :default)) @@ -2972,7 +3300,9 @@ value. (The property value is used as the PREDICATE argument to (read-file-name prompt (file-name-directory last-value) default - (plist-get plist :must-match) + (if (plist-member plist :must-match) + (plist-get plist :must-match) + t) (file-name-nondirectory last-value) (when (plist-get plist :file) `(lambda (f) @@ -2989,7 +3319,9 @@ value. (The property value is used as the PREDICATE argument to (completing-read prompt-def (plist-get plist :completion) nil - (plist-get plist :must-match) + (if (plist-member plist :must-match) + (plist-get plist :must-match) + t) last-value history-var default)) @@ -3017,6 +3349,10 @@ symbol `password', for the server if it contains the symbol `database'. The members of WHAT are processed in the order in which they are provided. +If the `sql-password-wallet' is non-nil and WHAT contains the +`password' token, then the `password' token will be pushed to the +end to be sure that all of the values can be fed to the wallet. + Each token may also be a list with the token in the car and a plist of options as the cdr. The following properties are supported: @@ -3028,24 +3364,45 @@ supported: In order to ask the user for username, password and database, call the function like this: (sql-get-login \\='user \\='password \\='database)." + + ;; Push the password to the end if we have a wallet + (when (and sql-password-wallet + (fboundp sql-password-search-wallet-function) + (member 'password what)) + (setq what (append (cl-delete 'password what) + '(password)))) + + ;; Prompt for each parameter (dolist (w what) (let ((plist (cdr-safe w))) (pcase (or (car-safe w) w) - (`user + ('user (sql-get-login-ext 'sql-user "User: " 'sql-user-history plist)) - (`password + ('password (setq-default sql-password - (read-passwd "Password: " nil (sql-default-value 'sql-password)))) - - (`server + (if (and sql-password-wallet + (fboundp sql-password-search-wallet-function)) + (let ((password (funcall sql-password-search-wallet-function + sql-password-wallet + sql-product + sql-user + sql-server + sql-database + sql-port))) + (if password + password + (read-passwd "Password: " nil (sql-default-value 'sql-password)))) + (read-passwd "Password: " nil (sql-default-value 'sql-password))))) + + ('server (sql-get-login-ext 'sql-server "Server: " 'sql-server-history plist)) - (`database + ('database (sql-get-login-ext 'sql-database "Database: " 'sql-database-history plist)) - (`port + ('port (sql-get-login-ext 'sql-port "Port: " nil (append '(:number t) plist))))))) @@ -3129,7 +3486,7 @@ See also `sql-help' on how to create such a buffer." (sql-set-sqli-buffer)) (display-buffer sql-buffer)) -(defun sql-make-alternate-buffer-name () +(defun sql-make-alternate-buffer-name (&optional product) "Return a string that can be used to rename a SQLi buffer. This is used to set `sql-alternate-buffer-name' within `sql-interactive-mode'. @@ -3151,23 +3508,23 @@ server/database name." (cdr (apply #'append nil (sql-for-each-login - (sql-get-product-feature sql-product :sqli-login) + (sql-get-product-feature (or product sql-product) :sqli-login) (lambda (token plist) (pcase token - (`user + ('user (unless (string= "" sql-user) (list "/" sql-user))) - (`port + ('port (unless (or (not (numberp sql-port)) (= 0 sql-port)) (list ":" (number-to-string sql-port)))) - (`server + ('server (unless (string= "" sql-server) (list "." (if (plist-member plist :file) (file-name-nondirectory sql-server) sql-server)))) - (`database + ('database (unless (string= "" sql-database) (list "@" (if (plist-member plist :file) @@ -3198,6 +3555,39 @@ server/database name." ;; Use the name we've got name)))) +(defun sql-generate-unique-sqli-buffer-name (product base) + "Generate a new, unique buffer name for a SQLi buffer. + +Append a sequence number until a unique name is found." + (let ((base-name (substring-no-properties + (if base + (if (stringp base) + base + (format "%S" base)) + (or (sql-get-product-feature product :name) + (symbol-name product))))) + buf-fmt-1st + buf-fmt-rest) + + ;; Calculate buffer format + (if (string-blank-p base-name) + (setq buf-fmt-1st "*SQL*" + buf-fmt-rest "*SQL-%d*") + (setq buf-fmt-1st (format "*SQL: %s*" base-name) + buf-fmt-rest (format "*SQL: %s-%%d*" base-name))) + + ;; See if we can find an unused buffer + (let ((buf-name buf-fmt-1st) + (i 1)) + (while (if (sql-is-sqli-buffer-p buf-name) + (comint-check-proc buf-name) + (buffer-live-p (get-buffer buf-name))) + ;; Check a sequence number on the BASE + (setq buf-name (format buf-fmt-rest i) + i (1+ i))) + + buf-name))) + (defun sql-rename-buffer (&optional new-name) "Rename a SQL interactive buffer. @@ -3213,18 +3603,20 @@ NEW-NAME is empty, then the buffer name will be \"*SQL*\"." (user-error "Current buffer is not a SQL interactive buffer") (setq sql-alternate-buffer-name - (cond - ((stringp new-name) new-name) - ((consp new-name) - (read-string "Buffer name (\"*SQL: XXX*\"; enter `XXX'): " - sql-alternate-buffer-name)) - (t sql-alternate-buffer-name))) - - (setq sql-alternate-buffer-name (substring-no-properties sql-alternate-buffer-name)) - (rename-buffer (if (string= "" sql-alternate-buffer-name) - "*SQL*" - (format "*SQL: %s*" sql-alternate-buffer-name)) - t))) + (substring-no-properties + (cond + ((stringp new-name) + new-name) + ((consp new-name) + (read-string "Buffer name (\"*SQL: XXX*\"; enter `XXX'): " + sql-alternate-buffer-name)) + (t + sql-alternate-buffer-name)))) + + (rename-buffer + (sql-generate-unique-sqli-buffer-name sql-product + sql-alternate-buffer-name) + t))) (defun sql-copy-column () "Copy current column to the end of buffer. @@ -3268,12 +3660,16 @@ Inserts SELECT or commas if appropriate." Placeholders are words starting with an ampersand like &this." (when sql-oracle-scan-on - (while (string-match "&?&\\(\\(?:\\sw\\|\\s_\\)+\\)[.]?" string) - (setq string (replace-match - (read-from-minibuffer - (format "Enter value for %s: " (match-string 1 string)) - nil nil nil 'sql-placeholder-history) - t t string)))) + (let ((start 0) + (replacement "")) + (while (string-match "&?&\\(\\(?:\\sw\\|\\s_\\)+\\)[.]?" string start) + (setq replacement (read-from-minibuffer + (format "Enter value for %s: " + (propertize (match-string 1 string) + 'face 'font-lock-variable-name-face)) + nil nil nil 'sql-placeholder-history) + string (replace-match replacement t t string) + start (+ (match-beginning 1) (length replacement)))))) string) ;; Using DB2 interactively, newlines must be escaped with " \". @@ -3323,8 +3719,8 @@ Allows the suppression of continuation prompts.") ;; Count how many newlines in the string (setq sql-output-newline-count - (apply #'+ (mapcar (lambda (ch) - (if (eq ch ?\n) 1 0)) string))) + (apply #'+ (mapcar (lambda (ch) (if (eq ch ?\n) 1 0)) + string))) ;; Send the string (comint-simple-send proc string))) @@ -3370,7 +3766,8 @@ to avoid deleting non-prompt output." (or (> (length (or sql-preoutput-hold "")) 0) (> (or sql-output-newline-count 0) 0) (not (or (string-match sql-prompt-regexp oline) - (string-match sql-prompt-cont-regexp oline))))) + (and sql-prompt-cont-regexp + (string-match sql-prompt-cont-regexp oline)))))) (save-match-data (let (prompt-found last-nl) @@ -3422,6 +3819,8 @@ to avoid deleting non-prompt output." oline) ;;; Sending the region to the SQLi buffer. +(defvar sql-debug-send nil + "Display text sent to SQL process pragmatically.") (defun sql-send-string (str) "Send the string STR to the SQL process." @@ -3435,19 +3834,20 @@ to avoid deleting non-prompt output." (save-excursion ;; Set product context (with-current-buffer sql-buffer + (when sql-debug-send + (message ">>SQL> %S" s)) + ;; Send the string (trim the trailing whitespace) - (sql-input-sender (get-buffer-process sql-buffer) s) + (sql-input-sender (get-buffer-process (current-buffer)) s) ;; Send a command terminator if we must - (if sql-send-terminator - (sql-send-magic-terminator sql-buffer s sql-send-terminator)) + (sql-send-magic-terminator sql-buffer s sql-send-terminator) - (message "Sent string to buffer %s" sql-buffer))) + (when sql-pop-to-buffer-after-send-region + (message "Sent string to buffer %s" sql-buffer)))) ;; Display the sql buffer - (if sql-pop-to-buffer-after-send-region - (pop-to-buffer sql-buffer) - (display-buffer sql-buffer))) + (sql-display-buffer sql-buffer)) ;; We don't have no stinkin' sql (user-error "No SQL process started")))) @@ -3503,12 +3903,8 @@ to avoid deleting non-prompt output." ;; Check to see if the pattern is present in the str already sent (unless (and pat term - (string-match (concat pat "\\'") str)) - (comint-simple-send (get-buffer-process buf) term) - (setq sql-output-newline-count - (if sql-output-newline-count - (1+ sql-output-newline-count) - 1))))) + (string-match-p (concat pat "\\'") str)) + (sql-input-sender (get-buffer-process buf) term)))) (defun sql-remove-tabs-filter (str) "Replace tab characters with spaces." @@ -3546,15 +3942,22 @@ of commands accepted by the SQLi program. COMMAND may also be a list of SQLi command strings." (let* ((visible (and outbuf - (not (string= " " (substring outbuf 0 1)))))) + (not (sql-buffer-hidden-p outbuf)))) + (this-save save-prior) + (next-save t)) + (when visible (message "Executing SQL command...")) + (if (consp command) - (mapc (lambda (c) (sql-redirect-one sqlbuf c outbuf save-prior)) - command) + (dolist (onecmd command) + (sql-redirect-one sqlbuf onecmd outbuf this-save) + (setq this-save next-save)) (sql-redirect-one sqlbuf command outbuf save-prior)) + (when visible - (message "Executing SQL command...done")))) + (message "Executing SQL command...done")) + nil)) (defun sql-redirect-one (sqlbuf command outbuf save-prior) (when command @@ -3603,7 +4006,7 @@ list of SQLi command strings." (replace-match "" t t)) (goto-char start)))))))) -(defun sql-redirect-value (sqlbuf command regexp &optional regexp-groups) +(defun sql-redirect-value (sqlbuf command &optional regexp regexp-groups) "Execute the SQL command and return part of result. SQLBUF must be an active SQL interactive buffer. COMMAND should @@ -3618,7 +4021,7 @@ for each match." (results nil)) (sql-redirect sqlbuf command outbuf nil) (with-current-buffer outbuf - (while (re-search-forward regexp nil t) + (while (re-search-forward (or regexp "^.+$") nil t) (push (cond ;; no groups-return all of them @@ -3868,7 +4271,7 @@ must tell Emacs. Here's how to do that in your init file: ;; Set syntax and font-face highlighting ;; Catch changes to sql-product and highlight accordingly (sql-set-product (or sql-product 'ansi)) ; Fixes bug#13591 - (add-hook 'hack-local-variables-hook 'sql-highlight-product t t)) + (add-hook 'hack-local-variables-hook #'sql-highlight-product t t)) @@ -3876,7 +4279,7 @@ must tell Emacs. Here's how to do that in your init file: (put 'sql-interactive-mode 'mode-class 'special) (put 'sql-interactive-mode 'custom-mode-group 'SQL) - +;; FIXME: Why not use `define-derived-mode'? (defun sql-interactive-mode () "Major mode to use a SQL interpreter interactively. @@ -3938,13 +4341,15 @@ certain length. \(add-hook \\='sql-interactive-mode-hook (function (lambda () - (setq comint-output-filter-functions \\='comint-truncate-buffer)))) + (setq comint-output-filter-functions #\\='comint-truncate-buffer)))) Here is another example. It will always put point back to the statement you entered, right above the output it created. \(setq comint-output-filter-functions (function (lambda (STR) (comint-show-output))))" + ;; FIXME: The doc above uses `setq' on `comint-output-filter-functions', + ;; whereas hooks should be manipulated with things like `add/remove-hook'. (delay-mode-hooks (comint-mode)) ;; Get the `sql-product' for this interactive session. @@ -3975,7 +4380,8 @@ you entered, right above the output it created. (setq local-abbrev-table sql-mode-abbrev-table) (setq abbrev-all-caps 1) ;; Exiting the process will call sql-stop. - (set-process-sentinel (get-buffer-process (current-buffer)) 'sql-stop) + (let ((proc (get-buffer-process (current-buffer)))) + (when proc (set-process-sentinel proc #'sql-stop))) ;; Save the connection and login params (set (make-local-variable 'sql-user) sql-user) (set (make-local-variable 'sql-database) sql-database) @@ -3993,7 +4399,7 @@ you entered, right above the output it created. (sql-make-alternate-buffer-name)) ;; User stuff. Initialize before the hook. (set (make-local-variable 'sql-prompt-regexp) - (sql-get-product-feature sql-product :prompt-regexp)) + (or (sql-get-product-feature sql-product :prompt-regexp) "^")) (set (make-local-variable 'sql-prompt-length) (sql-get-product-feature sql-product :prompt-length)) (set (make-local-variable 'sql-prompt-cont-regexp) @@ -4001,7 +4407,7 @@ you entered, right above the output it created. (make-local-variable 'sql-output-newline-count) (make-local-variable 'sql-preoutput-hold) (add-hook 'comint-preoutput-filter-functions - 'sql-interactive-remove-continuation-prompt nil t) + #'sql-interactive-remove-continuation-prompt nil t) (make-local-variable 'sql-input-ring-separator) (make-local-variable 'sql-input-ring-file-name) ;; Run the mode hook (along with comint's hooks). @@ -4009,12 +4415,12 @@ you entered, right above the output it created. ;; Set comint based on user overrides. (setq comint-prompt-regexp (if sql-prompt-cont-regexp - (concat "\\(" sql-prompt-regexp - "\\|" sql-prompt-cont-regexp "\\)") + (concat "\\(?:\\(?:" sql-prompt-regexp "\\)" + "\\|\\(?:" sql-prompt-cont-regexp "\\)\\)") sql-prompt-regexp)) - (setq left-margin sql-prompt-length) + (setq left-margin (or sql-prompt-length 0)) ;; Install input sender - (set (make-local-variable 'comint-input-sender) 'sql-input-sender) + (set (make-local-variable 'comint-input-sender) #'sql-input-sender) ;; People wanting a different history file for each ;; buffer/process/client/whatever can change separator and file-name ;; on the sql-interactive-mode-hook. @@ -4031,15 +4437,16 @@ Writes the input history to a history file using This function is a sentinel watching the SQL interpreter process. Sentinels will always get the two parameters PROCESS and EVENT." - (with-current-buffer (process-buffer process) - (let - ((comint-input-ring-separator sql-input-ring-separator) - (comint-input-ring-file-name sql-input-ring-file-name)) - (comint-write-input-ring)) + (when (buffer-live-p (process-buffer process)) + (with-current-buffer (process-buffer process) + (let + ((comint-input-ring-separator sql-input-ring-separator) + (comint-input-ring-file-name sql-input-ring-file-name)) + (comint-write-input-ring)) - (if (not buffer-read-only) - (insert (format "\nProcess %s %s\n" process event)) - (message "Process %s %s" process event)))) + (if (not buffer-read-only) + (insert (format "\nProcess %s %s\n" process event)) + (message "Process %s %s" process event))))) @@ -4049,8 +4456,7 @@ Sentinels will always get the two parameters PROCESS and EVENT." "Read a connection name." (let ((completion-ignore-case t)) (completing-read prompt - (mapcar (lambda (c) (car c)) - sql-connection-alist) + (mapcar #'car sql-connection-alist) nil t initial 'sql-connection-history default))) ;;;###autoload @@ -4099,11 +4505,11 @@ is specified in the connection settings." (mapcar (lambda (v) (pcase (car v) - (`sql-user 'user) - (`sql-password 'password) - (`sql-server 'server) - (`sql-database 'database) - (`sql-port 'port) + ('sql-user 'user) + ('sql-password 'password) + ('sql-server 'server) + ('sql-database 'database) + ('sql-port 'port) (s s))) connect-set)) @@ -4167,11 +4573,11 @@ optionally is saved to the user's init file." `(product ,@login) (lambda (token _plist) (pcase token - (`product `(sql-product ',product)) - (`user `(sql-user ,user)) - (`database `(sql-database ,database)) - (`server `(sql-server ,server)) - (`port `(sql-port ,port))))))) + ('product `(sql-product ',product)) + ('user `(sql-user ,user)) + ('database `(sql-database ,database)) + ('server `(sql-server ,server)) + ('port `(sql-port ,port))))))) (setq alist (append alist (list connect))) @@ -4215,31 +4621,30 @@ the call to \\[sql-product-interactive] with ;; Handle universal arguments if specified (when (not (or executing-kbd-macro noninteractive)) - (when (and (consp product) - (not (cdr product)) - (numberp (car product))) - (when (>= (prefix-numeric-value product) 16) - (when (not new-name) - (setq new-name '(4))) - (setq product '(4))))) + (when (>= (prefix-numeric-value product) 16) + (when (not new-name) + (setq new-name '(4))) + (setq product '(4)))) ;; Get the value of product that we need (setq product (cond ((= (prefix-numeric-value product) 4) ; C-u, prompt for product (sql-read-product "SQL product: " sql-product)) - ((and product ; Product specified - (symbolp product)) product) + ((assoc product sql-product-alist) ; Product specified + product) (t sql-product))) ; Default to sql-product ;; If we have a product and it has an interactive mode (if product (when (sql-get-product-feature product :sqli-comint-func) - ;; If no new name specified, try to pop to an active SQL - ;; interactive for the same product + ;; If no new name specified or new name in buffer name, + ;; try to pop to an active SQL interactive for the same product (let ((buf (sql-find-sqli-buffer product sql-connection))) - (if (and (not new-name) buf) - (pop-to-buffer buf) + (if (and buf (or (not new-name) + (and (stringp new-name) + (string-match-p (regexp-quote new-name) buf)))) + (sql-display-buffer buf) ;; We have a new name or sql-buffer doesn't exist or match ;; Start by remembering where we start @@ -4251,34 +4656,41 @@ the call to \\[sql-product-interactive] with (sql-get-product-feature product :sqli-login)) ;; Connect to database. - (setq rpt (make-progress-reporter "Login")) + (setq rpt (sql-make-progress-reporter nil "Login")) (let ((sql-user (default-value 'sql-user)) (sql-password (default-value 'sql-password)) (sql-server (default-value 'sql-server)) (sql-database (default-value 'sql-database)) (sql-port (default-value 'sql-port)) - (default-directory (or sql-default-directory - default-directory))) + (default-directory + (or sql-default-directory + default-directory))) + + ;; The password wallet returns a function which supplies the password. + (when (functionp sql-password) + (setq sql-password (funcall sql-password))) + + ;; Call the COMINT service (funcall (sql-get-product-feature product :sqli-comint-func) product (sql-get-product-feature product :sqli-options) + ;; generate a buffer name (cond - ((null new-name) - "*SQL*") - ((stringp new-name) - (if (string-prefix-p "*SQL: " new-name t) - new-name - (concat "*SQL: " new-name "*"))) - ((equal new-name '(4)) - (concat - "*SQL: " + ((not new-name) + (sql-generate-unique-sqli-buffer-name product nil)) + ((consp new-name) + (sql-generate-unique-sqli-buffer-name product (read-string "Buffer name (\"*SQL: XXX*\"; enter `XXX'): " - sql-alternate-buffer-name) - "*")) + (sql-make-alternate-buffer-name product)))) + ((stringp new-name) + (if (or (string-prefix-p " " new-name) + (string-match-p "\\`[*].*[*]\\'" new-name)) + new-name + (sql-generate-unique-sqli-buffer-name product new-name))) (t - (format "*SQL: %s*" new-name))))) + (sql-generate-unique-sqli-buffer-name product new-name))))) ;; Set SQLi mode. (let ((sql-interactive-product product)) @@ -4301,30 +4713,32 @@ the call to \\[sql-product-interactive] with (let ((proc (get-buffer-process new-sqli-buffer)) (secs sql-login-delay) (step 0.3)) - (while (and (memq (process-status proc) '(open run)) + (while (and proc + (memq (process-status proc) '(open run)) (or (accept-process-output proc step) (<= 0.0 (setq secs (- secs step)))) (progn (goto-char (point-max)) (not (re-search-backward sql-prompt-regexp 0 t)))) - (progress-reporter-update rpt))) + (sql-progress-reporter-update rpt))) (goto-char (point-max)) (when (re-search-backward sql-prompt-regexp nil t) (run-hooks 'sql-login-hook)) ;; All done. - (progress-reporter-done rpt) - (pop-to-buffer new-sqli-buffer) + (sql-progress-reporter-done rpt) (goto-char (point-max)) - (current-buffer))))) - (user-error "No default SQL product defined. Set `sql-product'."))) + (let ((sql-display-sqli-buffer-function t)) + (sql-display-buffer new-sqli-buffer)) + (get-buffer new-sqli-buffer))))) + (user-error "No default SQL product defined: set `sql-product'"))) (defun sql-comint (product params &optional buf-name) "Set up a comint buffer to run the SQL processor. PRODUCT is the SQL product. PARAMS is a list of strings which are passed as command line arguments. BUF-NAME is the name of the new -buffer. If nil, a name is chosen for it." +buffer. If nil, a name is chosen for it." (let ((program (sql-get-product-feature product :sqli-program))) ;; Make sure we can find the program. `executable-find' does not @@ -4337,15 +4751,10 @@ buffer. If nil, a name is chosen for it." ;; if not specified, try *SQL* then *SQL-product*, then *SQL-product1*, ... ;; otherwise, use *buf-name* (if buf-name - (unless (string-match-p "\\`[*].*[*]\\'" buf-name) + (unless (or (string-prefix-p " " buf-name) + (string-match-p "\\`[*].*[*]\\'" buf-name)) (setq buf-name (concat "*" buf-name "*"))) - (setq buf-name "*SQL*") - (when (sql-buffer-live-p buf-name) - (setq buf-name (format "*SQL-%s*" product))) - (let ((i 1)) - (while (sql-buffer-live-p buf-name) - (setq buf-name (format "*SQL-%s%d*" product i) - i (1+ i))))) + (setq buf-name (sql-generate-unique-sqli-buffer-name product nil))) (set-text-properties 0 (length buf-name) nil buf-name) ;; Start the command interpreter in the buffer @@ -4426,7 +4835,8 @@ The default comes from `process-coding-system-alist' and (or coding 'utf-8)) (when (string-match (format "\\.%s\\'" (car cs)) nlslang) (setq coding (cdr cs))))) - (set-buffer-process-coding-system coding coding))) + (set-process-coding-system (get-buffer-process (current-buffer)) + coding coding))) (defun sql-oracle-save-settings (sqlbuf) "Save most SQL*Plus settings so they may be reset by \\[sql-redirect]." @@ -4787,6 +5197,46 @@ The default comes from `process-coding-system-alist' and (list sql-database))))) (sql-comint product params buf-name))) +;;;###autoload +(defun sql-mariadb (&optional buffer) + "Run mysql by MariaDB as an inferior process. + +MariaDB is free software. + +If buffer `*SQL*' exists but no process is running, make a new process. +If buffer exists and a process is running, just switch to buffer +`*SQL*'. + +Interpreter used comes from variable `sql-mariadb-program'. Login uses +the variables `sql-user', `sql-password', `sql-database', and +`sql-server' as defaults, if set. Additional command line parameters +can be stored in the list `sql-mariadb-options'. + +The buffer is put in SQL interactive mode, giving commands for sending +input. See `sql-interactive-mode'. + +To set the buffer name directly, use \\[universal-argument] +before \\[sql-mariadb]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + +To specify a coding system for converting non-ASCII characters +in the input and output to the process, use \\[universal-coding-system-argument] +before \\[sql-mariadb]. You can also specify this with \\[set-buffer-process-coding-system] +in the SQL buffer, after you start the process. +The default comes from `process-coding-system-alist' and +`default-process-coding-system'. + +\(Type \\[describe-mode] in the SQL buffer for a list of commands.)" + (interactive "P") + (sql-product-interactive 'mariadb buffer)) + +(defun sql-comint-mariadb (product options &optional buf-name) + "Create comint buffer and connect to MariaDB. + +Use the MySQL comint driver since the two are compatible." + (sql-comint-mysql product options buf-name)) + ;;;###autoload @@ -4968,8 +5418,7 @@ The default comes from `process-coding-system-alist' and your might try undecided-dos as a coding system. If this doesn't help, Try to set `comint-output-filter-functions' like this: -\(setq comint-output-filter-functions (append comint-output-filter-functions - \\='(comint-strip-ctrl-m))) +\(add-hook 'comint-output-filter-functions #\\='comint-strip-ctrl-m 'append) \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" (interactive "P") diff --git a/lisp/progmodes/subword.el b/lisp/progmodes/subword.el index a188168c04f..58a266c117e 100644 --- a/lisp/progmodes/subword.el +++ b/lisp/progmodes/subword.el @@ -93,9 +93,6 @@ ;;;###autoload (define-minor-mode subword-mode "Toggle subword movement and editing (Subword mode). -With a prefix argument ARG, enable Subword mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Subword mode is a buffer-local minor mode. Enabling it changes the definition of a word so that word-based commands stop inside @@ -148,8 +145,6 @@ Optional argument ARG is the same as for `forward-word'." (t (point)))) -(put 'subword-forward 'CUA 'move) - (defun subword-backward (&optional arg) "Do the same as `backward-word' but on subwords. See the command `subword-mode' for a description of subwords. @@ -190,8 +185,6 @@ Optional argument ARG is the same as for `mark-word'." (point)) nil t)))) -(put 'subword-backward 'CUA 'move) - (defun subword-kill (arg) "Do the same as `kill-word' but on subwords. See the command `subword-mode' for a description of subwords. @@ -267,9 +260,6 @@ Optional argument ARG is the same as for `capitalize-word'." ;;;###autoload (define-minor-mode superword-mode "Toggle superword movement and editing (Superword mode). -With a prefix argument ARG, enable Superword mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Superword mode is a buffer-local minor mode. Enabling it changes the definition of words such that symbols characters are treated diff --git a/lisp/progmodes/tcl.el b/lisp/progmodes/tcl.el index 3ebb311212e..0fd3d6d1bf4 100644 --- a/lisp/progmodes/tcl.el +++ b/lisp/progmodes/tcl.el @@ -2,9 +2,9 @@ ;; Copyright (C) 1994, 1998-2019 Free Software Foundation, Inc. -;; Maintainer: emacs-devel@gnu.org ;; Author: Tom Tromey <tromey@redhat.com> ;; Chris Lindblad <cjl@lcs.mit.edu> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: languages tcl modes ;; This file is part of GNU Emacs. @@ -360,7 +360,7 @@ Add functions to the hook with `add-hook': (defvar tcl-proc-list - '("proc" "method" "itcl_class" "body" "configbody" "class") + '("proc" "method" "itcl_class" "body" "configbody" "class" "namespace") "List of commands whose first argument defines something. This exists because some people (eg, me) use `defvar' et al. Call `tcl-set-proc-regexp' and `tcl-set-font-lock-keywords' @@ -611,6 +611,9 @@ already exist." (set (make-local-variable 'add-log-current-defun-function) 'tcl-add-log-defun) + (setq-local beginning-of-defun-function #'tcl-beginning-of-defun-function) + (setq-local end-of-defun-function #'tcl-end-of-defun-function) + (easy-menu-add tcl-mode-menu) ;; Append Tcl menu to popup menu for XEmacs. (if (boundp 'mode-popup-menu) @@ -993,15 +996,49 @@ Returns nil if line starts inside a string, t if in a comment." ;; Interfaces to other packages. ;; -;; FIXME Definition of function is very ad-hoc. Should use -;; beginning-of-defun. Also has incestuous knowledge about the -;; format of tcl-proc-regexp. +(defun tcl-beginning-of-defun-function (&optional arg) + "`beginning-of-defun-function' for Tcl mode." + (when (or (not arg) (= arg 0)) + (setq arg 1)) + (let* ((search-fn (if (> arg 0) + ;; Positive arg means to search backward. + #'re-search-backward + #'re-search-forward)) + (arg (abs arg)) + (result t)) + (while (and (> arg 0) result) + (unless (funcall search-fn tcl-proc-regexp nil t) + (setq result nil)) + (setq arg (1- arg))) + result)) + +(defun tcl-end-of-defun-function () + "`end-of-defun-function' for Tcl mode." + ;; Because we let users redefine tcl-proc-list, we don't really know + ;; too much about the exact arguments passed to the "proc"-defining + ;; command. Instead we just skip words and lists until we see + ;; either a ";" or a newline, either of which terminates a command. + (skip-syntax-forward "-") + (while (and (not (eobp)) + (not (looking-at-p "[\n;]"))) + (condition-case nil + (forward-sexp) + (scan-error + (goto-char (point-max)))) + ;; Note that here we do not want to skip \n. + (skip-chars-forward " \t"))) + (defun tcl-add-log-defun () "Return name of Tcl function point is in, or nil." (save-excursion - (end-of-line) - (if (re-search-backward (concat tcl-proc-regexp "\\([^ \t\n{]+\\)") nil t) - (match-string 2)))) + (let ((orig-point (point))) + (when (beginning-of-defun) + ;; Only return the name when in the body of the function. + (when (save-excursion + (end-of-defun) + (>= (point) orig-point)) + (when (looking-at (concat tcl-proc-regexp "\\([^ \t\n{]+\\)")) + (match-string 2))))))) (defun tcl-outline-level () (save-excursion diff --git a/lisp/progmodes/vera-mode.el b/lisp/progmodes/vera-mode.el index a03556ee12d..21d3db91ad3 100644 --- a/lisp/progmodes/vera-mode.el +++ b/lisp/progmodes/vera-mode.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1997-2019 Free Software Foundation, Inc. ;; Author: Reto Zimmermann <reto@gnu.org> -;; Maintainer: Reto Zimmermann <reto@gnu.org> ;; Version: 2.28 ;; Keywords: languages vera ;; WWW: http://www.iis.ee.ethz.ch/~zimmi/emacs/vera-mode.html @@ -636,7 +635,7 @@ Adapted from `font-lock-match-c-style-declaration-item-and-skip-to-next'." (list (concat "^\\s-*" vera-rvm-types-regexp "\\s-*\\(\\[[^]]+\\]\\s-+\\)?") '(vera-font-lock-match-item nil nil (1 font-lock-variable-name-face))) ;; highlight numbers - '("\\([0-9]*'[bdoh][0-9a-fA-FxXzZ_]+\\)" 1 vera-font-lock-number) + '("\\([0-9]*'[bdoh][[:xdigit:]xXzZ_]+\\)" 1 vera-font-lock-number) ;; highlight filenames in #include directives '("^#\\s-*include\\s-*\\(<[^>\"\n]*>?\\)" 1 font-lock-string-face) diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index da2e99292f9..2939108d47b 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: 2017.8.7.201875024 +;; Version: 2019.06.21.103209889 ;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this ;; file on 19/3/2008, and the maintainer agreed that when a bug is @@ -111,7 +111,6 @@ ;; verilog-minimum-comment-distance 40 ;; verilog-indent-begin-after-if t ;; verilog-auto-lineup 'declarations -;; verilog-highlight-p1800-keywords nil ;; verilog-linter "my_lint_shell_command" ;; ) @@ -125,7 +124,7 @@ ;; ;; This variable will always hold the version number of the mode -(defconst verilog-mode-version "2017-08-07-c085e50-vpo-GNU" +(defconst verilog-mode-version "2019-06-21-626dba1-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.") @@ -241,7 +240,7 @@ STRING should be given if the last search was by `string-match' on STRING." (unless (featurep 'xemacs) (unless (fboundp 'region-active-p) (defmacro region-active-p () - `(and transient-mark-mode mark-active)))) + '(and transient-mark-mode mark-active)))) ) ;; Provide a regular expression optimization routine, using regexp-opt @@ -253,7 +252,7 @@ STRING should be given if the last search was by `string-match' on STRING." (if (fboundp 'regexp-opt) ;; regexp-opt is defined, does it take 3 or 2 arguments? (if (fboundp 'function-max-args) - (let ((args (function-max-args `regexp-opt))) + (let ((args (function-max-args 'regexp-opt))) (cond ((eq args 3) ; It takes 3 (condition-case nil ; Hide this defun from emacses @@ -385,7 +384,7 @@ wherever possible, since it is slow." ((vectorp menu) (let ((i 0) (out [])) (while (< i (length menu)) - (if (equal `:help (aref menu i)) + (if (equal :help (aref menu i)) (setq i (+ 2 i)) (setq out (vconcat out (vector (aref menu i))) i (1+ i)))) @@ -722,15 +721,13 @@ default avoids too many redundant comments in tight quarters." (put 'verilog-minimum-comment-distance 'safe-local-variable 'integerp) (defcustom verilog-highlight-p1800-keywords nil - "Non-nil means highlight words newly reserved by IEEE-1800. -These will appear in `verilog-font-lock-p1800-face' in order to gently -suggest changing where these words are used as variables to something else. -A nil value means highlight these words as appropriate for the SystemVerilog -IEEE-1800 standard. Note that changing this will require restarting Emacs -to see the effect as font color choices are cached by Emacs." + "Obsolete. +Was non-nil means highlight SystemVerilog IEEE-1800 differently. +All code is now highlighted as if SystemVerilog IEEE-1800." :group 'verilog-mode-indent :type 'boolean) (put 'verilog-highlight-p1800-keywords 'safe-local-variable 'verilog-booleanp) +(make-obsolete-variable 'verilog-highlight-p1800-keywords nil "27.1") (defcustom verilog-highlight-grouping-keywords nil "Non-nil means highlight grouping keywords more dramatically. @@ -1073,6 +1070,18 @@ of each Verilog file that requires it, rather than being set globally." :type 'boolean) (put 'verilog-auto-sense-defines-constant 'safe-local-variable 'verilog-booleanp) +(defcustom verilog-auto-simplify-expressions t + "Non-nil means AUTOs will simplify expressions when calculating bit ranges. +When nil, do not simply ranges, which may simplify the output, +but may cause problems when there are multiple instantiations +outputting to the same wire. To maintain compatibility with +other sites, this should be set at the bottom of each Verilog +file that requires it, rather than being set globally." + :version "27.1" + :group 'verilog-mode-auto + :type 'boolean) +(put 'verilog-auto-simplify-expressions 'safe-local-variable 'verilog-booleanp) + (defcustom verilog-auto-reset-blocking-in-non t "Non-nil means AUTORESET will reset blocking statements. When true, AUTORESET will reset in blocking statements those @@ -1165,7 +1174,7 @@ inputs. This is then used by an upper module: output OUT_t o; endmodule - module ExampInst; + module ExampParamVal1; /*AUTOOUTPUT*/ // Beginning of automatic outputs output OUT_t o; @@ -1176,8 +1185,13 @@ inputs. This is then used by an upper module: ,.OUT_t(upper_t)) instName (/*AUTOINST*/ - .i (i[WIDTH-1:0]), - .o (o)); + .o (o), + .i (i[WIDTH-1:0])); + endmodule + + // Local Variables: + // verilog-typedef-regexp: \"_t$\" + // End: Note even though WIDTH=10, the AUTOINST has left the parameter as a symbolic name. Likewise the OUT_t is preserved as the name @@ -1186,7 +1200,7 @@ from the instantiated module. If `verilog-auto-inst-param-value' is set, this will instead expand to: - module ExampInst; + module ExampParamVal1; /*AUTOOUTPUT*/ // Beginning of automatic outputs output upper_t o; @@ -1197,8 +1211,8 @@ instead expand to: ,.OUT_t(upper_t)) instName (/*AUTOINST*/ - .i (i[9:0]), - .o (o)); + .o (o), + .i (i[9:0])); Note that the instantiation now has \"i[9:0]\" as the WIDTH was expanded. Likewise the data type of \"o\" in the AUTOOUTPUT @@ -1279,6 +1293,13 @@ See the \\[verilog-faq] for examples on using this." :type '(choice (const nil) regexp)) (put 'verilog-auto-input-ignore-regexp 'safe-local-variable 'stringp) +(defcustom verilog-auto-reg-input-assigned-ignore-regexp nil + "If non-nil, when creating AUTOINPUTREG, ignore signals matching this regexp." + :version "27.1" + :group 'verilog-mode-auto + :type '(choice (const nil) regexp)) +(put 'verilog-auto-reg-input-assigned-ignore-regexp 'safe-local-variable 'stringp) + (defcustom verilog-auto-inout-ignore-regexp nil "If non-nil, when creating AUTOINOUT, ignore signals matching this regexp. See the \\[verilog-faq] for examples on using this." @@ -1392,7 +1413,7 @@ See also `verilog-case-fold'." ("*Variables*" "^\\s-*\\(reg\\|wire\\|logic\\)\\s-+\\(\\|\\[[^]]+\\]\\s-+\\)\\([A-Za-z0-9_]+\\)" 3) ("*Classes*" "^\\s-*\\(?:\\(?:virtual\\|interface\\)\\s-+\\)?class\\s-+\\([A-Za-z_][A-Za-z0-9_]+\\)" 1) ("*Tasks*" "^\\s-*\\(?:\\(?:static\\|pure\\|virtual\\|local\\|protected\\)\\s-+\\)*task\\s-+\\(?:\\(?:static\\|automatic\\)\\s-+\\)?\\([A-Za-z_][A-Za-z0-9_:]+\\)" 1) - ("*Functions*" "^\\s-*\\(?:\\(?:static\\|pure\\|virtual\\|local\\|protected\\)\\s-+\\)*function\\s-+\\(?:\\(?:static\\|automatic\\)\\s-+\\)?\\(?:\\w+\\s-+\\)?\\([A-Za-z_][A-Za-z0-9_:]+\\)" 1) + ("*Functions*" "^\\s-*\\(?:\\(?:static\\|pure\\|virtual\\|local\\|protected\\)\\s-+\\)*function\\s-+\\(?:\\(?:static\\|automatic\\)\\s-+\\)?\\(?:\\w+\\s-+\\)?\\(?:\\(?:un\\)signed\\s-+\\)?\\([A-Za-z_][A-Za-z0-9_:]+\\)" 1) ("*Interfaces*" "^\\s-*interface\\s-+\\([a-zA-Z_0-9]+\\)" 1) ("*Types*" "^\\s-*typedef\\s-+.*\\s-+\\([a-zA-Z_0-9]+\\)\\s-*;" 1)) "Imenu expression for Verilog mode. See `imenu-generic-expression'.") @@ -1435,7 +1456,7 @@ If set will become buffer local.") (define-key map [(meta delete)] 'kill-word)) (define-key map "\M-\C-b" 'electric-verilog-backward-sexp) (define-key map "\M-\C-f" 'electric-verilog-forward-sexp) - (define-key map "\M-\r" `electric-verilog-terminate-and-indent) + (define-key map "\M-\r" 'electric-verilog-terminate-and-indent) (define-key map "\M-\t" (if (fboundp 'completion-at-point) 'completion-at-point 'verilog-complete-word)) (define-key map "\M-?" (if (fboundp 'completion-help-at-point) @@ -1484,35 +1505,35 @@ If set will become buffer local.") (setq verilog-tool 'verilog-linter) (verilog-set-compile-command)) :style radio - :selected (equal verilog-tool `verilog-linter) + :selected (equal verilog-tool 'verilog-linter) :help "When invoking compilation, use lint checker"] ["Coverage" (progn (setq verilog-tool 'verilog-coverage) (verilog-set-compile-command)) :style radio - :selected (equal verilog-tool `verilog-coverage) + :selected (equal verilog-tool 'verilog-coverage) :help "When invoking compilation, annotate for coverage"] ["Simulator" (progn (setq verilog-tool 'verilog-simulator) (verilog-set-compile-command)) :style radio - :selected (equal verilog-tool `verilog-simulator) + :selected (equal verilog-tool 'verilog-simulator) :help "When invoking compilation, interpret Verilog source"] ["Compiler" (progn (setq verilog-tool 'verilog-compiler) (verilog-set-compile-command)) :style radio - :selected (equal verilog-tool `verilog-compiler) + :selected (equal verilog-tool 'verilog-compiler) :help "When invoking compilation, compile Verilog source"] ["Preprocessor" (progn (setq verilog-tool 'verilog-preprocessor) (verilog-set-compile-command)) :style radio - :selected (equal verilog-tool `verilog-preprocessor) + :selected (equal verilog-tool 'verilog-preprocessor) :help "When invoking compilation, preprocess Verilog source, see also `verilog-preprocess'"] ) ("Move" @@ -1731,29 +1752,29 @@ If set will become buffer local.") :enable-function (lambda () (not (verilog-in-comment-or-string-p)))) (verilog-define-abbrev verilog-mode-abbrev-table "class" "" 'verilog-sk-ovm-class) (verilog-define-abbrev verilog-mode-abbrev-table "always" "" 'verilog-sk-always) -(verilog-define-abbrev verilog-mode-abbrev-table "begin" nil `verilog-sk-begin) -(verilog-define-abbrev verilog-mode-abbrev-table "case" "" `verilog-sk-case) -(verilog-define-abbrev verilog-mode-abbrev-table "for" "" `verilog-sk-for) -(verilog-define-abbrev verilog-mode-abbrev-table "generate" "" `verilog-sk-generate) -(verilog-define-abbrev verilog-mode-abbrev-table "initial" "" `verilog-sk-initial) -(verilog-define-abbrev verilog-mode-abbrev-table "fork" "" `verilog-sk-fork) -(verilog-define-abbrev verilog-mode-abbrev-table "module" "" `verilog-sk-module) -(verilog-define-abbrev verilog-mode-abbrev-table "primitive" "" `verilog-sk-primitive) -(verilog-define-abbrev verilog-mode-abbrev-table "repeat" "" `verilog-sk-repeat) -(verilog-define-abbrev verilog-mode-abbrev-table "specify" "" `verilog-sk-specify) -(verilog-define-abbrev verilog-mode-abbrev-table "task" "" `verilog-sk-task) -(verilog-define-abbrev verilog-mode-abbrev-table "while" "" `verilog-sk-while) -(verilog-define-abbrev verilog-mode-abbrev-table "casex" "" `verilog-sk-casex) -(verilog-define-abbrev verilog-mode-abbrev-table "casez" "" `verilog-sk-casez) -(verilog-define-abbrev verilog-mode-abbrev-table "if" "" `verilog-sk-if) -(verilog-define-abbrev verilog-mode-abbrev-table "else if" "" `verilog-sk-else-if) -(verilog-define-abbrev verilog-mode-abbrev-table "assign" "" `verilog-sk-assign) -(verilog-define-abbrev verilog-mode-abbrev-table "function" "" `verilog-sk-function) -(verilog-define-abbrev verilog-mode-abbrev-table "input" "" `verilog-sk-input) -(verilog-define-abbrev verilog-mode-abbrev-table "output" "" `verilog-sk-output) -(verilog-define-abbrev verilog-mode-abbrev-table "inout" "" `verilog-sk-inout) -(verilog-define-abbrev verilog-mode-abbrev-table "wire" "" `verilog-sk-wire) -(verilog-define-abbrev verilog-mode-abbrev-table "reg" "" `verilog-sk-reg) +(verilog-define-abbrev verilog-mode-abbrev-table "begin" nil 'verilog-sk-begin) +(verilog-define-abbrev verilog-mode-abbrev-table "case" "" 'verilog-sk-case) +(verilog-define-abbrev verilog-mode-abbrev-table "for" "" 'verilog-sk-for) +(verilog-define-abbrev verilog-mode-abbrev-table "generate" "" 'verilog-sk-generate) +(verilog-define-abbrev verilog-mode-abbrev-table "initial" "" 'verilog-sk-initial) +(verilog-define-abbrev verilog-mode-abbrev-table "fork" "" 'verilog-sk-fork) +(verilog-define-abbrev verilog-mode-abbrev-table "module" "" 'verilog-sk-module) +(verilog-define-abbrev verilog-mode-abbrev-table "primitive" "" 'verilog-sk-primitive) +(verilog-define-abbrev verilog-mode-abbrev-table "repeat" "" 'verilog-sk-repeat) +(verilog-define-abbrev verilog-mode-abbrev-table "specify" "" 'verilog-sk-specify) +(verilog-define-abbrev verilog-mode-abbrev-table "task" "" 'verilog-sk-task) +(verilog-define-abbrev verilog-mode-abbrev-table "while" "" 'verilog-sk-while) +(verilog-define-abbrev verilog-mode-abbrev-table "casex" "" 'verilog-sk-casex) +(verilog-define-abbrev verilog-mode-abbrev-table "casez" "" 'verilog-sk-casez) +(verilog-define-abbrev verilog-mode-abbrev-table "if" "" 'verilog-sk-if) +(verilog-define-abbrev verilog-mode-abbrev-table "else if" "" 'verilog-sk-else-if) +(verilog-define-abbrev verilog-mode-abbrev-table "assign" "" 'verilog-sk-assign) +(verilog-define-abbrev verilog-mode-abbrev-table "function" "" 'verilog-sk-function) +(verilog-define-abbrev verilog-mode-abbrev-table "input" "" 'verilog-sk-input) +(verilog-define-abbrev verilog-mode-abbrev-table "output" "" 'verilog-sk-output) +(verilog-define-abbrev verilog-mode-abbrev-table "inout" "" 'verilog-sk-inout) +(verilog-define-abbrev verilog-mode-abbrev-table "wire" "" 'verilog-sk-wire) +(verilog-define-abbrev verilog-mode-abbrev-table "reg" "" 'verilog-sk-reg) ;; ;; Macros @@ -2047,7 +2068,7 @@ find the errors." "`resetall" "`timescale" "`unconnected_drive" "`undef" "`undefineall" ;; compiler directives not covered by IEEE 1800 "`case" "`default" "`endfor" "`endprotect" "`endswitch" "`endwhile" "`for" - "`format" "`if" "`let" "`protect" "`switch" "`timescale" "`time_scale" + "`format" "`if" "`let" "`protect" "`switch" "`time_scale" "`while" )) "List of Verilog compiler directives.") @@ -2138,14 +2159,7 @@ find the errors." ) nil ) ) ) (defconst verilog-vmm-statement-re - (eval-when-compile - (verilog-regexp-opt - '( - "`vmm_\\(data\\|env\\|scenario\\|subenv\\|xactor\\)_member_\\(scalar\\|string\\|enum\\|vmm_data\\|channel\\|xactor\\|subenv\\|user_defined\\)\\(_array\\)?" - ;; "`vmm_xactor_member_enum_array" - ;; "`vmm_xactor_member_scalar_array" - ;; "`vmm_xactor_member_scalar" - ) nil ))) + "`vmm_\\(data\\|env\\|scenario\\|subenv\\|xactor\\)_member_\\(scalar\\|string\\|enum\\|vmm_data\\|channel\\|xactor\\|subenv\\|user_defined\\)\\(_array\\)?") (defconst verilog-ovm-statement-re (eval-when-compile @@ -2405,12 +2419,10 @@ find the errors." (defconst verilog-assignment-operator-re (eval-when-compile (verilog-regexp-opt - `( + '( ;; blocking assignment_operator "=" "+=" "-=" "*=" "/=" "%=" "&=" "|=" "^=" "<<=" ">>=" "<<<=" ">>>=" - ;; non blocking assignment operator - "<=" - ;; comparison + ;; comparison (also nonblocking assignment "<=") "==" "!=" "===" "!==" "<=" ">=" "==?" "!=?" "<->" ;; event_trigger "->" "->>" @@ -2481,7 +2493,7 @@ find the errors." verilog-directive-re "\\)\\|\\(" (eval-when-compile (verilog-regexp-words - `( "begin" + '( "begin" "else" "end" "endcase" @@ -2534,7 +2546,7 @@ find the errors." (eval-when-compile (verilog-regexp-words - `("end" ; closes begin + '("end" ; closes begin "endcase" ; closes any of case, casex casez or randcase "join" "join_any" "join_none" ; closes fork "endclass" @@ -2604,7 +2616,7 @@ find the errors." (defconst verilog-beg-block-re (eval-when-compile (verilog-regexp-words - `("begin" + '("begin" "case" "casex" "casez" "randcase" "clocking" "generate" @@ -2680,7 +2692,7 @@ find the errors." (defconst verilog-nameable-item-re (eval-when-compile (verilog-regexp-words - `("begin" + '("begin" "fork" "join" "join_any" "join_none" "end" @@ -2707,12 +2719,12 @@ find the errors." (defconst verilog-declaration-opener (eval-when-compile (verilog-regexp-words - `("module" "begin" "task" "function")))) + '("module" "begin" "task" "function")))) (defconst verilog-declaration-prefix-re (eval-when-compile (verilog-regexp-words - `( + '( ;; port direction "inout" "input" "output" "ref" ;; changeableness @@ -2721,11 +2733,13 @@ find the errors." "localparam" "parameter" "var" ;; type creation "typedef" + ;; randomness + "rand" )))) (defconst verilog-declaration-core-re (eval-when-compile (verilog-regexp-words - `( + '( ;; port direction (by themselves) "inout" "input" "output" ;; integer_atom_type @@ -2754,38 +2768,38 @@ find the errors." (defconst verilog-delay-re "#\\s-*\\(\\([0-9_]+\\('s?[hdxbo][0-9a-fA-F_xz]+\\)?\\)\\|\\(([^()]*)\\)\\|\\(\\sw+\\)\\)") (defconst verilog-declaration-re-2-no-macro (concat "\\s-*" verilog-declaration-re - "\\s-*\\(\\(" verilog-optional-signed-range-re "\\)\\|\\(" verilog-delay-re "\\)" - "\\)?")) + "\\s-*\\(\\(" verilog-optional-signed-range-re "\\)\\|\\(" verilog-delay-re "\\)" + "\\)")) (defconst verilog-declaration-re-2-macro (concat "\\s-*" verilog-declaration-re - "\\s-*\\(\\(" verilog-optional-signed-range-re "\\)\\|\\(" verilog-delay-re "\\)" - "\\|\\(" verilog-macroexp-re "\\)" - "\\)?")) + "\\s-*\\(\\(" verilog-optional-signed-range-re "\\)\\|\\(" verilog-delay-re "\\)" + "\\|\\(" verilog-macroexp-re "\\)" + "\\)")) (defconst verilog-declaration-re-1-macro (concat "^" verilog-declaration-re-2-macro)) (defconst verilog-declaration-re-1-no-macro (concat "^" verilog-declaration-re-2-no-macro)) (defconst verilog-defun-re - (eval-when-compile (verilog-regexp-words `("macromodule" "module" "class" "program" "interface" "package" "primitive" "config")))) + (eval-when-compile (verilog-regexp-words '("macromodule" "module" "class" "program" "interface" "package" "primitive" "config")))) (defconst verilog-end-defun-re - (eval-when-compile (verilog-regexp-words `("endmodule" "endclass" "endprogram" "endinterface" "endpackage" "endprimitive" "endconfig")))) + (eval-when-compile (verilog-regexp-words '("endmodule" "endclass" "endprogram" "endinterface" "endpackage" "endprimitive" "endconfig")))) (defconst verilog-zero-indent-re (concat verilog-defun-re "\\|" verilog-end-defun-re)) (defconst verilog-inst-comment-re - (eval-when-compile (verilog-regexp-words `("Outputs" "Inouts" "Inputs" "Interfaces" "Interfaced")))) + (eval-when-compile (verilog-regexp-words '("Outputs" "Inouts" "Inputs" "Interfaces" "Interfaced")))) (defconst verilog-behavioral-block-beg-re - (eval-when-compile (verilog-regexp-words `("initial" "final" "always" "always_comb" "always_latch" "always_ff" - "function" "task")))) -(defconst verilog-coverpoint-re "\\w+\\s*:\\s*\\(coverpoint\\|cross\\constraint\\)" ) + (eval-when-compile (verilog-regexp-words '("initial" "final" "always" "always_comb" "always_latch" "always_ff" + "function" "task")))) +(defconst verilog-coverpoint-re "\\w+\\s-*:\\s-*\\(coverpoint\\|cross\\|constraint\\)") (defconst verilog-in-constraint-re ; keywords legal in constraint blocks starting a statement/block - (eval-when-compile (verilog-regexp-words `("if" "else" "solve" "foreach")))) + (eval-when-compile (verilog-regexp-words '("if" "else" "solve" "foreach")))) (defconst verilog-indent-re (eval-when-compile (verilog-regexp-words - `( + '( "{" "always" "always_latch" "always_ff" "always_comb" "begin" "end" @@ -2869,28 +2883,28 @@ find the errors." (defconst verilog-defun-level-not-generate-re (eval-when-compile (verilog-regexp-words - `( "module" "macromodule" "primitive" "class" "program" - "interface" "package" "config")))) + '( "module" "macromodule" "primitive" "class" "program" + "interface" "package" "config")))) (defconst verilog-defun-level-re (eval-when-compile (verilog-regexp-words (append - `( "module" "macromodule" "primitive" "class" "program" - "interface" "package" "config") - `( "initial" "final" "always" "always_comb" "always_ff" - "always_latch" "endtask" "endfunction" ))))) + '( "module" "macromodule" "primitive" "class" "program" + "interface" "package" "config") + '( "initial" "final" "always" "always_comb" "always_ff" + "always_latch" "endtask" "endfunction" ))))) (defconst verilog-defun-level-generate-only-re (eval-when-compile (verilog-regexp-words - `( "initial" "final" "always" "always_comb" "always_ff" - "always_latch" "endtask" "endfunction" )))) + '( "initial" "final" "always" "always_comb" "always_ff" + "always_latch" "endtask" "endfunction" )))) (defconst verilog-cpp-level-re (eval-when-compile (verilog-regexp-words - `( + '( "endmodule" "endprimitive" "endinterface" "endpackage" "endprogram" "endclass" )))) @@ -2899,7 +2913,7 @@ find the errors." "\\(\\<\\(import\\|export\\)\\>\\s-+\"DPI\\(-C\\)?\"\\s-+\\(\\<\\(context\\|pure\\)\\>\\s-+\\)?\\([A-Za-z_][A-Za-z0-9_]*\\s-*=\\s-*\\)?\\<\\(function\\|task\\)\\>\\)" )) -(defconst verilog-default-clocking-re "\\<default\\s-+clocking\\>") +(defconst verilog-default-clocking-re "\\<default\\s-+clocking\\s-+[A-Za-z_][A-Za-z0-9_]*\\s-*;") (defconst verilog-disable-fork-re "\\(disable\\|wait\\)\\s-+fork\\>") (defconst verilog-extended-case-re "\\(\\(unique0?\\s-+\\|priority\\s-+\\)?case[xz]?\\|randcase\\)") (defconst verilog-extended-complete-re @@ -2911,7 +2925,7 @@ find the errors." (defconst verilog-basic-complete-re (eval-when-compile (verilog-regexp-words - `( + '( "always" "assign" "always_latch" "always_ff" "always_comb" "constraint" "import" "initial" "final" "module" "macromodule" "repeat" "randcase" "while" "if" "for" "forever" "foreach" "else" "parameter" "do" "localparam" "assert" @@ -2940,7 +2954,7 @@ find the errors." ;; single words "\\(?:" (verilog-regexp-words - `("`__FILE__" + '("`__FILE__" "`__LINE__" "`celldefine" "`else" @@ -2965,9 +2979,10 @@ find the errors." "\\<\\(`pragma\\)\\>\\s-+.+$" "\\)\\|\\(?:" ;; `timescale time_unit / time_precision - "\\<\\(`timescale\\)\\>\\s-+10\\{0,2\\}\\s-*[munpf]?s\\s-*\\/\\s-*10\\{0,2\\}\\s-*[munpf]?s" + "\\<\\(`timescale\\)\\>\\s-+10\\{0,2\\}\\s-*[munpf]?s\\s-*/\\s-*10\\{0,2\\}\\s-*[munpf]?s" "\\)\\|\\(?:" - ;; `define and `if can span multiple lines if line ends in '\'. NOTE: `if is not IEEE 1800-2012 + ;; `define and `if can span multiple lines if line ends in '\'. + ;; NOTE: `if is not IEEE 1800-2012. ;; from http://www.emacswiki.org/emacs/MultilineRegexp (concat "\\<\\(`define\\|`if\\)\\>" ; directive "\\s-+" ; separator @@ -3099,7 +3114,7 @@ See also `verilog-font-lock-extra-types'.") (defvar verilog-font-lock-p1800-face 'verilog-font-lock-p1800-face - "Font to use for p1800 keywords.") + "Obsolete font to use for p1800 keywords.") (defface verilog-font-lock-p1800-face '((((class color) (background light)) @@ -3110,6 +3125,7 @@ See also `verilog-font-lock-extra-types'.") (t (:italic t))) "Font lock mode face used to highlight P1800 keywords." :group 'font-lock-highlighting-faces) +(make-obsolete-variable 'verilog-font-lock-p1800-face nil "27.1") (defvar verilog-font-lock-ams-face 'verilog-font-lock-ams-face @@ -3140,133 +3156,110 @@ See also `verilog-font-lock-extra-types'.") :group 'font-lock-highlighting-faces) (let* ((verilog-type-font-keywords - (eval-when-compile - (verilog-regexp-opt - '( - "and" "bit" "buf" "bufif0" "bufif1" "cmos" "defparam" - "event" "genvar" "inout" "input" "integer" "localparam" - "logic" "mailbox" "nand" "nmos" "nor" "not" "notif0" "notif1" "or" - "output" "parameter" "pmos" "pull0" "pull1" "pulldown" "pullup" - "rcmos" "real" "realtime" "reg" "rnmos" "rpmos" "rtran" - "rtranif0" "rtranif1" "semaphore" "signed" "struct" "supply" - "supply0" "supply1" "time" "tran" "tranif0" "tranif1" - "tri" "tri0" "tri1" "triand" "trior" "trireg" "typedef" - "uwire" "vectored" "wand" "wire" "wor" "xnor" "xor" - ) nil ))) + (eval-when-compile + (verilog-regexp-opt + '("and" "buf" "bufif0" "bufif1" "cmos" "defparam" "event" + "genvar" "highz0" "highz1" "inout" "input" "integer" + "localparam" "mailbox" "nand" "nmos" "nor" "not" "notif0" + "notif1" "or" "output" "parameter" "pmos" "pull0" "pull1" + "pulldown" "pullup" "rcmos" "real" "realtime" "reg" "rnmos" + "rpmos" "rtran" "rtranif0" "rtranif1" "semaphore" "signed" + "specparam" "strong0" "strong1" "supply" "supply0" "supply1" + "time" "tran" "tranif0" "tranif1" "tri" "tri0" "tri1" "triand" + "trior" "trireg" "unsigned" "uwire" "vectored" "wand" "weak0" + "weak1" "wire" "wor" "xnor" "xor" + ;; 1800-2005 + "bit" "byte" "chandle" "const" "enum" "int" "logic" "longint" + "packed" "ref" "shortint" "shortreal" "static" "string" + "struct" "type" "typedef" "union" "var" + ;; 1800-2009 + ;; 1800-2012 + "interconnect" "nettype" ) nil))) (verilog-pragma-keywords - (eval-when-compile - (verilog-regexp-opt - '("surefire" "auto" "synopsys" "rtl_synthesis" "verilint" "leda" "0in" - ) nil ))) - - (verilog-1800-2005-keywords - (eval-when-compile - (verilog-regexp-opt - '("alias" "assert" "assume" "automatic" "before" "bind" - "bins" "binsof" "break" "byte" "cell" "chandle" "class" - "clocking" "config" "const" "constraint" "context" "continue" - "cover" "covergroup" "coverpoint" "cross" "deassign" "design" - "dist" "do" "edge" "endclass" "endclocking" "endconfig" - "endgroup" "endprogram" "endproperty" "endsequence" "enum" - "expect" "export" "extends" "extern" "first_match" "foreach" - "forkjoin" "genvar" "highz0" "highz1" "ifnone" "ignore_bins" - "illegal_bins" "import" "incdir" "include" "inside" "instance" - "int" "intersect" "large" "liblist" "library" "local" "longint" - "matches" "medium" "modport" "new" "noshowcancelled" "null" - "packed" "program" "property" "protected" "pull0" "pull1" - "pulsestyle_onevent" "pulsestyle_ondetect" "pure" "rand" "randc" - "randcase" "randsequence" "ref" "release" "return" "scalared" - "sequence" "shortint" "shortreal" "showcancelled" "small" "solve" - "specparam" "static" "string" "strong0" "strong1" "struct" - "super" "tagged" "this" "throughout" "timeprecision" "timeunit" - "type" "union" "unsigned" "use" "var" "virtual" "void" - "wait_order" "weak0" "weak1" "wildcard" "with" "within" - ) nil ))) - - (verilog-1800-2009-keywords - (eval-when-compile - (verilog-regexp-opt - '("accept_on" "checker" "endchecker" "eventually" "global" - "implies" "let" "nexttime" "reject_on" "restrict" "s_always" - "s_eventually" "s_nexttime" "s_until" "s_until_with" "strong" - "sync_accept_on" "sync_reject_on" "unique0" "until" - "until_with" "untyped" "weak" ) nil ))) - - (verilog-1800-2012-keywords - (eval-when-compile - (verilog-regexp-opt - '("implements" "interconnect" "nettype" "soft" ) nil ))) + (eval-when-compile + (verilog-regexp-opt + '("surefire" "0in" "auto" "leda" "rtl_synthesis" "synopsys" + "verilint" ) nil))) (verilog-ams-keywords - (eval-when-compile - (verilog-regexp-opt - '("above" "abs" "absdelay" "acos" "acosh" "ac_stim" - "aliasparam" "analog" "analysis" "asin" "asinh" "atan" "atan2" "atanh" - "branch" "ceil" "connectmodule" "connectrules" "cos" "cosh" "ddt" - "ddx" "discipline" "driver_update" "enddiscipline" "endconnectrules" - "endnature" "endparamset" "exclude" "exp" "final_step" "flicker_noise" - "floor" "flow" "from" "ground" "hypot" "idt" "idtmod" "inf" - "initial_step" "laplace_nd" "laplace_np" "laplace_zd" "laplace_zp" - "last_crossing" "limexp" "ln" "log" "max" "min" "nature" - "net_resolution" "noise_table" "paramset" "potential" "pow" "sin" - "sinh" "slew" "sqrt" "tan" "tanh" "timer" "transition" "white_noise" - "wreal" "zi_nd" "zi_np" "zi_zd" ) nil ))) - - (verilog-font-keywords - (eval-when-compile - (verilog-regexp-opt - '( - "assign" "case" "casex" "casez" "randcase" "deassign" - "default" "disable" "else" "endcase" "endfunction" - "endgenerate" "endinterface" "endmodule" "endprimitive" - "endspecify" "endtable" "endtask" "final" "for" "force" "return" "break" - "continue" "forever" "fork" "function" "generate" "if" "iff" "initial" - "interface" "join" "join_any" "join_none" "macromodule" "module" "negedge" - "package" "endpackage" "always" "always_comb" "always_ff" - "always_latch" "posedge" "primitive" "priority" "release" - "repeat" "specify" "table" "task" "unique" "wait" "while" - "class" "program" "endclass" "endprogram" - ) nil ))) + (eval-when-compile + (verilog-regexp-opt + '("above" "abs" "absdelay" "abstol" "ac_stim" "access" "acos" + "acosh" "aliasparam" "analog" "analysis" "asin" "asinh" "atan" + "atan2" "atanh" "branch" "ceil" "connect" "connectmodule" + "connectrules" "continuous" "cos" "cosh" "ddt" "ddt_nature" + "ddx" "discipline" "discrete" "domain" "driver_update" + "endconnectrules" "enddiscipline" "endnature" "endparamset" + "exclude" "exp" "final_step" "flicker_noise" "floor" "flow" + "from" "ground" "hypot" "idt" "idt_nature" "idtmod" "inf" + "initial_step" "laplace_nd" "laplace_np" "laplace_zd" + "laplace_zp" "last_crossing" "limexp" "ln" "log" "max" + "merged" "min" "nature" "net_resolution" "noise_table" + "paramset" "potential" "pow" "resolveto" "sin" "sinh" "slew" + "split" "sqrt" "tan" "tanh" "timer" "transition" "units" + "white_noise" "wreal" "zi_nd" "zi_np" "zi_zd" "zi_zp" + ;; Excluded AMS keywords: "assert" "cross" "string" + ) nil))) + + (verilog-font-general-keywords + (eval-when-compile + (verilog-regexp-opt + '("always" "assign" "automatic" "case" "casex" "casez" "cell" + "config" "deassign" "default" "design" "disable" "edge" "else" + "endcase" "endconfig" "endfunction" "endgenerate" "endmodule" + "endprimitive" "endspecify" "endtable" "endtask" "for" "force" + "forever" "fork" "function" "generate" "if" "ifnone" "incdir" + "include" "initial" "instance" "join" "large" "liblist" + "library" "macromodule" "medium" "module" "negedge" + "noshowcancelled" "posedge" "primitive" "pulsestyle_ondetect" + "pulsestyle_onevent" "release" "repeat" "scalared" + "showcancelled" "small" "specify" "strength" "table" "task" + "use" "wait" "while" + ;; 1800-2005 + "alias" "always_comb" "always_ff" "always_latch" "assert" + "assume" "before" "bind" "bins" "binsof" "break" "class" + "clocking" "constraint" "context" "continue" "cover" + "covergroup" "coverpoint" "cross" "dist" "do" "endclass" + "endclocking" "endgroup" "endinterface" "endpackage" + "endprogram" "endproperty" "endsequence" "expect" "export" + "extends" "extern" "final" "first_match" "foreach" "forkjoin" + "iff" "ignore_bins" "illegal_bins" "import" "inside" + "interface" "intersect" "join_any" "join_none" "local" + "matches" "modport" "new" "null" "package" "priority" + "program" "property" "protected" "pure" "rand" "randc" + "randcase" "randsequence" "return" "sequence" "solve" "super" + "tagged" "this" "throughout" "timeprecision" "timeunit" + "unique" "virtual" "void" "wait_order" "wildcard" "with" + "within" + ;; 1800-2009 + "accept_on" "checker" "endchecker" "eventually" "global" + "implies" "let" "nexttime" "reject_on" "restrict" "s_always" + "s_eventually" "s_nexttime" "s_until" "s_until_with" "strong" + "sync_accept_on" "sync_reject_on" "unique0" "until" + "until_with" "untyped" "weak" + ;; 1800-2012 + "implements" "soft" ) nil))) (verilog-font-grouping-keywords - (eval-when-compile - (verilog-regexp-opt - '( "begin" "end" ) nil )))) + (eval-when-compile + (verilog-regexp-opt + '( "begin" "end" ) nil)))) (setq verilog-font-lock-keywords (list ;; Fontify all builtin keywords - (concat "\\<\\(" verilog-font-keywords "\\|" + (concat "\\<\\(" verilog-font-general-keywords "\\|" ;; And user/system tasks and functions "\\$[a-zA-Z][a-zA-Z0-9_\\$]*" "\\)\\>") ;; Fontify all types - (if verilog-highlight-grouping-keywords - (cons (concat "\\<\\(" verilog-font-grouping-keywords "\\)\\>") - 'verilog-font-lock-grouping-keywords-face) - (cons (concat "\\<\\(" verilog-font-grouping-keywords "\\)\\>") + (cons (concat "\\<\\(" verilog-font-grouping-keywords "\\)\\>") + (if verilog-highlight-grouping-keywords + 'verilog-font-lock-grouping-keywords-face 'font-lock-type-face)) (cons (concat "\\<\\(" verilog-type-font-keywords "\\)\\>") 'font-lock-type-face) - ;; Fontify IEEE-1800-2005 keywords appropriately - (if verilog-highlight-p1800-keywords - (cons (concat "\\<\\(" verilog-1800-2005-keywords "\\)\\>") - 'verilog-font-lock-p1800-face) - (cons (concat "\\<\\(" verilog-1800-2005-keywords "\\)\\>") - 'font-lock-type-face)) - ;; Fontify IEEE-1800-2009 keywords appropriately - (if verilog-highlight-p1800-keywords - (cons (concat "\\<\\(" verilog-1800-2009-keywords "\\)\\>") - 'verilog-font-lock-p1800-face) - (cons (concat "\\<\\(" verilog-1800-2009-keywords "\\)\\>") - 'font-lock-type-face)) - ;; Fontify IEEE-1800-2012 keywords appropriately - (if verilog-highlight-p1800-keywords - (cons (concat "\\<\\(" verilog-1800-2012-keywords "\\)\\>") - 'verilog-font-lock-p1800-face) - (cons (concat "\\<\\(" verilog-1800-2012-keywords "\\)\\>") - 'font-lock-type-face)) ;; Fontify Verilog-AMS keywords (cons (concat "\\<\\(" verilog-ams-keywords "\\)\\>") 'verilog-font-lock-ams-face))) @@ -3495,7 +3488,7 @@ either is ok to parse as a non-comment, or `verilog-insert' was used." (remove-text-properties (point-min) (point-max) '(face nil)) (while (not (eobp)) (cond ((get-text-property (point) 'v-cmts) - (put-text-property (point) (1+ (point)) `face 'underline) + (put-text-property (point) (1+ (point)) 'face 'underline) ;;(if dbg (setq dbg (concat dbg (format " v-cmts at %S\n" (point))))) (forward-char 1)) (t @@ -3963,13 +3956,15 @@ Key bindings specific to `verilog-mode-map' are: (setq hs-special-modes-alist (cons '(verilog-mode "\\<begin\\>" "\\<end\\>" nil verilog-forward-sexp-function) - hs-special-modes-alist)))) + hs-special-modes-alist)))) (add-hook 'completion-at-point-functions #'verilog-completion-at-point nil 'local) ;; Stuff for autos - (add-hook 'write-contents-hooks 'verilog-auto-save-check nil 'local) + (add-hook (if (boundp 'write-contents-hooks) 'write-contents-hooks + 'write-contents-functions) ; Emacs >= 22.1 + 'verilog-auto-save-check nil 'local) ;; verilog-mode-hook call added by define-derived-mode ) @@ -4165,6 +4160,7 @@ With optional ARG, remove existing end of line comments." To call this from the command line, see \\[verilog-batch-indent]." (interactive) (verilog-mode) + (verilog-auto-reeval-locals) (indent-region (point-min) (point-max) nil)) (defun verilog-insert-block () @@ -4986,21 +4982,21 @@ primitive or interface named NAME." (match-end 11) ; of verilog-end-block-ordered-re ;;(goto-char there) (let ((nest 0) - (reg "\\<\\(class\\)\\|\\(endclass\\)\\|\\(package\\|primitive\\|\\(macro\\)?module\\)\\>") + (reg "\\<\\(\\(class\\)\\|\\(endclass\\)\\|\\(package\\|primitive\\|\\(macro\\)?module\\)\\)\\>") string) (save-excursion (catch 'skip (while (verilog-re-search-backward reg nil 'move) (cond - ((match-end 3) ; endclass + ((match-end 4) ; endclass (ding 't) (setq string "unmatched endclass") (throw 'skip 1)) - ((match-end 2) ; endclass + ((match-end 3) ; endclass (setq nest (1+ nest))) - ((match-end 1) ; class + ((match-end 2) ; class (setq nest (1- nest)) (if (< nest 0) (progn @@ -5238,11 +5234,11 @@ Useful for creating tri's and other expanded fields." compile-command)) (lint-word1 (verilog-string-replace-matches "\\s .*$" "" nil nil verilog-linter))) - (cond ((equal compile-word1 "surelint") `surelint) - ((equal compile-word1 "verilint") `verilint) - ((equal lint-word1 "surelint") `surelint) - ((equal lint-word1 "verilint") `verilint) - (t `surelint)))) ; back compatibility + (cond ((equal compile-word1 "surelint") 'surelint) + ((equal compile-word1 "verilint") 'verilint) + ((equal lint-word1 "surelint") 'surelint) + ((equal lint-word1 "verilint") 'verilint) + (t 'surelint)))) ; back compatibility (defun verilog-lint-off () "Convert a Verilog linter warning line into a disable statement. @@ -5256,9 +5252,9 @@ variables is used to determine which product is being used. See \\[verilog-surelint-off] and \\[verilog-verilint-off]." (interactive) (let ((linter (verilog-linter-name))) - (cond ((equal linter `surelint) + (cond ((equal linter 'surelint) (verilog-surelint-off)) - ((equal linter `verilint) + ((equal linter 'verilint) (verilog-verilint-off)) (t (error "Linter name not set"))))) @@ -5362,7 +5358,7 @@ FILENAME to find directory to run in, or defaults to `buffer-file-name'." (interactive (list (let ((default (verilog-expand-command verilog-preprocessor))) - (set (make-local-variable `verilog-preprocessor) + (set (make-local-variable 'verilog-preprocessor) (read-from-minibuffer "Run Preprocessor (like this): " default nil nil 'verilog-preprocess-history default))))) @@ -5408,6 +5404,9 @@ This lets programs calling batch mode to easily extract error messages." (error "%%Error: %s%s" (error-message-string err) (if (featurep 'xemacs) "\n" "")))))) ; XEmacs forgets to add a newline +;; Eliminate compile warning +(defvar verilog-batch-orig-buffer-string) + (defun verilog-batch-execute-func (funref &optional no-save) "Internal processing of a batch command. Runs FUNREF on all command arguments. @@ -5429,26 +5428,31 @@ Save the result unless optional NO-SAVE is t." ;; Remember buffer list, so don't later pickup any verilog-getopt files (let ((orig-buffer-list (buffer-list))) (mapc (lambda (buf) - (when (buffer-file-name buf) - (with-current-buffer buf - (verilog-mode) - (verilog-auto-reeval-locals) - (verilog-getopt-flags)))) - orig-buffer-list) + (when (buffer-file-name buf) + (with-current-buffer buf + (set (make-local-variable 'verilog-batch-orig-buffer-string) + (buffer-string)) + (put 'verilog-batch-orig-buffer-string 'permanent-local t) + (verilog-mode) + (verilog-auto-reeval-locals) + (verilog-getopt-flags)))) + orig-buffer-list) ;; Process the files - (mapcar (lambda (buf) - (when (buffer-file-name buf) - (save-excursion - (if (not (file-exists-p (buffer-file-name buf))) - (error - "File not found: %s" (buffer-file-name buf))) - (message "Processing %s" (buffer-file-name buf)) - (set-buffer buf) - (funcall funref) - (when (and (not no-save) - (buffer-modified-p)) ; Avoid "no changes to be saved" - (save-buffer))))) - orig-buffer-list)))) + (mapc (lambda (buf) + (when (buffer-file-name buf) + (save-excursion + (if (not (file-exists-p (buffer-file-name buf))) + (error + "File not found: %s" (buffer-file-name buf))) + (message "Processing %s" (buffer-file-name buf)) + (set-buffer buf) + (funcall funref) + (verilog-star-cleanup) + (when (and (not no-save) + (buffer-modified-p) + (not (equal verilog-batch-orig-buffer-string (buffer-string)))) + (save-buffer))))) + orig-buffer-list)))) (defun verilog-batch-auto () "For use with --batch, perform automatic expansions as a stand-alone tool. @@ -5458,7 +5462,7 @@ For proper results, multiple filenames need to be passed on the command line in bottom-up order." (unless noninteractive (error "Use verilog-batch-auto only with --batch")) ; Otherwise we'd mess up buffer modes - (verilog-batch-execute-func `verilog-auto)) + (verilog-batch-execute-func 'verilog-auto)) (defun verilog-batch-delete-auto () "For use with --batch, perform automatic deletion as a stand-alone tool. @@ -5466,7 +5470,7 @@ This sets up the appropriate Verilog mode environment, deletes automatics with \\[verilog-delete-auto] on all command-line files, and saves the buffers." (unless noninteractive (error "Use verilog-batch-delete-auto only with --batch")) ; Otherwise we'd mess up buffer modes - (verilog-batch-execute-func `verilog-delete-auto)) + (verilog-batch-execute-func 'verilog-delete-auto)) (defun verilog-batch-delete-trailing-whitespace () "For use with --batch, perform whitespace deletion as a stand-alone tool. @@ -5475,7 +5479,7 @@ whitespace with \\[verilog-delete-trailing-whitespace] on all command-line files, and saves the buffers." (unless noninteractive (error "Use verilog-batch-delete-trailing-whitespace only with --batch")) ; Otherwise we'd mess up buffer modes - (verilog-batch-execute-func `verilog-delete-trailing-whitespace)) + (verilog-batch-execute-func 'verilog-delete-trailing-whitespace)) (defun verilog-batch-diff-auto () "For use with --batch, perform automatic differences as a stand-alone tool. @@ -5485,7 +5489,7 @@ if any differences are observed. This is appropriate for adding to regressions to insure automatics are always properly maintained." (unless noninteractive (error "Use verilog-batch-diff-auto only with --batch")) ; Otherwise we'd mess up buffer modes - (verilog-batch-execute-func `verilog-diff-auto t)) + (verilog-batch-execute-func 'verilog-diff-auto t)) (defun verilog-batch-inject-auto () "For use with --batch, perform automatic injection as a stand-alone tool. @@ -5495,7 +5499,7 @@ For proper results, multiple filenames need to be passed on the command line in bottom-up order." (unless noninteractive (error "Use verilog-batch-inject-auto only with --batch")) ; Otherwise we'd mess up buffer modes - (verilog-batch-execute-func `verilog-inject-auto)) + (verilog-batch-execute-func 'verilog-inject-auto)) (defun verilog-batch-indent () "For use with --batch, reindent an entire file as a stand-alone tool. @@ -5503,7 +5507,7 @@ This sets up the appropriate Verilog mode environment, calls \\[verilog-indent-buffer] on all command-line files, and saves the buffers." (unless noninteractive (error "Use verilog-batch-indent only with --batch")) ; Otherwise we'd mess up buffer modes - (verilog-batch-execute-func `verilog-indent-buffer)) + (verilog-batch-execute-func 'verilog-indent-buffer)) ;;; Indentation: ;; @@ -6409,7 +6413,7 @@ Return >0 for nested struct." (equal (char-before) ?\;) (equal (char-before) ?\})) ;; skip what looks like bus repetition operator {#{ - (not (string-match "^{\\s-*[0-9]+\\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) @@ -6427,9 +6431,11 @@ Return >0 for nested struct." ;; check next word token (if (looking-at "\\<\\w+\\>\\|\\s-*(\\s-*\\S-+") (progn (verilog-beg-of-statement) - (if (looking-at (concat "\\<\\(constraint\\|" + (if (and + (not (string-match verilog-named-block-re (buffer-substring pt (point)))) ;; Abort if 'begin' keyword is found + (looking-at (concat "\\<\\(constraint\\|" "\\(?:\\w+\\s-*:\\s-*\\)?\\(coverpoint\\|cross\\)" - "\\|with\\)\\>\\|" verilog-in-constraint-re)) + "\\|with\\)\\>\\|" verilog-in-constraint-re))) (setq pass 1))))) (if (eq pass 0) (progn (goto-char pt) nil) 1))) @@ -6559,9 +6565,9 @@ Return >0 for nested struct." (t nil)))) (skip-chars-forward " \t\n\f") (while - (cond - ((looking-at "\\/\\*") - (progn + (cond + ((looking-at "/\\*") + (progn (setq h (point)) (goto-char (match-end 0)) (if (search-forward "*/" nil t) @@ -7340,7 +7346,7 @@ will be completed at runtime and should not be added to this list.") ("xor" "output")) "Map of direction for each positional argument to each gate primitive.") -(defvar verilog-gate-keywords (mapcar `car verilog-gate-ios) +(defvar verilog-gate-keywords (mapcar #'car verilog-gate-ios) "Keywords for gate primitives.") (defun verilog-string-diff (str1 str2) @@ -8173,7 +8179,7 @@ Duplicate signals are also removed. For example A[2] and A[1] become A[2:1]." sv-modport bus) ;; Shove signals so duplicated signals will be adjacent - (setq in-list (sort in-list `verilog-signals-sort-compare)) + (setq in-list (sort in-list #'verilog-signals-sort-compare)) (while in-list (setq sig (car in-list)) ;; No current signal; form from existing details @@ -8194,11 +8200,11 @@ Duplicate signals are also removed. For example A[2] and A[1] become A[2:1]." (setq bus (verilog-sig-bits sig)) (setq bus (and bus (verilog-simplify-range-expression bus))) (cond ((and bus - (or (and (string-match "\\[\\([0-9]+\\):\\([0-9]+\\)\\]" bus) + (or (and (string-match "^\\[\\([0-9]+\\):\\([0-9]+\\)\\]$" bus) (setq highbit (string-to-number (match-string 1 bus)) lowbit (string-to-number (match-string 2 bus)))) - (and (string-match "\\[\\([0-9]+\\)\\]" bus) + (and (string-match "^\\[\\([0-9]+\\)\\]$" bus) (setq highbit (string-to-number (match-string 1 bus)) lowbit highbit)))) ;; Combine bits in bus @@ -8359,13 +8365,13 @@ Use optional HEADER and PREFIX." (when (looking-at ")") (verilog-backward-open-paren) (verilog-re-search-backward-quick "\\b[a-zA-Z0-9`_$]" nil nil)) - (skip-chars-backward "a-zA-Z0-9'_$") + (skip-chars-backward "a-zA-Z0-9`_$") ;; #1 is legal syntax for gate primitives (when (save-excursion - (verilog-backward-syntactic-ws-quick) - (eq ?# (char-before))) + (verilog-backward-syntactic-ws-quick) + (eq ?# (char-before))) (verilog-re-search-backward-quick "\\b[a-zA-Z0-9`_$]" nil nil) - (skip-chars-backward "a-zA-Z0-9'_$")) + (skip-chars-backward "a-zA-Z0-9`_$")) (looking-at "[a-zA-Z0-9`_$]+") ;; Important: don't use match string, this must work with Emacs 19 font-lock on (buffer-substring-no-properties (match-beginning 0) (match-end 0)) @@ -8432,7 +8438,7 @@ Optional NUM-PARAM and MAX-PARAM check for a specific number of parameters." ;; /*AUTOPUNT("parameter", "parameter")*/ (backward-sexp 1) (while (looking-at "(?\\s *\"\\([^\"]*\\)\"\\s *,?") - (setq olist (cons (match-string 1) olist)) + (setq olist (cons (match-string-no-properties 1) olist)) (goto-char (match-end 0)))) (or (eq nil num-param) (<= num-param (length olist)) @@ -8464,12 +8470,12 @@ Return an array of [outputs inouts inputs wire reg assign const]." (cond ((looking-at "//") (when (looking-at "[^\n]*\\(auto\\|synopsys\\)\\s +enum\\s +\\([a-zA-Z0-9_]+\\)") - (setq enum (match-string 2))) + (setq enum (match-string-no-properties 2))) (search-forward "\n")) ((looking-at "/\\*") (forward-char 2) (when (looking-at "[^\n]*\\(auto\\|synopsys\\)\\s +enum\\s +\\([a-zA-Z0-9_]+\\)") - (setq enum (match-string 2))) + (setq enum (match-string-no-properties 2))) (or (search-forward "*/") (error "%s: Unmatched /* */, at char %d" (verilog-point-text) (point)))) ((looking-at "(\\*") @@ -8516,33 +8522,36 @@ Return an array of [outputs inouts inputs wire reg assign const]." (forward-char 1) (when (< paren sig-paren) (setq expect-signal nil rvalue nil))) ; ) that ends variables inside v2k arg list - ((looking-at "\\s-*\\(\\[[^]]+\\]\\)") - (goto-char (match-end 0)) + ((looking-at "\\[") + (setq keywd (buffer-substring-no-properties + (point) + (progn (forward-sexp 1) (point)))) (cond (newsig ; Memory, not just width. Patch last signal added's memory (nth 3) (setcar (cdr (cdr (cdr newsig))) (if (verilog-sig-memory newsig) - (concat (verilog-sig-memory newsig) (match-string 1)) - (match-string-no-properties 1)))) + (concat (verilog-sig-memory newsig) + keywd) + keywd))) (vec ; Multidimensional (setq multidim (cons vec multidim)) (setq vec (verilog-string-replace-matches - "\\s-+" "" nil nil (match-string-no-properties 1)))) + "\\s-+" "" nil nil keywd))) (t ; Bit width (setq vec (verilog-string-replace-matches - "\\s-+" "" nil nil (match-string-no-properties 1)))))) + "\\s-+" "" nil nil keywd))))) ;; Normal or escaped identifier -- note we remember the \ if escaped ((looking-at "\\s-*\\([a-zA-Z0-9`_$]+\\|\\\\[^ \t\n\f]+\\)") (goto-char (match-end 0)) (setq last-keywd keywd keywd (match-string-no-properties 1)) - (when (string-match "^\\\\" (match-string 1)) + (when (string-match "^\\\\" (match-string-no-properties 1)) (setq keywd (concat keywd " "))) ; Escaped ID needs space at end ;; Add any :: package names to same identifier ;; '*' here is for "import x::*" (while (looking-at "\\s-*::\\s-*\\(\\*\\|[a-zA-Z0-9`_$]+\\|\\\\[^ \t\n\f]+\\)") (goto-char (match-end 0)) - (setq keywd (concat keywd "::" (match-string 1))) - (when (string-match "^\\\\" (match-string 1)) + (setq keywd (concat keywd "::" (match-string-no-properties 1))) + (when (string-match "^\\\\" (match-string-no-properties 1)) (setq keywd (concat keywd " ")))) ; Escaped ID needs space at end (cond ((equal keywd "input") (setq vec nil enum nil rvalue nil newsig nil signed nil @@ -8627,10 +8636,12 @@ Return an array of [outputs inouts inputs wire reg assign const]." ((and v2kargs-ok (eq paren 1) (not rvalue) - (looking-at "\\s-*\\(\\.\\(\\s-*[a-zA-Z`_$][a-zA-Z0-9`_$]*\\)\\|\\)\\s-*[a-zA-Z`_$][a-zA-Z0-9`_$]*")) + (or (looking-at "\\s-*#") + (looking-at "\\s-*\\(\\.\\(\\s-*[a-zA-Z`_$][a-zA-Z0-9`_$]*\\)\\|\\)\\s-*[a-zA-Z`_$][a-zA-Z0-9`_$]*"))) (when (match-end 2) (goto-char (match-end 2))) (setq vec nil enum nil rvalue nil signed nil - typedefed keywd multidim nil ptype nil modport (match-string 2) + typedefed keywd multidim nil ptype nil + modport (match-string-no-properties 2) newsig nil sig-paren paren expect-signal 'sigs-intf io t )) ;; Ignore dotted LHS assignments: "assign foo.bar = z;" @@ -8679,7 +8690,8 @@ Return an array of [outputs inouts inputs wire reg assign const]." ((and expect-signal (not rvalue) (eq functask 0) - (not (member keywd verilog-keywords))) + (not (member keywd verilog-keywords)) + (or (not io) (eq paren sig-paren))) ;; Add new signal to expect-signal's variable ;;(if dbg (setq dbg (concat dbg (format "Pt %s New sig %s'\n" (point) keywd)))) (setq newsig (verilog-sig-new keywd vec nil nil enum signed typedefed multidim modport)) @@ -8744,7 +8756,7 @@ Return an array of [outputs inouts inputs wire reg assign const]." (setq port (verilog-symbol-detick-denumber port)) (setq sig (if dotname port (verilog-symbol-detick-denumber sig))) (if vec (setq vec (verilog-symbol-detick-denumber vec))) - (if multidim (setq multidim (mapcar `verilog-symbol-detick-denumber multidim))) + (if multidim (setq multidim (mapcar #'verilog-symbol-detick-denumber multidim))) (if mem (setq mem (verilog-symbol-detick-denumber mem))) (unless (or (not sig) (equal sig "")) ; Ignore .foo(1'b1) assignments @@ -8852,8 +8864,9 @@ Return an array of [outputs inouts inputs wire reg assign const]." ;;(message "vrsde-s: `%s'" (match-string 1 expr)) (setq sig (verilog-string-remove-spaces (match-string 1 expr)) expr (substring expr (match-end 0))))) - ;; Find [vector] or [multi][multi][multi][vector] - (while (string-match "^\\s-*\\(\\[[^]]+\\]\\)" expr) + ;; Find [vector] or [multi][multi][multi][vector] or [vector[VEC2]] + ;; Unfortunately Emacs regexps don't allow matching bracket searches, so just 2 deep. + (while (string-match "^\\s-*\\(\\[\\([^][]+\\|\\[[^][]+\\]\\)*\\]\\)" expr) ;;(message "vrsde-v: `%s'" (match-string 1 expr)) (when vec (setq multidim (cons vec multidim))) (setq vec (match-string 1 expr) @@ -8911,7 +8924,7 @@ Inserts the list of signals found, using submodi to look up each port." (verilog-string-remove-spaces (match-string-no-properties 1)) ; sig nil nil nil)) ; vec multidim mem ;; - ((looking-at "\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\s-*\\(\\[[^]]+\\]\\)\\s-*)") + ((looking-at "\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\s-*\\(\\[[^][]+\\]\\)\\s-*)") (verilog-read-sub-decls-sig submoddecls par-values comment port (verilog-string-remove-spaces (match-string-no-properties 1)) ; sig @@ -8927,7 +8940,7 @@ Inserts the list of signals found, using submodi to look up each port." (point)))))))) ; expr ;; (forward-line 1))))) -;;(verilog-read-sub-decls-line (verilog-subdecls-new nil nil nil nil nil) nil "Cmt") +;;(verilog-read-sub-decls-line (verilog-decls-new nil nil nil nil nil nil nil nil nil) nil "Cmt") (defun verilog-read-sub-decls-gate (submoddecls par-values comment submod end-inst-point) "For `verilog-read-sub-decls', read lines of UDP gate decl until none match. @@ -8946,15 +8959,15 @@ Inserts the list of signals found." (forward-char 1) (or (search-forward "*)") (error "%s: Unmatched (* *), at char %d" (verilog-point-text) (point)))) - ;; On pins, parse and advance to next pin - ;; Looking at pin, but *not* an // Output comment, or ) to end the inst - ((looking-at "\\s-*[a-zA-Z0-9`_$({}\\\\][^,]*") - (goto-char (match-end 0)) + ;; On pins, parse and advance to next pin + ;; Looking at pin, but *not* an // Output comment, or ) to end the inst + ((looking-at "\\s-*[a-zA-Z0-9`_$({}\\][^,]*") + (goto-char (match-end 0)) (setq verilog-read-sub-decls-gate-ios (or (car iolist) "input") iolist (cdr iolist)) (verilog-read-sub-decls-expr submoddecls par-values comment "primitive_port" - (match-string 0))) + (match-string-no-properties 0))) (t (forward-char 1) (skip-syntax-forward " "))))))) @@ -8972,11 +8985,11 @@ component library to determine connectivity of the design. One work around for this problem is to manually create // Inputs and // Outputs comments above subcell signals, for example: - module ModuleName ( - // Outputs - .out (out), - // Inputs - .in (in));" + submod SubModuleName ( + // Outputs + .out (out), + // Inputs + .in (in));" (save-excursion (let ((end-mod-point (verilog-get-end-of-defun)) st-point end-inst-point par-values @@ -8998,7 +9011,7 @@ Outputs comments above subcell signals, for example: submodi submoddecls) (cond (subprim - (setq submodi `primitive + (setq submodi 'primitive submoddecls (verilog-decls-new nil nil nil nil nil nil nil nil nil) comment (concat inst " of " submod)) (verilog-backward-open-paren) @@ -9051,7 +9064,7 @@ For example if declare A A (.B(SIG)) then B will be included in the list." pins pin) (verilog-backward-open-paren) (while (re-search-forward "\\.\\([^(,) \t\n\f]*\\)\\s-*" end-mod-point t) - (setq pin (match-string 1)) + (setq pin (match-string-no-properties 1)) (unless (verilog-inside-comment-or-string-p) (setq pins (cons (list pin) pins)) (when (looking-at "(") @@ -9065,7 +9078,7 @@ For example if declare A A (.B(SIG)) then B will be included in the list." pins pin) (verilog-backward-open-paren) (while (re-search-forward "\\([a-zA-Z0-9$_.%`]+\\)" end-mod-point t) - (setq pin (match-string 1)) + (setq pin (match-string-no-properties 1)) (unless (verilog-inside-comment-or-string-p) (setq pins (cons (list pin) pins)))) (vector pins)))) @@ -9086,7 +9099,7 @@ For example if declare A A (.B(SIG)) then B will be included in the list." (backward-char 1) (point))) (while (re-search-forward "\\s-*\\([\"a-zA-Z0-9$_.%`]+\\)\\s-*,*" tpl-end-pt t) - (setq sig-list (cons (list (match-string 1) nil nil) sig-list)))) + (setq sig-list (cons (list (match-string-no-properties 1) nil nil) sig-list)))) sig-list))) (defvar verilog-cache-has-lisp nil "True if any AUTO_LISP in buffer.") @@ -9118,7 +9131,7 @@ Must call `verilog-read-auto-lisp-present' before this function." "Recursive routine for parentheses/bracket matching. EXIT-KEYWD is expression to stop at, nil if top level. RVALUE is true if at right hand side of equal. -IGNORE-NEXT is true to ignore next token, fake from inside case statement." +TEMP-NEXT is true to ignore next token, fake from inside case statement." (let* ((semi-rvalue (equal "endcase" exit-keywd)) ; true if after a ; we are looking for rvalue keywd last-keywd sig-tolk sig-last-tolk gotend got-sig got-list end-else-check ignore-next) @@ -9157,7 +9170,9 @@ IGNORE-NEXT is true to ignore next token, fake from inside case statement." ;;(if dbg (setq dbg (concat dbg (format "\tif-check-else-other %s\n" keywd)))) (setq gotend t)) ;; Final statement? - ((and exit-keywd (and (equal keywd exit-keywd) + ((and exit-keywd (and (or (equal keywd exit-keywd) + (and (equal exit-keywd "'}") + (equal keywd "}"))) (not (looking-at "::")))) (setq gotend t) (forward-char (length keywd))) @@ -9170,9 +9185,13 @@ IGNORE-NEXT is true to ignore next token, fake from inside case statement." (setq end-else-check t)) (forward-char 1)) ((equal keywd "'") - (if (looking-at "'[sS]?[hdxboHDXBO]?[ \t]*[0-9a-fA-F_xzXZ?]+") - (goto-char (match-end 0)) - (forward-char 1))) + (cond ((looking-at "'[sS]?[hdxboHDXBO]?[ \t]*[0-9a-fA-F_xzXZ?]+") + (goto-char (match-end 0))) + ((looking-at "'{") + (forward-char 2) + (verilog-read-always-signals-recurse "'}" t nil)) + (t + (forward-char 1)))) ((equal keywd ":") ; Case statement, begin/end label, x?y:z (cond ((looking-at "::") (forward-char 1)) ; Another forward-char below @@ -9182,6 +9201,8 @@ IGNORE-NEXT is true to ignore next token, fake from inside case statement." ) ; NOP ((equal "]" exit-keywd) ; [x:y] rvalue ) ; NOP + ((equal "'}" exit-keywd) ; Pattern assignment + ) ; NOP (got-sig ; label: statement (setq ignore-next nil rvalue semi-rvalue got-sig nil)) ((not rvalue) ; begin label @@ -9292,9 +9313,8 @@ IGNORE-NEXT is true to ignore next token, fake from inside case statement." (forward-line 1)) (beginning-of-line) (if (looking-at "^\\s-*\\([a-zA-Z0-9`_$]+\\)\\s-+\\([a-zA-Z0-9`_$]+\\)\\s-*(") - ;;(if (looking-at "^\\(.+\\)$") - (let ((module (match-string 1)) - (instant (match-string 2))) + (let ((module (match-string-no-properties 1)) + (instant (match-string-no-properties 2))) (if (not (member module verilog-keywords)) (setq instants-list (cons (list module instant) instants-list))))) (forward-line 1))) @@ -9314,7 +9334,7 @@ Returns REGEXP and list of ( (signal_name connection_name)... )." ;; We reserve @"..." for future lisp expressions that evaluate ;; once-per-AUTOINST (when (looking-at "\\s-*\"\\([^\"]*\\)\"") - (setq tpl-regexp (match-string 1)) + (setq tpl-regexp (match-string-no-properties 1)) (goto-char (match-end 0))) (search-forward "(") ;; Parse lines in the template @@ -9343,10 +9363,10 @@ Returns REGEXP and list of ( (signal_name connection_name)... )." templateno lineno) tpl-sig-list)) (goto-char (match-end 0))) - ;; Regexp form?? - ((looking-at - ;; Regexp bug in XEmacs disallows ][ inside [], and wants + last - "\\s-*\\.\\(\\([a-zA-Z0-9`_$+@^.*?|---]\\|[][]\\|\\\\[()|]\\)+\\)\\s-*(\\(.*\\))\\s-*\\(,\\|)\\s-*;\\)") + ;; Regexp form?? + ((looking-at + ;; Regexp bug in XEmacs disallows ][ inside [], and wants + last + "\\s-*\\.\\(\\([-a-zA-Z0-9`_$+@^.*?|]\\|[][]\\|\\\\[()|0-9]\\)+\\)\\s-*(\\(.*\\))\\s-*\\(,\\|)\\s-*;\\)") (setq rep (match-string-no-properties 3)) (goto-char (match-end 0)) (setq tpl-wild-list @@ -9511,8 +9531,8 @@ warning message, you need to add to your init file: (when recurse (goto-char (point-min)) (while (re-search-forward "^\\s-*`include\\s-+\\([^ \t\n\f]+\\)" nil t) - (let ((inc (verilog-string-replace-matches - "\"" "" nil nil (match-string-no-properties 1)))) + (let ((inc (verilog-substitute-include-name + (match-string-no-properties 1)))) (unless (verilog-inside-comment-or-string-p) (verilog-read-defines inc recurse t))))) ;; Read `defines @@ -9584,7 +9604,8 @@ foo.v (an include file): (verilog-getopt-flags) (goto-char (point-min)) (while (re-search-forward "^\\s-*`include\\s-+\\([^ \t\n\f]+\\)" nil t) - (let ((inc (verilog-string-replace-matches "\"" "" nil nil (match-string 1)))) + (let ((inc (verilog-substitute-include-name + (match-string-no-properties 1)))) (verilog-read-defines inc nil t))))) (defun verilog-read-signals (&optional start end) @@ -9653,7 +9674,7 @@ Use DEFAULT-DIR to anchor paths if non-nil." ((string-match "^\\+libext\\+\\(.*\\)" arg) (setq arg (match-string 1 arg)) (while (string-match "\\([^+]+\\)\\+?\\(.*\\)" arg) - (verilog-add-list-unique `verilog-library-extensions + (verilog-add-list-unique 'verilog-library-extensions (match-string 1 arg)) (setq arg (match-string 2 arg)))) ;; @@ -9665,7 +9686,7 @@ Use DEFAULT-DIR to anchor paths if non-nil." ;; ((or (string-match "^\\+incdir\\+\\(.*\\)" arg) ; +incdir+dir (string-match "^-I\\(.*\\)" arg)) ; -Idir - (verilog-add-list-unique `verilog-library-directories + (verilog-add-list-unique 'verilog-library-directories (substitute-in-file-name (match-string 1 arg)))) ;; Ignore ((equal "+librescan" arg)) @@ -9680,15 +9701,15 @@ Use DEFAULT-DIR to anchor paths if non-nil." (verilog-getopt-file (verilog-substitute-file-name-path arg default-dir) nil)) ((equal next-param "-v") (setq next-param nil) - (verilog-add-list-unique `verilog-library-files + (verilog-add-list-unique 'verilog-library-files (verilog-substitute-file-name-path arg default-dir))) ((equal next-param "-y") (setq next-param nil) - (verilog-add-list-unique `verilog-library-directories + (verilog-add-list-unique 'verilog-library-directories (verilog-substitute-file-name-path arg default-dir))) ;; Filename ((string-match "^[^-+]" arg) - (verilog-add-list-unique `verilog-library-files + (verilog-add-list-unique 'verilog-library-files (verilog-substitute-file-name-path arg default-dir))) ;; Default - ignore; no warning )))) @@ -9717,7 +9738,7 @@ Use DEFAULT-DIR to anchor paths if non-nil." (defun verilog-getopt-flags () "Convert `verilog-library-flags' into standard library variables." ;; If the flags are local, then all the outputs should be local also - (when (local-variable-p `verilog-library-flags (current-buffer)) + (when (local-variable-p 'verilog-library-flags (current-buffer)) (mapc 'make-local-variable '(verilog-library-extensions verilog-library-directories verilog-library-files @@ -9736,6 +9757,12 @@ Use DEFAULT-DIR to anchor paths if non-nil." (expand-file-name (substitute-in-file-name filename) default-dir) (substitute-in-file-name filename))) +(defun verilog-substitute-include-name (filename) + "Return FILENAME for include with define substituted." + (setq filename (verilog-string-replace-matches "\"" "" nil nil filename)) + (verilog-string-replace-matches "\"" "" nil nil + (verilog-symbol-detick filename t))) + (defun verilog-add-list-unique (varref object) "Append to VARREF list the given OBJECT, unless it is already a member of the variable's list." @@ -9747,10 +9774,10 @@ unless it is already a member of the variable's list." (defun verilog-current-flags () "Convert `verilog-library-flags' and similar variables to command line. Used for __FLAGS__ in `verilog-expand-command'." - (let ((cmd (mapconcat `concat verilog-library-flags " "))) + (let ((cmd (mapconcat #'concat verilog-library-flags " "))) (when (equal cmd "") (setq cmd (concat - "+libext+" (mapconcat `concat verilog-library-extensions "+") + "+libext+" (mapconcat #'concat verilog-library-extensions "+") (mapconcat (lambda (i) (concat " -y " i " +incdir+" i)) verilog-library-directories "") (mapconcat (lambda (i) (concat " -v " i)) @@ -9889,7 +9916,8 @@ If undefined, and WING-IT, return just SYMBOL without the tick, else nil." (defun verilog-symbol-detick-text (text) "Return TEXT without any known defines. -If the variable vh-{symbol} is defined, substitute that value." +If the variable vh-{symbol} is defined, substitute that value. +This function is intended for use in AUTO_TEMPLATE Lisp expressions." (let ((ok t) symbol val) (while (and ok (string-match "`\\([a-zA-Z0-9_]+\\)" text)) (setq symbol (match-string 1 text)) @@ -9975,7 +10003,7 @@ variables to build the path. With optional CHECK-EXT also check (while chkdirs (setq chkdir (expand-file-name (car chkdirs) (file-name-directory current)) - chkexts (if check-ext verilog-library-extensions `(""))) + chkexts (if check-ext verilog-library-extensions '(""))) (while chkexts (setq fn (expand-file-name (concat filename (car chkexts)) chkdir)) @@ -10134,7 +10162,7 @@ Return modi if successful, else print message unless IGNORE-ERROR is true." (set-buffer (if (bufferp (verilog-modi-file-or-buffer modi)) (verilog-modi-file-or-buffer modi) (find-file-noselect (verilog-modi-file-or-buffer modi)))) - (or (equal major-mode `verilog-mode) ; Put into Verilog mode to get syntax + (or (equal major-mode 'verilog-mode) ; Put into Verilog mode to get syntax (verilog-mode)) (goto-char (verilog-modi-get-point modi))) @@ -10405,7 +10433,7 @@ When MODI is non-null, also add to modi-cache, for tracking." (t (error "Unsupported verilog-insert-definition direction: `%s'" direction)))) (or dont-sort - (setq sigs (sort (copy-alist sigs) `verilog-signals-sort-compare))) + (setq sigs (sort (copy-alist sigs) #'verilog-signals-sort-compare))) (while sigs (let ((sig (car sigs))) (verilog-insert-one-definition @@ -10473,7 +10501,7 @@ Presumes that any newlines end a list element." (looking-at "[(,]"))) (not (save-excursion ; Not `endif, or user define (backward-char 1) - (skip-chars-backward "[a-zA-Z0-9_`]") + (skip-chars-backward "a-zA-Z0-9_`") (looking-at "`")))) (insert ",")))) @@ -10521,67 +10549,96 @@ This repairs those mis-inserted by an AUTOARG." (defun verilog-simplify-range-expression (expr) "Return a simplified range expression with constants eliminated from EXPR." ;; Note this is always called with brackets; ie [z] or [z:z] - (if (not (string-match "[---+*()]" expr)) - expr ; short-circuit + (if (or (not verilog-auto-simplify-expressions) + (not (string-match "[---+*/<>()]" expr))) + expr ; disabled or short-circuited (let ((out expr) (last-pass "")) (while (not (equal last-pass out)) - (setq last-pass out) - ;; Prefix regexp needs beginning of match, or some symbol of - ;; lesser or equal precedence. We assume the [:]'s exist in expr. - ;; Ditto the end. - (while (string-match - (concat "\\([[({:*+-]\\)" ; - must be last - "(\\<\\([0-9A-Za-z_]+\\))" - "\\([])}:*+-]\\)") - out) - (setq out (replace-match "\\1\\2\\3" nil nil out))) - (while (string-match - (concat "\\([[({:*+-]\\)" ; - must be last - "\\$clog2\\s *(\\<\\([0-9]+\\))" - "\\([])}:*+-]\\)") - out) - (setq out (replace-match - (concat - (match-string 1 out) - (int-to-string (verilog-clog2 (string-to-number (match-string 2 out)))) - (match-string 3 out)) - nil nil out))) - ;; For precedence do * before +/- - (while (string-match - (concat "\\([[({:*+-]\\)" - "\\([0-9]+\\)\\s *\\([*]\\)\\s *\\([0-9]+\\)" - "\\([])}:*+-]\\)") - out) - (setq out (replace-match - (concat (match-string 1 out) - (int-to-string (* (string-to-number (match-string 2 out)) - (string-to-number (match-string 4 out)))) - (match-string 5 out)) - nil nil out))) - (while (string-match - (concat "\\([[({:+-]\\)" ; No * here as higher prec - "\\([0-9]+\\)\\s *\\([---+]\\)\\s *\\([0-9]+\\)" - "\\([])}:+-]\\)") - out) - (let ((pre (match-string 1 out)) - (lhs (string-to-number (match-string 2 out))) - (rhs (string-to-number (match-string 4 out))) - (post (match-string 5 out)) - val) - (when (equal pre "-") - (setq lhs (- lhs))) - (setq val (if (equal (match-string 3 out) "-") - (- lhs rhs) - (+ lhs rhs)) - out (replace-match - (concat (if (and (equal pre "-") - (< val 0)) - "" ; Not "--20" but just "-20" - pre) - (int-to-string val) - post) - nil nil out)) ))) + (while (not (equal last-pass out)) + (setq last-pass out) + ;; Prefix regexp needs beginning of match, or some symbol of + ;; lesser or equal precedence. We assume the [:]'s exist in expr. + ;; Ditto the end. + (while (string-match + (concat "\\([[({:*/<>+-]\\)" ; - must be last + "(\\<\\([0-9A-Za-z_]+\\))" + "\\([])}:*/<>+-]\\)") + out) + (setq out (replace-match "\\1\\2\\3" nil nil out))) + (while (string-match + (concat "\\([[({:*/<>+-]\\)" ; - must be last + "\\$clog2\\s *(\\<\\([0-9]+\\))" + "\\([])}:*/<>+-]\\)") + out) + (setq out (replace-match + (concat + (match-string 1 out) + (int-to-string (verilog-clog2 (string-to-number (match-string 2 out)))) + (match-string 3 out)) + nil nil out))) + ;; For precedence do *,/ before +,-,>>,<< + (while (string-match + (concat "\\([[({:*/<>+-]\\)" + "\\([0-9]+\\)\\s *\\([*/]\\)\\s *\\([0-9]+\\)" + "\\([])}:*/<>+-]\\)") + out) + (setq out (replace-match + (concat (match-string 1 out) + (if (equal (match-string 3 out) "/") + (int-to-string (/ (string-to-number (match-string 2 out)) + (string-to-number (match-string 4 out))))) + (if (equal (match-string 3 out) "*") + (int-to-string (* (string-to-number (match-string 2 out)) + (string-to-number (match-string 4 out))))) + (match-string 5 out)) + nil nil out))) + ;; Next precedence is +,- + (while (string-match + (concat "\\([[({:<>+-]\\)" ; No *,/ here as higher prec + "\\([0-9]+\\)\\s *\\([---+]\\)\\s *\\([0-9]+\\)" + "\\([])}:<>+-]\\)") + out) + (let ((pre (match-string 1 out)) + (lhs (string-to-number (match-string 2 out))) + (rhs (string-to-number (match-string 4 out))) + (post (match-string 5 out)) + val) + (when (equal pre "-") + (setq lhs (- lhs))) + (setq val (if (equal (match-string 3 out) "-") + (- lhs rhs) + (+ lhs rhs)) + out (replace-match + (concat (if (and (equal pre "-") + (< val 0)) + "" ; Not "--20" but just "-20" + pre) + (int-to-string val) + post) + nil nil out)) )) + ;; Next precedence is >>,<< + (while (string-match + (concat "\\([[({:]\\)" ;; No << as not transitive + "\\([0-9]+\\)\\s *\\([<]\\{2,3\\}\\|[>]\\{2,3\\}\\)\\s *\\([0-9]+\\)" + "\\([])}:<>]\\)") + out) + (setq out (replace-match + (concat (match-string 1 out) + (if (equal (match-string 3 out) ">>") + (int-to-string (lsh (string-to-number (match-string 2 out)) + (* -1 (string-to-number (match-string 4 out)))))) + (if (equal (match-string 3 out) "<<") + (int-to-string (lsh (string-to-number (match-string 2 out)) + (string-to-number (match-string 4 out))))) + (if (equal (match-string 3 out) ">>>") + (int-to-string (ash (string-to-number (match-string 2 out)) + (* -1 (string-to-number (match-string 4 out)))))) + (if (equal (match-string 3 out) "<<<") + (int-to-string (ash (string-to-number (match-string 2 out)) + (string-to-number (match-string 4 out))))) + (match-string 5 out)) + nil nil out))))) out))) ;;(verilog-simplify-range-expression "[1:3]") ; 1 @@ -10594,6 +10651,9 @@ This repairs those mis-inserted by an AUTOARG." ;;(verilog-simplify-range-expression "[FOO-1+1-1+1]") ; FOO-0 ;;(verilog-simplify-range-expression "[$clog2(2)]") ; 1 ;;(verilog-simplify-range-expression "[$clog2(7)]") ; 3 +;;(verilog-simplify-range-expression "[(TEST[1])-1:0]") +;;(verilog-simplify-range-expression "[1<<2:8>>2]") ; [4:2] +;;(verilog-simplify-range-expression "[2*4/(4-2) +2+4 <<4 >>2]") (defun verilog-clog2 (value) "Compute $clog2 - ceiling log2 of VALUE." @@ -10749,7 +10809,7 @@ Intended for internal use inside a `verilog-save-font-no-change-functions' block (concat "/\\*" (eval-when-compile (verilog-regexp-words - `("AS" "AUTOARG" "AUTOCONCATWIDTH" "AUTOINST" "AUTOINSTPARAM" + '("AS" "AUTOARG" "AUTOCONCATWIDTH" "AUTOINST" "AUTOINSTPARAM" "AUTOSENSE"))) "\\*/") 'verilog-delete-to-paren) @@ -10758,7 +10818,7 @@ Intended for internal use inside a `verilog-save-font-no-change-functions' block 'verilog-delete-auto-star-all) ;; Remove template comments ... anywhere in case was pasted after AUTOINST removed (goto-char (point-min)) - (while (re-search-forward "\\s-*// \\(Templated\\|Implicit \\.\\*\\)\\([ \tLT0-9]*\\| LHS: .*\\)?$" nil t) + (while (re-search-forward "\\s-*// \\(Templated\\|Implicit \\.\\*\\)\\([ \tLT0-9]*\\| LHS: .*\\)$" nil t) (replace-match "")) ;; Final customize @@ -10796,32 +10856,33 @@ support adding new ports. You may wish to delete older ports yourself. For example: - module ExampInject (i, o); - input i; - input j; - output o; - always @ (i or j) - o = i | j; - InstModule instName + module ExampInject (i, o); + input i; + input j; + output o; + always @ (i or j) + o = i | j; + InstModule instName (.foobar(baz), - j(j)); - endmodule - -Typing \\[verilog-inject-auto] will make this into: - - module ExampInject (i, o/*AUTOARG*/ - // Inputs - j); - input i; - output o; - always @ (/*AS*/i or j) - o = i | j; - InstModule instName + .j(j)); + endmodule + +Typing \\[verilog-inject-auto] (with an appropriate submodule not +shown) will make this into: + + module ExampInject (i, o/*AUTOARG*/ + // Inputs + j); + input i; + output o; + always @ (/*AS*/i or j) + o = i | j; + InstModule instName (.foobar(baz), - /*AUTOINST*/ - // Outputs - j(j)); - endmodule" + /*AUTOINST*/ + // Outputs + j(j)); + endmodule" (interactive) (verilog-auto t)) @@ -11021,8 +11082,7 @@ or `diff' in batch mode." (progn (with-current-buffer b1 (setq buffer-file-name nil)) (verilog-auto) - (when (not verilog-auto-star-save) - (verilog-delete-auto-star-implicit))) + (verilog-star-cleanup)) ;; Restore name if unwind (with-current-buffer b1 (setq buffer-file-name name1))))) ;; @@ -11039,6 +11099,11 @@ or `diff' in batch mode." ;; Auto save ;; +(defun verilog-star-cleanup () + "On saving or diff, cleanup .* expansions." + (when (not verilog-auto-star-save) + (verilog-delete-auto-star-implicit))) + (defun verilog-auto-save-check () "On saving see if we need auto update." (cond ((not verilog-auto-save-policy)) ; disabled @@ -11058,8 +11123,7 @@ or `diff' in batch mode." (verilog-auto)) ;; Don't ask again if didn't update (set (make-local-variable 'verilog-auto-update-tick) (buffer-chars-modified-tick)))) - (when (not verilog-auto-star-save) - (verilog-delete-auto-star-implicit)) + (verilog-star-cleanup) nil) ; Always return nil -- we don't write the file ourselves (defun verilog-auto-read-locals () @@ -11090,7 +11154,7 @@ If FORCE, always reread it." Takes SIGS list, adds MESSAGE to front and inserts each at INDENT-PT." (when sigs (when verilog-auto-arg-sort - (setq sigs (sort (copy-alist sigs) `verilog-signals-sort-compare))) + (setq sigs (sort (copy-alist sigs) #'verilog-signals-sort-compare))) (insert "\n") (indent-to indent-pt) (insert message) @@ -11129,22 +11193,21 @@ Limitations: For example: - module ExampArg (/*AUTOARG*/); - input i; - output o; - endmodule + module ExampArg (/*AUTOARG*/); + input i; + output o; + endmodule Typing \\[verilog-auto] will make this into: - module ExampArg (/*AUTOARG*/ - // Outputs - o, - // Inputs - i - ); - input i; - output o; - endmodule + module ExampArg (/*AUTOARG*/ + // Outputs + o, + // Inputs + i); + input i; + output o; + endmodule The argument declarations may be printed in declaration order to best suit order based instantiations, or alphabetically, based on @@ -11244,8 +11307,8 @@ See the example in `verilog-auto-inout-modport'." (verilog-signals-matching-dir-re (verilog-signals-matching-regexp sig-list-o regexp) "output" direction-re))) - (setq sig-list-i (sort (copy-alist sig-list-i) `verilog-signals-sort-compare)) - (setq sig-list-o (sort (copy-alist sig-list-o) `verilog-signals-sort-compare)) + (setq sig-list-i (sort (copy-alist sig-list-i) #'verilog-signals-sort-compare)) + (setq sig-list-o (sort (copy-alist sig-list-o) #'verilog-signals-sort-compare)) (when (or sig-list-i sig-list-o) (verilog-insert-indent "// Beginning of automatic assignments from modport\n") ;; Don't sort them so an upper AUTOINST will match the main module @@ -11357,7 +11420,7 @@ If PAR-VALUES replace final strings with these parameter values." (when tpl-ass ;; Evaluate @"(lispcode)" (when (string-match "@\".*[^\\]\"" tpl-net) - (while (string-match "@\"\\(\\([^\\\"]*\\(\\\\.\\)*\\)*\\)\"" tpl-net) + (while (string-match "@\"\\(\\([^\\\"]\\|\\\\.\\)*\\)\"" tpl-net) (setq tpl-net (concat (substring tpl-net 0 (match-beginning 0)) @@ -11389,7 +11452,7 @@ If PAR-VALUES replace final strings with these parameter values." (indent-to (+ (if (< verilog-auto-inst-column 48) 24 16) verilog-auto-inst-column)) ;; verilog-insert requires the complete comment in one call - including the newline - (cond ((equal verilog-auto-inst-template-numbers `lhs) + (cond ((equal verilog-auto-inst-template-numbers 'lhs) (verilog-insert " // Templated" " LHS: " (nth 0 tpl-ass) "\n")) @@ -11413,7 +11476,7 @@ If PAR-VALUES replace final strings with these parameter values." (defun verilog-auto-inst-port-list (sig-list indent-pt moddecls tpl-list tpl-num for-star par-values) "For `verilog-auto-inst' print a list of ports using `verilog-auto-inst-port'." (when verilog-auto-inst-sort - (setq sig-list (sort (copy-alist sig-list) `verilog-signals-sort-compare))) + (setq sig-list (sort (copy-alist sig-list) #'verilog-signals-sort-compare))) (mapc (lambda (port) (verilog-auto-inst-port port indent-pt moddecls tpl-list tpl-num for-star par-values)) @@ -11464,6 +11527,11 @@ See `verilog-auto-star' for more information. The pins are printed in declaration order or alphabetically, based on the `verilog-auto-inst-sort' variable. +To debug what file a submodule comes from, in a buffer with +AUTOINST, use \\[verilog-goto-defun] to switch buffers to the +point containing the given symbol (i.e. a submodule name)'s +module definition. + Limitations: Module names must be resolvable to filenames by adding a `verilog-library-extensions', and being found in the same directory, or @@ -11493,33 +11561,33 @@ Limitations: For example, first take the submodule InstModule.v: - module InstModule (o,i); - output [31:0] o; - input i; - wire [31:0] o = {32{i}}; - endmodule + module InstModule (o,i); + output [31:0] o; + input i; + wire [31:0] o = {32{i}}; + endmodule This is then used in an upper level module: - module ExampInst (o,i); - output o; - input i; - InstModule instName - (/*AUTOINST*/); - endmodule + module ExampInst (o,i); + output o; + input i; + InstModule instName + (/*AUTOINST*/); + endmodule Typing \\[verilog-auto] will make this into: - module ExampInst (o,i); - output o; - input i; - InstModule instName - (/*AUTOINST*/ - // Outputs - .ov (ov[31:0]), - // Inputs - .i (i)); - endmodule + module ExampInst (o,i); + output o; + input i; + InstModule instName + (/*AUTOINST*/ + // Outputs + .o (o[31:0]), + // Inputs + .i (i)); + endmodule Where the list of inputs and outputs came from the inst module. @@ -11540,12 +11608,12 @@ Exceptions: you have the appropriate // Input or // Output comment, and exactly the same line formatting as AUTOINST itself uses. - InstModule instName + InstModule instName (// Inputs - .i (my_i_dont_mess_with_it), - /*AUTOINST*/ - // Outputs - .ov (ov[31:0])); + .i (my_i_dont_mess_with_it), + /*AUTOINST*/ + // Outputs + .o (o[31:0])); Templates: @@ -11553,10 +11621,10 @@ Templates: For multiple instantiations based upon a single template, create a commented out template: - /* InstModule AUTO_TEMPLATE ( - .sig3 (sigz[]), - ); - */ + /* InstModule AUTO_TEMPLATE ( + .sig3 (sigz[]), + ); + */ Templates go ABOVE the instantiation(s). When an instantiation is expanded `verilog-mode' simply searches up for the closest template. @@ -11600,19 +11668,19 @@ Templates: For example: - /* InstModule AUTO_TEMPLATE ( - .ptl_bus (ptl_busnew[]), - ); - */ - InstModule ms2m (/*AUTOINST*/); + /* InstModule AUTO_TEMPLATE ( + .ptl_bus (ptl_busnew[]), + ); + */ + InstModule ms2m (/*AUTOINST*/); Typing \\[verilog-auto] will make this into: - InstModule ms2m (/*AUTOINST*/ - // Outputs - .NotInTemplate (NotInTemplate), - .ptl_bus (ptl_busnew[3:0]), // Templated - .... + InstModule ms2m (/*AUTOINST*/ + // Outputs + .NotInTemplate (NotInTemplate), + .ptl_bus (ptl_busnew[3:0]), // Templated + .... Multiple Module Templates: @@ -11620,13 +11688,13 @@ Multiple Module Templates: The same template lines can be applied to multiple modules with the syntax as follows: - /* InstModuleA AUTO_TEMPLATE - InstModuleB AUTO_TEMPLATE - InstModuleC AUTO_TEMPLATE - InstModuleD AUTO_TEMPLATE ( - .ptl_bus (ptl_busnew[]), - ); - */ + /* InstModuleA AUTO_TEMPLATE + InstModuleB AUTO_TEMPLATE + InstModuleC AUTO_TEMPLATE + InstModuleD AUTO_TEMPLATE ( + .ptl_bus (ptl_busnew[]), + ); + */ Note there is only one AUTO_TEMPLATE opening parenthesis. @@ -11635,11 +11703,11 @@ Multiple Module Templates: It is common to instantiate a cell multiple times, so templates make it trivial to substitute part of the cell name into the connection name. - /* InstName AUTO_TEMPLATE <optional \"REGEXP\"> ( - .sig1 (sigx[@]), - .sig2 (sigy[@\"(% (+ 1 @) 4)\"]), - ); - */ + /* InstName AUTO_TEMPLATE <optional \"REGEXP\"> ( + .sig1 (sigx[@]), + .sig2 (sigy[@\"(% (+ 1 @) 4)\"]), + ); + */ If no regular expression is provided immediately after the AUTO_TEMPLATE keyword, then the @ character in any connection names will be replaced @@ -11657,49 +11725,49 @@ Multiple Module Templates: For example: - /* InstModule AUTO_TEMPLATE ( - .ptl_mapvalidx (ptl_mapvalid[@]), - .ptl_mapvalidp1x (ptl_mapvalid[@\"(% (+ 1 @) 4)\"]), - ); - */ - InstModule ms2m (/*AUTOINST*/); + /* InstModule AUTO_TEMPLATE ( + .ptl_mapvalidx (ptl_mapvalid[@]), + .ptl_mapvalidp1x (ptl_mapvalid[@\"(% (+ 1 @) 4)\"]), + ); + */ + InstModule ms2m (/*AUTOINST*/); Typing \\[verilog-auto] will make this into: - InstModule ms2m (/*AUTOINST*/ - // Outputs - .ptl_mapvalidx (ptl_mapvalid[2]), - .ptl_mapvalidp1x (ptl_mapvalid[3])); + InstModule ms2m (/*AUTOINST*/ + // Outputs + .ptl_mapvalidx (ptl_mapvalid[2]), + .ptl_mapvalidp1x (ptl_mapvalid[3])); Note the @ character was replaced with the 2 from \"ms2m\". Alternatively, using a regular expression for @: - /* InstModule AUTO_TEMPLATE \"_\\([a-z]+\\)\" ( - .ptl_mapvalidx (@_ptl_mapvalid), - .ptl_mapvalidp1x (ptl_mapvalid_@), - ); - */ - InstModule ms2_FOO (/*AUTOINST*/); - InstModule ms2_BAR (/*AUTOINST*/); + /* InstModule AUTO_TEMPLATE \"_\\([a-z]+\\)\" ( + .ptl_mapvalidx (@_ptl_mapvalid), + .ptl_mapvalidp1x (ptl_mapvalid_@), + ); + */ + InstModule ms2_FOO (/*AUTOINST*/); + InstModule ms2_BAR (/*AUTOINST*/); Typing \\[verilog-auto] will make this into: - InstModule ms2_FOO (/*AUTOINST*/ - // Outputs - .ptl_mapvalidx (FOO_ptl_mapvalid), - .ptl_mapvalidp1x (ptl_mapvalid_FOO)); - InstModule ms2_BAR (/*AUTOINST*/ - // Outputs - .ptl_mapvalidx (BAR_ptl_mapvalid), - .ptl_mapvalidp1x (ptl_mapvalid_BAR)); + InstModule ms2_FOO (/*AUTOINST*/ + // Outputs + .ptl_mapvalidx (FOO_ptl_mapvalid), + .ptl_mapvalidp1x (ptl_mapvalid_FOO)); + InstModule ms2_BAR (/*AUTOINST*/ + // Outputs + .ptl_mapvalidx (BAR_ptl_mapvalid), + .ptl_mapvalidp1x (ptl_mapvalid_BAR)); Regexp Templates: A template entry of the form - .pci_req\\([0-9]+\\)_l (pci_req_jtag_[\\1]), + .pci_req\\([0-9]+\\)_l (pci_req_jtag_[\\1]), will apply an Emacs style regular expression search for any port beginning in pci_req followed by numbers and ending in _l and connecting that to @@ -11711,13 +11779,13 @@ Regexp Templates: completely different -- still use \\1 there!) Thus this is the same as the above template: - .pci_req@_l (pci_req_jtag_[\\1]), + .pci_req@_l (pci_req_jtag_[\\1]), Here's another example to remove the _l, useful when naming conventions specify _ alone to mean active low. Note the use of [] to keep the bus subscript: - .\\(.*\\)_l (\\1_[]), + .\\(.*\\)_l (\\1_[]), Lisp Templates: @@ -11733,21 +11801,21 @@ Lisp Templates: There are special variables defined that are useful in these Lisp functions: - vl-name Name portion of the input/output port. - vl-bits Bus bits portion of the input/output port (`[2:0]'). - vl-mbits Multidimensional array bits for port (`[2:0][3:0]'). - vl-width Width of the input/output port (`3' for [2:0]). + vl-name Name portion of the input/output port. + vl-bits Bus bits portion of the input/output port (`[2:0]'). + vl-mbits Multidimensional array bits for port (`[2:0][3:0]'). + vl-width Width of the input/output port (`3' for [2:0]). May be a (...) expression if bits isn't a constant. - vl-dir Direction of the pin input/output/inout/interface. - vl-modport The modport, if an interface with a modport. - vl-cell-type Module name/type of the cell (`InstModule'). - vl-cell-name Instance name of the cell (`instName'). + vl-dir Direction of the pin input/output/inout/interface. + vl-modport The modport, if an interface with a modport. + vl-cell-type Module name/type of the cell (`InstModule'). + vl-cell-name Instance name of the cell (`instName'). Normal Lisp variables may be used in expressions. See `verilog-read-defines' which can set vh-{definename} variables for use here. Also, any comments of the form: - /*AUTO_LISP(setq foo 1)*/ + /*AUTO_LISP(setq foo 1)*/ will evaluate any Lisp expression inside the parenthesis between the beginning of the buffer and the point of the AUTOINST. This allows @@ -11877,28 +11945,27 @@ output. For example, first take the submodule InstModule.v: - module InstModule (o,i); - parameter PAR; - endmodule + module InstModule (o,i); + parameter PAR; + endmodule This is then used in an upper level module: - module ExampInst (o,i); - parameter PAR; - InstModule #(/*AUTOINSTPARAM*/) - instName (/*AUTOINST*/); - endmodule + module ExampInstParam (o,i); + parameter PAR; + InstModule #(/*AUTOINSTPARAM*/) + instName (/*AUTOINST*/); + endmodule Typing \\[verilog-auto] will make this into: - module ExampInst (o,i); - output o; - input i; - InstModule #(/*AUTOINSTPARAM*/ - // Parameters - .PAR (PAR)); - instName (/*AUTOINST*/); - endmodule + module ExampInstParam (o,i); + parameter PAR; + InstModule #(/*AUTOINSTPARAM*/ + // Parameters + .PAR (PAR)) + instName (/*AUTOINST*/); + endmodule Where the list of parameter connections come from the inst module. @@ -11980,24 +12047,24 @@ Limitations: An example: - module ExampReg (o,i); - output o; - input i; - /*AUTOREG*/ - always o = i; - endmodule + module ExampReg (o,i); + output o; + input i; + /*AUTOREG*/ + always o = i; + endmodule Typing \\[verilog-auto] will make this into: - module ExampReg (o,i); - output o; - input i; - /*AUTOREG*/ - // Beginning of automatic regs (for this module's undeclared outputs) - reg o; - // End of automatics - always o = i; - endmodule" + module ExampReg (o,i); + output o; + input i; + /*AUTOREG*/ + // Beginning of automatic regs + reg o; + // End of automatics + always o = i; + endmodule" (save-excursion ;; Point must be at insertion point. (let* ((indent-pt (current-indentation)) @@ -12024,41 +12091,41 @@ Typing \\[verilog-auto] will make this into: (defun verilog-auto-reg-input () "Expand AUTOREGINPUT statements, as part of \\[verilog-auto]. -Make reg statements instantiation inputs that aren't already declared. -This is useful for making a top level shell for testing the module that is -to be instantiated. +Make reg statements instantiation inputs that aren't already +declared or assigned to. This is useful for making a top level +shell for testing the module that is to be instantiated. Limitations: This ONLY detects inputs of AUTOINSTants (see `verilog-read-sub-decls'). This does NOT work on memories, declare those yourself. + Assignments cause the assigned-to variable not to be declared unless + the name matches `verilog-auto-reg-input-assigned-ignore-regexp'. + An example (see `verilog-auto-inst' for what else is going on here): - module ExampRegInput (o,i); - output o; - input i; - /*AUTOREGINPUT*/ + module InstModule (input i); + endmodule + + module ExampRegInput (); + /*AUTOREGINPUT*/ InstModule instName (/*AUTOINST*/); - endmodule + endmodule Typing \\[verilog-auto] will make this into: - module ExampRegInput (o,i); - output o; - input i; - /*AUTOREGINPUT*/ - // Beginning of automatic reg inputs (for undeclared ... - reg [31:0] iv; // From inst of inst.v - // End of automatics - InstModule instName + module ExampRegInput (); + /*AUTOREGINPUT*/ + // Beginning of automatic reg inputs + reg i; // To instName of InstModule.v + // End of automatics + InstModule instName (/*AUTOINST*/ - // Outputs - .o (o[31:0]), - // Inputs - .iv (iv)); - endmodule" + // Inputs + .i (i)); + endmodule" (save-excursion ;; Point must be at insertion point. (let* ((indent-pt (current-indentation)) @@ -12070,7 +12137,9 @@ Typing \\[verilog-auto] will make this into: (append (verilog-subdecls-get-inputs modsubdecls) (verilog-subdecls-get-inouts modsubdecls)) (append (verilog-decls-get-signals moddecls) - (verilog-decls-get-assigns moddecls)))))) + (verilog-signals-not-matching-regexp + (verilog-decls-get-assigns moddecls) + verilog-auto-reg-input-assigned-ignore-regexp)))))) (when sig-list (verilog-forward-or-insert-line) (verilog-insert-indent "// Beginning of automatic reg inputs (for undeclared instantiated-module inputs)\n") @@ -12123,31 +12192,29 @@ Limitations: An example (see `verilog-auto-inst' for what else is going on here): - module ExampWire (o,i); - output o; - input i; - /*AUTOWIRE*/ + module ExampWire (i); + input i; + /*AUTOWIRE*/ InstModule instName - (/*AUTOINST*/); - endmodule + (/*AUTOINST*/); + endmodule Typing \\[verilog-auto] will make this into: - module ExampWire (o,i); - output o; - input i; - /*AUTOWIRE*/ - // Beginning of automatic wires - wire [31:0] ov; // From inst of inst.v - // End of automatics - InstModule instName - (/*AUTOINST*/ - // Outputs - .ov (ov[31:0]), - // Inputs - .i (i)); - wire o = | ov; - endmodule" + module ExampWire (i); + input i; + /*AUTOWIRE*/ + // Beginning of automatic wires + wire [31:0] o; // From instName of InstModule.v + // End of automatics + InstModule instName + (/*AUTOINST*/ + // Outputs + .o (o[31:0]), + // Inputs + .i (i)); + wire o = | ov; + endmodule" (save-excursion ;; Point must be at insertion point. (let* ((indent-pt (current-indentation)) @@ -12194,28 +12261,29 @@ Limitations: An example (see `verilog-auto-inst' for what else is going on here): - module ExampOutput (ov,i); - input i; - /*AUTOOUTPUT*/ - InstModule instName - (/*AUTOINST*/); - endmodule + module InstModule (output o); + endmodule + + module ExampOutput + (/*AUTOOUTPUT*/ + ); + InstModule instName + (/*AUTOINST*/); + endmodule Typing \\[verilog-auto] will make this into: - module ExampOutput (ov,i); - input i; - /*AUTOOUTPUT*/ - // Beginning of automatic outputs (from unused autoinst outputs) - output [31:0] ov; // From inst of inst.v - // End of automatics - InstModule instName - (/*AUTOINST*/ - // Outputs - .ov (ov[31:0]), - // Inputs - .i (i)); - endmodule + module ExampOutput + (/*AUTOOUTPUT*/ + // Beginning of automatic outputs + output o // From instName of InstModule.v + // End of automatics + ); + InstModule instName + (/*AUTOINST*/ + // Outputs + .o (o)); + endmodule You may also provide an optional regular expression, in which case only signals matching the regular expression will be included. For example the @@ -12255,40 +12323,41 @@ same expansion will result from only extracting outputs starting with ov: "Expand AUTOOUTPUTEVERY statements, as part of \\[verilog-auto]. Make output statements for any signals that aren't primary inputs or outputs already. This makes every signal in the design an output. This is -useful to get Synopsys to preserve every signal in the design, since it +useful to get synthesis to preserve every signal in the design, since it won't optimize away the outputs. An example: - module ExampOutputEvery (o,i,tempa,tempb); - output o; - input i; - /*AUTOOUTPUTEVERY*/ - wire tempa = i; - wire tempb = tempa; - wire o = tempb; - endmodule + module ExampOutputEvery (o,i,tempa,tempb); + output o; + input i; + /*AUTOOUTPUTEVERY*/ + wire tempa = i; + wire tempb = tempa; + wire o = tempb; + endmodule Typing \\[verilog-auto] will make this into: - module ExampOutputEvery (o,i,tempa,tempb); - output o; - input i; - /*AUTOOUTPUTEVERY*/ - // Beginning of automatic outputs (every signal) - output tempb; - output tempa; - // End of automatics - wire tempa = i; - wire tempb = tempa; - wire o = tempb; - endmodule + module ExampOutputEvery ( + /*AUTOOUTPUTEVERY*/ + // Beginning of automatic outputs (every signal) + output o, + output tempa, + output tempb, + // End of automatics + input i + ); + wire tempa = i; + wire tempb = tempa; + wire o = tempb; + endmodule You may also provide an optional regular expression, in which case only signals matching the regular expression will be included. For example the same expansion will result from only extracting outputs starting with ov: - /*AUTOOUTPUTEVERY(\"^ov\")*/" + /*AUTOOUTPUTEVERY(\"^ov\")*/" (save-excursion ;;Point must be at insertion point (let* ((indent-pt (current-indentation)) @@ -12338,28 +12407,29 @@ Limitations: An example (see `verilog-auto-inst' for what else is going on here): - module ExampInput (ov,i); - output [31:0] ov; - /*AUTOINPUT*/ - InstModule instName - (/*AUTOINST*/); - endmodule + module InstModule (input i); + endmodule + + module ExampInput ( + /*AUTOINPUT*/ + ); + InstModule instName + (/*AUTOINST*/); + endmodule Typing \\[verilog-auto] will make this into: - module ExampInput (ov,i); - output [31:0] ov; - /*AUTOINPUT*/ - // Beginning of automatic inputs (from unused autoinst inputs) - input i; // From inst of inst.v - // End of automatics - InstModule instName - (/*AUTOINST*/ - // Outputs - .ov (ov[31:0]), - // Inputs - .i (i)); - endmodule + module ExampInput ( + /*AUTOINPUT*/ + // Beginning of automatic inputs (from unused autoinst inputs) + input i // To instName of InstModule.v + // End of automatics + ); + InstModule instName + (/*AUTOINST*/ + // Inputs + .i (i)); + endmodule You may also provide an optional regular expression, in which case only signals matching the regular expression will be included. For example the @@ -12421,34 +12491,35 @@ Limitations: An example (see `verilog-auto-inst' for what else is going on here): - module ExampInout (ov,i); - input i; - /*AUTOINOUT*/ - InstModule instName - (/*AUTOINST*/); - endmodule + module InstModule (inout io); + endmodule + + module ExampInout ( + /*AUTOINOUT*/ + ); + InstModule instName + (/*AUTOINST*/); + endmodule Typing \\[verilog-auto] will make this into: - module ExampInout (ov,i); - input i; - /*AUTOINOUT*/ - // Beginning of automatic inouts (from unused autoinst inouts) - inout [31:0] ov; // From inst of inst.v - // End of automatics - InstModule instName - (/*AUTOINST*/ - // Inouts - .ov (ov[31:0]), - // Inputs - .i (i)); - endmodule + module ExampInout ( + /*AUTOINOUT*/ + // Beginning of automatic inouts + inout io // To/From instName of InstModule.v + // End of automatics + ); + InstModule instName + (/*AUTOINST*/ + // Inouts + .io (io)); + endmodule You may also provide an optional regular expression, in which case only signals matching the regular expression will be included. For example the same expansion will result from only extracting inouts starting with i: - /*AUTOINOUT(\"^i\")*/" + /*AUTOINOUT(\"^i\")*/" (save-excursion ;; Point must be at insertion point. (let* ((indent-pt (current-indentation)) @@ -12506,32 +12577,32 @@ Limitations: An example: - module ExampShell (/*AUTOARG*/); - /*AUTOINOUTMODULE(\"ExampMain\")*/ - endmodule + module ExampMain + (input i, + output o, + inout io); + endmodule - module ExampMain (i,o,io); - input i; - output o; - inout io; + module ExampShell (/*AUTOARG*/); + /*AUTOINOUTMODULE(\"ExampMain\")*/ endmodule Typing \\[verilog-auto] will make this into: - module ExampShell (/*AUTOARG*/i,o,io); - /*AUTOINOUTMODULE(\"ExampMain\")*/ - // Beginning of automatic in/out/inouts (from specific module) + module ExampShell (/*AUTOARG*/o, io, o); + /*AUTOINOUTMODULE(\"ExampMain\")*/ + // Beginning of automatic in/out/inouts output o; inout io; input i; - // End of automatics - endmodule + // End of automatics + endmodule You may also provide an optional regular expression, in which case only signals matching the regular expression will be included. For example the same expansion will result from only extracting signals starting with i: - /*AUTOINOUTMODULE(\"ExampMain\",\"^i\")*/ + /*AUTOINOUTMODULE(\"ExampMain\",\"^i\")*/ You may also provide an optional third argument regular expression, in which case only signals which have that pin @@ -12545,7 +12616,7 @@ probably want to skip spaces in your regexp. For example, the below will result in matching the output \"o\" against the previous example's module: - /*AUTOINOUTMODULE(\"ExampMain\",\"\",\"^output.*\")*/ + /*AUTOINOUTMODULE(\"ExampMain\",\"\",\"^output.*\")*/ You may also provide an optional fourth argument regular expression, which if not \"\" only signals which do NOT match @@ -12644,32 +12715,32 @@ Limitations: An example: - module ExampShell (/*AUTOARG*/); - /*AUTOINOUTCOMP(\"ExampMain\")*/ - endmodule + module ExampMain + (input i, + output o, + inout io); + endmodule - module ExampMain (i,o,io); - input i; - output o; - inout io; + module ExampBench (/*AUTOARG*/); + /*AUTOINOUTCOMP(\"ExampMain\")*/ endmodule Typing \\[verilog-auto] will make this into: - module ExampShell (/*AUTOARG*/i,o,io); - /*AUTOINOUTCOMP(\"ExampMain\")*/ - // Beginning of automatic in/out/inouts (from specific module) + module ExampShell (/*AUTOARG*/i, io, o); + /*AUTOINOUTCOMP(\"ExampMain\")*/ + // Beginning of automatic in/out/inouts output i; inout io; input o; - // End of automatics - endmodule + // End of automatics + endmodule You may also provide an optional regular expression, in which case only signals matching the regular expression will be included. For example the same expansion will result from only extracting signals starting with i: - /*AUTOINOUTCOMP(\"ExampMain\",\"^i\")*/ + /*AUTOINOUTCOMP(\"ExampMain\",\"^i\")*/ You may also provide an optional third argument regular expression, in which case only signals which have that pin @@ -12683,7 +12754,7 @@ probably want to skip spaces in your regexp. For example, the below will result in matching the output \"o\" against the previous example's module: - /*AUTOINOUTCOMP(\"ExampMain\",\"\",\"^output.*\")*/ + /*AUTOINOUTCOMP(\"ExampMain\",\"\",\"^output.*\")*/ You may also provide an optional fourth argument regular expression, which if not \"\" only signals which do NOT match @@ -12714,32 +12785,32 @@ Limitations: An example: - module ExampShell (/*AUTOARG*/); - /*AUTOINOUTIN(\"ExampMain\")*/ - endmodule + module ExampMain + (input i, + output o, + inout io); + endmodule - module ExampMain (i,o,io); - input i; - output o; - inout io; + module ExampInoutIn (/*AUTOARG*/); + /*AUTOINOUTIN(\"ExampMain\")*/ endmodule Typing \\[verilog-auto] will make this into: - module ExampShell (/*AUTOARG*/i,o,io); - /*AUTOINOUTIN(\"ExampMain\")*/ - // Beginning of automatic in/out/inouts (from specific module) + module ExampInoutIn (/*AUTOARG*/i, io, o); + /*AUTOINOUTIN(\"ExampMain\")*/ + // Beginning of automatic in/out/inouts input i; input io; input o; - // End of automatics - endmodule + // End of automatics + endmodule You may also provide an optional regular expression, in which case only signals matching the regular expression will be included. For example the same expansion will result from only extracting signals starting with i: - /*AUTOINOUTIN(\"ExampMain\",\"^i\")*/" + /*AUTOINOUTIN(\"ExampMain\",\"^i\")*/" (verilog-auto-inout-module nil t)) (defun verilog-auto-inout-param () @@ -12763,28 +12834,28 @@ Limitations: An example: - module ExampShell (); - /*AUTOINOUTPARAM(\"ExampMain\")*/ - endmodule - - module ExampMain (); + module ExampMain (); parameter PARAM = 22; endmodule + module ExampInoutParam (); + /*AUTOINOUTPARAM(\"ExampMain\")*/ + endmodule + Typing \\[verilog-auto] will make this into: - module ExampShell (/*AUTOARG*/i,o,io); - /*AUTOINOUTPARAM(\"ExampMain\")*/ + module ExampInoutParam (); + /*AUTOINOUTPARAM(\"ExampMain\")*/ // Beginning of automatic parameters (from specific module) - parameter PARAM; - // End of automatics - endmodule + parameter PARAM; + // End of automatics + endmodule You may also provide an optional regular expression, in which case only parameters matching the regular expression will be included. For example the same expansion will result from only extracting parameters starting with i: - /*AUTOINOUTPARAM(\"ExampMain\",\"^i\")*/" + /*AUTOINOUTPARAM(\"ExampMain\",\"^i\")*/" (save-excursion (let* ((params (verilog-read-auto-params 1 2)) (submod (nth 0 params)) @@ -12837,39 +12908,34 @@ the same name. An example: - interface ExampIf - ( input logic clk ); - logic req_val; - logic [7:0] req_dat; - clocking mon_clkblk @(posedge clk); - input req_val; - input req_dat; - endclocking - modport mp(clocking mon_clkblk); - endinterface - - module ExampMain - ( input clk, - /*AUTOINOUTMODPORT(\"ExampIf\" \"mp\")*/ - // Beginning of automatic in/out/inouts (from modport) - input [7:0] req_dat, - input req_val - // End of automatics - ); - /*AUTOASSIGNMODPORT(\"ExampIf\" \"mp\")*/ - endmodule + interface ExampIf + ( input logic clk ); + logic req_val; + logic [7:0] req_dat; + clocking mon_clkblk @(posedge clk); + input req_val; + input req_dat; + endclocking + modport mp(clocking mon_clkblk); + endinterface + + module ExampMain + ( input clk, + /*AUTOINOUTMODPORT(\"ExampIf\", \"mp\")*/ + ); + endmodule Typing \\[verilog-auto] will make this into: - ... - module ExampMain - ( input clk, - /*AUTOINOUTMODPORT(\"ExampIf\" \"mp\")*/ - // Beginning of automatic in/out/inouts (from modport) - input req_dat, - input req_val - // End of automatics - ); + module ExampMain + ( input clk, + /*AUTOINOUTMODPORT(\"ExampIf\", \"mp\")*/ + // Beginning of automatic in/out/inouts (from modport) + input req_val, + input [7:0] req_dat + // End of automatics + ); + endmodule If the modport is part of a UVM monitor/driver class, this creates a wrapper module that may be used to instantiate the @@ -12945,35 +13011,36 @@ it during `verilog-auto-inst' but does not insert any text. An example: - module ExampInsertLisp; - /*AUTOINSERTLISP(my-verilog-insert-hello \"world\")*/ - endmodule - - // For this example we declare the function in the - // module's file itself. Often you'd define it instead - // in a site-start.el or init file. - /* - Local Variables: - eval: - (defun my-verilog-insert-hello (who) - (insert (concat \"initial $write(\\\"hello \" who \"\\\");\\n\"))) - End: - */ + module ExampInsertLisp; + /*AUTOINSERTLISP(my-verilog-insert-hello \"world\")*/ + endmodule + + // For this example we declare the function in the + // module's file itself. Often you'd define it instead + // in a site-start.el or init file. + /* + Local Variables: + eval: + (defun my-verilog-insert-hello (who) + (insert (concat \"initial $write(\\\"hello \" who \"\\\");\\n\"))) + End: + */ Typing \\[verilog-auto] will call my-verilog-insert-hello and expand the above into: - // Beginning of automatic insert lisp - initial $write(\"hello world\"); - // End of automatics + /*AUTOINSERTLISP(my-verilog-insert-hello \"world\")*/ + // Beginning of automatic insert lisp + initial $write(\"hello world\"); + // End of automatics You can also call an external program and insert the returned text: - /*AUTOINSERTLISP(insert (shell-command-to-string \"echo //hello\"))*/ - // Beginning of automatic insert lisp - //hello - // End of automatics" + /*AUTOINSERTLISP(insert (shell-command-to-string \"echo //hello\"))*/ + // Beginning of automatic insert lisp + //hello + // End of automatics" (save-excursion ;; Point is at end of /*AUTO...*/ (let* ((indent-pt (current-indentation)) @@ -13059,27 +13126,27 @@ OOps! An example: - always @ (/*AS*/) begin - /* AUTO_CONSTANT (\\=`constant) */ - outin = ina | inb | \\=`constant; - out = outin; - end + always @ (/*AS*/) begin + /*AUTO_CONSTANT (\\=`constant) */ + outin = ina | inb | \\=`constant; + out = outin; + end Typing \\[verilog-auto] will make this into: - always @ (/*AS*/ina or inb) begin - /* AUTO_CONSTANT (\\=`constant) */ - outin = ina | inb | \\=`constant; - out = outin; - end + always @ (/*AS*/ina or inb) begin + /*AUTO_CONSTANT (\\=`constant) */ + outin = ina | inb | \\=`constant; + out = outin; + end Note in Verilog 2001, you can often get the same result from the new @* operator. (This was added to the language in part due to AUTOSENSE!) - always @* begin - outin = ina | inb | \\=`constant; - out = outin; - end" + always @* begin + outin = ina | inb | \\=`constant; + out = outin; + end" (save-excursion ;; Find beginning (let* ((start-pt (save-excursion @@ -13111,7 +13178,7 @@ operator. (This was added to the language in part due to AUTOSENSE!) (verilog-re-search-backward-quick "\\s-" start-pt t)) (not (looking-at "\\s-or\\b")))) (setq not-first t)) - (setq sig-list (sort sig-list `verilog-signals-sort-compare)) + (setq sig-list (sort sig-list #'verilog-signals-sort-compare)) (while sig-list (cond ((> (+ 4 (current-column) (length (verilog-sig-name (car sig-list)))) fill-column) ;+4 for width of or (insert "\n") @@ -13160,35 +13227,30 @@ signals manually (or put them into a \"\\=`ifdef NEVER signal<=\\=`0; An example: - always @(posedge clk or negedge reset_l) begin - if (!reset_l) begin - c <= 1; - /*AUTORESET*/ - end - else begin - a <= in_a; - b <= in_b; - c <= in_c; - end - end + module ExampReset (); + always @(posedge clk or negedge reset_l) begin + if (!reset_l) begin + c <= 1; + /*AUTORESET*/ + end + else begin + a <= in_a; + b <= in_b; + c <= in_c; + end + end + endmodule Typing \\[verilog-auto] will make this into: - always @(posedge core_clk or negedge reset_l) begin - if (!reset_l) begin - c <= 1; - /*AUTORESET*/ - // Beginning of autoreset for uninitialized flops - a <= 0; - b = 0; // if `verilog-auto-reset-blocking-in-non' true - // End of automatics - end - else begin - a <= in_a; - b = in_b; - c <= in_c; - end - end" + ... + c <= 1; + /*AUTORESET*/ + // Beginning of autoreset for uninitialized flops + a <= 1'h0; + b <= 1'h0; + // End of automatics + ..." (interactive) (save-excursion @@ -13220,7 +13282,7 @@ Typing \\[verilog-auto] will make this into: (append (verilog-alw-get-temps sigss) prereset-sigs))) - (setq sig-list (sort sig-list `verilog-signals-sort-compare)) + (setq sig-list (sort sig-list #'verilog-signals-sort-compare)) (when sig-list (insert "\n"); (verilog-insert-indent "// Beginning of autoreset for uninitialized flops\n"); @@ -13264,32 +13326,32 @@ value's width is generated. An example of making a stub for another module: - module ExampStub (/*AUTOINST*/); - /*AUTOINOUTPARAM(\"Foo\")*/ - /*AUTOINOUTMODULE(\"Foo\")*/ - /*AUTOTIEOFF*/ - // verilator lint_off UNUSED - wire _unused_ok = &{1\\='b0, - /*AUTOUNUSED*/ - 1\\='b0}; - // verilator lint_on UNUSED - endmodule + module ExampMain + #(parameter P) + (input i, output o, inout io); + endmodule -Typing \\[verilog-auto] will make this into: + module ExampStub (/*AUTOARG*/); + /*AUTOINOUTPARAM(\"ExampMain\")*/ + /*AUTOINOUTMODULE(\"ExampMain\")*/ - module ExampStub (/*AUTOINST*/...); - /*AUTOINOUTPARAM(\"Foo\")*/ - /*AUTOINOUTMODULE(\"Foo\")*/ - // Beginning of autotieoff - output [2:0] foo; - // End of automatics + /*AUTOTIEOFF*/ + + // verilator lint_off UNUSED + wire _unused_ok = &{1\\='b0, + /*AUTOUNUSED*/ + 1\\='b0}; + // verilator lint_on UNUSED + endmodule +Typing \\[verilog-auto] will make this into: + + ... /*AUTOTIEOFF*/ - // Beginning of autotieoff - wire [2:0] foo = 3\\='b0; + // Beginning of automatic tieoffs + wire [2:0] o = 3\\='b0; // End of automatics - ... - endmodule" + ..." (interactive) (save-excursion ;; Find beginning @@ -13311,7 +13373,7 @@ Typing \\[verilog-auto] will make this into: (when sig-list (verilog-forward-or-insert-line) (verilog-insert-indent "// Beginning of automatic tieoffs (for this module's unterminated outputs)\n") - (setq sig-list (sort (copy-alist sig-list) `verilog-signals-sort-compare)) + (setq sig-list (sort (copy-alist sig-list) #'verilog-signals-sort-compare)) (verilog-modi-cache-add-vars modi sig-list) ; Before we trash list (while sig-list (let ((sig (car sig-list))) @@ -13342,24 +13404,24 @@ Limitations: An example: - \\=`define XX_FOO - \\=`define M_BAR(x) - \\=`define M_BAZ - ... - \\=`ifdef NEVER - \\=`undef M_BAZ // Emacs will see this and not \\=`undef M_BAZ - \\=`endif - ... - /*AUTOUNDEF*/ + \\=`define XX_FOO + \\=`define M_BAR(x) + \\=`define M_BAZ + ... + \\=`ifdef NEVER + \\=`undef M_BAZ // Emacs will see this and not \\=`undef M_BAZ + \\=`endif + ... + /*AUTOUNDEF*/ Typing \\[verilog-auto] will make this into: - ... - /*AUTOUNDEF*/ - // Beginning of automatic undefs - \\=`undef XX_FOO - \\=`undef M_BAR - // End of automatics + ... + /*AUTOUNDEF*/ + // Beginning of automatic undefs + \\=`undef M_BAR + \\=`undef XX_FOO + // End of automatics You may also provide an optional regular expression, in which case only defines the regular expression will be undefed." @@ -13422,31 +13484,36 @@ You can add signals you do not want included in AUTOUNUSED with An example of making a stub for another module: - module ExampStub (/*AUTOINST*/); - /*AUTOINOUTPARAM(\"Examp\")*/ - /*AUTOINOUTMODULE(\"Examp\")*/ - /*AUTOTIEOFF*/ - // verilator lint_off UNUSED - wire _unused_ok = &{1\\='b0, - /*AUTOUNUSED*/ - 1\\='b0}; - // verilator lint_on UNUSED - endmodule + module ExampMain + (input unused_input_a, input unused_input_b); + endmodule + + module ExampStub2 (/*AUTOARG*/); + /*AUTOINOUTPARAM(\"ExampMain\")*/ + /*AUTOINOUTMODULE(\"ExampMain\")*/ + + /*AUTOTIEOFF*/ + + // verilator lint_off UNUSED + wire _unused_ok = &{1\\='b0, + /*AUTOUNUSED*/ + 1\\='b0}; + // verilator lint_on UNUSED + endmodule Typing \\[verilog-auto] will make this into: - ... - // verilator lint_off UNUSED - wire _unused_ok = &{1\\='b0, - /*AUTOUNUSED*/ - // Beginning of automatics - unused_input_a, - unused_input_b, - unused_input_c, - // End of automatics - 1\\='b0}; - // verilator lint_on UNUSED - endmodule" + ... + // verilator lint_off UNUSED + wire _unused_ok = &{1\\='b0, + /*AUTOUNUSED*/ + // Beginning of automatics + unused_input_a, + unused_input_b + // End of automatics + 1\\='b0}; + // verilator lint_on UNUSED + endmodule" (interactive) (save-excursion ;; Find beginning @@ -13464,7 +13531,7 @@ Typing \\[verilog-auto] will make this into: (when sig-list (verilog-forward-or-insert-line) (verilog-insert-indent "// Beginning of automatic unused inputs\n") - (setq sig-list (sort (copy-alist sig-list) `verilog-signals-sort-compare)) + (setq sig-list (sort (copy-alist sig-list) #'verilog-signals-sort-compare)) (while sig-list (let ((sig (car sig-list))) (indent-to indent-pt) @@ -13513,39 +13580,38 @@ Finally, an AUTOASCIIENUM command is used. `verilog-auto-wire-type' may be used to change the datatype of the declarations. - \"auto enum\" may be used in place of \"synopsys enum\". + \"synopsys enum\" may be used in place of \"auto enum\". An example: - //== State enumeration - parameter [2:0] // synopsys enum state_info - SM_IDLE = 3\\='b000, - SM_SEND = 3\\='b001, - SM_WAIT1 = 3\\='b010; - //== State variables - reg [2:0] /* synopsys enum state_info */ - state_r; /* synopsys state_vector state_r */ - reg [2:0] /* synopsys enum state_info */ - state_e1; + //== State enumeration + parameter [2:0] // auto enum state_info + SM_IDLE = 3\\='b000, + SM_SEND = 3\\='b001, + SM_WAIT1 = 3\\='b010; + //== State variables + reg [2:0] /* auto enum state_info */ + state_r; /* auto state_vector state_r */ + reg [2:0] /* auto enum state_info */ + state_e1; - /*AUTOASCIIENUM(\"state_r\", \"state_ascii_r\", \"SM_\")*/ + /*AUTOASCIIENUM(\"state_r\", \"state_ascii_r\", \"SM_\")*/ Typing \\[verilog-auto] will make this into: - ... same front matter ... - - /*AUTOASCIIENUM(\"state_r\", \"state_ascii_r\", \"SM_\")*/ - // Beginning of automatic ASCII enum decoding - reg [39:0] state_ascii_r; // Decode of state_r - always @(state_r) begin - case ({state_r}) - SM_IDLE: state_ascii_r = \"idle \"; - SM_SEND: state_ascii_r = \"send \"; - SM_WAIT1: state_ascii_r = \"wait1\"; - default: state_ascii_r = \"%Erro\"; - endcase - end - // End of automatics" + ... + /*AUTOASCIIENUM(\"state_r\", \"state_ascii_r\", \"SM_\")*/ + // Beginning of automatic ASCII enum decoding + reg [39:0] state_ascii_r; // Decode of state_r + always @(state_r) begin + case ({state_r}) + SM_IDLE: state_ascii_r = \"idle \"; + SM_SEND: state_ascii_r = \"send \"; + SM_WAIT1: state_ascii_r = \"wait1\"; + default: state_ascii_r = \"%Erro\"; + endcase + end + // End of automatics" (save-excursion (let* ((params (verilog-read-auto-params 2 4)) (undecode-name (nth 0 params)) @@ -13657,9 +13723,11 @@ being different from the final output's line numbering." (while (re-search-forward " Templated T\\([0-9]+\\) L\\([0-9]+\\)" nil t) (replace-match (concat " Templated " - (int-to-string (+ (nth (string-to-number (match-string 1)) + (int-to-string (+ (nth (string-to-number + (match-string-no-properties 1)) template-line) - (string-to-number (match-string 2))))) + (string-to-number + (match-string-no-properties 2))))) t t)))) (defun verilog-auto-template-lint () @@ -13714,12 +13782,13 @@ The hooks `verilog-before-auto-hook' and `verilog-auto-hook' are called before and after this function, respectively. For example: - module ModuleName (/*AUTOARG*/); - /*AUTOINPUT*/ - /*AUTOOUTPUT*/ - /*AUTOWIRE*/ - /*AUTOREG*/ - InstMod instName #(/*AUTOINSTPARAM*/) (/*AUTOINST*/); + module ExampModule (/*AUTOARG*/); + /*AUTOINPUT*/ + /*AUTOOUTPUT*/ + /*AUTOWIRE*/ + /*AUTOREG*/ + InstMod instName #(/*AUTOINSTPARAM*/) (/*AUTOINST*/); + endmodule You can also update the AUTOs from the shell using: emacs --batch <filenames.v> -f verilog-batch-auto @@ -13790,7 +13859,7 @@ Wilson Snyder (wsnyder@wsnyder.org)." ;; Local state (verilog-read-auto-template-init) ;; If we're not in verilog-mode, change syntax table so parsing works right - (unless (eq major-mode `verilog-mode) (verilog-mode)) + (unless (eq major-mode 'verilog-mode) (verilog-mode)) ;; Allow user to customize (verilog-run-hooks 'verilog-before-auto-hook) ;; Try to save the user from needing to revert-file to reread file local-variables @@ -14201,13 +14270,13 @@ and the case items." (defun verilog-sk-define-signal () "Insert a definition of signal under point at top of module." (interactive "*") - (let* ((sig-re "[a-zA-Z0-9_]*") + (let* ((sig-chars "a-zA-Z0-9_") (v1 (buffer-substring (save-excursion - (skip-chars-backward sig-re) + (skip-chars-backward sig-chars) (point)) (save-excursion - (skip-chars-forward sig-re) + (skip-chars-forward sig-chars) (point))))) (if (not (member v1 verilog-keywords)) (save-excursion @@ -14421,11 +14490,14 @@ Files are checked based on `verilog-library-flags'." (when (and (not hit) (looking-at verilog-include-file-regexp)) (if (and (car (verilog-library-filenames - (match-string 1) (buffer-file-name))) + (match-string-no-properties 1) + (buffer-file-name))) (file-readable-p (car (verilog-library-filenames - (match-string 1) (buffer-file-name))))) + (match-string-no-properties 1) + (buffer-file-name))))) (find-file (car (verilog-library-filenames - (match-string 1) (buffer-file-name)))) + (match-string-no-properties 1) + (buffer-file-name)))) (when warn (message "File `%s' isn't readable, use shift-mouse2 to paste in this field" @@ -14510,7 +14582,6 @@ Files are checked based on `verilog-library-flags'." verilog-highlight-grouping-keywords verilog-highlight-includes verilog-highlight-modules - verilog-highlight-p1800-keywords verilog-highlight-translate-off verilog-indent-begin-after-if verilog-indent-declaration-macros diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index 506e9a6b2c7..9eedbf9cbc9 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -126,13 +126,15 @@ ;;; Code: -(eval-when-compile (require 'cl)) -(eval-and-compile - ;; Before Emacs-24.4, `pushnew' expands to runtime calls to `cl-adjoin' - ;; even for relatively simple cases such as used here. We only test <25 - ;; because it's easier and sufficient. - (when (or (featurep 'xemacs) (< emacs-major-version 25)) - (require 'cl))) +(eval-when-compile + (condition-case nil (require 'cl-lib) (file-missing (require 'cl))) + (defalias 'vhdl--pushnew (if (fboundp 'cl-pushnew) 'cl-pushnew 'pushnew))) + +;; Before Emacs-24.4, `pushnew' expands to runtime calls to `cl-adjoin' +;; even for relatively simple cases such as used here. We only test <25 +;; because it's easier and sufficient. +(when (< emacs-major-version 25) + (condition-case nil (require 'cl-lib) (file-missing (require 'cl)))) ;; Emacs 21+ handling (defconst vhdl-emacs-21 (and (<= 21 emacs-major-version) (not (featurep 'xemacs))) @@ -2474,7 +2476,7 @@ specified." (defun vhdl-resolve-env-variable (string) "Resolve environment variables in STRING." - (while (string-match "\\(.*\\)${?\\(\\(\\w\\|_\\)+\\)}?\\(.*\\)" string) + (while (string-match "\\(.*\\)\\${?\\(\\(\\w\\|_\\)+\\)}?\\(.*\\)" string) (setq string (concat (match-string 1 string) (getenv (match-string 2 string)) (match-string 4 string)))) @@ -4953,8 +4955,8 @@ Key bindings: (defun vhdl-write-file-hooks-init () "Add/remove hooks when buffer is saved." (if vhdl-modify-date-on-saving - (add-hook 'local-write-file-hooks 'vhdl-template-modify-noerror nil t) - (remove-hook 'local-write-file-hooks 'vhdl-template-modify-noerror t)) + (add-hook 'write-file-functions 'vhdl-template-modify-noerror nil t) + (remove-hook 'write-file-functions 'vhdl-template-modify-noerror t)) (if (featurep 'xemacs) (make-local-hook 'after-save-hook)) (add-hook 'after-save-hook 'vhdl-add-modified-file nil t)) @@ -6699,7 +6701,7 @@ search, and an argument indicating an interactive call." (if (and interactive (or (nth 3 state) (nth 4 state) - (looking-at (concat "[ \t]*" comment-start-skip)))) + (looking-at (concat "[ \t]*\\(?:" comment-start-skip "\\)")))) (forward-sentence (- count)) (while (> count 0) (vhdl-beginning-of-statement-1 lim) @@ -7392,8 +7394,8 @@ only-lines." (defun vhdl-update-progress-info (string pos) "Update progress information." (when (and vhdl-progress-info (not noninteractive) - (< vhdl-progress-interval - (- (nth 1 (current-time)) (aref vhdl-progress-info 2)))) + (time-less-p vhdl-progress-interval + (time-since (aref vhdl-progress-info 2)))) (let ((delta (- (aref vhdl-progress-info 1) (aref vhdl-progress-info 0)))) (message "%s... (%2d%%)" string @@ -7401,7 +7403,7 @@ only-lines." 100 (floor (* 100.0 (- pos (aref vhdl-progress-info 0))) delta)))) - (aset vhdl-progress-info 2 (nth 1 (current-time))))) + (aset vhdl-progress-info 2 (encode-time nil 'integer)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Indentation commands @@ -8142,12 +8144,12 @@ depending on parameter UPPER-CASE." (upcase-word -1) (downcase-word -1))) (when (and count vhdl-progress-interval (not noninteractive) - (< vhdl-progress-interval - (- (nth 1 (current-time)) last-update))) + (time-less-p vhdl-progress-interval + (time-since last-update))) (message "Fixing case... (%2d%s)" (+ (* count 20) (/ (* 20 (- (point) beg)) (- end beg))) "%") - (setq last-update (nth 1 (current-time))))) + (setq last-update (encode-time nil 'integer)))) (goto-char end))))) (defun vhdl-fix-case-region (beg end &optional arg) @@ -8707,17 +8709,11 @@ project is defined." ;; Enabling/disabling (define-minor-mode vhdl-electric-mode - "Toggle VHDL electric mode. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable it if ARG -is omitted or nil." + "Toggle VHDL electric mode." :global t :group 'vhdl-mode) (define-minor-mode vhdl-stutter-mode - "Toggle VHDL stuttering mode. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable it if ARG -is omitted or nil." + "Toggle VHDL stuttering mode." :global t :group 'vhdl-mode) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -14321,7 +14317,7 @@ of PROJECT." (vhdl-scan-directory-contents dir-name project nil (format "(%s/%s) " act-dir num-dir) (cdr dir-list)) - (pushnew (file-name-directory dir-name) dir-list-tmp :test #'equal) + (vhdl--pushnew (file-name-directory dir-name) dir-list-tmp :test #'equal) (setq dir-list (cdr dir-list) act-dir (1+ act-dir))) (vhdl-aput 'vhdl-directory-alist project (list (nreverse dir-list-tmp))) @@ -15121,7 +15117,7 @@ otherwise use cached data." (defun vhdl-speedbar-expand-project (text token indent) "Expand/contract the project under the cursor." (cond - ((string-match "+" text) ; expand project + ((string-match "\\+" text) ; expand project (speedbar-change-expand-button-char ?-) (unless (member token vhdl-speedbar-shown-project-list) (setq vhdl-speedbar-shown-project-list @@ -15143,7 +15139,7 @@ otherwise use cached data." (defun vhdl-speedbar-expand-entity (text token indent) "Expand/contract the entity under the cursor." (cond - ((string-match "+" text) ; expand entity + ((string-match "\\+" text) ; expand entity (let* ((key (vhdl-speedbar-line-key indent)) (ent-alist (vhdl-aget vhdl-entity-alist key)) (ent-entry (vhdl-aget ent-alist token)) @@ -15212,7 +15208,7 @@ otherwise use cached data." (defun vhdl-speedbar-expand-architecture (text token indent) "Expand/contract the architecture under the cursor." (cond - ((string-match "+" text) ; expand architecture + ((string-match "\\+" text) ; expand architecture (let* ((key (vhdl-speedbar-line-key (1- indent))) (ent-alist (vhdl-aget vhdl-entity-alist key)) (conf-alist (vhdl-aget vhdl-config-alist key)) @@ -15272,7 +15268,7 @@ otherwise use cached data." (defun vhdl-speedbar-expand-config (text token indent) "Expand/contract the configuration under the cursor." (cond - ((string-match "+" text) ; expand configuration + ((string-match "\\+" text) ; expand configuration (let* ((key (vhdl-speedbar-line-key indent)) (conf-alist (vhdl-aget vhdl-config-alist key)) (conf-entry (vhdl-aget conf-alist token)) @@ -15330,7 +15326,7 @@ otherwise use cached data." (defun vhdl-speedbar-expand-package (text token indent) "Expand/contract the package under the cursor." (cond - ((string-match "+" text) ; expand package + ((string-match "\\+" text) ; expand package (let* ((key (vhdl-speedbar-line-key indent)) (pack-alist (vhdl-aget vhdl-package-alist key)) (pack-entry (vhdl-aget pack-alist token)) @@ -15735,7 +15731,7 @@ NO-POSITION non-nil means do not re-position cursor." (defun vhdl-speedbar-dired (text token indent) "Speedbar click handler for directory expand button in hierarchy mode." - (cond ((string-match "+" text) ; we have to expand this dir + (cond ((string-match "\\+" text) ; we have to expand this dir (setq speedbar-shown-directories (cons (expand-file-name (concat (speedbar-line-directory indent) token "/")) @@ -16413,8 +16409,8 @@ component instantiation." (if (or (member constant-name single-list) (member constant-name multi-list)) (progn (setq single-list (delete constant-name single-list)) - (pushnew constant-name multi-list :test #'equal)) - (pushnew constant-name single-list :test #'equal)) + (vhdl--pushnew constant-name multi-list :test #'equal)) + (vhdl--pushnew constant-name single-list :test #'equal)) (unless (match-string 1) (setq generic-alist (cdr generic-alist))) (vhdl-forward-syntactic-ws)) @@ -16440,12 +16436,12 @@ component instantiation." (member signal-name multi-out-list)) (setq single-out-list (delete signal-name single-out-list)) (setq multi-out-list (delete signal-name multi-out-list)) - (pushnew signal-name local-list :test #'equal)) + (vhdl--pushnew signal-name local-list :test #'equal)) ((member signal-name single-in-list) (setq single-in-list (delete signal-name single-in-list)) - (pushnew signal-name multi-in-list :test #'equal)) + (vhdl--pushnew signal-name multi-in-list :test #'equal)) ((not (member signal-name multi-in-list)) - (pushnew signal-name single-in-list :test #'equal))) + (vhdl--pushnew signal-name single-in-list :test #'equal))) ;; output signal (cond ((member signal-name local-list) @@ -16454,12 +16450,12 @@ component instantiation." (member signal-name multi-in-list)) (setq single-in-list (delete signal-name single-in-list)) (setq multi-in-list (delete signal-name multi-in-list)) - (pushnew signal-name local-list :test #'equal)) + (vhdl--pushnew signal-name local-list :test #'equal)) ((member signal-name single-out-list) (setq single-out-list (delete signal-name single-out-list)) - (pushnew signal-name multi-out-list :test #'equal)) + (vhdl--pushnew signal-name multi-out-list :test #'equal)) ((not (member signal-name multi-out-list)) - (pushnew signal-name single-out-list :test #'equal)))) + (vhdl--pushnew signal-name single-out-list :test #'equal)))) (unless (match-string 1) (setq port-alist (cdr port-alist))) (vhdl-forward-syntactic-ws)) @@ -16542,14 +16538,14 @@ component instantiation." generic-end-pos (vhdl-compose-insert-generic constant-entry))) (setq generic-pos (point-marker)) - (pushnew constant-name written-list :test #'equal)) + (vhdl--pushnew constant-name written-list :test #'equal)) (t (vhdl-goto-marker (vhdl-max-marker generic-inst-pos generic-pos)) (setq generic-end-pos (vhdl-compose-insert-generic constant-entry)) (setq generic-inst-pos (point-marker)) - (pushnew constant-name written-list :test #'equal)))) + (vhdl--pushnew constant-name written-list :test #'equal)))) (setq constant-alist (cdr constant-alist))) (when (/= constant-temp-pos generic-inst-pos) (vhdl-goto-marker (vhdl-max-marker constant-temp-pos generic-pos)) @@ -16568,14 +16564,14 @@ component instantiation." (vhdl-max-marker port-end-pos (vhdl-compose-insert-port signal-entry))) (setq port-in-pos (point-marker)) - (pushnew signal-name written-list :test #'equal)) + (vhdl--pushnew signal-name written-list :test #'equal)) ((member signal-name multi-out-list) (vhdl-goto-marker (vhdl-max-marker port-out-pos port-in-pos)) (setq port-end-pos (vhdl-max-marker port-end-pos (vhdl-compose-insert-port signal-entry))) (setq port-out-pos (point-marker)) - (pushnew signal-name written-list :test #'equal)) + (vhdl--pushnew signal-name written-list :test #'equal)) ((or (member signal-name single-in-list) (member signal-name single-out-list)) (vhdl-goto-marker @@ -16584,12 +16580,12 @@ component instantiation." (vhdl-max-marker port-out-pos port-in-pos))) (setq port-end-pos (vhdl-compose-insert-port signal-entry)) (setq port-inst-pos (point-marker)) - (pushnew signal-name written-list :test #'equal)) + (vhdl--pushnew signal-name written-list :test #'equal)) ((equal (upcase (nth 2 signal-entry)) "OUT") (vhdl-goto-marker signal-pos) (vhdl-compose-insert-signal signal-entry) (setq signal-pos (point-marker)) - (pushnew signal-name written-list :test #'equal))) + (vhdl--pushnew signal-name written-list :test #'equal))) (setq signal-alist (cdr signal-alist))) (when (/= port-temp-pos port-inst-pos) (vhdl-goto-marker @@ -16940,7 +16936,7 @@ no project is defined." "Remove duplicate elements from IN-LIST." (let (out-list) (while in-list - (pushnew (car in-list) out-list :test #'equal) + (vhdl--pushnew (car in-list) out-list :test #'equal) (setq in-list (cdr in-list))) out-list)) diff --git a/lisp/progmodes/which-func.el b/lisp/progmodes/which-func.el index 28303022d96..564e0ff62c4 100644 --- a/lisp/progmodes/which-func.el +++ b/lisp/progmodes/which-func.el @@ -247,9 +247,6 @@ It creates the Imenu index for the buffer, if necessary." ;;;###autoload (define-minor-mode which-function-mode "Toggle mode line display of current function (Which Function mode). -With a prefix argument ARG, enable Which Function mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Which Function mode is a global minor mode. When enabled, the current function name is continuously displayed in the mode line, @@ -275,16 +272,21 @@ It calls them sequentially, and if any returns non-nil, (defun which-function () "Return current function name based on point. -Uses `which-func-functions', `imenu--index-alist' -or `add-log-current-defun'. +Uses `which-func-functions', `add-log-current-defun'. +or `imenu--index-alist' If no function name is found, return nil." (let ((name ;; Try the `which-func-functions' functions first. (run-hook-with-args-until-success 'which-func-functions))) - + ;; Try using add-log support. + (when (null name) + (setq name (add-log-current-defun))) ;; If Imenu is loaded, try to make an index alist with it. (when (and (null name) - (boundp 'imenu--index-alist) (null imenu--index-alist) + (boundp 'imenu--index-alist) + (or (null imenu--index-alist) + ;; Update if outdated + (/= (buffer-chars-modified-tick) imenu-menubar-modified-tick)) (null which-function-imenu-failed)) (ignore-errors (imenu--make-index-alist t)) (unless imenu--index-alist @@ -326,10 +328,6 @@ If no function name is found, return nil." (funcall which-func-imenu-joiner-function (reverse (cons (car pair) namestack)))))))))))) - - ;; Try using add-log support. - (when (null name) - (setq name (add-log-current-defun))) ;; Filter the name if requested. (when name (if which-func-cleanup-function diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index e59bfdd36d2..57d803894c8 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -71,9 +71,6 @@ (require 'ring) (require 'project) -(eval-when-compile - (require 'semantic/symref)) ;; for hit-lines slot - (defgroup xref nil "Cross-referencing commands" :version "25.1" :group 'tools) @@ -101,6 +98,16 @@ This is typically the filename.") ;;;; Commonly needed location classes are defined here: +(defcustom xref-file-name-display 'abs + "Style of file name display in *xref* buffers. +If the value is the symbol `abs', the default, show the file names +in their full absolute form. +If `nondirectory', show only the nondirectory (a.k.a. \"base name\") +part of the file name." + :type '(choice (const :tag "absolute file name" abs) + (const :tag "nondirectory file name" nondirectory)) + :version "27.1") + ;; FIXME: might be useful to have an optional "hint" i.e. a string to ;; search for in case the line number is slightly out of date. (defclass xref-file-location (xref-location) @@ -129,7 +136,9 @@ Line numbers start from 1 and columns from 0.") (point-marker)))))) (cl-defmethod xref-location-group ((l xref-file-location)) - (oref l file)) + (cl-ecase xref-file-name-display + (abs (oref l file)) + (nondirectory (file-name-nondirectory (oref l file))))) (defclass xref-buffer-location (xref-location) ((buffer :type buffer :initarg :buffer) @@ -317,8 +326,12 @@ backward." ;;; Marker stack (M-. pushes, M-, pops) (defcustom xref-marker-ring-length 16 - "Length of the xref marker ring." - :type 'integer) + "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) (defcustom xref-prompt-for-identifier '(not xref-find-definitions xref-find-definitions-other-window @@ -354,6 +367,14 @@ elements is negated: these commands will NOT prompt." (defvar xref--marker-ring (make-ring xref-marker-ring-length) "Ring of markers to implement the marker stack.") +(defun xref-set-marker-ring-length (var val) + "Set `xref-marker-ring-length'. +VAR is the symbol `xref-marker-ring-length' and VAL is the new +value." + (set-default var val) + (if (ring-p xref--marker-ring) + (ring-resize xref--marker-ring val))) + (defun xref-push-marker-stack (&optional m) "Add point M (defaults to `point-marker') to the marker stack." (ring-insert xref--marker-ring (or m (point-marker)))) @@ -414,7 +435,7 @@ elements is negated: these commands will NOT prompt." (set-buffer (marker-buffer marker)) (xref--goto-char marker))) -(defun xref--pop-to-location (item &optional action) +(defun xref-pop-to-location (item &optional action) "Go to the location of ITEM and display the buffer. ACTION controls how the buffer is displayed: nil -- switch-to-buffer @@ -439,6 +460,18 @@ If SELECT is non-nil, select the target window." (defconst xref-buffer-name "*xref*" "The name of the buffer to show xrefs.") +(defface xref-file-header '((t :inherit compilation-info)) + "Face used to highlight file header in the xref buffer." + :version "27.1") + +(defface xref-line-number '((t :inherit compilation-line-number)) + "Face for displaying line numbers in the xref buffer." + :version "27.1") + +(defface xref-match '((t :inherit highlight)) + "Face used to highlight matches in the xref buffer." + :version "27.1") + (defmacro xref--with-dedicated-window (&rest body) `(let* ((xref-w (get-buffer-window xref-buffer-name)) (xref-w-dedicated (window-dedicated-p xref-w))) @@ -456,6 +489,9 @@ If SELECT is non-nil, select the target window." (defvar-local xref--original-window nil "The original window this xref buffer was created from.") +(defvar-local xref--fetcher nil + "The original function to call to fetch the list of xrefs.") + (defun xref--show-pos-in-buf (pos buf) "Goto and display position POS of buffer BUF in a window. Honor `xref--original-window-intent', run `xref-after-jump-hook' @@ -465,27 +501,18 @@ and finally return the window." (or (eq xref--original-window-intent 'frame) pop-up-frames)) (action - (cond ((memq - xref--original-window-intent - '(window frame)) + (cond ((eq xref--original-window-intent 'frame) t) + ((eq xref--original-window-intent 'window) + `((xref--display-buffer-in-other-window) + (window . ,xref--original-window))) ((and (window-live-p xref--original-window) (or (not (window-dedicated-p xref--original-window)) (eq (window-buffer xref--original-window) buf))) - `(,(lambda (buf _alist) - (set-window-buffer xref--original-window buf) - xref--original-window)))))) - (with-selected-window - (with-selected-window - ;; Just before `display-buffer', place ourselves in the - ;; original window to suggest preserving it. Of course, if - ;; user has deleted the original window, all bets are off, - ;; just use the selected one. - (or (and (window-live-p xref--original-window) - xref--original-window) - (selected-window)) - (display-buffer buf action)) + `((xref--display-buffer-in-window) + (window . ,xref--original-window)))))) + (with-selected-window (display-buffer buf action) (xref--goto-char pos) (run-hooks 'xref-after-jump-hook) (let ((buf (current-buffer))) @@ -493,6 +520,19 @@ and finally return the window." (setq-local other-window-scroll-buffer buf))) (selected-window)))) +(defun xref--display-buffer-in-other-window (buffer alist) + (let ((window (assoc-default 'window alist))) + (cl-assert window) + (xref--with-dedicated-window + (with-selected-window window + (display-buffer buffer t))))) + +(defun xref--display-buffer-in-window (buffer alist) + (let ((window (assoc-default 'window alist))) + (cl-assert window) + (with-selected-window window + (display-buffer buffer '(display-buffer-same-window))))) + (defun xref--show-location (location &optional select) "Help `xref-show-xref' and `xref-goto-xref' do their job. Go to LOCATION and if SELECT is non-nil select its window. If @@ -503,8 +543,9 @@ SELECT is `quit', also quit the *xref* window." (xref-buffer (current-buffer))) (cond (select (if (eq select 'quit) (quit-window nil nil)) - (with-current-buffer xref-buffer - (select-window (xref--show-pos-in-buf marker buf)))) + (select-window + (with-current-buffer xref-buffer + (xref--show-pos-in-buf marker buf)))) (t (save-selected-window (xref--with-dedicated-window @@ -541,9 +582,12 @@ SELECT is `quit', also quit the *xref* window." Non-interactively, non-nil QUIT means to first quit the *xref* buffer." (interactive) - (let ((xref (or (xref--item-at-point) - (user-error "No reference at point")))) - (xref--show-location (xref-item-location xref) (if quit 'quit t)))) + (let* ((buffer (current-buffer)) + (xref (or (xref--item-at-point) + (user-error "No reference at point"))) + (xref--current-item xref)) + (xref--show-location (xref-item-location xref) (if quit 'quit t)) + (next-error-found buffer (current-buffer)))) (defun xref-quit-and-goto-xref () "Quit *xref* buffer, then jump to xref on current line." @@ -677,6 +721,7 @@ references displayed in the current *xref* buffer." ;; suggested by Johan Claesson "to further reduce finger movement": (define-key map (kbd ".") #'xref-next-line) (define-key map (kbd ",") #'xref-prev-line) + (define-key map (kbd "g") #'xref-revert-buffer) map)) (define-derived-mode xref--xref-buffer-mode special-mode "XREF" @@ -685,14 +730,26 @@ references displayed in the current *xref* buffer." (setq next-error-function #'xref--next-error-function) (setq next-error-last-buffer (current-buffer))) +(defvar xref--transient-buffer-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") #'xref-quit-and-goto-xref) + (set-keymap-parent map xref--xref-buffer-mode-map) + map)) + +(define-derived-mode xref--transient-buffer-mode + xref--xref-buffer-mode + "XREF Transient") + (defun xref--next-error-function (n reset?) (when reset? (goto-char (point-min))) (let ((backward (< n 0)) (n (abs n)) (xref nil)) - (dotimes (_ n) - (setq xref (xref--search-property 'xref-item backward))) + (if (= n 0) + (setq xref (get-text-property (point) 'xref-item)) + (dotimes (_ n) + (setq xref (xref--search-property 'xref-item backward)))) (cond (xref ;; Save the current position (when the buffer is visible, ;; it gets reset to that window's point from time to time). @@ -704,7 +761,6 @@ references displayed in the current *xref* buffer." (defvar xref--button-map (let ((map (make-sparse-keymap))) - (define-key map [(control ?m)] #'xref-goto-xref) (define-key map [mouse-1] #'xref-goto-xref) (define-key map [mouse-2] #'xref--mouse-2) map)) @@ -714,7 +770,8 @@ references displayed in the current *xref* buffer." (interactive "e") (mouse-set-point event) (forward-line 0) - (xref--search-property 'xref-item) + (or (get-text-property (point) 'xref-item) + (xref--search-property 'xref-item)) (xref-show-location-at-point)) (defun xref--insert-xrefs (xref-alist) @@ -732,18 +789,17 @@ GROUP is a string for decoration purposes and XREF is an for line-format = (and max-line-width (format "%%%dd: " max-line-width)) do - (xref--insert-propertized '(face compilation-info) group "\n") + (xref--insert-propertized '(face xref-file-header) group "\n") (cl-loop for (xref . more2) on xrefs do (with-slots (summary location) xref (let* ((line (xref-location-line location)) (prefix (if line (propertize (format line-format line) - 'face 'compilation-line-number) + 'face 'xref-line-number) " "))) (xref--insert-propertized (list 'xref-item xref - ;; 'face 'font-lock-keyword-face 'mouse-face 'highlight 'keymap xref--button-map 'help-echo @@ -760,47 +816,121 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)." (xref-location-group (xref-item-location x))) #'equal)) -(defun xref--show-xref-buffer (xrefs alist) - (let ((xref-alist (xref--analyze xrefs))) +(defun xref--show-xref-buffer (fetcher alist) + (cl-assert (functionp fetcher)) + (let* ((xrefs + (or + (assoc-default 'fetched-xrefs alist) + (funcall fetcher))) + (xref-alist (xref--analyze xrefs))) (with-current-buffer (get-buffer-create xref-buffer-name) - (setq buffer-undo-list nil) - (let ((inhibit-read-only t) - (buffer-undo-list t)) - (erase-buffer) - (xref--insert-xrefs xref-alist) - (xref--xref-buffer-mode) - (pop-to-buffer (current-buffer)) - (goto-char (point-min)) - (setq xref--original-window (assoc-default 'window alist) - xref--original-window-intent (assoc-default 'display-action alist)) - (current-buffer))))) + (xref--xref-buffer-mode) + (xref--show-common-initialize xref-alist fetcher alist) + (pop-to-buffer (current-buffer)) + (current-buffer)))) + +(defun xref--show-common-initialize (xref-alist fetcher alist) + (setq buffer-undo-list nil) + (let ((inhibit-read-only t) + (buffer-undo-list t)) + (erase-buffer) + (xref--insert-xrefs xref-alist) + (goto-char (point-min)) + (setq xref--original-window (assoc-default 'window alist) + xref--original-window-intent (assoc-default 'display-action alist)) + (setq xref--fetcher fetcher))) + +(defun xref-revert-buffer () + "Refresh the search results in the current buffer." + (interactive) + (let ((inhibit-read-only t) + (buffer-undo-list t)) + (save-excursion + (erase-buffer) + (condition-case err + (xref--insert-xrefs + (xref--analyze (funcall xref--fetcher))) + (user-error + (insert + (propertize + (error-message-string err) + 'face 'error)))) + (goto-char (point-min))))) + +(defun xref--show-defs-buffer (fetcher alist) + (let ((xrefs (funcall fetcher))) + (cond + ((not (cdr xrefs)) + (xref-pop-to-location (car xrefs) + (assoc-default 'display-action alist))) + (t + (xref--show-xref-buffer fetcher + (cons (cons 'fetched-xrefs xrefs) + alist)))))) + +(defun xref--show-defs-buffer-at-bottom (fetcher alist) + "Show definitions list in a window at the bottom. +When there is more than one definition, split the selected window +and show the list in a small window at the bottom. And use a +local keymap that binds `RET' to `xref-quit-and-goto-xref'." + (let ((xrefs (funcall fetcher))) + (cond + ((not (cdr xrefs)) + (xref-pop-to-location (car xrefs) + (assoc-default 'display-action alist))) + (t + (with-current-buffer (get-buffer-create xref-buffer-name) + (xref--transient-buffer-mode) + (xref--show-common-initialize (xref--analyze xrefs) fetcher alist) + (pop-to-buffer (current-buffer) + '(display-buffer-in-direction . ((direction . below)))) + (current-buffer)))))) -;; This part of the UI seems fairly uncontroversial: it reads the -;; identifier and deals with the single definition case. -;; (FIXME: do we really want this case to be handled like that in -;; "find references" and "find regexp searches"?) -;; -;; The controversial multiple definitions case is handed off to -;; xref-show-xrefs-function. +(defcustom xref-show-xrefs-function 'xref--show-xref-buffer + "Function to display a list of search results. + +It should accept two arguments: FETCHER and ALIST. + +FETCHER is a function of no arguments that returns a list of xref +values. It must not depend on the current buffer or selected +window. + +ALIST can include, but limited to, the following keys: + +WINDOW for the window that was selected before the current +command was called. -(defvar xref-show-xrefs-function 'xref--show-xref-buffer - "Function to display a list of xrefs.") +DISPLAY-ACTION indicates where the target location should be +displayed. The possible values are nil, `window' meaning the +other window, or `frame' meaning the other frame." + :type 'function) + +(defcustom xref-show-definitions-function 'xref--show-defs-buffer + "Function to display a list of definitions. + +Accepts the same arguments as `xref-show-xrefs-function'." + :type 'function) (defvar xref--read-identifier-history nil) (defvar xref--read-pattern-history nil) -(defun xref--show-xrefs (xrefs display-action &optional always-show-list) - (cond - ((and (not (cdr xrefs)) (not always-show-list)) - (xref-push-marker-stack) - (xref--pop-to-location (car xrefs) display-action)) - (t - (xref-push-marker-stack) - (funcall xref-show-xrefs-function xrefs - `((window . ,(selected-window)) - (display-action . ,display-action)))))) +(defun xref--show-xrefs (fetcher display-action) + (xref--push-markers) + (funcall xref-show-xrefs-function fetcher + `((window . ,(selected-window)) + (display-action . ,display-action)))) + +(defun xref--show-defs (xrefs display-action) + (xref--push-markers) + (funcall xref-show-definitions-function xrefs + `((window . ,(selected-window)) + (display-action . ,display-action)))) + +(defun xref--push-markers () + (unless (region-active-p) (push-mark nil t)) + (xref-push-marker-stack)) (defun xref--prompt-p (command) (or (eq xref-prompt-for-identifier t) @@ -811,34 +941,66 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)." (defun xref--read-identifier (prompt) "Return the identifier at point or read it from the minibuffer." (let* ((backend (xref-find-backend)) - (id (xref-backend-identifier-at-point backend))) + (def (xref-backend-identifier-at-point backend))) (cond ((or current-prefix-arg - (not id) + (not def) (xref--prompt-p this-command)) - (completing-read (if id - (format "%s (default %s): " - (substring prompt 0 (string-match - "[ :]+\\'" prompt)) - id) - prompt) - (xref-backend-identifier-completion-table backend) - nil nil nil - 'xref--read-identifier-history id)) - (t id)))) + (let ((id + (completing-read + (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))) + (if (equal id "") + (or def (user-error "There is no defailt identifier")) + id))) + (t def)))) ;;; Commands (defun xref--find-xrefs (input kind arg display-action) - (let ((xrefs (funcall (intern (format "xref-backend-%s" kind)) - (xref-find-backend) - arg))) - (unless xrefs - (user-error "No %s found for: %s" (symbol-name kind) input)) - (xref--show-xrefs xrefs display-action))) + (xref--show-xrefs + (xref--create-fetcher input kind arg) + display-action)) (defun xref--find-definitions (id display-action) - (xref--find-xrefs id 'definitions id display-action)) + (xref--show-defs + (xref--create-fetcher id 'definitions id) + display-action)) + +(defun xref--create-fetcher (input kind arg) + "Return an xref list fetcher function. + +It revisits the saved position and delegates the finding logic to +the xref backend method indicated by KIND and passes ARG to it." + (let* ((orig-buffer (current-buffer)) + (orig-position (point)) + (backend (xref-find-backend)) + (method (intern (format "xref-backend-%s" kind)))) + (lambda () + (save-excursion + ;; Xref methods are generally allowed to depend on the text + ;; around point, not just on their explicit arguments. + ;; + ;; There is only so much we can do, however, to recreate that + ;; context, given that the user is free to change the buffer + ;; contents freely in the meantime. + (when (buffer-live-p orig-buffer) + (set-buffer orig-buffer) + (ignore-errors (goto-char orig-position))) + (let ((xrefs (funcall method backend arg))) + (unless xrefs + (xref--not-found-error kind input)) + xrefs))))) + +(defun xref--not-found-error (kind input) + (user-error "No %s found for: %s" (symbol-name kind) input)) ;;;###autoload (defun xref-find-definitions (identifier) @@ -876,6 +1038,19 @@ 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)) +;;;###autoload +(defun xref-find-definitions-at-mouse (event) + "Find the definition of identifier at or around mouse click. +This command is intended to be bound to a mouse event." + (interactive "e") + (let ((identifier + (save-excursion + (mouse-set-point event) + (xref-backend-identifier-at-point (xref-find-backend))))) + (if identifier + (xref-find-definitions identifier) + (user-error "No identifier here")))) + (declare-function apropos-parse-pattern "apropos" (pattern)) ;;;###autoload @@ -976,7 +1151,7 @@ IGNORES is a list of glob patterns." ;; do that reliably enough, without creating false negatives? (command (xref--rgrep-command (xref--regexp-to-extended regexp) files - (expand-file-name dir) + (file-local-name (expand-file-name dir)) ignores)) (def default-directory) (buf (get-buffer-create " *xref-grep*")) @@ -987,7 +1162,7 @@ IGNORES is a list of glob patterns." (erase-buffer) (setq default-directory def) (setq status - (call-process-shell-command command nil t)) + (process-file-shell-command command nil t)) (goto-char (point-min)) ;; Can't use the exit status: Grep exits with 1 to mean "no ;; matches found". Find exits with 1 if any of the invocations @@ -1028,7 +1203,8 @@ IGNORES is a list of glob patterns." 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))) - (when ignores + (if (not ignores) + "" (concat (shell-quote-argument "(") " -path " @@ -1089,6 +1265,7 @@ Such as the current syntax table and the applied syntax properties." (defun xref--collect-matches (hit regexp tmp-buffer) (pcase-let* ((`(,line ,file ,text) hit) + (file (and file (concat (file-remote-p default-directory) file))) (buf (xref--find-buffer-visiting file)) (syntax-needed (xref--regexp-syntax-dependent-p regexp))) (if buf @@ -1139,7 +1316,7 @@ Such as the current syntax table and the applied syntax properties." (end-column (- (match-end 0) line-beg)) (loc (xref-make-file-location file line beg-column)) (summary (buffer-substring line-beg line-end))) - (add-face-text-property beg-column end-column 'highlight + (add-face-text-property beg-column end-column 'xref-match t summary) (push (xref-make-match summary loc (- end-column beg-column)) matches))) diff --git a/lisp/ps-bdf.el b/lisp/ps-bdf.el index 1c818fd7ab4..2e75e53fc26 100644 --- a/lisp/ps-bdf.el +++ b/lisp/ps-bdf.el @@ -9,7 +9,7 @@ ;; National Institute of Advanced Industrial Science and Technology (AIST) ;; Registration Number H13PRO009 -;; Author: Kenichi Handa <handa@m17n.org> +;; Author: Kenichi Handa <handa@gnu.org> ;; (according to ack.texi) ;; Keywords: wp, BDF, font, PostScript ;; Package: ps-print @@ -70,13 +70,12 @@ for BDFNAME." (defsubst bdf-file-mod-time (filename) "Return modification time of FILENAME. -The value is a list of integers in the same format as `current-time'." - (nth 5 (file-attributes filename))) +The value is a timestamp in the same format as `current-time'." + (file-attribute-modification-time (file-attributes filename))) (defun bdf-file-newer-than-time (filename mod-time) "Return non-nil if and only if FILENAME is newer than MOD-TIME. -MOD-TIME is a modification time as a list of integers in the same -format as `current-time'." +MOD-TIME is a modification time in the same format as `current-time'." (let ((new-mod-time (bdf-file-mod-time filename))) (time-less-p mod-time new-mod-time))) @@ -145,7 +144,7 @@ See the documentation of the function `bdf-read-font-info' for more detail." (if (or (< code (aref code-range 4)) (> code (aref code-range 5))) (setq code (aref code-range 6))) - (+ (* (- (lsh code -8) (aref code-range 0)) + (+ (* (- (ash code -8) (aref code-range 0)) (1+ (- (aref code-range 3) (aref code-range 2)))) (- (logand code 255) (aref code-range 2)))) @@ -168,8 +167,7 @@ FONT-INFO is a list of the following format: (BDFFILE MOD-TIME FONT-BOUNDING-BOX RELATIVE-COMPOSE BASELINE-OFFSET CODE-RANGE MAXLEN OFFSET-VECTOR) -MOD-TIME is last modification time as a list of integers in the -same format as `current-time'. +MOD-TIME is last modification time in the same format as `current-time'. SIZE is a size of the font on 72 dpi device. This value is got from SIZE record of the font. @@ -262,7 +260,7 @@ CODE, where N and CODE are in the following relation: (setq code (read (current-buffer))) (if (< code 0) (search-forward "ENDCHAR") - (setq code0 (lsh code -8) + (setq code0 (ash code -8) code1 (logand code 255) min-code (min min-code code) max-code (max max-code code) diff --git a/lisp/ps-def.el b/lisp/ps-def.el index e3c9504a01f..f33f81770dd 100644 --- a/lisp/ps-def.el +++ b/lisp/ps-def.el @@ -1,11 +1,9 @@ -;;; ps-def.el --- XEmacs and Emacs definitions for ps-print -*- lexical-binding: t -*- +;;; ps-def.el --- Emacs definitions for ps-print -*- lexical-binding: t -*- ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Kenichi Handa <handa@m17n.org> (multi-byte characters) -;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters) -;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> +;; Kenichi Handa <handa@gnu.org> (multi-byte characters) ;; Keywords: wp, print, PostScript ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre ;; Package: ps-print @@ -31,9 +29,6 @@ ;;; Code: -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r)))) - (declare-function ps-plot-with-face "ps-print" (from to face)) (declare-function ps-plot-string "ps-print" (string)) @@ -42,316 +37,104 @@ -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; XEmacs Definitions - - -(cond - ((featurep 'xemacs) ; XEmacs - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; ps-bdf - - (defvar installation-directory nil) - (defvar coding-system-for-read) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; ps-mule - - (or (fboundp 'charset-dimension) - (defun charset-dimension (_charset) 1)) ; ascii - - (or (fboundp 'char-width) - (defun char-width (_char) 1)) ; ascii - - (or (fboundp 'encode-char) - (defun encode-char (ch _ccs) - ch)) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; ps-print - - ;; GNU Emacs - (or (fboundp 'line-beginning-position) - (defun line-beginning-position (&optional n) - (save-excursion - (and n (/= n 1) (forward-line (1- n))) - (beginning-of-line) - (point)))) - - - ;; GNU Emacs - (or (fboundp 'find-composition) - (defalias 'find-composition 'ignore)) - - - (defun ps-xemacs-color-name (color) - (if (color-specifier-p color) - (color-name color) - color)) - - - (defalias 'ps-mark-active-p 'region-active-p) - - - (defun ps-face-foreground-name (face) - (ps-xemacs-color-name (face-foreground face))) - - - (defun ps-face-background-name (face) - (ps-xemacs-color-name (face-background face))) - - - (defalias 'ps-frame-parameter 'frame-property) - - - ;; Return t if the device (which can be changed during an emacs session) - ;; can handle colors. - (defun ps-color-device () - (eq (device-class) 'color)) - - (defun ps-mapper (extent list) - (nconc list - (list (list (extent-start-position extent) 'push extent) - (list (extent-end-position extent) 'pull extent))) - nil) - - - (defun ps-extent-sorter (a b) - (< (extent-priority a) (extent-priority b))) - - - (defun ps-xemacs-face-kind-p (face kind kind-regex) - (let* ((frame-font (or (face-font-instance face) - (face-font-instance 'default))) - (kind-cons - (and frame-font - (assq kind - (font-instance-properties frame-font)))) - (kind-spec (cdr-safe kind-cons)) - (case-fold-search t)) - (and kind-spec (string-match kind-regex kind-spec)))) - - - ;; to avoid XEmacs compilation gripes - (defvar coding-system-for-write) - (defvar buffer-file-coding-system) - - (and (fboundp 'find-coding-system) - (or (funcall 'find-coding-system 'raw-text-unix) - (funcall 'copy-coding-system 'no-conversion-unix 'raw-text-unix))) - - - (defun ps-color-values (x-color) - (let ((color (ps-xemacs-color-name x-color))) - (cond - ((fboundp 'x-color-values) - (funcall 'x-color-values color)) - ((and (fboundp 'color-instance-rgb-components) - (ps-color-device)) - (funcall 'color-instance-rgb-components - (if (color-instance-p x-color) - x-color - (make-color-instance color)))) - (t - (error "No available function to determine X color values"))))) - - - (defun ps-face-bold-p (face) - (or (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold") - (memq face ps-bold-faces))) ; Kludge-compatible - - - (defun ps-face-italic-p (face) - (or (ps-xemacs-face-kind-p face 'ANGLE_NAME "i\\|o") - (ps-xemacs-face-kind-p face 'SLANT "i\\|o") - (memq face ps-italic-faces))) ; Kludge-compatible - - - (defalias 'ps-face-strikeout-p 'ignore) - - - (defalias 'ps-face-overline-p 'ignore) - - - (defalias 'ps-face-box-p 'ignore) - - - ;; XEmacs will have to make do with %s (princ) for floats. - (defvar ps-color-format "%s %s %s") - (defvar ps-float-format "%s ") - - - (defun ps-generate-postscript-with-faces1 (from to) - ;; Generate some PostScript. - (let ((face 'default) - (position to) - ;; XEmacs - ;; Build the list of extents... - (a (cons 'dummy nil)) - record type extent extent-list) - (map-extents 'ps-mapper nil from to a) - (setq a (sort (cdr a) 'car-less-than-car) - extent-list nil) - - ;; Loop through the extents... - (while a - (setq record (car a) - position (car record) - - record (cdr record) - type (car record) - - record (cdr record) - extent (car record)) - - ;; Plot up to this record. - ;; XEmacs 19.12: for some reason, we're getting into a - ;; situation in which some of the records have - ;; positions less than 'from'. Since we've narrowed - ;; the buffer, this'll generate errors. This is a hack, - ;; but don't call ps-plot-with-face unless from > point-min. - (and (>= from (point-min)) - (ps-plot-with-face from (min position (point-max)) face)) - - (cond - ((eq type 'push) - (and (extent-face extent) - (setq extent-list (sort (cons extent extent-list) - 'ps-extent-sorter)))) - - ((eq type 'pull) - (setq extent-list (sort (delq extent extent-list) - 'ps-extent-sorter)))) - - (setq face (if extent-list - (extent-face (car extent-list)) - 'default) - from position - a (cdr a))) - - (ps-plot-with-face from to face))) - - ) - (t ; Emacs - ;; Do nothing - )) ; end cond featurep - - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Emacs Definitions -(cond - ((featurep 'xemacs) ; XEmacs - ;; Do nothing - ) - (t ; Emacs - - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; ps-print - - - (defun ps-mark-active-p () - mark-active) - +(defun ps-mark-active-p () + mark-active) - (defun ps-face-foreground-name (face) - (face-foreground face nil t)) +(defun ps-face-foreground-name (face) + (face-foreground face nil t)) - (defun ps-face-background-name (face) - (face-background face nil t)) +(defun ps-face-background-name (face) + (face-background face nil t)) - (defalias 'ps-frame-parameter 'frame-parameter) +(defalias 'ps-frame-parameter 'frame-parameter) - ;; Return t if the device (which can be changed during an emacs session) can - ;; handle colors. This function is not yet implemented for GNU emacs. - (defun ps-color-device () - (if (fboundp 'color-values) - (funcall 'color-values "Green") - t)) +;; Return t if the device (which can be changed during an emacs session) can +;; handle colors. This function is not yet implemented for GNU emacs. +(defun ps-color-device () + (if (fboundp 'color-values) + (funcall 'color-values "Green") + t)) - (defun ps-color-values (x-color) - (cond - ((fboundp 'color-values) - (funcall 'color-values x-color)) - ((fboundp 'x-color-values) - (funcall 'x-color-values x-color)) - (t - (error "No available function to determine X color values")))) +(defun ps-color-values (x-color) + (cond + ((fboundp 'color-values) + (funcall 'color-values x-color)) + ((fboundp 'x-color-values) + (funcall 'x-color-values x-color)) + (t + (error "No available function to determine X color values")))) - (defun ps-face-bold-p (face) - (or (face-bold-p face) - (memq face ps-bold-faces))) +(defun ps-face-bold-p (face) + (or (face-bold-p face) + (memq face ps-bold-faces))) - (defun ps-face-italic-p (face) - (or (face-italic-p face) - (memq face ps-italic-faces))) +(defun ps-face-italic-p (face) + (or (face-italic-p face) + (memq face ps-italic-faces))) - (defun ps-face-strikeout-p (face) - (eq (face-attribute face :strike-through) t)) +(defun ps-face-strikeout-p (face) + (eq (face-attribute face :strike-through) t)) - (defun ps-face-overline-p (face) - (eq (face-attribute face :overline) t)) +(defun ps-face-overline-p (face) + (eq (face-attribute face :overline) t)) - (defun ps-face-box-p (face) - (not (memq (face-attribute face :box) '(nil unspecified)))) +(defun ps-face-box-p (face) + (not (memq (face-attribute face :box) '(nil unspecified)))) - ;; Emacs understands the %f format; we'll use it to limit color RGB values - ;; to three decimals to cut down some on the size of the PostScript output. - (defvar ps-color-format "%0.3f %0.3f %0.3f") - (defvar ps-float-format "%0.3f ") +;; Emacs understands the %f format; we'll use it to limit color RGB values +;; to three decimals to cut down some on the size of the PostScript output. +(defvar ps-color-format "%0.3f %0.3f %0.3f") +(defvar ps-float-format "%0.3f ") - (defun ps-generate-postscript-with-faces1 (from to) - ;; Generate some PostScript. - (let ((face 'default) - (position to) - ;; Emacs - (property-change from) - (overlay-change from) - before-string after-string) - (while (< from to) - (and (< property-change to) ; Don't search for property change +(defun ps-generate-postscript-with-faces1 (from to) + ;; Generate some PostScript. + (let ((face 'default) + (position to) + ;; Emacs + (property-change from) + (overlay-change from) + before-string after-string) + (while (< from to) + (and (< property-change to) ; Don't search for property change ; unless previous search succeeded. - (setq property-change (next-property-change from nil to))) - (and (< overlay-change to) ; Don't search for overlay change + (setq property-change (next-property-change from nil to))) + (and (< overlay-change to) ; Don't search for overlay change ; unless previous search succeeded. - (setq overlay-change (min (next-overlay-change from) - to))) - (setq position (min property-change overlay-change) - before-string nil - after-string nil) - (setq face - (cond ((invisible-p from) - 'emacs--invisible--face) - ((get-char-property from 'face)) - (t 'default))) - ;; Plot up to this record. - (and before-string - (ps-plot-string before-string)) - (ps-plot-with-face from position face) - (and after-string - (ps-plot-string after-string)) - (setq from position)) - (ps-plot-with-face from to face))) - - )) ; end cond featurep + (setq overlay-change (min (next-overlay-change from) + to))) + (setq position (min property-change overlay-change) + before-string nil + after-string nil) + (setq face + (cond ((invisible-p from) + 'emacs--invisible--face) + ((get-char-property from 'face)) + (t 'default))) + ;; Plot up to this record. + (and before-string + (ps-plot-string before-string)) + (ps-plot-with-face from position face) + (and after-string + (ps-plot-string after-string)) + (setq from position)) + (ps-plot-with-face from to face))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/lisp/ps-mule.el b/lisp/ps-mule.el index 9a32b05526e..24604e9d5cf 100644 --- a/lisp/ps-mule.el +++ b/lisp/ps-mule.el @@ -2,10 +2,8 @@ ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Kenichi Handa <handa@m17n.org> (multi-byte characters) -;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters) -;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> +;; Kenichi Handa <handa@gnu.org> (multi-byte characters) ;; Keywords: wp, print, PostScript, multibyte, mule ;; Package: ps-print @@ -1031,7 +1029,7 @@ the sequence." (setq ps-mule-prologue-generated nil ps-mule-composition-prologue-generated nil ps-mule-bitmap-prologue-generated nil) - (mapcar `(lambda (x) (setcar (nthcdr 2 x) nil)) + (mapcar (lambda (x) (setcar (nthcdr 2 x) nil)) ps-mule-external-libraries)) (defun ps-mule-encode-header-string (string fonttag) diff --git a/lisp/ps-print.el b/lisp/ps-print.el index 000aa850834..8dd1d1e2bf2 100644 --- a/lisp/ps-print.el +++ b/lisp/ps-print.el @@ -4,14 +4,15 @@ ;; Author: Jim Thompson (was <thompson@wg2.waii.com>) ;; Jacques Duthen (was <duthen@cegelec-red.fr>) -;; Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Kenichi Handa <handa@m17n.org> (multi-byte characters) -;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters) -;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> +;; Kenichi Handa <handa@gnu.org> (multi-byte characters) +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, print, PostScript ;; Version: 7.3.5 ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre +(eval-when-compile (require 'cl-lib)) + (defconst ps-print-version "7.3.5" "ps-print.el, v 7.3.5 <2009/12/23 vinicius> @@ -20,7 +21,7 @@ Emacs without changes to the version number. When reporting bugs, please also report the version of Emacs, if any, that ps-print was distributed with. Please send all bug fixes and enhancements to - bug-gnu-emacs@gnu.org and Vinicius Jose Latorre <viniciusjl@ig.com.br>.") + bug-gnu-emacs@gnu.org and Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>.") ;; This file is part of GNU Emacs. @@ -46,7 +47,7 @@ Please send all bug fixes and enhancements to ;; ;; This package provides printing of Emacs buffers on PostScript printers; the ;; buffer's bold and italic text attributes are preserved in the printer -;; output. ps-print is intended for use with Emacs or XEmacs, together with a +;; output. ps-print is intended for use with Emacs, together with a ;; fontifying package such as font-lock or hilit. ;; ;; ps-print uses the same face attributes defined through font-lock or hilit to @@ -1216,7 +1217,7 @@ Please send all bug fixes and enhancements to ;; New since version 2.8 ;; --------------------- ;; -;; [vinicius] Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; [vinicius] Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; ;; 2007-10-27 ;; `ps-fg-validate-p', `ps-fg-list' @@ -1274,7 +1275,7 @@ Please send all bug fixes and enhancements to ;; ;; `ps-print-region-function' ;; -;; [vinicius] Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; [vinicius] Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; ;; 1999-03-01 ;; PostScript tumble and setpagedevice. @@ -1287,7 +1288,7 @@ Please send all bug fixes and enhancements to ;; ;; Multi-byte buffer handling. ;; -;; [vinicius] Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; [vinicius] Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; ;; 1998-03-06 ;; Skip invisible text. @@ -1403,7 +1404,7 @@ Please send all bug fixes and enhancements to ;; prologue code suggestion, for odd/even printing suggestion and for ;; `ps-prologue-file' enhancement. ;; -;; Thanks to Ken'ichi Handa <handa@m17n.org> for multi-byte buffer handling. +;; Thanks to Ken'ichi Handa <handa@gnu.org> for multi-byte buffer handling. ;; ;; Thanks to Matthew O Persico <Matthew.Persico@lazard.com> for line number on ;; empty columns. @@ -1463,16 +1464,7 @@ Please send all bug fixes and enhancements to (require 'lpr) - -(if (featurep 'xemacs) - (or (featurep 'lisp-float-type) - (error "`ps-print' requires floating point support")) - (unless (and (boundp 'emacs-major-version) - (>= emacs-major-version 23)) - (error "`ps-print' only supports Emacs 23 and higher"))) - - -;; Load XEmacs/Emacs definitions +;; Load Emacs definitions (require 'ps-def) ;; autoloads for secondary file @@ -1773,7 +1765,7 @@ See `ps-lpr-command'." (defcustom ps-print-region-function (if (memq system-type '(ms-dos windows-nt)) - #'w32-direct-ps-print-region-function + 'w32-direct-ps-print-region-function #'call-process-region) "Specify a function to print the region on a PostScript printer. See definition of `call-process-region' for calling conventions. The fourth @@ -2950,13 +2942,8 @@ Either a float or a cons of floats (LANDSCAPE-SIZE . PORTRAIT-SIZE)." ;;; Colors ;; Printing color requires x-color-values. -;; XEmacs change: Need autoload for the "Options->Printing->Color Printing" -;; widget to work. ;;;###autoload -(defcustom ps-print-color-p - (or (fboundp 'x-color-values) ; Emacs - (fboundp 'color-instance-rgb-components)) - ; XEmacs +(defcustom ps-print-color-p (fboundp 'x-color-values) "Specify how buffer's text color is printed. Valid values are: @@ -3380,13 +3367,7 @@ It's like the very first character of buffer (or region) is ^L (\\014)." :version "20" :group 'ps-print-headers) -(defcustom ps-postscript-code-directory - (cond ((fboundp 'locate-data-directory) ; XEmacs - (locate-data-directory "ps-print")) - ((boundp 'data-directory) ; XEmacs and Emacs. - data-directory) - (t ; don't know what to do - (error "`ps-postscript-code-directory' isn't set properly"))) +(defcustom ps-postscript-code-directory data-directory "Directory where it's located the PostScript prologue file used by ps-print. By default, this directory is the same as in the variable `data-directory'." :type 'directory @@ -3631,8 +3612,7 @@ The table depends on the current ps-print setup." (mapconcat #'ps-print-quote (list - (concat "\n;;; (" (if (featurep 'xemacs) "XEmacs" "Emacs") - ") ps-print version " ps-print-version "\n") + (concat "\n;;; (Emacs) ps-print version " ps-print-version "\n") ";; internal vars" (ps-comment-string "emacs-version " emacs-version) (ps-comment-string "lpr-windows-system" lpr-windows-system) @@ -4140,48 +4120,6 @@ If EXTENSION is any other symbol, it is ignored." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Adapted from font-lock: (obsolete stuff) -;; Originally face attributes were specified via `font-lock-face-attributes'. -;; Users then changed the default face attributes by setting that variable. -;; However, we try and be back-compatible and respect its value if set except -;; for faces where M-x customize has been used to save changes for the face. - - -(defun ps-font-lock-face-attributes () - (and (boundp 'font-lock-mode) (symbol-value 'font-lock-mode) - (boundp 'font-lock-face-attributes) - (let ((face-attributes (symbol-value 'font-lock-face-attributes))) - (while face-attributes - (let* ((face-attribute - (car (prog1 face-attributes - (setq face-attributes (cdr face-attributes))))) - (face (car face-attribute))) - ;; Rustle up a `defface' SPEC from a - ;; `font-lock-face-attributes' entry. - (unless (get face 'saved-face) - (let ((foreground (nth 1 face-attribute)) - (background (nth 2 face-attribute)) - (bold-p (nth 3 face-attribute)) - (italic-p (nth 4 face-attribute)) - (underline-p (nth 5 face-attribute)) - face-spec) - (when foreground - (setq face-spec (cons ':foreground - (cons foreground face-spec)))) - (when background - (setq face-spec (cons ':background - (cons background face-spec)))) - (when bold-p - (setq face-spec (append '(:weight bold) face-spec))) - (when italic-p - (setq face-spec (append '(:slant italic) face-spec))) - (when underline-p - (setq face-spec (append '(:underline t) face-spec))) - (custom-declare-face face (list (list t face-spec)) nil) - ))))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Internal functions and variables @@ -4654,7 +4592,9 @@ page-height == ((floor print-height ((th + ls) * zh)) * ((th + ls) * zh)) - th (defsubst ps-output-string-prim (string) (insert "(") ;insert start-string delimiter (save-excursion ;insert string - (insert (string-as-unibyte string))) + (insert (if (multibyte-string-p string) + (encode-coding-string string 'utf-8) + string))) ;; Find and quote special characters as necessary for PS ;; This skips everything except control chars, non-ASCII chars, (, ) and \. (while (progn (skip-chars-forward " -'*-[]-~") (not (eobp))) @@ -5812,9 +5752,9 @@ XSTART YSTART are the relative position for the first page in a sheet.") ps-footer-font-size-internal (ps-get-font-size 'ps-footer-font-size) ps-control-or-escape-regexp (cond ((eq ps-print-control-characters '8-bit) - (string-as-unibyte "[\000-\037\177-\377]")) + "[\000-\037\177-\377]") ((eq ps-print-control-characters 'control-8-bit) - (string-as-unibyte "[\000-\037\177-\237]")) + "[\000-\037\177-\237]") ((eq ps-print-control-characters 'control) "[\000-\037\177]") (t "[\t\n\f]")) @@ -5869,6 +5809,7 @@ XSTART YSTART are the relative position for the first page in a sheet.") ;; They may be overridden by ps-mule-begin-job. ps-basic-plot-string-function 'ps-basic-plot-string ps-encode-header-string-function nil) + (cl-assert (not (multibyte-string-p ps-control-or-escape-regexp))) ;; initialize page dimensions (ps-get-page-dimensions) ;; final check @@ -6341,7 +6282,7 @@ If FACE is not a valid face name, use default face." (ps-font-number 'ps-font-for-text (or (aref ps-font-type (logand effect 3)) face)) - fg-color bg-color (lsh effect -2))))) + fg-color bg-color (ash effect -2))))) (goto-char to)) @@ -6350,10 +6291,6 @@ If FACE is not a valid face name, use default face." (defun ps-build-reference-face-lists () - ;; Ensure that face database is updated with faces on - ;; `font-lock-face-attributes' (obsolete stuff) - (ps-font-lock-face-attributes) - ;; Now, rebuild reference face lists (setq ps-print-face-alist nil) (if ps-auto-font-detect (mapc 'ps-map-face (face-list)) diff --git a/lisp/ps-samp.el b/lisp/ps-samp.el index cccf035834f..1a2f7742d2f 100644 --- a/lisp/ps-samp.el +++ b/lisp/ps-samp.el @@ -4,10 +4,9 @@ ;; Author: Jim Thompson (was <thompson@wg2.waii.com>) ;; Jacques Duthen (was <duthen@cegelec-red.fr>) -;; Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Kenichi Handa <handa@m17n.org> (multi-byte characters) -;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters) -;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> +;; Kenichi Handa <handa@gnu.org> (multi-byte characters) +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, print, PostScript ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre ;; Package: ps-print diff --git a/lisp/recentf.el b/lisp/recentf.el index 4390626ef20..4112b44e484 100644 --- a/lisp/recentf.el +++ b/lisp/recentf.el @@ -229,10 +229,6 @@ This item will replace the \"More...\" item." :group 'recentf :type 'boolean) -(define-obsolete-variable-alias 'recentf-menu-append-commands-p - 'recentf-menu-append-commands-flag - "22.1") - (defcustom recentf-menu-append-commands-flag t "Non-nil means to append command items to the menu." :group 'recentf @@ -1347,9 +1343,6 @@ That is, remove duplicates, non-kept, and excluded files." ;;;###autoload (define-minor-mode recentf-mode "Toggle \"Open Recent\" menu (Recentf mode). -With a prefix argument ARG, enable Recentf mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -Recentf mode if ARG is omitted or nil. When Recentf mode is enabled, a \"Open Recent\" submenu is displayed in the \"File\" menu, containing a list of files that diff --git a/lisp/rect.el b/lisp/rect.el index f180431a588..34f79e3ed3c 100644 --- a/lisp/rect.el +++ b/lisp/rect.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1985, 1999-2019 Free Software Foundation, Inc. -;; Maintainer: Didier Verna <didier@xemacs.org> +;; Maintainer: Didier Verna <didier@didierverna.net> ;; Keywords: internal ;; Package: emacs @@ -27,7 +27,7 @@ ;; in the Emacs manual. ;; ### NOTE: this file was almost completely rewritten by Didier Verna -;; <didier@xemacs.org> in July 1999. +;; in July 1999. ;;; Code: @@ -77,34 +77,35 @@ Point is at the end of the segment of this line within the rectangle." ;; At this stage, we don't know which of start/end is point/mark :-( ;; And in case start=end, it might still be that point and mark have ;; different crutches! - (let ((cw (window-parameter window 'rectangle--point-crutches))) - (cond - ((eq start (car cw)) - (let ((sc (cdr cw)) - (ec (if (eq end (car rectangle--mark-crutches)) - (cdr rectangle--mark-crutches) - (if rectangle--mark-crutches - (setq rectangle--mark-crutches nil)) - (goto-char end) (current-column)))) - (if (eq start end) (cons (min sc ec) (max sc ec)) (cons sc ec)))) - ((eq end (car cw)) - (if (eq start (car rectangle--mark-crutches)) - (cons (cdr rectangle--mark-crutches) (cdr cw)) + (save-excursion + (let ((cw (window-parameter window 'rectangle--point-crutches))) + (cond + ((eq start (car cw)) + (let ((sc (cdr cw)) + (ec (if (eq end (car rectangle--mark-crutches)) + (cdr rectangle--mark-crutches) + (if rectangle--mark-crutches + (setq rectangle--mark-crutches nil)) + (goto-char end) (current-column)))) + (if (eq start end) (cons (min sc ec) (max sc ec)) (cons sc ec)))) + ((eq end (car cw)) + (if (eq start (car rectangle--mark-crutches)) + (cons (cdr rectangle--mark-crutches) (cdr cw)) + (if rectangle--mark-crutches (setq rectangle--mark-crutches nil)) + (cons (progn (goto-char start) (current-column)) (cdr cw)))) + ((progn + (if cw (setf (window-parameter nil 'rectangle--point-crutches) nil)) + (eq start (car rectangle--mark-crutches))) + (let ((sc (cdr rectangle--mark-crutches)) + (ec (progn (goto-char end) (current-column)))) + (if (eq start end) (cons (min sc ec) (max sc ec)) (cons sc ec)))) + ((eq end (car rectangle--mark-crutches)) + (cons (progn (goto-char start) (current-column)) + (cdr rectangle--mark-crutches))) + (t (if rectangle--mark-crutches (setq rectangle--mark-crutches nil)) - (cons (progn (goto-char start) (current-column)) (cdr cw)))) - ((progn - (if cw (setf (window-parameter nil 'rectangle--point-crutches) nil)) - (eq start (car rectangle--mark-crutches))) - (let ((sc (cdr rectangle--mark-crutches)) - (ec (progn (goto-char end) (current-column)))) - (if (eq start end) (cons (min sc ec) (max sc ec)) (cons sc ec)))) - ((eq end (car rectangle--mark-crutches)) - (cons (progn (goto-char start) (current-column)) - (cdr rectangle--mark-crutches))) - (t - (if rectangle--mark-crutches (setq rectangle--mark-crutches nil)) - (cons (progn (goto-char start) (current-column)) - (progn (goto-char end) (current-column))))))) + (cons (progn (goto-char start) (current-column)) + (progn (goto-char end) (current-column)))))))) (defun rectangle--col-pos (col kind) (let ((c (move-to-column col))) @@ -167,6 +168,45 @@ The final point after the last operation will be returned." (<= (point) endpt)))) final-point))) +(defun rectangle-position-as-coordinates (position) + "Return cons of the column and line values of POSITION. +POSITION specifies a position of the current buffer. The value +returned has the form (COLUMN . LINE)." + (save-excursion + (goto-char position) + (let ((col (current-column)) + (line (line-number-at-pos))) + (cons col line)))) + +(defun rectangle-intersect-p (pos1 size1 pos2 size2) + "Return non-nil if two rectangles intersect. +POS1 and POS2 specify the positions of the upper-left corners of +the first and second rectangles as conses of the form (COLUMN . LINE). +SIZE1 and SIZE2 specify the dimensions of the first and second +rectangles, as conses of the form (WIDTH . HEIGHT)." + (let ((x1 (car pos1)) + (y1 (cdr pos1)) + (x2 (car pos2)) + (y2 (cdr pos2)) + (w1 (car size1)) + (h1 (cdr size1)) + (w2 (car size2)) + (h2 (cdr size2))) + (not (or (<= (+ x1 w1) x2) + (<= (+ x2 w2) x1) + (<= (+ y1 h1) y2) + (<= (+ y2 h2) y1))))) + +(defun rectangle-dimensions (start end) + "Return the dimensions of the rectangle with corners at START +and END. The returned value has the form of (WIDTH . HEIGHT)." + (save-excursion + (let* ((height (1+ (abs (- (line-number-at-pos end) + (line-number-at-pos start))))) + (cols (rectangle--pos-cols start end)) + (width (abs (- (cdr cols) (car cols))))) + (cons width height)))) + (defun delete-rectangle-line (startcol endcol fill) (when (= (move-to-column startcol (if fill t 'coerce)) startcol) (delete-region (point) @@ -604,6 +644,7 @@ with a prefix argument, prompt for START-AT and FORMAT." ;;;###autoload (define-minor-mode rectangle-mark-mode "Toggle the region as rectangular. + Activates the region if needed. Only lasts until the region is deactivated." nil nil nil (rectangle--reset-crutches) diff --git a/lisp/register.el b/lisp/register.el index 008c1611dfe..775e1a2cc92 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -39,9 +39,7 @@ (registerv (:constructor nil) (:constructor registerv--make (&optional data print-func jump-func insert-func)) - (:copier nil) - (:type vector) - :named) + (:copier nil)) (data nil :read-only t) (print-func nil :read-only t) (jump-func nil :read-only t) @@ -59,6 +57,7 @@ this sentence: JUMP-FUNC if provided, controls how `jump-to-register' jumps to the register. INSERT-FUNC if provided, controls how `insert-register' insert the register. They both receive DATA as argument." + (declare (obsolete "Use your own type with methods on register-val-(insert|describe|jump-to)" "27.1")) (registerv--make data print-func jump-func insert-func)) (defvar register-alist nil @@ -182,8 +181,11 @@ Use \\[jump-to-register] to go to that location or restore that configuration. Argument is a character, naming the register. Interactively, reads the register using `register-read-with-preview'." - (interactive (list (register-read-with-preview "Point to register: ") - current-prefix-arg)) + (interactive (list (register-read-with-preview + (if current-prefix-arg + "Frame configuration to register: " + "Point to register: ")) + current-prefix-arg)) ;; Turn the marker into a file-ref if the buffer is killed. (add-hook 'kill-buffer-hook 'register-swap-out nil t) (set-register register @@ -229,6 +231,7 @@ Interactively, reads the register using `register-read-with-preview'." (defalias 'register-to-point 'jump-to-register) (defun jump-to-register (register &optional delete) "Move point to location stored in a register. +Push the mark if jumping moves point, unless called in succession. If the register contains a file name, find that file. \(To put a file name in a register, you must use `set-register'.) If the register contains a window configuration (one frame) or a frameset @@ -242,36 +245,44 @@ Interactively, reads the register using `register-read-with-preview'." (interactive (list (register-read-with-preview "Jump to register: ") current-prefix-arg)) (let ((val (get-register register))) - (cond - ((registerv-p val) - (cl-assert (registerv-jump-func val) nil - "Don't know how to jump to register %s" - (single-key-description register)) - (funcall (registerv-jump-func val) (registerv-data val))) - ((and (consp val) (frame-configuration-p (car val))) - (set-frame-configuration (car val) (not delete)) - (goto-char (cadr val))) - ((and (consp val) (window-configuration-p (car val))) - (set-window-configuration (car val)) - (goto-char (cadr val))) - ((markerp val) - (or (marker-buffer val) - (user-error "That register's buffer no longer exists")) - (switch-to-buffer (marker-buffer val)) - (unless (or (= (point) (marker-position val)) - (eq last-command 'jump-to-register)) - (push-mark)) - (goto-char val)) - ((and (consp val) (eq (car val) 'file)) - (find-file (cdr val))) - ((and (consp 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))) - (user-error "Register access aborted")) - (find-file (nth 1 val)) - (goto-char (nth 2 val))) - (t - (user-error "Register doesn't contain a buffer position or configuration"))))) + (register-val-jump-to val delete))) + +(cl-defgeneric register-val-jump-to (_val _arg) + "Execute the \"jump\" operation of VAL. +ARG is the value of the prefix argument or nil." + (user-error "Register doesn't contain a buffer position or configuration")) + +(cl-defmethod register-val-jump-to ((val registerv) _arg) + (cl-assert (registerv-jump-func val) nil + "Don't know how to jump to register value %S" val) + (funcall (registerv-jump-func val) (registerv-data val))) + +(cl-defmethod register-val-jump-to ((val marker) _arg) + (or (marker-buffer val) + (user-error "That register's buffer no longer exists")) + (switch-to-buffer (marker-buffer val)) + (unless (or (= (point) (marker-position val)) + (eq last-command 'jump-to-register)) + (push-mark)) + (goto-char val)) + +(cl-defmethod register-val-jump-to ((val cons) delete) + (cond + ((frame-configuration-p (car val)) + (set-frame-configuration (car val) (not delete)) + (goto-char (cadr val))) + ((window-configuration-p (car val)) + (set-window-configuration (car val)) + (goto-char (cadr val))) + ((eq (car val) 'file) + (find-file (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))) + (user-error "Register access aborted")) + (find-file (nth 1 val)) + (goto-char (nth 2 val))) + (t (cl-call-next-method val delete)))) (defun register-swap-out () "Turn markers into file-query references when a buffer is killed." @@ -353,79 +364,97 @@ Interactively, reads the register using `register-read-with-preview'." (princ (single-key-description register)) (princ " contains ") (let ((val (get-register register))) + (register-val-describe val verbose))) + +(cl-defgeneric register-val-describe (val verbose) + "Print description of register value VAL to `standard-output'." + (princ "Garbage:\n") + (if verbose (prin1 val))) + +(cl-defmethod register-val-describe ((val registerv) _verbose) + (if (registerv-print-func val) + (funcall (registerv-print-func val) (registerv-data val)) + (princ "[UNPRINTABLE CONTENTS]."))) + +(cl-defmethod register-val-describe ((val number) _verbose) + (princ val)) + +(cl-defmethod register-val-describe ((val marker) _verbose) + (let ((buf (marker-buffer val))) + (if (null buf) + (princ "a marker in no buffer") + (princ "a buffer position:\n buffer ") + (princ (buffer-name buf)) + (princ ", position ") + (princ (marker-position val))))) + +(cl-defmethod register-val-describe ((val cons) verbose) + (cond + ((window-configuration-p (car val)) + (let* ((stored-window-config (car val)) + (window-config-frame (window-configuration-frame stored-window-config)) + (current-frame (selected-frame))) + (princ (format "a window configuration: %s." + (if (frame-live-p window-config-frame) + (with-selected-frame window-config-frame + (save-window-excursion + (set-window-configuration stored-window-config) + (concat + (mapconcat (lambda (w) (buffer-name (window-buffer w))) + (window-list (selected-frame)) ", ") + (unless (eq current-frame window-config-frame) + " in another frame")))) + "dead frame"))))) + + ((frame-configuration-p (car val)) + (princ "a frame configuration.")) + + ((eq (car val) 'file) + (princ "the file ") + (prin1 (cdr val)) + (princ ".")) + + ((eq (car val) 'file-query) + (princ "a file-query reference:\n file ") + (prin1 (car (cdr val))) + (princ ",\n position ") + (princ (car (cdr (cdr val)))) + (princ ".")) + + (t + (if verbose + (progn + (princ "the rectangle:\n") + (while val + (princ " ") + (princ (car val)) + (terpri) + (setq val (cdr val)))) + (princ "a rectangle starting with ") + (princ (car val)))))) + +(cl-defmethod register-val-describe ((val string) verbose) + (setq val (copy-sequence val)) + (if (eq yank-excluded-properties t) + (set-text-properties 0 (length val) nil val) + (remove-list-of-text-properties 0 (length val) + yank-excluded-properties val)) + (if verbose + (progn + (princ "the text:\n") + (princ val)) (cond - ((registerv-p val) - (if (registerv-print-func val) - (funcall (registerv-print-func val) (registerv-data val)) - (princ "[UNPRINTABLE CONTENTS]."))) - - ((numberp val) - (princ val)) - - ((markerp val) - (let ((buf (marker-buffer val))) - (if (null buf) - (princ "a marker in no buffer") - (princ "a buffer position:\n buffer ") - (princ (buffer-name buf)) - (princ ", position ") - (princ (marker-position val))))) - - ((and (consp val) (window-configuration-p (car val))) - (princ "a window configuration.")) - - ((and (consp val) (frame-configuration-p (car val))) - (princ "a frame configuration.")) - - ((and (consp val) (eq (car val) 'file)) - (princ "the file ") - (prin1 (cdr val)) - (princ ".")) - - ((and (consp val) (eq (car val) 'file-query)) - (princ "a file-query reference:\n file ") - (prin1 (car (cdr val))) - (princ ",\n position ") - (princ (car (cdr (cdr val)))) - (princ ".")) - - ((consp val) - (if verbose - (progn - (princ "the rectangle:\n") - (while val - (princ " ") - (princ (car val)) - (terpri) - (setq val (cdr val)))) - (princ "a rectangle starting with ") - (princ (car val)))) - - ((stringp val) - (setq val (copy-sequence val)) - (if (eq yank-excluded-properties t) - (set-text-properties 0 (length val) nil val) - (remove-list-of-text-properties 0 (length val) - yank-excluded-properties val)) - (if verbose - (progn - (princ "the text:\n") - (princ val)) - (cond - ;; Extract first N characters starting with first non-whitespace. - ((string-match (format "[^ \t\n].\\{,%d\\}" - ;; Deduct 6 for the spaces inserted below. - (min 20 (max 0 (- (window-width) 6)))) - val) - (princ "text starting with\n ") - (princ (match-string 0 val))) - ((string-match "^[ \t\n]+$" val) - (princ "whitespace")) - (t - (princ "the empty string"))))) + ;; Extract first N characters starting with first non-whitespace. + ((string-match (format "[^ \t\n].\\{,%d\\}" + ;; Deduct 6 for the spaces inserted below. + (min 20 (max 0 (- (window-width) 6)))) + val) + (princ "text starting with\n ") + (princ (match-string 0 val))) + ((string-match "^[ \t\n]+$" val) + (princ "whitespace")) (t - (princ "Garbage:\n") - (if verbose (prin1 val)))))) + (princ "the empty string"))))) (defun insert-register (register &optional arg) "Insert contents of register REGISTER. (REGISTER is a character.) @@ -441,24 +470,32 @@ Interactively, reads the register using `register-read-with-preview'." (not current-prefix-arg)))) (push-mark) (let ((val (get-register register))) - (cond - ((registerv-p val) - (cl-assert (registerv-insert-func val) nil - "Don't know how to insert register %s" - (single-key-description register)) - (funcall (registerv-insert-func val) (registerv-data val))) - ((consp val) - (insert-rectangle val)) - ((stringp val) - (insert-for-yank val)) - ((numberp val) - (princ val (current-buffer))) - ((and (markerp val) (marker-position val)) - (princ (marker-position val) (current-buffer))) - (t - (user-error "Register does not contain text")))) + (register-val-insert val)) (if (not arg) (exchange-point-and-mark))) +(cl-defgeneric register-val-insert (_val) + "Insert register value VAL." + (user-error "Register does not contain text")) + +(cl-defmethod register-val-insert ((val registerv)) + (cl-assert (registerv-insert-func val) nil + "Don't know how to insert register value %S" val) + (funcall (registerv-insert-func val) (registerv-data val))) + +(cl-defmethod register-val-insert ((val cons)) + (insert-rectangle val)) + +(cl-defmethod register-val-insert ((val string)) + (insert-for-yank val)) + +(cl-defmethod register-val-insert ((val number)) + (princ val (current-buffer))) + +(cl-defmethod register-val-insert ((val marker)) + (if (marker-position val) + (princ (marker-position val) (current-buffer)) + (cl-call-next-method val))) + (defun copy-to-register (register start end &optional delete-flag region) "Copy region into register REGISTER. With prefix arg, delete as well. diff --git a/lisp/registry.el b/lisp/registry.el index 52ff12360f2..8e2005b0a5a 100644 --- a/lisp/registry.el +++ b/lisp/registry.el @@ -358,11 +358,12 @@ return LIMIT such candidates. If SORTFUNC is provided, sort entries first and return candidates from beginning of list." (let* ((precious (oref db precious)) (precious-p (lambda (entry-key) - (memq (car entry-key) precious))) + (memq (car-safe entry-key) precious))) (data (oref db data)) (candidates (cl-loop for k being the hash-keys of data using (hash-values v) - when (cl-notany precious-p v) + when (and (listp v) + (cl-notany precious-p v)) collect (cons k v)))) ;; We want the full entries for sorting, but should only return a ;; list of entry keys. diff --git a/lisp/replace.el b/lisp/replace.el index 08feb8eae7e..7c6c6fc9b7f 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -39,7 +39,7 @@ (defcustom replace-char-fold nil "Non-nil means replacement commands should do character folding in matches. This means, for instance, that \\=' will match a large variety of -unicode quotes. +Unicode quotes. This variable affects `query-replace' and `replace-string', but not `replace-regexp'." :type 'boolean @@ -147,15 +147,27 @@ is highlighted lazily using isearch lazy highlighting (see See `replace-regexp' and `query-replace-regexp-eval'.") (defun query-replace-descr (string) - (mapconcat 'isearch-text-char-description string "")) + (setq string (copy-sequence string)) + (dotimes (i (length string)) + (let ((c (aref string i))) + (cond + ((< c ?\s) (add-text-properties + i (1+ i) + `(display ,(propertize (format "^%c" (+ c 64)) 'face 'escape-glyph)) + string)) + ((= c ?\^?) (add-text-properties + i (1+ i) + `(display ,(propertize "^?" 'face 'escape-glyph)) + string))))) + string) (defun query-replace--split-string (string) "Split string STRING at a substring with property `separator'." (let* ((length (length string)) (split-pos (text-property-any 0 length 'separator t string))) (if (not split-pos) - (substring-no-properties string) - (cons (substring-no-properties string 0 split-pos) + string + (cons (substring string 0 split-pos) (substring-no-properties string (or (text-property-not-all (1+ split-pos) length 'separator t string) @@ -273,7 +285,7 @@ the original string if not." (string-match "\\(\\`\\|[^\\]\\)\\(\\\\\\\\\\)*\\\\[,#]" to))) (setq to (nreverse (delete "" (cons to list)))) (replace-match-string-symbols to) - (cons 'replace-eval-replacement + (cons #'replace-eval-replacement (if (cdr to) (cons 'concat to) (car to)))) @@ -301,7 +313,9 @@ the original string if not." (to (if (consp from) (prog1 (cdr from) (setq from (car from))) (query-replace-read-to from prompt regexp-flag)))) (list from to - (and current-prefix-arg (not (eq current-prefix-arg '-))) + (or (and current-prefix-arg (not (eq current-prefix-arg '-))) + (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 '-))))) (defun query-replace (from-string to-string &optional delimited start end backward region-noncontiguous-p) @@ -345,6 +359,9 @@ character strings. Fourth and fifth arg START and END specify the region to operate on. +Arguments FROM-STRING, TO-STRING, DELIMITED, START, END, BACKWARD, and +REGION-NONCONTIGUOUS-P are passed to `perform-replace' (which see). + To customize possible responses, change the bindings in `query-replace-map'." (interactive (let ((common @@ -427,7 +444,10 @@ to terminate it. One space there, if any, will be discarded. When using those Lisp features interactively in the replacement text, TO-STRING is actually made a list instead of a string. -Use \\[repeat-complex-command] after this command for details." +Use \\[repeat-complex-command] after this command for details. + +Arguments REGEXP, TO-STRING, DELIMITED, START, END, BACKWARD, and +REGION-NONCONTIGUOUS-P are passed to `perform-replace' (which see)." (interactive (let ((common (query-replace-read-args @@ -450,7 +470,7 @@ Use \\[repeat-complex-command] after this command for details." (define-key esc-map [?\C-%] 'query-replace-regexp) -(defun query-replace-regexp-eval (regexp to-expr &optional delimited start end) +(defun query-replace-regexp-eval (regexp to-expr &optional delimited start end region-noncontiguous-p) "Replace some things after point matching REGEXP with the result of TO-EXPR. Interactive use of this function is deprecated in favor of the @@ -496,7 +516,10 @@ This function is not affected by `replace-char-fold'. Third arg DELIMITED (prefix arg if interactive), if non-nil, means replace only matches that are surrounded by word boundaries. -Fourth and fifth arg START and END specify the region to operate on." +Fourth and fifth arg START and END specify the region to operate on. + +Arguments REGEXP, DELIMITED, START, END, and REGION-NONCONTIGUOUS-P +are passed to `perform-replace' (which see)." (declare (obsolete "use the `\\,' feature of `query-replace-regexp' for interactive calls, and `search-forward-regexp'/`replace-match' for Lisp calls." "22.1")) @@ -518,11 +541,12 @@ for Lisp calls." "22.1")) (replace-match-string-symbols to) (list from (car to) current-prefix-arg (if (use-region-p) (region-beginning)) - (if (use-region-p) (region-end)))))) - (perform-replace regexp (cons 'replace-eval-replacement to-expr) - t 'literal delimited nil nil start end)) + (if (use-region-p) (region-end)) + (if (use-region-p) (region-noncontiguous-p)))))) + (perform-replace regexp (cons #'replace-eval-replacement to-expr) + t 'literal delimited nil nil start end nil region-noncontiguous-p)) -(defun map-query-replace-regexp (regexp to-strings &optional n start end) +(defun map-query-replace-regexp (regexp to-strings &optional n start end region-noncontiguous-p) "Replace some matches for REGEXP with various strings, in rotation. The second argument TO-STRINGS contains the replacement strings, separated by spaces. This command works like `query-replace-regexp' except that @@ -542,7 +566,10 @@ that reads REGEXP. A prefix argument N says to use each replacement string N times before rotating to the next. -Fourth and fifth arg START and END specify the region to operate on." +Fourth and fifth arg START and END specify the region to operate on. + +Arguments REGEXP, START, END, and REGION-NONCONTIGUOUS-P are passed to +`perform-replace' (which see)." (interactive (let* ((from (read-regexp "Map query replace (regexp): " nil query-replace-from-history-variable)) @@ -555,7 +582,8 @@ Fourth and fifth arg START and END specify the region to operate on." (and current-prefix-arg (prefix-numeric-value current-prefix-arg)) (if (use-region-p) (region-beginning)) - (if (use-region-p) (region-end))))) + (if (use-region-p) (region-end)) + (if (use-region-p) (region-noncontiguous-p))))) (let (replacements) (if (listp to-strings) (setq replacements to-strings) @@ -569,9 +597,9 @@ Fourth and fifth arg START and END specify the region to operate on." (1+ (string-match " " to-strings)))) (setq replacements (append replacements (list to-strings)) to-strings "")))) - (perform-replace regexp replacements t t nil n nil start end))) + (perform-replace regexp replacements t t nil n nil start end nil region-noncontiguous-p))) -(defun replace-string (from-string to-string &optional delimited start end backward) +(defun replace-string (from-string to-string &optional delimited start end backward region-noncontiguous-p) "Replace occurrences of FROM-STRING with TO-STRING. Preserve case in each match if `case-replace' and `case-fold-search' are non-nil and FROM-STRING has no uppercase letters. @@ -625,10 +653,11 @@ and TO-STRING is also null.)" (list (nth 0 common) (nth 1 common) (nth 2 common) (if (use-region-p) (region-beginning)) (if (use-region-p) (region-end)) - (nth 3 common)))) - (perform-replace from-string to-string nil nil delimited nil nil start end backward)) + (nth 3 common) + (if (use-region-p) (region-noncontiguous-p))))) + (perform-replace from-string to-string nil nil delimited nil nil start end backward region-noncontiguous-p)) -(defun replace-regexp (regexp to-string &optional delimited start end backward) +(defun replace-regexp (regexp to-string &optional delimited start end backward region-noncontiguous-p) "Replace things after point matching REGEXP with TO-STRING. Preserve case in each match if `case-replace' and `case-fold-search' are non-nil and REGEXP has no uppercase letters. @@ -701,8 +730,9 @@ which will run faster and will not set the mark or print anything." (list (nth 0 common) (nth 1 common) (nth 2 common) (if (use-region-p) (region-beginning)) (if (use-region-p) (region-end)) - (nth 3 common)))) - (perform-replace regexp to-string nil t delimited nil nil start end backward)) + (nth 3 common) + (if (use-region-p) (region-noncontiguous-p))))) + (perform-replace regexp to-string nil t delimited nil nil start end backward region-noncontiguous-p)) (defvar regexp-history nil @@ -820,7 +850,6 @@ If nil, uses `regexp-history'." (defalias 'delete-matching-lines 'flush-lines) (defalias 'count-matches 'how-many) - (defun keep-lines-read-args (prompt) "Read arguments for `keep-lines' and friends. Prompt for a regexp with PROMPT. @@ -900,9 +929,8 @@ a previously found match." (set-marker rend nil) nil) - (defun flush-lines (regexp &optional rstart rend interactive) - "Delete lines containing matches for REGEXP. + "Delete lines containing matches for REGEXP. When called from Lisp (and usually when called interactively as well, see below), applies to the part of the buffer after point. The line point is in is deleted if and only if it contains a @@ -923,7 +951,10 @@ a non-nil INTERACTIVE argument. If a match is split across lines, all the lines it lies in are deleted. They are deleted _before_ looking for the next match. Hence, a match -starting on the same line at which another match ended is ignored." +starting on the same line at which another match ended is ignored. + +Return the number of deleted matching lines. When called interactively, +also print the number." (interactive (progn (barf-if-buffer-read-only) @@ -938,7 +969,8 @@ starting on the same line at which another match ended is ignored." (setq rstart (point) rend (point-max-marker))) (goto-char rstart)) - (let ((case-fold-search + (let ((count 0) + (case-fold-search (if (and case-fold-search search-upper-case) (isearch-no-upper-case-p regexp t) case-fold-search))) @@ -948,10 +980,14 @@ starting on the same line at which another match ended is ignored." (delete-region (save-excursion (goto-char (match-beginning 0)) (forward-line 0) (point)) - (progn (forward-line 1) (point)))))) - (set-marker rend nil) - nil) - + (progn (forward-line 1) (point))) + (setq count (1+ count)))) + (set-marker rend nil) + (when interactive (message (ngettext "Deleted %d matching line" + "Deleted %d matching lines" + count) + count)) + count)) (defun how-many (regexp &optional rstart rend interactive) "Print and return number of matches for REGEXP following point. @@ -999,9 +1035,10 @@ a previously found match." (if (= opoint (point)) (forward-char 1) (setq count (1+ count)))) - (when interactive (message "%d occurrence%s" - count - (if (= count 1) "" "s"))) + (when interactive (message (ngettext "%d occurrence" + "%d occurrences" + count) + count)) count))) @@ -1069,10 +1106,9 @@ a previously found match." map) "Keymap for `occur-mode'.") -(defvar occur-revert-arguments nil +(defvar-local occur-revert-arguments nil "Arguments to pass to `occur-1' to revert an Occur mode buffer. See `occur-revert-function'.") -(make-variable-buffer-local 'occur-revert-arguments) (put 'occur-revert-arguments 'permanent-local t) (defcustom occur-mode-hook '(turn-on-font-lock) @@ -1092,6 +1128,11 @@ for this is to reveal context in an outline-mode when the occurrence is hidden." :type 'hook :group 'matching) +(defun occur--garbage-collect-revert-args () + (dolist (boo (nth 2 occur-revert-arguments)) + (when (overlayp boo) (delete-overlay boo))) + (kill-local-variable 'occur-revert-arguments)) + (put 'occur-mode 'mode-class 'special) (define-derived-mode occur-mode special-mode "Occur" "Major mode for output from \\[occur]. @@ -1100,8 +1141,9 @@ for this is to reveal context in an outline-mode when the occurrence is hidden." Alternatively, click \\[occur-mode-mouse-goto] on an item to go to it. \\{occur-mode-map}" - (set (make-local-variable 'revert-buffer-function) 'occur-revert-function) - (setq next-error-function 'occur-next-error)) + (setq-local revert-buffer-function #'occur-revert-function) + (add-hook 'kill-buffer-hook #'occur--garbage-collect-revert-args nil t) + (setq next-error-function #'occur-next-error)) ;;; Occur Edit mode @@ -1124,7 +1166,7 @@ the originating buffer. To return to ordinary Occur mode, use \\[occur-cease-edit]." (setq buffer-read-only nil) - (add-hook 'after-change-functions 'occur-after-change-function nil t) + (add-hook 'after-change-functions #'occur-after-change-function nil t) (message (substitute-command-keys "Editing: Type \\[occur-cease-edit] to return to Occur mode."))) @@ -1178,7 +1220,7 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]." (defun occur-revert-function (_ignore1 _ignore2) "Handle `revert-buffer' for Occur mode buffers." - (apply 'occur-1 (append occur-revert-arguments (list (buffer-name))))) + (apply #'occur-1 (append occur-revert-arguments (list (buffer-name))))) (defun occur-mode-find-occurrence () (let ((pos (get-text-property (point) 'occur-target))) @@ -1192,7 +1234,8 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]." (defun occur-mode-goto-occurrence (&optional event) "Go to the occurrence on the current line." (interactive (list last-nonmenu-event)) - (let ((pos + (let ((buffer (when event (current-buffer))) + (pos (if (null event) ;; Actually `event-end' works correctly with a nil argument as ;; well, so we could dispense with this test, but let's not @@ -1204,26 +1247,31 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]." (occur-mode-find-occurrence)))))) (pop-to-buffer (marker-buffer pos)) (goto-char pos) + (when buffer (next-error-found buffer (current-buffer))) (run-hooks 'occur-mode-find-occurrence-hook))) (defun occur-mode-goto-occurrence-other-window () "Go to the occurrence the current line describes, in another window." (interactive) - (let ((pos (occur-mode-find-occurrence))) + (let ((buffer (current-buffer)) + (pos (occur-mode-find-occurrence))) (switch-to-buffer-other-window (marker-buffer pos)) (goto-char pos) + (next-error-found buffer (current-buffer)) (run-hooks 'occur-mode-find-occurrence-hook))) (defun occur-mode-display-occurrence () "Display in another window the occurrence the current line describes." (interactive) - (let ((pos (occur-mode-find-occurrence)) + (let ((buffer (current-buffer)) + (pos (occur-mode-find-occurrence)) window) (setq window (display-buffer (marker-buffer pos) t)) ;; This is the way to set point in the proper window. (save-selected-window (select-window window) (goto-char pos) + (next-error-found buffer (current-buffer)) (run-hooks 'occur-mode-find-occurrence-hook)))) (defun occur-find-match (n search message) @@ -1236,7 +1284,7 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]." (setq r (funcall search r 'occur-match))) (if r (goto-char r) - (error message)) + (user-error message)) (setq n (1- n))))) (defun occur-next (&optional n) @@ -1253,29 +1301,20 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]." "Move to the Nth (default 1) next match in an Occur mode buffer. Compatibility function for \\[next-error] invocations." (interactive "p") - ;; we need to run occur-find-match from within the Occur buffer - (with-current-buffer - ;; Choose the buffer and make it current. - (if (next-error-buffer-p (current-buffer)) - (current-buffer) - (next-error-find-buffer nil nil - (lambda () - (eq major-mode 'occur-mode)))) - - (goto-char (cond (reset (point-min)) - ((< argp 0) (line-beginning-position)) - ((> argp 0) (line-end-position)) - ((point)))) - (occur-find-match - (abs argp) - (if (> 0 argp) - #'previous-single-property-change - #'next-single-property-change) - "No more matches") - ;; In case the *Occur* buffer is visible in a nonselected window. - (let ((win (get-buffer-window (current-buffer) t))) - (if win (set-window-point win (point)))) - (occur-mode-goto-occurrence))) + (goto-char (cond (reset (point-min)) + ((< argp 0) (line-beginning-position)) + ((> argp 0) (line-end-position)) + ((point)))) + (occur-find-match + (abs argp) + (if (> 0 argp) + #'previous-single-property-change + #'next-single-property-change) + "No more matches") + ;; In case the *Occur* buffer is visible in a nonselected window. + (let ((win (get-buffer-window (current-buffer) t))) + (if win (set-window-point win (point)))) + (occur-mode-goto-occurrence)) (defface match '((((class color) (min-colors 88) (background light)) @@ -1385,11 +1424,6 @@ invoke `occur'." (or unique-p (not interactive-p))))) ;; Region limits when `occur' applies on a region. -(defvar occur--region-start nil) -(defvar occur--region-end nil) -(defvar occur--matches-threshold nil) -(defvar occur--orig-line nil) -(defvar occur--orig-line-str nil) (defvar occur--final-pos nil) (defun occur (regexp &optional nlines region) @@ -1436,25 +1470,14 @@ is not modified." (and (use-region-p) (list (region-bounds))))) (let* ((start (and (caar region) (max (caar region) (point-min)))) (end (and (cdar region) (min (cdar region) (point-max)))) - (in-region-p (or start end))) - (when in-region-p - (or start (setq start (point-min))) - (or end (setq end (point-max)))) - (let ((occur--region-start start) - (occur--region-end end) - (occur--matches-threshold - (and in-region-p - (line-number-at-pos (min start end)))) - (occur--orig-line - (line-number-at-pos (point))) - (occur--orig-line-str - (buffer-substring-no-properties - (line-beginning-position) - (line-end-position)))) - (save-excursion ; If no matches `occur-1' doesn't restore the point. - (and in-region-p (narrow-to-region start end)) - (occur-1 regexp nlines (list (current-buffer))) - (and in-region-p (widen)))))) + (in-region (or start end)) + (bufs (if (not in-region) (list (current-buffer)) + (let ((ol (make-overlay + (or start (point-min)) + (or end (point-max))))) + (overlay-put ol 'occur--orig-point (point)) + (list ol))))) + (occur-1 regexp nlines bufs))) (defvar ido-ignore-item-temp-list) @@ -1525,17 +1548,27 @@ See also `multi-occur'." (query-replace-descr regexp)))) (defun occur-1 (regexp nlines bufs &optional buf-name) + ;; BUFS is a list of buffer-or-overlay! (unless (and regexp (not (equal regexp ""))) (error "Occur doesn't work with the empty regexp")) (unless buf-name (setq buf-name "*Occur*")) (let (occur-buf - (active-bufs (delq nil (mapcar #'(lambda (buf) - (when (buffer-live-p buf) buf)) - bufs)))) + (active-bufs + (delq nil (mapcar (lambda (boo) + (when (or (buffer-live-p boo) + (and (overlayp boo) + (overlay-buffer boo))) + boo)) + bufs)))) ;; Handle the case where one of the buffers we're searching is the ;; output buffer. Just rename it. - (when (member buf-name (mapcar 'buffer-name active-bufs)) + (when (member buf-name + ;; FIXME: Use cl-exists. + (mapcar + (lambda (boo) + (buffer-name (if (overlayp boo) (overlay-buffer boo) boo))) + active-bufs)) (with-current-buffer (get-buffer buf-name) (rename-uniquely))) @@ -1550,27 +1583,29 @@ See also `multi-occur'." (let ((inhibit-read-only t) ;; Don't generate undo entries for creation of the initial contents. (buffer-undo-list t) - (occur--final-pos nil)) + (occur--final-pos nil)) (erase-buffer) (let ((count (if (stringp nlines) ;; Treat nlines as a regexp to collect. - (let ((bufs active-bufs) - (count 0)) - (while bufs - (with-current-buffer (car bufs) + (let ((count 0)) + (dolist (boo active-bufs) + (with-current-buffer + (if (overlayp boo) (overlay-buffer boo) boo) (save-excursion - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - ;; Insert the replacement regexp. - (let ((str (match-substitute-replacement nlines))) - (if str - (with-current-buffer occur-buf - (insert str) - (setq count (1+ count)) - (or (zerop (current-column)) - (insert "\n")))))))) - (setq bufs (cdr bufs))) + (goto-char + (if (overlayp boo) (overlay-start boo) (point-min))) + (let ((end (if (overlayp boo) (overlay-end boo)))) + (while (re-search-forward regexp end t) + ;; Insert the replacement regexp. + (let ((str (match-substitute-replacement + nlines))) + (if str + (with-current-buffer occur-buf + (insert str) + (setq count (1+ count)) + (or (zerop (current-column)) + (insert "\n")))))))))) count) ;; Perform normal occur. (occur-engine @@ -1586,11 +1621,12 @@ See also `multi-occur'." (not (eq occur-excluded-properties t)))))) (let* ((bufcount (length active-bufs)) (diff (- (length bufs) bufcount))) - (message "Searched %d buffer%s%s; %s match%s%s" - bufcount (if (= bufcount 1) "" "s") + (message "Searched %d %s%s; %s %s%s" + bufcount + (ngettext "buffer" "buffers" bufcount) (if (zerop diff) "" (format " (%d killed)" diff)) (if (zerop count) "no" (format "%d" count)) - (if (= count 1) "" "es") + (ngettext "match" "matches" count) ;; Don't display regexp if with remaining text ;; it is longer than window-width. (if (> (+ (length (or (get-text-property 0 'isearch-string regexp) @@ -1598,6 +1634,7 @@ See also `multi-occur'." 42) (window-width)) "" (occur-regexp-descr regexp)))) + (occur--garbage-collect-revert-args) (setq occur-revert-arguments (list regexp nlines bufs)) (if (= count 0) (kill-buffer occur-buf) @@ -1613,51 +1650,55 @@ See also `multi-occur'." (defun occur-engine (regexp buffers out-buf nlines case-fold title-face prefix-face match-face keep-props) + ;; BUFFERS is a list of buffer-or-overlay! (with-current-buffer out-buf (let ((global-lines 0) ;; total count of matching lines (global-matches 0) ;; total count of matches (coding nil) (case-fold-search case-fold) - (in-region-p (and occur--region-start occur--region-end)) - (multi-occur-p (cdr buffers))) + (multi-occur-p (cdr buffers))) ;; Map over all the buffers - (dolist (buf buffers) - (when (buffer-live-p buf) - (let ((lines 0) ;; count of matching lines - (matches 0) ;; count of matches - (curr-line ;; line count - (or occur--matches-threshold 1)) - (orig-line occur--orig-line) - (orig-line-str occur--orig-line-str) - (orig-line-shown-p) - (prev-line nil) ;; line number of prev match endpt - (prev-after-lines nil) ;; context lines of prev match - (matchbeg 0) - (origpt nil) - (begpt nil) - (endpt nil) - (finalpt nil) - (marker nil) - (curstring "") - (ret nil) - (inhibit-field-text-motion t) - (headerpt (with-current-buffer out-buf (point)))) - (with-current-buffer buf - ;; The following binding is for when case-fold-search - ;; has a local binding in the original buffer, in which - ;; case we cannot bind it globally and let that have - ;; effect in every buffer we search. - (let ((case-fold-search case-fold)) - (or coding - ;; Set CODING only if the current buffer locally - ;; binds buffer-file-coding-system. - (not (local-variable-p 'buffer-file-coding-system)) - (setq coding buffer-file-coding-system)) - (save-excursion - (goto-char (point-min)) ;; begin searching in the buffer - (while (not (eobp)) + (dolist (boo buffers) + (when (if (overlayp boo) (overlay-buffer boo) (buffer-live-p boo)) + (with-current-buffer (if (overlayp boo) (overlay-buffer boo) boo) + (let ((inhibit-field-text-motion t) + (lines 0) ; count of matching lines + (matches 0) ; count of matches + (headerpt (with-current-buffer out-buf (point))) + (orig-line (if (not (overlayp boo)) + (line-number-at-pos) + (line-number-at-pos + (overlay-get boo 'occur--orig-point))))) + (save-excursion + ;; begin searching in the buffer + (goto-char (if (overlayp boo) (overlay-start boo) (point-min))) + (forward-line 0) + (let* ((limit (if (overlayp boo) (overlay-end boo) (point-max))) + (start-line (line-number-at-pos)) + (curr-line start-line) ; line count + (orig-line-shown-p) + (prev-line nil) ; line number of prev match endpt + (prev-after-lines nil) ; context lines of prev match + (matchbeg 0) + (origpt nil) + (begpt nil) + (endpt nil) + (marker nil) + (curstring "") + (ret nil) + ;; The following binding is for when case-fold-search + ;; has a local binding in the original buffer, in which + ;; case we cannot bind it globally and let that have + ;; effect in every buffer we search. + (case-fold-search case-fold)) + (or coding + ;; Set CODING only if the current buffer locally + ;; binds buffer-file-coding-system. + (not (local-variable-p 'buffer-file-coding-system)) + (setq coding buffer-file-coding-system)) + (while (< (point) limit) (setq origpt (point)) - (when (setq endpt (re-search-forward regexp nil t)) + (when (setq endpt (re-search-forward regexp limit t)) (setq lines (1+ lines)) ;; increment matching lines count (setq matchbeg (match-beginning 0)) ;; Get beginning of first match line and end of the last. @@ -1677,6 +1718,18 @@ See also `multi-occur'." ;; Count empty lines that don't use next loop (Bug#22062). (when (zerop len) (setq matches (1+ matches))) + (when (and list-matching-lines-jump-to-current-line + (not multi-occur-p)) + (or orig-line (setq orig-line 1)) + (or nlines (setq nlines (line-number-at-pos (point-max)))) + (when (= curr-line orig-line) + (add-face-text-property + 0 len list-matching-lines-current-line-face nil curstring) + (add-text-properties 0 len '(current-line t) curstring)) + (when (and (>= orig-line (- curr-line nlines)) + (<= orig-line (+ curr-line nlines))) + ;; Shown either here or will be shown by occur-context-lines + (setq orig-line-shown-p t))) (while (and (< start len) (string-match regexp curstring start)) (setq matches (1+ matches)) @@ -1698,36 +1751,39 @@ See also `multi-occur'." (append (when prefix-face `(font-lock-face ,prefix-face)) - `(occur-prefix t mouse-face (highlight) + `(occur-prefix t ;; Allow insertion of text ;; at the end of the prefix ;; (for Occur Edit mode). front-sticky t - rear-nonsticky t - occur-target ,marker - follow-link t + rear-nonsticky t + occur-target ,marker + follow-link t help-echo "mouse-2: go to this occurrence")))) (match-str ;; We don't put `mouse-face' on the newline, ;; because that loses. And don't put it ;; on context lines to reduce flicker. - (propertize curstring 'mouse-face (list 'highlight) + (propertize curstring 'occur-target marker 'follow-link t 'help-echo "mouse-2: go to this occurrence")) (out-line - (concat - match-prefix - ;; Add non-numeric prefix to all non-first lines - ;; of multi-line matches. + ;; Add non-numeric prefix to all non-first lines + ;; of multi-line matches. + (concat (replace-regexp-in-string "\n" (if prefix-face (propertize - "\n :" 'font-lock-face prefix-face) + "\n :" 'font-lock-face prefix-face) "\n :") - match-str) + ;; Add mouse face in one section to + ;; ensure the prefix and the string + ;; get a contiguous highlight. + (propertize (concat match-prefix match-str) + 'mouse-face 'highlight)) ;; Add marker at eol, but no mouse props. (propertize "\n" 'occur-target marker))) (data @@ -1737,27 +1793,33 @@ See also `multi-occur'." ;; The complex multi-line display style. (setq ret (occur-context-lines out-line nlines keep-props begpt - endpt curr-line prev-line - prev-after-lines prefix-face)) + endpt curr-line prev-line + prev-after-lines prefix-face + orig-line multi-occur-p)) ;; Set first elem of the returned list to `data', ;; and the second elem to `prev-after-lines'. (setq prev-after-lines (nth 1 ret)) - (nth 0 ret)))) + (nth 0 ret))) + (orig-line-str + (when (and list-matching-lines-jump-to-current-line + (null orig-line-shown-p) + (> curr-line orig-line)) + (setq orig-line-shown-p t) + (save-excursion + (goto-char (point-min)) + (forward-line (1- orig-line)) + (occur-engine-line (line-beginning-position) + (line-end-position) keep-props))))) ;; Actually insert the match display data (with-current-buffer out-buf - (when (and list-matching-lines-jump-to-current-line - (not multi-occur-p) - (not orig-line-shown-p) - orig-line - (>= curr-line orig-line)) - (insert - (concat - (propertize - (format "%7d:%s" orig-line orig-line-str) - 'face list-matching-lines-current-line-face - 'mouse-face 'mode-line-highlight - 'help-echo "Current line") "\n")) - (setq orig-line-shown-p t finalpt (point))) + (when orig-line-str + (add-face-text-property + 0 (length orig-line-str) + list-matching-lines-current-line-face nil orig-line-str) + (add-text-properties 0 (length orig-line-str) + '(current-line t) orig-line-str) + (insert (car (occur-engine-add-prefix + (list orig-line-str) prefix-face)))) (insert data))) (goto-char endpt)) (if endpt @@ -1766,30 +1828,34 @@ See also `multi-occur'." (setq curr-line (+ curr-line (count-lines begpt endpt) ;; Add 1 for empty last match line ;; since count-lines returns one - ;; line less. + ;; line less. (if (and (bolp) (eolp)) 1 0))) ;; On to the next match... (forward-line 1)) (goto-char (point-max))) (setq prev-line (1- curr-line))) - ;; Insert original line if haven't done yet. - (when (and list-matching-lines-jump-to-current-line - (not multi-occur-p) - (not orig-line-shown-p) - orig-line) - (with-current-buffer out-buf - (insert - (concat - (propertize - (format "%7d:%s" orig-line orig-line-str) - 'face list-matching-lines-current-line-face - 'mouse-face 'mode-line-highlight - 'help-echo "Current line") "\n")))) ;; Flush remaining context after-lines. (when prev-after-lines (with-current-buffer out-buf (insert (apply #'concat (occur-engine-add-prefix - prev-after-lines prefix-face))))))) + prev-after-lines prefix-face))))) + (when (and list-matching-lines-jump-to-current-line + (null orig-line-shown-p)) + (setq orig-line-shown-p t) + (let ((orig-line-str + (save-excursion + (goto-char (point-min)) + (forward-line (1- orig-line)) + (occur-engine-line (line-beginning-position) + (line-end-position) keep-props)))) + (add-face-text-property + 0 (length orig-line-str) + list-matching-lines-current-line-face nil orig-line-str) + (add-text-properties 0 (length orig-line-str) + '(current-line t) orig-line-str) + (with-current-buffer out-buf + (insert (car (occur-engine-add-prefix + (list orig-line-str) prefix-face)))))))) (when (not (zerop lines)) ;; is the count zero? (setq global-lines (+ global-lines lines) global-matches (+ global-matches matches)) @@ -1798,44 +1864,49 @@ See also `multi-occur'." (let ((beg (point)) end) (insert (propertize - (format "%d match%s%s%s in buffer: %s%s\n" - matches (if (= matches 1) "" "es") + (format "%d %s%s%s in buffer: %s%s\n" + matches + (ngettext "match" "matches" matches) ;; Don't display the same number of lines ;; and matches in case of 1 match per line. (if (= lines matches) - "" (format " in %d line%s" + "" (format " in %d %s" lines - (if (= lines 1) "" "s"))) + (ngettext "line" "lines" lines))) ;; Don't display regexp for multi-buffer. (if (> (length buffers) 1) "" (occur-regexp-descr regexp)) - (buffer-name buf) - (if in-region-p - (format " within region: %d-%d" - occur--region-start - occur--region-end) - "")) + (buffer-name (if (overlayp boo) (overlay-buffer boo) boo)) + (if (overlayp boo) + (format " within region: %d-%d" + (overlay-start boo) + (overlay-end boo)) + "")) 'read-only t)) (setq end (point)) - (add-text-properties beg end `(occur-title ,buf)) (when title-face (add-face-text-property beg end title-face)) - (goto-char (if finalpt - (setq occur--final-pos - (cl-incf finalpt (- end beg))) - (point-min)))))))))) + (goto-char (if (and list-matching-lines-jump-to-current-line + (not multi-occur-p)) + (setq occur--final-pos + (and (goto-char (point-max)) + (or (previous-single-property-change (point) 'current-line) + (point-max)))) + (point-min)))))))))) ;; Display total match count and regexp for multi-buffer. (when (and (not (zerop global-lines)) (> (length buffers) 1)) (goto-char (point-min)) (let ((beg (point)) end) - (insert (format "%d match%s%s total%s:\n" - global-matches (if (= global-matches 1) "" "es") + (insert (format "%d %s%s total%s:\n" + global-matches + (ngettext "match" "matches" global-matches) ;; Don't display the same number of lines ;; and matches in case of 1 match per line. (if (= global-lines global-matches) - "" (format " in %d line%s" - global-lines (if (= global-lines 1) "" "s"))) + "" (format " in %d %s" + global-lines + (ngettext "line" "lines" global-lines))) (occur-regexp-descr regexp))) (setq end (point)) (when title-face @@ -1850,10 +1921,8 @@ See also `multi-occur'." global-matches))) (defun occur-engine-line (beg end &optional keep-props) - (if (and keep-props (if (boundp 'jit-lock-mode) jit-lock-mode) - (text-property-not-all beg end 'fontified t)) - (if (fboundp 'jit-lock-fontify-now) - (jit-lock-fontify-now beg end))) + (if (and keep-props font-lock-mode) + (font-lock-ensure beg end)) (if (and keep-props (not (eq occur-excluded-properties t))) (let ((str (buffer-substring beg end))) (remove-list-of-text-properties @@ -1897,7 +1966,8 @@ See also `multi-occur'." ;; then concatenate them all together. (defun occur-context-lines (out-line nlines keep-props begpt endpt curr-line prev-line prev-after-lines - &optional prefix-face) + &optional prefix-face + orig-line multi-occur-p) ;; Find after- and before-context lines of the current match. (let ((before-lines (nreverse (cdr (occur-accumulate-lines @@ -1907,13 +1977,32 @@ See also `multi-occur'." (1+ nlines) keep-props endpt))) separator) + (when (and list-matching-lines-jump-to-current-line + (not multi-occur-p)) + (when (and (>= orig-line (- curr-line nlines)) + (< orig-line curr-line)) + (let ((curstring (nth (- (length before-lines) (- curr-line orig-line)) before-lines))) + (add-face-text-property + 0 (length curstring) + list-matching-lines-current-line-face nil curstring) + (add-text-properties 0 (length curstring) + '(current-line t) curstring))) + (when (and (<= orig-line (+ curr-line nlines)) + (> orig-line curr-line)) + (let ((curstring (nth (- orig-line curr-line 1) after-lines))) + (add-face-text-property + 0 (length curstring) + list-matching-lines-current-line-face nil curstring) + (add-text-properties 0 (length curstring) + '(current-line t) curstring)))) + ;; Combine after-lines of the previous match ;; with before-lines of the current match. (when prev-after-lines ;; Don't overlap prev after-lines with current before-lines. (if (>= (+ prev-line (length prev-after-lines)) - (- curr-line (length before-lines))) + (- curr-line (length before-lines))) (setq prev-after-lines (butlast prev-after-lines (- (length prev-after-lines) @@ -2186,9 +2275,9 @@ It is called with three arguments, as if it were ;; used after `recursive-edit' might override them. (let* ((isearch-regexp regexp-flag) (isearch-regexp-function (or delimited-flag - (and replace-char-fold - (not regexp-flag) - #'char-fold-to-regexp))) + (and replace-char-fold + (not regexp-flag) + #'char-fold-to-regexp))) (isearch-lax-whitespace replace-lax-whitespace) (isearch-regexp-lax-whitespace @@ -2218,7 +2307,10 @@ 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 delimited-flag) + (isearch-regexp-function (or delimited-flag + (and replace-char-fold + (not regexp-flag) + #'char-fold-to-regexp))) (isearch-lax-whitespace replace-lax-whitespace) (isearch-regexp-lax-whitespace @@ -2279,7 +2371,12 @@ REPLACEMENTS is either a string, a list of strings, or a cons cell containing a function and its first argument. The function is called to generate each replacement like this: (funcall (car replacements) (cdr replacements) replace-count) -It must return a string." +It must return a string. + +Non-nil REGION-NONCONTIGUOUS-P means that the region is composed of +noncontiguous pieces. The most common example of this is a +rectangular region, where the pieces are separated by newline +characters." (or map (setq map query-replace-map)) (and query-flag minibuffer-auto-raise (raise-frame (window-frame (minibuffer-window)))) @@ -2323,9 +2420,18 @@ It must return a string." (message (if query-flag - (apply 'propertize - (substitute-command-keys - "Query replacing %s with %s: (\\<query-replace-map>\\[help] for help) ") + (apply #'propertize + (concat "Query replacing " + (if backward "backward " "") + (if delimited-flag + (or (and (symbolp delimited-flag) + (get delimited-flag + 'isearch-message-prefix)) + "word ") "") + (if regexp-flag "regexp " "") + "%s with %s: " + (substitute-command-keys + "(\\<query-replace-map>\\[help] for help) ")) minibuffer-prompt-properties)))) ;; Unless a single contiguous chunk is selected, operate on multiple chunks. @@ -2368,7 +2474,8 @@ It must return a string." replacements nil)) ((stringp (car replacements)) ; If it isn't a string, it must be a cons (or repeat-count (setq repeat-count 1)) - (setq replacements (cons 'replace-loop-through-replacements + ;; This is a hand-made `iterator'. + (setq replacements (cons #'replace-loop-through-replacements (vector repeat-count repeat-count replacements replacements))))) @@ -2493,6 +2600,11 @@ It must return a string." ;; Commands not setting `done' need to adjust ;; `real-match-data'. (while (not done) + ;; This sets match-data only for the next hook and + ;; replace-highlight that calls `sit-for' from + ;; isearch-lazy-highlight-new-loop whose redisplay + ;; might clobber match-data. So subsequent code should + ;; use only real-match-data, not match-data (bug#36328). (set-match-data real-match-data) (run-hooks 'replace-update-post-hook) ; Before `replace-highlight'. (replace-highlight @@ -2505,14 +2617,14 @@ It must return a string." (setq last-was-undo nil real-match-data (save-excursion - (goto-char (match-beginning 0)) + (goto-char (nth 0 real-match-data)) (looking-at search-string) (match-data t real-match-data)))) ;; Matched string and next-replacement-replaced ;; stored in stack. (setq search-string-replaced (buffer-substring-no-properties - (match-beginning 0) - (match-end 0)) + (nth 0 real-match-data) + (nth 1 real-match-data)) next-replacement-replaced (query-replace-descr (save-match-data @@ -2540,22 +2652,24 @@ It must return a string." (setq def (lookup-key map key)) ;; Restore the match data while we process the command. (cond ((eq def 'help) - (with-output-to-temp-buffer "*Help*" - (princ - (concat "Query replacing " - (if delimited-flag - (or (and (symbolp delimited-flag) - (get delimited-flag - 'isearch-message-prefix)) - "word ") "") - (if regexp-flag "regexp " "") - (if backward "backward " "") - from-string " with " - next-replacement ".\n\n" - (substitute-command-keys - query-replace-help))) - (with-current-buffer standard-output - (help-mode)))) + (let ((display-buffer-overriding-action + '(nil (inhibit-same-window . t)))) + (with-output-to-temp-buffer "*Help*" + (princ + (concat "Query replacing " + (if backward "backward " "") + (if delimited-flag + (or (and (symbolp delimited-flag) + (get delimited-flag + 'isearch-message-prefix)) + "word ") "") + (if regexp-flag "regexp " "") + from-string " with " + next-replacement ".\n\n" + (substitute-command-keys + query-replace-help))) + (with-current-buffer standard-output + (help-mode))))) ((eq def 'exit) (setq keep-going nil) (setq done t)) @@ -2635,10 +2749,10 @@ It must return a string." (1+ num-replacements)))))) (when (and (eq def 'undo-all) (null (zerop num-replacements))) - (message "Undid %d %s" num-replacements - (if (= num-replacements 1) - "replacement" - "replacements")) + (message (ngettext "Undid %d replacement" + "Undid %d replacements" + num-replacements) + num-replacements) (ding 'no-terminate) (sit-for 1))) (setq replaced nil last-was-undo t last-was-act-and-show nil))) @@ -2764,15 +2878,17 @@ It must return a string." last-was-act-and-show nil)))))) (replace-dehighlight)) (or unread-command-events - (message "Replaced %d occurrence%s%s" + (message (ngettext "Replaced %d occurrence%s" + "Replaced %d occurrences%s" + replace-count) replace-count - (if (= replace-count 1) "" "s") (if (> (+ skip-read-only-count skip-filtered-count - skip-invisible-count) 0) + skip-invisible-count) + 0) (format " (skipped %s)" (mapconcat - 'identity + #'identity (delq nil (list (if (> skip-read-only-count 0) (format "%s read-only" diff --git a/lisp/reveal.el b/lisp/reveal.el index d5dc3acf79a..67740c8149b 100644 --- a/lisp/reveal.el +++ b/lisp/reveal.el @@ -191,9 +191,6 @@ Each element has the form (WINDOW . OVERLAY).") ;;;###autoload (define-minor-mode reveal-mode "Toggle uncloaking of invisible text near point (Reveal mode). -With a prefix argument ARG, enable Reveal mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -Reveal mode if ARG is omitted or nil. Reveal mode is a buffer-local minor mode. When enabled, it reveals invisible text around point." @@ -210,11 +207,7 @@ reveals invisible text around point." ;;;###autoload (define-minor-mode global-reveal-mode "Toggle Reveal mode in all buffers (Global Reveal mode). -Reveal mode renders invisible text around point visible again. - -With a prefix argument ARG, enable Global Reveal mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil." +Reveal mode renders invisible text around point visible again." :global t :group 'reveal (setq-default reveal-mode global-reveal-mode) (if global-reveal-mode diff --git a/lisp/rfn-eshadow.el b/lisp/rfn-eshadow.el index 0a65e9a7384..d0a022aa92e 100644 --- a/lisp/rfn-eshadow.el +++ b/lisp/rfn-eshadow.el @@ -207,9 +207,6 @@ been set up by `rfn-eshadow-setup-minibuffer'." (define-minor-mode file-name-shadow-mode "Toggle file-name shadowing in minibuffers (File-Name Shadow mode). -With a prefix argument ARG, enable File-Name Shadow mode if ARG -is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. File-Name Shadow mode is a global minor mode. When enabled, any part of a filename being read in the minibuffer that would be diff --git a/lisp/rtree.el b/lisp/rtree.el index ff160f207b2..9a0a649abf1 100644 --- a/lisp/rtree.el +++ b/lisp/rtree.el @@ -1,4 +1,4 @@ -;;; rtree.el --- functions for manipulating range trees +;;; rtree.el --- functions for manipulating range trees -*- lexical-binding:t -*- ;; Copyright (C) 2010-2019 Free Software Foundation, Inc. @@ -43,11 +43,8 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - (defmacro rtree-make-node () - `(list (list nil) nil)) + '(list (list nil) nil)) (defmacro rtree-set-left (node left) `(setcar (cdr ,node) ,left)) @@ -85,7 +82,7 @@ range) (define-obsolete-function-alias 'rtree-normalise-range - 'rtree-normalize-range "25.1") + #'rtree-normalize-range "25.1") (defun rtree-make (range) "Make an rtree from RANGE." diff --git a/lisp/ruler-mode.el b/lisp/ruler-mode.el index ddf62d913d4..093dd497dc1 100644 --- a/lisp/ruler-mode.el +++ b/lisp/ruler-mode.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2001-2019 Free Software Foundation, Inc. ;; Author: David Ponce <david@dponce.com> -;; Maintainer: David Ponce <david@dponce.com> ;; Created: 24 Mar 2001 ;; Version: 1.6 ;; Keywords: convenience @@ -591,10 +590,7 @@ format first." ;;;###autoload (define-minor-mode ruler-mode - "Toggle display of ruler in header line (Ruler mode). -With a prefix argument ARG, enable Ruler mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "Toggle display of ruler in header line (Ruler mode)." nil nil ruler-mode-map :group 'ruler-mode @@ -616,7 +612,7 @@ if ARG is omitted or nil." ;; Add ruler-mode to the minor mode menu in the mode line (define-key mode-line-mode-menu [ruler-mode] - `(menu-item "Ruler" ruler-mode + '(menu-item "Ruler" ruler-mode :button (:toggle . ruler-mode))) (defconst ruler-mode-ruler-help-echo @@ -709,20 +705,18 @@ Optional argument PROPS specifies other text properties to apply." ;; Create an "clean" ruler. (ruler (propertize - ;; FIXME: `make-string' returns a unibyte string if it's ASCII-only, - ;; which prevents further `aset' from inserting non-ASCII chars, - ;; hence the need for `string-to-multibyte'. - ;; https://lists.gnu.org/r/emacs-devel/2017-05/msg00841.html - (string-to-multibyte - ;; Make the part of header-line corresponding to the - ;; line-number display be blank, not filled with - ;; ruler-mode-basic-graduation-char. - (if display-line-numbers - (let* ((lndw (round (line-number-display-width 'columns))) - (s (make-string lndw ?\s))) - (concat s (make-string (- w lndw) - ruler-mode-basic-graduation-char))) - (make-string w ruler-mode-basic-graduation-char))) + ;; Make the part of header-line corresponding to the + ;; line-number display be blank, not filled with + ;; ruler-mode-basic-graduation-char. + (if display-line-numbers + (let* ((lndw (round (line-number-display-width 'columns))) + ;; We need a multibyte string here so we could + ;; later use aset to insert multibyte characters + ;; into that string. + (s (make-string lndw ?\s t))) + (concat s (make-string (- w lndw) + ruler-mode-basic-graduation-char t))) + (make-string w ruler-mode-basic-graduation-char t)) 'face 'ruler-mode-default 'local-map ruler-mode-map 'help-echo (cond diff --git a/lisp/savehist.el b/lisp/savehist.el index 795a3cab744..83591310829 100644 --- a/lisp/savehist.el +++ b/lisp/savehist.el @@ -1,8 +1,8 @@ -;;; savehist.el --- Save minibuffer history +;;; savehist.el --- Save minibuffer history -*- lexical-binding:t -*- ;; Copyright (C) 1997, 2005-2019 Free Software Foundation, Inc. -;; Author: Hrvoje Niksic <hniksic@xemacs.org> +;; Author: Hrvoje Nikšić <hrvoje.niksic@avl.com> ;; Maintainer: emacs-devel@gnu.org ;; Keywords: minibuffer ;; Version: 24 @@ -48,8 +48,6 @@ ;;; Code: (require 'custom) -(eval-when-compile - (if (featurep 'xemacs) (require 'cl))) ;; User variables @@ -62,8 +60,7 @@ "If non-nil, save all recorded minibuffer histories. If you want to save only specific histories, use `savehist-save-hook' to modify the value of `savehist-minibuffer-history-variables'." - :type 'boolean - :group 'savehist) + :type 'boolean) (defcustom savehist-additional-variables () "List of additional variables to save. @@ -77,13 +74,11 @@ non-nil. User options should be saved with the Customize interface. This list is useful for saving automatically updated variables that are not minibuffer histories, such as `compile-command' or `kill-ring'." - :type '(repeat variable) - :group 'savehist) + :type '(repeat variable)) (defcustom savehist-ignored-variables nil ;; '(command-history) "List of additional variables not to save." - :type '(repeat variable) - :group 'savehist) + :type '(repeat variable)) (defcustom savehist-file (locate-user-emacs-file "history" ".emacs-history") @@ -95,8 +90,7 @@ for more details. If you want your minibuffer history shared between Emacs and XEmacs, customize this value and make sure that `savehist-coding-system' is set to a coding system that exists in both emacsen." - :type 'file - :group 'savehist) + :type 'file) (defcustom savehist-file-modes #o600 "Default permissions of the history file. @@ -104,36 +98,28 @@ This is decimal, not octal. The default is 384 (0600 in octal). Set to nil to use the default permissions that Emacs uses, typically mandated by umask. The default is a bit more restrictive to protect the user's privacy." - :type 'integer - :group 'savehist) + :type 'integer) (defcustom savehist-autosave-interval (* 5 60) "The interval between autosaves of minibuffer history. If set to nil, disables timer-based autosaving." :type '(choice (const :tag "Disabled" nil) - (integer :tag "Seconds")) - :group 'savehist) + (integer :tag "Seconds"))) (defcustom savehist-mode-hook nil "Hook called when Savehist mode is turned on." - :type 'hook - :group 'savehist) + :type 'hook) (defcustom savehist-save-hook nil "Hook called by `savehist-save' before saving the variables. You can use this hook to influence choice and content of variables to save." - :type 'hook - :group 'savehist) + :type 'hook) ;; This should be capable of representing characters used by Emacs. ;; We prefer UTF-8 over ISO 2022 because it is well-known outside -;; Mule. XEmacs prior to 21.5 had UTF-8 provided by an external -;; package which may not be loaded, which is why we check for version. -(defvar savehist-coding-system (if (and (featurep 'xemacs) - (<= emacs-major-version 21) - (< emacs-minor-version 5)) - 'iso-2022-8 'utf-8-unix) +;; Mule. +(defvar savehist-coding-system 'utf-8-unix "The coding system Savehist uses for saving the minibuffer history. Changing this value while Emacs is running is supported, but considered unwise, unless you know what you are doing.") @@ -150,30 +136,17 @@ The contents of this variable is built while Emacs is running, and saved along with minibuffer history. You can change its value off `savehist-save-hook' to influence which variables are saved.") -(defconst savehist-no-conversion (if (featurep 'xemacs) 'binary 'no-conversion) - "Coding system without any conversion. -This is used for calculating an internal checksum. Should be as fast -as possible, ideally simply exposing the internal representation of -buffer text.") - (defvar savehist-loaded nil "Whether the history has already been loaded. This prevents toggling Savehist mode from destroying existing minibuffer history.") -(when (featurep 'xemacs) - ;; Must declare this under XEmacs, which doesn't have built-in - ;; minibuffer history truncation. - (defvar history-length 100)) ;; Functions. ;;;###autoload (define-minor-mode savehist-mode "Toggle saving of minibuffer history (Savehist mode). -With a prefix argument ARG, enable Savehist mode if ARG is -positive, and disable it otherwise. If called from Lisp, -also enable the mode if ARG is omitted or nil. When Savehist mode is enabled, minibuffer history is saved to `savehist-file' periodically and when exiting Emacs. When @@ -221,64 +194,31 @@ histories, which is probably undesirable." (signal (car errvar) (cdr errvar))))) (savehist-install))) -(defun savehist-load () - "Load the variables stored in `savehist-file' and turn on Savehist mode. -If `savehist-file' is in the old format that doesn't record -the value of `savehist-minibuffer-history-variables', that -value is deducted from the contents of the file." - (declare (obsolete savehist-mode "22.1")) - (savehist-mode 1) - ;; Old versions of savehist distributed with XEmacs didn't save - ;; savehist-minibuffer-history-variables. If that variable is nil - ;; after loading the file, try to intuit the intended value. - (when (null savehist-minibuffer-history-variables) - (setq savehist-minibuffer-history-variables - (with-temp-buffer - (ignore-errors - (insert-file-contents savehist-file)) - (let ((vars ()) form) - (while (setq form (condition-case nil - (read (current-buffer)) (error nil))) - ;; Each form read is of the form (setq VAR VALUE). - ;; Collect VAR, i.e. (nth form 1). - (push (nth 1 form) vars)) - vars))))) - (defun savehist-install () "Hook Savehist into Emacs. Normally invoked by calling `savehist-mode' to set the minor mode. Installs `savehist-autosave' in `kill-emacs-hook' and on a timer. To undo this, call `savehist-uninstall'." - (add-hook 'minibuffer-setup-hook 'savehist-minibuffer-hook) - (add-hook 'kill-emacs-hook 'savehist-autosave) + (add-hook 'minibuffer-setup-hook #'savehist-minibuffer-hook) + (add-hook 'kill-emacs-hook #'savehist-autosave) ;; Install an invocation of savehist-autosave on a timer. This ;; should not cause noticeable delays for users -- savehist-autosave ;; executes in under 5 ms on my system. (when (and savehist-autosave-interval (null savehist-timer)) (setq savehist-timer - (if (featurep 'xemacs) - (start-itimer - "savehist" 'savehist-autosave savehist-autosave-interval - savehist-autosave-interval) - (run-with-timer savehist-autosave-interval - savehist-autosave-interval 'savehist-autosave))))) + (run-with-timer savehist-autosave-interval + savehist-autosave-interval #'savehist-autosave)))) (defun savehist-uninstall () "Undo installing savehist. Normally invoked by calling `savehist-mode' to unset the minor mode." - (remove-hook 'minibuffer-setup-hook 'savehist-minibuffer-hook) - (remove-hook 'kill-emacs-hook 'savehist-autosave) + (remove-hook 'minibuffer-setup-hook #'savehist-minibuffer-hook) + (remove-hook 'kill-emacs-hook #'savehist-autosave) (when savehist-timer - (if (featurep 'xemacs) - (delete-itimer savehist-timer) - (cancel-timer savehist-timer)) + (cancel-timer savehist-timer) (setq savehist-timer nil))) -;; From XEmacs? -(defvar print-readably) -(defvar print-string-length) - (defun savehist-save (&optional auto-save) "Save the values of minibuffer history variables. Unbound symbols referenced in `savehist-additional-variables' are ignored. @@ -295,9 +235,7 @@ If AUTO-SAVE is non-nil, compare the saved contents to the one last saved, savehist-coding-system)) (run-hooks 'savehist-save-hook) (let ((print-length nil) - (print-string-length nil) (print-level nil) - (print-readably t) (print-quoted t)) ;; Save the minibuffer histories, along with the value of ;; savehist-minibuffer-history-variables itself. @@ -309,7 +247,7 @@ If AUTO-SAVE is non-nil, compare the saved contents to the one last saved, (dolist (symbol savehist-minibuffer-history-variables) (when (and (boundp symbol) (not (memq symbol savehist-ignored-variables))) - (let ((value (savehist-trim-history (symbol-value symbol))) + (let ((value (symbol-value symbol)) excess-space) (when value ; Don't save empty histories. (insert "(setq ") @@ -353,7 +291,7 @@ If AUTO-SAVE is non-nil, compare the saved contents to the one last saved, (insert ?\n)))))) ;; If autosaving, avoid writing if nothing has changed since the ;; last write. - (let ((checksum (md5 (current-buffer) nil nil savehist-no-conversion))) + (let ((checksum (md5 (current-buffer) nil nil savehist-coding-system))) (unless (and auto-save (equal checksum savehist-last-checksum)) ;; Set file-precious-flag when saving the buffer because we ;; don't want a half-finished write ruining the entire @@ -361,7 +299,11 @@ If AUTO-SAVE is non-nil, compare the saved contents to the one last saved, ;; kill-emacs-hook, and also that multiple Emacs instances ;; could write to this file at once. (let ((file-precious-flag t) - (coding-system-for-write savehist-coding-system)) + (coding-system-for-write savehist-coding-system) + (dir (file-name-directory savehist-file))) + ;; Ensure that the directory exists before saving. + (unless (file-exists-p dir) + (make-directory dir t)) (write-region (point-min) (point-max) savehist-file nil (unless (called-interactively-p 'interactive) 'quiet))) (when savehist-file-modes @@ -374,17 +316,7 @@ Does nothing if Savehist mode is off." (when savehist-mode (savehist-save t))) -(defun savehist-trim-history (value) - "Retain only the first `history-length' items in VALUE. -Only used under XEmacs, which doesn't (yet) implement automatic -trimming of history lists to `history-length' items." - (if (and (featurep 'xemacs) - (natnump history-length) - (> (length value) history-length)) - ;; Equivalent to `(subseq value 0 history-length)', but doesn't - ;; need cl-extra at run-time. - (loop repeat history-length collect (pop value)) - value)) +(define-obsolete-function-alias 'savehist-trim-history #'identity "27.1") (defun savehist-printable (value) "Return non-nil if VALUE is printable." @@ -399,20 +331,22 @@ trimming of history lists to `history-length' items." ;; For others, check explicitly. (with-temp-buffer (condition-case nil - (let ((print-readably t) (print-level nil)) - ;; Print the value into a buffer... - (prin1 value (current-buffer)) - ;; ...and attempt to read it. - (read (point-min-marker)) - ;; The attempt worked: the object is printable. - t) + (let ((print-level nil)) + ;; Print the value into a buffer... + (prin1 value (current-buffer)) + ;; ...and attempt to read it. + (read (point-min-marker)) + ;; The attempt worked: the object is printable. + t) ;; The attempt failed: the object is not printable. (error nil)))))) (defun savehist-minibuffer-hook () (unless (or (eq minibuffer-history-variable t) - ;; XEmacs sets minibuffer-history-variable to t to mean "no - ;; history is being recorded". + ;; If `read-string' is called with a t HISTORY argument + ;; (which `read-password' does), + ;; `minibuffer-history-variable' is bound to t to mean + ;; "no history is being recorded". (memq minibuffer-history-variable savehist-ignored-variables)) (add-to-list 'savehist-minibuffer-history-variables minibuffer-history-variable))) diff --git a/lisp/saveplace.el b/lisp/saveplace.el index 56cfce39c8e..730d31ead25 100644 --- a/lisp/saveplace.el +++ b/lisp/saveplace.el @@ -160,9 +160,6 @@ 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. -If called with a prefix arg, the mode is enabled if and only if -the argument is positive. - To save places automatically in all files, put this in your init file: diff --git a/lisp/scroll-all.el b/lisp/scroll-all.el index 08e8bc699b8..78a05b5d31d 100644 --- a/lisp/scroll-all.el +++ b/lisp/scroll-all.el @@ -102,9 +102,6 @@ ;;;###autoload (define-minor-mode scroll-all-mode "Toggle shared scrolling in same-frame windows (Scroll-All mode). -With a prefix argument ARG, enable Scroll-All mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. When Scroll-All mode is enabled, scrolling commands invoked in one window apply to all visible windows in the same frame." diff --git a/lisp/scroll-bar.el b/lisp/scroll-bar.el index e864b41c7d2..61fa754e390 100644 --- a/lisp/scroll-bar.el +++ b/lisp/scroll-bar.el @@ -49,9 +49,7 @@ from a scroll bar event, then (scroll-bar-scale SCROLL-BAR-POS \(buffer-size)) is the position in the current buffer corresponding to that scroll bar position." ;; We multiply before we divide to maintain precision. - ;; We use floating point because the product of a large buffer size - ;; with a large scroll bar portion can easily overflow a lisp int. - (truncate (/ (* (float (car num-denom)) whole) (cdr num-denom)))) + (truncate (* (car num-denom) whole) (cdr num-denom))) (defun scroll-bar-columns (side) "Return the width, measured in columns, of the vertical scrollbar on SIDE. @@ -133,9 +131,6 @@ 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). -With a prefix argument ARG, enable Scroll Bar mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. This command applies to all frames that exist and frames to be created in the future." @@ -152,9 +147,6 @@ created in the future." (define-minor-mode horizontal-scroll-bar-mode "Toggle horizontal scroll bars on all frames (Horizontal Scroll Bar mode). -With a prefix argument ARG, enable Horizontal Scroll Bar mode if -ARG is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. This command applies to all frames that exist and frames to be created in the future." @@ -260,14 +252,22 @@ EVENT should be a scroll bar click or drag event." (let* ((start-position (event-start event)) (window (nth 0 start-position)) (portion-whole (nth 2 start-position))) - (save-excursion - (with-current-buffer (window-buffer window) - ;; Calculate position relative to the accessible part of the buffer. - (goto-char (+ (point-min) - (scroll-bar-scale portion-whole - (- (point-max) (point-min))))) - (vertical-motion 0 window) - (set-window-start window (point)))))) + ;; With 'scroll-bar-adjust-thumb-portion' nil and 'portion-whole' + ;; indicating that the buffer is fully visible, do not scroll the + ;; window since that might make it impossible to scroll it back + ;; with GTK's thumb (Bug#32002). + (when (or scroll-bar-adjust-thumb-portion + (not (numberp (car portion-whole))) + (not (numberp (cdr portion-whole))) + (/= (car portion-whole) (cdr portion-whole))) + (save-excursion + (with-current-buffer (window-buffer window) + ;; Calculate position relative to the accessible part of the buffer. + (goto-char (+ (point-min) + (scroll-bar-scale portion-whole + (- (point-max) (point-min))))) + (vertical-motion 0 window) + (set-window-start window (point))))))) (defun scroll-bar-drag (event) "Scroll the window by dragging the scroll bar slider. diff --git a/lisp/scroll-lock.el b/lisp/scroll-lock.el index f3ab069b3ec..3a74c11b7a1 100644 --- a/lisp/scroll-lock.el +++ b/lisp/scroll-lock.el @@ -36,6 +36,7 @@ (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.") @@ -49,12 +50,11 @@ ;;;###autoload (define-minor-mode scroll-lock-mode "Buffer-local minor mode for pager-like scrolling. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. 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." + +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." :lighter " ScrLck" :keymap scroll-lock-mode-map (if scroll-lock-mode @@ -82,6 +82,16 @@ vertically fixed relative to window boundaries during scrolling." (move-to-column column) (forward-char (min column (- (line-end-position) (point)))))) +(defun scroll-lock-next-line-always-scroll (&optional arg) + "Scroll up ARG lines keeping point fixed." + (interactive "p") + (or arg (setq arg 1)) + (scroll-lock-update-goal-column) + (condition-case nil + (scroll-up arg) + (end-of-buffer (goto-char (point-max)) (recenter 1))) + (scroll-lock-move-to-column scroll-lock-temporary-goal-column)) + (defun scroll-lock-next-line (&optional arg) "Scroll up ARG lines keeping point fixed." (interactive "p") diff --git a/lisp/select.el b/lisp/select.el index f590025d8b9..59bcf7da664 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -49,16 +49,17 @@ the current system default encoding on 9x/Me, `utf-16le-dos' For X Windows: When sending text via selection and clipboard, if the target -data-type matches with the type of this coding system, it is used -for encoding the text. Otherwise (including the case that this -variable is nil), a proper coding system is used as below: +data-type matches this coding system according to the table +below, it is used for encoding the text. Otherwise (including +the case that this variable is nil), a proper coding system is +selected as below: data-type coding system --------- ------------- UTF8_STRING utf-8 COMPOUND_TEXT compound-text-with-extensions STRING iso-latin-1 -C_STRING no-conversion +C_STRING raw-text-unix When receiving text, if this coding system is non-nil, it is used for decoding regardless of the data-type. If this is nil, a @@ -86,6 +87,8 @@ After the communication, this variable is set to nil.") ;; Only declared obsolete in 23.3. (define-obsolete-function-alias 'x-selection 'x-get-selection "at least 19.34") +(define-obsolete-variable-alias 'x-select-enable-clipboard + 'select-enable-clipboard "25.1") (defcustom select-enable-clipboard t "Non-nil means cutting and pasting uses the clipboard. This can be in addition to, but in preference to, the primary selection, @@ -94,9 +97,9 @@ if applicable (i.e. under X11)." :group 'killing ;; The GNU/Linux version changed in 24.1, the MS-Windows version did not. :version "24.1") -(define-obsolete-variable-alias 'x-select-enable-clipboard - 'select-enable-clipboard "25.1") +(define-obsolete-variable-alias 'x-select-enable-primary + 'select-enable-primary "25.1") (defcustom select-enable-primary nil "Non-nil means cutting and pasting uses the primary selection. The existence of a primary selection depends on the underlying GUI you use. @@ -104,8 +107,6 @@ E.g. it doesn't exist under MS-Windows." :type 'boolean :group 'killing :version "25.1") -(define-obsolete-variable-alias 'x-select-enable-primary - 'select-enable-primary "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 @@ -309,6 +310,10 @@ the formats available in the clipboard if TYPE is `CLIPBOARD'." (_ (error "Unknown selection data type: %S" type)))))) (setq data (if coding (decode-coding-string data coding) + ;; This is for C_STRING case. + ;; We want to convert each non-ASCII byte to the + ;; corresponding eight-bit character, which has + ;; a codepoint >= #x3FFF00. (string-to-multibyte data)))) (setq next-selection-coding-system nil) (put-text-property 0 (length data) 'foreign-selection data-type data)) @@ -472,7 +477,15 @@ two markers or an overlay. Otherwise, it is nil." (setq str (encode-coding-string str coding))) ((eq type 'C_STRING) - (setq str (string-make-unibyte str))) + ;; According to ICCCM Protocol v2.0 (para 2.7.1), C_STRING + ;; is a zero-terminated sequence of raw bytes that + ;; shouldn't be interpreted as text in any encoding. + ;; Therefore, if STR is unibyte (the normal case), we use + ;; it as-is; otherwise we assume some of the characters + ;; are eight-bit and ensure they are converted to their + ;; single-byte representation. + (or (null (multibyte-string-p str)) + (setq str (encode-coding-string str 'raw-text-unix)))) (t (error "Unknown selection type: %S" type))))) diff --git a/lisp/server.el b/lisp/server.el index 42329e853ba..d491a260377 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -96,7 +96,6 @@ (unless load-in-progress (message "Local sockets unsupported, using TCP sockets"))) (set-default sym val)) - :group 'server :type 'boolean :version "22.1") @@ -108,7 +107,6 @@ DO NOT give this a non-nil value unless you know what you are doing! On unsecured networks, accepting remote connections is very dangerous, because server-client communication (including session authentication) is not encrypted." - :group 'server :type '(choice (string :tag "Name or IP address") (const :tag "Local" nil)) @@ -121,7 +119,6 @@ is not encrypted." This variable only takes effect when the Emacs server is using TCP instead of local sockets. A nil value means to use a random port number." - :group 'server :type '(choice (string :tag "Port number") (const :tag "Random" nil)) @@ -138,7 +135,6 @@ NOTE: On FAT32 filesystems, directories are not secure; files can be read and modified by any user or process. It is strongly suggested to set `server-auth-dir' to a directory residing in a NTFS partition instead." - :group 'server :type 'directory :version "22.1") ;;;###autoload @@ -166,7 +162,6 @@ communications are unencrypted, still apply. The key must consist of 64 ASCII printable characters except for space (this means characters from ! to ~; or from code 33 to 126). You can use \\[server-generate-key] to get a random key." - :group 'server :type '(choice (const :tag "Random" nil) (string :tag "Password")) @@ -174,23 +169,25 @@ space (this means characters from ! to ~; or from code 33 to (defcustom server-raise-frame t "If non-nil, raise frame when switching to a buffer." - :group 'server :type 'boolean :version "22.1") (defcustom server-visit-hook nil "Hook run when visiting a file for the Emacs server." - :group 'server :type 'hook) (defcustom server-switch-hook nil "Hook run when switching to a buffer for the Emacs server." - :group 'server :type 'hook) +(defcustom server-after-make-frame-hook nil + "Hook run when the Emacs server creates a client frame. +The created frame is selected when the hook is called." + :type 'hook + :version "27.1") + (defcustom server-done-hook nil "Hook run when done editing a buffer for the Emacs server." - :group 'server :type 'hook) (defvar server-process nil @@ -216,7 +213,6 @@ If it is a frame, use the frame's selected window. It is not meaningful to set this to a specific frame or window with Custom. Only programs can do so." - :group 'server :version "22.1" :type '(choice (const :tag "Use selected window" :match (lambda (widget value) @@ -226,11 +222,10 @@ Only programs can do so." (function-item :tag "Use pop-to-buffer" pop-to-buffer) (function :tag "Other function"))) -(defcustom server-temp-file-regexp "^/tmp/Re\\|/draft$" +(defcustom server-temp-file-regexp "\\`/tmp/Re\\|/draft\\'" "Regexp matching names of temporary files. These are deleted and reused after each edit by the programs that invoke the Emacs server." - :group 'server :type 'regexp) (defcustom server-kill-new-buffers t @@ -241,7 +236,6 @@ it with the Emacs server. If nil, kill only buffers as specified by Please note that only buffers that still have a client are killed, i.e. buffers visited with \"emacsclient --no-wait\" are never killed in this way." - :group 'server :type 'boolean :version "21.1") @@ -251,8 +245,16 @@ This means that the server should not kill the buffer when you say you are done with it in the server.") (make-variable-buffer-local 'server-existing-buffer) -;;;###autoload -(defcustom server-name "server" +(defvar server--external-socket-initialized nil + "When an external socket is passed into Emacs, we need to call +`server-start' in order to initialize the connection. This flag +prevents multiple initializations when an external socket has +been consumed.") + +(defcustom server-name + (if internal--daemon-sockname + (file-name-nondirectory internal--daemon-sockname) + "server") "The name of the Emacs server, if this Emacs process creates one. The command `server-start' makes use of this. It should not be changed while a server is running. @@ -263,15 +265,19 @@ If this is an absolute file name, it specifies where the socket file will be created. To have emacsclient connect to the same socket, use the \"-s\" switch for local non-TCP sockets, and the \"-f\" switch otherwise." - :group 'server :type 'string :version "23.1") ;; We do not use `temporary-file-directory' here, because emacsclient ;; does not read the init file. (defvar server-socket-dir - (and (featurep 'make-network-process '(:family local)) - (format "%s/emacs%d" (or (getenv "TMPDIR") "/tmp") (user-uid))) + (if internal--daemon-sockname + (file-name-directory internal--daemon-sockname) + (and (featurep 'make-network-process '(:family local)) + (let ((xdg_runtime_dir (getenv "XDG_RUNTIME_DIR"))) + (if xdg_runtime_dir + (format "%s/emacs" xdg_runtime_dir) + (format "%s/emacs%d" (or (getenv "TMPDIR") "/tmp") (user-uid)))))) "The directory in which to place the server socket. If local sockets are not supported, this is nil.") @@ -361,7 +367,7 @@ Updates `server-clients'." (server-log "Deleted" proc)))) -(defvar server-log-time-function 'current-time-string +(defvar server-log-time-function #'current-time-string "Function to generate timestamps for `server-buffer'.") (defconst server-buffer " *server*" @@ -530,13 +536,13 @@ Creates the directory if necessary and makes sure: (setq attrs (file-attributes dir 'integer))) ;; Check that it's safe for use. - (let* ((uid (nth 2 attrs)) + (let* ((uid (file-attribute-user-id attrs)) (w32 (eq system-type 'windows-nt)) (unsafe (cond - ((not (eq t (car attrs))) + ((not (eq t (file-attribute-type attrs))) (if (null attrs) "its attributes can't be checked" (format "it is a %s" - (if (stringp (car attrs)) + (if (stringp (file-attribute-type attrs)) "symlink" "file")))) ((and w32 (zerop uid)) ; on FAT32? (display-warning @@ -628,23 +634,29 @@ the `server-process' variable." (when server-process ;; kill it dead! (ignore-errors (delete-process server-process))) - ;; Delete the socket files made by previous server invocations. - (if (not (eq t (server-running-p server-name))) - ;; Remove any leftover socket or authentication file - (ignore-errors - (let (delete-by-moving-to-trash) - (delete-file server-file))) - (setq server-mode nil) ;; already set by the minor mode code - (display-warning - 'server - (concat "Unable to start the Emacs server.\n" - (format "There is an existing Emacs server, named %S.\n" - server-name) - (substitute-command-keys - "To start the server in this Emacs process, stop the existing + ;; Check to see if an uninitialized external socket has been + ;; passed in, if that is the case, skip checking + ;; `server-running-p' as this will return the wrong result. + (if (and internal--daemon-sockname + (not server--external-socket-initialized)) + (setq server--external-socket-initialized t) + ;; Delete the socket files made by previous server invocations. + (if (not (eq t (server-running-p server-name))) + ;; Remove any leftover socket or authentication file. + (ignore-errors + (let (delete-by-moving-to-trash) + (delete-file server-file))) + (setq server-mode nil) ;; already set by the minor mode code + (display-warning + 'server + (concat "Unable to start the Emacs server.\n" + (format "There is an existing Emacs server, named %S.\n" + server-name) + (substitute-command-keys + "To start the server in this Emacs process, stop the existing server or call `\\[server-force-delete]' to forcibly disconnect it.")) - :warning) - (setq leave-dead t)) + :warning) + (setq leave-dead t))) ;; If this Emacs already had a server, clear out associated status. (while server-clients (server-delete-client (car server-clients))) @@ -658,16 +670,16 @@ server or call `\\[server-force-delete]' to forcibly disconnect it.")) (when server-process (server-log (message "Restarting server"))) (cl-letf (((default-file-modes) ?\700)) - (add-hook 'suspend-tty-functions 'server-handle-suspend-tty) - (add-hook 'delete-frame-functions 'server-handle-delete-frame) + (add-hook 'suspend-tty-functions #'server-handle-suspend-tty) + (add-hook 'delete-frame-functions #'server-handle-delete-frame) (add-hook 'kill-emacs-query-functions - 'server-kill-emacs-query-function) + #'server-kill-emacs-query-function) ;; We put server's kill-emacs-hook after the others, so that ;; frames are not deleted too early, because doing that ;; would severely degrade our abilities to communicate with ;; the user, while some hooks may wish to ask the user ;; questions (e.g., desktop-kill). - (add-hook 'kill-emacs-hook 'server-force-stop t) ;Cleanup upon exit. + (add-hook 'kill-emacs-hook #'server-force-stop t) ;Cleanup upon exit. (setq server-process (apply #'make-network-process :name server-name @@ -761,15 +773,11 @@ by the current Emacs process, use the `server-process' variable." ;;;###autoload (define-minor-mode server-mode "Toggle Server mode. -With a prefix argument ARG, enable Server mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -Server mode if ARG is omitted or nil. Server mode runs a process that accepts commands from the `emacsclient' program. See Info node `Emacs server' and `server-start' for details." :global t - :group 'server :version "22.1" ;; Fixme: Should this check for an existing server socket and do ;; nothing if there is one (for multiple Emacs sessions)? @@ -784,7 +792,7 @@ Server mode runs a process that accepts commands from the ;; intended it to interrupt us rather than interrupt whatever Emacs ;; was doing before it started handling the process filter. ;; Hence `with-local-quit' (bug#6585). - (let ((v (with-local-quit (eval (car (read-from-string expr)))))) + (let ((v (with-local-quit (eval (car (read-from-string expr)) t)))) (when proc (with-temp-buffer (let ((standard-output (current-buffer))) @@ -815,7 +823,7 @@ This handles splitting the command if it would be bigger than (setq prefix "-print-nonl ")) (server-send-string proc (concat prefix qtext "\n")))) -(defun server-create-tty-frame (tty type proc) +(defun server-create-tty-frame (tty type proc &optional parameters) (unless tty (error "Invalid terminal device")) (unless type @@ -848,7 +856,8 @@ This handles splitting the command if it would be bigger than ;; envvars, and then to change the ;; C functions `child_setup' and ;; `getenv_internal' accordingly. - (environment . ,(process-get proc 'env))))))) + (environment . ,(process-get proc 'env)) + ,@parameters))))) ;; ttys don't use the `display' parameter, but callproc.c does to set ;; the DISPLAY environment on subprocesses. @@ -1075,9 +1084,8 @@ The following commands are accepted by the client: ;; supported any more. (cl-assert (eq (match-end 0) (length string))) (let ((request (substring string 0 (match-beginning 0))) - (coding-system (and (default-value 'enable-multibyte-characters) - (or file-name-coding-system - default-file-name-coding-system))) + (coding-system (or file-name-coding-system + default-file-name-coding-system)) nowait ; t if emacsclient does not want to wait for us. frame ; Frame opened for the client (if any). display ; Open frame on this display. @@ -1091,24 +1099,25 @@ The following commands are accepted by the client: tty-type ; string. files filepos - args-left) + args-left + create-frame-func) ;; Remove this line from STRING. (setq string (substring string (match-end 0))) (setq args-left - (mapcar 'server-unquote-arg (split-string request " " t))) + (mapcar #'server-unquote-arg (split-string request " " t))) (while args-left (pcase (pop args-left) ;; -version CLIENT-VERSION: obsolete at birth. - (`"-version" (pop args-left)) + ("-version" (pop args-left)) ;; -nowait: Emacsclient won't wait for a result. - (`"-nowait" (setq nowait t)) + ("-nowait" (setq nowait t)) ;; -current-frame: Don't create frames. - (`"-current-frame" (setq use-current-frame t)) + ("-current-frame" (setq use-current-frame t)) ;; -frame-parameters: Set frame parameters - (`"-frame-parameters" + ("-frame-parameters" (let ((alist (pop args-left))) (if coding-system (setq alist (decode-coding-string alist coding-system))) @@ -1116,24 +1125,24 @@ The following commands are accepted by the client: ;; -display DISPLAY: ;; Open X frames on the given display instead of the default. - (`"-display" + ("-display" (setq display (pop args-left)) (if (zerop (length display)) (setq display nil))) ;; -parent-id ID: ;; Open X frame within window ID, via XEmbed. - (`"-parent-id" + ("-parent-id" (setq parent-id (pop args-left)) (if (zerop (length parent-id)) (setq parent-id nil))) ;; -window-system: Open a new X frame. - (`"-window-system" + ("-window-system" (if (fboundp 'x-create-frame) (setq dontkill t tty-name 'window-system))) ;; -resume: Resume a suspended tty frame. - (`"-resume" + ("-resume" (let ((terminal (process-get proc 'terminal))) (setq dontkill t) (push (lambda () @@ -1144,7 +1153,7 @@ The following commands are accepted by the client: ;; -suspend: Suspend the client's frame. (In case we ;; get out of sync, and a C-z sends a SIGTSTP to ;; emacsclient.) - (`"-suspend" + ("-suspend" (let ((terminal (process-get proc 'terminal))) (setq dontkill t) (push (lambda () @@ -1154,13 +1163,13 @@ The following commands are accepted by the client: ;; -ignore COMMENT: Noop; useful for debugging emacsclient. ;; (The given comment appears in the server log.) - (`"-ignore" + ("-ignore" (setq dontkill t) (pop args-left)) ;; -tty DEVICE-NAME TYPE: Open a new tty frame. ;; (But if we see -window-system later, use that.) - (`"-tty" + ("-tty" (setq tty-name (pop args-left) tty-type (pop args-left) dontkill (or dontkill @@ -1179,7 +1188,7 @@ The following commands are accepted by the client: ;; -position LINE[:COLUMN]: Set point to the given ;; position in the next file. - (`"-position" + ("-position" (if (not (string-match "\\+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?" (car args-left))) (error "Invalid -position command in client args")) @@ -1190,7 +1199,7 @@ The following commands are accepted by the client: "")))))) ;; -file FILENAME: Load the given file. - (`"-file" + ("-file" (let ((file (pop args-left))) (if coding-system (setq file (decode-coding-string file coding-system))) @@ -1208,7 +1217,7 @@ The following commands are accepted by the client: (setq filepos nil)) ;; -eval EXPR: Evaluate a Lisp expression. - (`"-eval" + ("-eval" (if use-current-frame (setq use-current-frame 'always)) (let ((expr (pop args-left))) @@ -1219,14 +1228,14 @@ The following commands are accepted by the client: (setq filepos nil))) ;; -env NAME=VALUE: An environment variable. - (`"-env" + ("-env" (let ((var (pop args-left))) ;; XXX Variables should be encoded as in getenv/setenv. (process-put proc 'env (cons var (process-get proc 'env))))) ;; -dir DIRNAME: The cwd of the emacsclient process. - (`"-dir" + ("-dir" (setq dir (pop args-left)) (if coding-system (setq dir (decode-coding-string dir coding-system))) @@ -1243,28 +1252,29 @@ The following commands are accepted by the client: (or files commands) (setq use-current-frame t)) - (setq frame - (cond - ((and use-current-frame - (or (eq use-current-frame 'always) - ;; We can't use the Emacs daemon's - ;; terminal frame. - (not (and (daemonp) - (null (cdr (frame-list))) - (eq (selected-frame) - terminal-frame))))) - (setq tty-name nil tty-type nil) - (if display (server-select-display display))) - ((or (and (eq system-type 'windows-nt) - (daemonp) - (setq display "w32")) - (eq tty-name 'window-system)) - (server-create-window-system-frame display nowait proc - parent-id - frame-parameters)) - ;; When resuming on a tty, tty-name is nil. - (tty-name - (server-create-tty-frame tty-name tty-type proc)))) + (setq create-frame-func + (lambda () + (cond + ((and use-current-frame + (or (eq use-current-frame 'always) + ;; We can't use the Emacs daemon's + ;; terminal frame. + (not (and (daemonp) + (null (cdr (frame-list))) + (eq (selected-frame) + terminal-frame))))) + (setq tty-name nil tty-type nil) + (if display (server-select-display display))) + ((or (and (eq system-type 'windows-nt) + (daemonp) + (setq display "w32")) + (eq tty-name 'window-system)) + (server-create-window-system-frame display nowait proc + parent-id + frame-parameters)) + ;; When resuming on a tty, tty-name is nil. + (tty-name + (server-create-tty-frame tty-name tty-type proc))))) (process-put proc 'continuation @@ -1276,16 +1286,16 @@ The following commands are accepted by the client: (if (and dir (file-directory-p dir)) dir default-directory))) (server-execute proc files nowait commands - dontkill frame tty-name))))) + dontkill create-frame-func tty-name))))) (when (or frame files) (server-goto-toplevel proc)) (server-execute-continuation proc)))) ;; condition-case - (error (server-return-error proc err)))) + (t (server-return-error proc err)))) -(defun server-execute (proc files nowait commands dontkill frame tty-name) +(defun server-execute (proc files nowait commands dontkill create-frame-func tty-name) ;; This is run from timers and process-filters, i.e. "asynchronously". ;; But w.r.t the user, this is not really asynchronous since the timer ;; is run after 0s and the process-filter is run in response to the @@ -1295,21 +1305,29 @@ The following commands are accepted by the client: ;; including code that needs to wait. (with-local-quit (condition-case err - (let ((buffers (server-visit-files files proc nowait))) - (mapc 'funcall (nreverse commands)) - - ;; If we were told only to open a new client, obey - ;; `initial-buffer-choice' if it specifies a file - ;; or a function. - (unless (or files commands) - (let ((buf - (cond ((stringp initial-buffer-choice) - (find-file-noselect initial-buffer-choice)) - ((functionp initial-buffer-choice) - (funcall initial-buffer-choice))))) - (switch-to-buffer - (if (buffer-live-p buf) buf (get-buffer-create "*scratch*")) - 'norecord))) + (let* ((buffers (server-visit-files files proc nowait)) + ;; If we were told only to open a new client, obey + ;; `initial-buffer-choice' if it specifies a file + ;; or a function. + (initial-buffer (unless (or files commands) + (let ((buf + (cond ((stringp initial-buffer-choice) + (find-file-noselect initial-buffer-choice)) + ((functionp initial-buffer-choice) + (funcall initial-buffer-choice))))) + (if (buffer-live-p buf) buf (startup--get-buffer-create-scratch))))) + ;; Set current buffer so that newly created tty frames + ;; show the correct buffer initially. + (frame (with-current-buffer (or (car buffers) + initial-buffer + (current-buffer)) + (prog1 + (funcall create-frame-func) + ;; Switch to initial buffer in case the frame was reused. + (when initial-buffer + (switch-to-buffer initial-buffer 'norecord)))))) + + (mapc #'funcall (nreverse commands)) ;; Delete the client if necessary. (cond @@ -1325,9 +1343,11 @@ The following commands are accepted by the client: ((or isearch-mode (minibufferp)) nil) ((and frame (null buffers)) + (run-hooks 'server-after-make-frame-hook) (message "%s" (substitute-command-keys "When done with this frame, type \\[delete-frame]"))) ((not (null buffers)) + (run-hooks 'server-after-make-frame-hook) (server-switch-buffer (car buffers) nil (cdr (car files))) (run-hooks 'server-switch-hook) (unless nowait @@ -1407,7 +1427,7 @@ so don't mark these buffers specially, just visit them normally." (run-hooks 'post-command-hook)) (unless nowait ;; When the buffer is killed, inform the clients. - (add-hook 'kill-buffer-hook 'server-kill-buffer nil t) + (add-hook 'kill-buffer-hook #'server-kill-buffer nil t) (push proc server-buffer-clients)) (push (current-buffer) client-record))) (unless nowait @@ -1518,8 +1538,8 @@ specifically for the clients and did not exist before their request for it." "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))) + (when (memq t (mapcar #'buffer-live-p + (process-get proc 'buffers))) (setq live-client t))) live-client)) (yes-or-no-p "This Emacs session has clients; exit anyway? "))) @@ -1555,7 +1575,7 @@ starts server process and that is all. Invoked by \\[server-edit]." (not server-process) (memq (process-status server-process) '(signal exit))) (server-mode 1)) - (server-clients (apply 'server-switch-buffer (server-done))) + (server-clients (apply #'server-switch-buffer (server-done))) (t (message "No server editing buffers exist")))) (defun server-switch-buffer (&optional next-buffer killed-one filepos) @@ -1588,7 +1608,7 @@ be a cons cell (LINENUMBER . COLUMNNUMBER)." (if (not (buffer-live-p next-buffer)) ;; If NEXT-BUFFER is a dead buffer, remove the server records for it ;; and try the next surviving server buffer. - (apply 'server-switch-buffer (server-buffer-done next-buffer)) + (apply #'server-switch-buffer (server-buffer-done next-buffer)) ;; OK, we know next-buffer is live, let's display and select it. (if (functionp server-window) (funcall server-window next-buffer) @@ -1653,13 +1673,15 @@ only these files will be asked to be saved." (save-buffers-kill-emacs arg))) ((processp proc) (let ((buffers (process-get proc 'buffers))) - ;; If client is bufferless, emulate a normal Emacs exit - ;; and offer to save all buffers. Otherwise, offer to - ;; save only the buffers belonging to the client. (save-some-buffers arg (if buffers + ;; Only files from emacsclient file list. (lambda () (memq (current-buffer) buffers)) - t)) + ;; 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"))))) @@ -1672,7 +1694,7 @@ only these files will be asked to be saved." (save-current-buffer (dolist (buffer (buffer-list)) (set-buffer buffer) - (remove-hook 'kill-buffer-hook 'server-kill-buffer t))) + (remove-hook 'kill-buffer-hook #'server-kill-buffer t))) ;; continue standard unloading nil) @@ -1715,7 +1737,7 @@ returns the process ID of the Emacs instance running \"server\"." (server-quote-arg (format "%S" form)) "\n")) (while (memq (process-status process) '(open run)) - (accept-process-output process 0 10)) + (accept-process-output process 0.01)) (goto-char (point-min)) ;; If the result is nil, there's nothing in the buffer. If the ;; result is non-nil, it's after "-print ". diff --git a/lisp/ses.el b/lisp/ses.el index f3de00427b3..37d0d615033 100644 --- a/lisp/ses.el +++ b/lisp/ses.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2002-2019 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@member.fsf.org> -;; Maintainer: Vincent Belaïche <vincentb1@users.sourceforge.net> +;; Maintainer: Vincent Belaïche <vincentb1@users.sourceforge.net> ;; Keywords: spreadsheet Dijkstra ;; This file is part of GNU Emacs. @@ -837,7 +837,7 @@ updated again." (defmacro ses--time-check (format &rest args) "If `ses-start-time' is more than a second ago, call `message' with FORMAT and ARGS and reset `ses-start-time' to the current time." - `(when (> (- (float-time) ses-start-time) 1.0) + `(when (time-less-p 1 (time-since ses-start-time)) (message ,format ,@args) (setq ses-start-time (float-time)))) @@ -858,7 +858,7 @@ cell (ROW,COL). This is undoable. The cell's data will be updated through ,(let ((field (progn (cl-assert (eq (car field) 'quote)) (cadr field)))) (if (eq field 'value) - `(ses-set-with-undo (ses-cell-symbol cell) val) + '(ses-set-with-undo (ses-cell-symbol cell) val) ;; (let* ((slots (get 'ses-cell 'cl-struct-slots)) ;; (slot (or (assq field slots) ;; (error "Unknown field %S" field))) @@ -1509,8 +1509,9 @@ Newlines in the data are escaped." ,printer ,(ses-cell-references cell)))) (ses-goto-data row col) - (delete-region (point) (line-end-position)) - (insert text))) + (let ((inhibit-quit t)) + (delete-region (point) (line-end-position)) + (insert text)))) (message " ")))) @@ -2495,7 +2496,7 @@ to are recalculated first." prefix-length) (when (and prefix (null (string= prefix ""))) (setq prefix-length (length prefix)) - (maphash (lambda (key val) + (maphash (lambda (key _val) (let ((key-name (symbol-name key))) (when (and (>= (length key-name) prefix-length) (string= prefix (substring key-name 0 prefix-length))) @@ -2648,7 +2649,7 @@ cells." prefix-length) (when prefix (setq prefix-length (length prefix)) - (maphash (lambda (key val) + (maphash (lambda (key _val) (let ((key-name (symbol-name key))) (when (and (>= (length key-name) prefix-length) (string= prefix (substring key-name 0 prefix-length))) @@ -3956,17 +3957,17 @@ Use `math-format-value' as a printer for Calc objects." (while rest (let ((x (pop rest))) (pcase x - (`>v (setq transpose nil reorient-x nil reorient-y nil)) - (`>^ (setq transpose nil reorient-x nil reorient-y t)) - (`<^ (setq transpose nil reorient-x t reorient-y t)) - (`<v (setq transpose nil reorient-x t reorient-y nil)) - (`v> (setq transpose t reorient-x nil reorient-y t)) - (`^> (setq transpose t reorient-x nil reorient-y nil)) - (`^< (setq transpose t reorient-x t reorient-y nil)) - (`v< (setq transpose t reorient-x t reorient-y t)) - ((or `* `*2 `*1) (setq vectorize x)) - (`! (setq clean 'ses--clean-!)) - (`_ (setq clean `(lambda (&rest x) + ('>v (setq transpose nil reorient-x nil reorient-y nil)) + ('>^ (setq transpose nil reorient-x nil reorient-y t)) + ('<^ (setq transpose nil reorient-x t reorient-y t)) + ('<v (setq transpose nil reorient-x t reorient-y nil)) + ('v> (setq transpose t reorient-x nil reorient-y t)) + ('^> (setq transpose t reorient-x nil reorient-y nil)) + ('^< (setq transpose t reorient-x t reorient-y nil)) + ('v< (setq transpose t reorient-x t reorient-y t)) + ((or '* '*2 '*1) (setq vectorize x)) + ('! (setq clean 'ses--clean-!)) + ('_ (setq clean `(lambda (&rest x) (ses--clean-_ x ,(if rest (pop rest) 0))))) (_ (cond @@ -4001,10 +4002,10 @@ Use `math-format-value' as a printer for Calc objects." (cons clean (cons (quote 'vec) x))) result))))) (pcase vectorize - (`nil (cons clean (apply #'append result))) - (`*1 (vectorize-*1 clean result)) - (`*2 (vectorize-*2 clean result)) - (`* (funcall (if (cdr result) + ('nil (cons clean (apply #'append result))) + ('*1 (vectorize-*1 clean result)) + ('*2 (vectorize-*2 clean result)) + ('* (funcall (if (cdr result) #'vectorize-*2 #'vectorize-*1) clean result)))))) diff --git a/lisp/shadowfile.el b/lisp/shadowfile.el index 729bcbb4f37..07e78506654 100644 --- a/lisp/shadowfile.el +++ b/lisp/shadowfile.el @@ -307,14 +307,7 @@ Replace HOST, and NAME when non-nil." (if (null (tramp-file-name-method hup)) (format "/%s:%s" (tramp-file-name-host hup) (tramp-file-name-localname hup)) - (tramp-make-tramp-file-name - (tramp-file-name-method hup) - (tramp-file-name-user hup) - (tramp-file-name-domain hup) - (tramp-file-name-host hup) - (tramp-file-name-port hup) - (tramp-file-name-localname hup) - (tramp-file-name-hop hup))))) + (tramp-make-tramp-file-name hup)))) (defun shadow-replace-name-component (fullname newname) "Return FULLNAME with the name component changed to NEWNAME." diff --git a/lisp/shell.el b/lisp/shell.el index 78227ca7351..2914d1d2c81 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -73,7 +73,7 @@ ;; c-c c-o comint-delete-output Delete last batch of process output ;; c-c c-r comint-show-output Show last batch of process output ;; c-c c-l comint-dynamic-list-input-ring List input history -;; send-invisible Read line w/o echo & send to proc +;; comint-send-invisible Read line w/o echo & send to proc ;; comint-continue-subjob Useful if you accidentally suspend ;; top-level job ;; comint-mode-hook is the comint mode hook. @@ -99,6 +99,7 @@ (require 'comint) (require 'pcomplete) +(eval-when-compile (require 'files-x)) ;with-connection-local-variables ;;; Customization and Buffer Variables @@ -315,6 +316,8 @@ for Shell mode only." "List of directories saved by pushd in this buffer's shell. Thus, this does not include the shell's current directory.") +(defvaralias 'shell-dirtrack-mode 'shell-dirtrackp) + (defvar shell-dirtrackp t "Non-nil in a shell buffer means directory tracking is enabled.") @@ -355,6 +358,10 @@ Thus, this does not include the shell's current directory.") ("^\\[[1-9][0-9]*\\]" . font-lock-string-face)) "Additional expressions to highlight in Shell mode.") +(defvar-local shell--start-prog nil + "Shell file name started in `shell'.") +(put 'shell--start-prog 'permanent-local t) + ;;; Basic Procedures (defun shell--unquote&requote-argument (qstr &optional upos) @@ -424,7 +431,7 @@ Thus, this does not include the shell's current directory.") (while (looking-at (eval-when-compile (concat - "\\(?:[^\s\t\n\\\"']+" + "\\(?:[^\s\t\n\\\"';]+" "\\|'\\([^']*\\)'?" "\\|\"\\(\\(?:[^\"\\]\\|\\\\.\\)*\\)\"?" "\\|\\\\\\(\\(?:.\\|\n\\)?\\)\\)"))) @@ -466,6 +473,8 @@ Shell buffers. It implements `shell-completion-execonly' for (set (make-local-variable 'comint-file-name-chars) shell-file-name-chars) (set (make-local-variable 'comint-file-name-quote-list) shell-file-name-quote-list) + (set (make-local-variable 'comint-file-name-prefix) + (or (file-remote-p default-directory) "")) (set (make-local-variable 'comint-dynamic-complete-functions) shell-dynamic-complete-functions) (setq-local comint-unquote-function #'shell--unquote-argument) @@ -486,7 +495,7 @@ Shell buffers. It implements `shell-completion-execonly' for (setq-local comint-input-autoexpand shell-input-autoexpand) ;; Not needed in shell-mode because it's inherited from comint-mode, but ;; placed here for read-shell-command. - (add-hook 'completion-at-point-functions 'comint-completion-at-point nil t)) + (add-hook 'completion-at-point-functions #'comint-completion-at-point nil t)) (put 'shell-mode 'mode-class 'special) @@ -496,7 +505,7 @@ Shell buffers. It implements `shell-completion-execonly' for the end of process to the end of the current line. \\[comint-send-input] before end of process output copies the current line minus the prompt to the end of the buffer and sends it (\\[comint-copy-old-input] just copies the current line). -\\[send-invisible] reads a line of text without echoing it, and sends it to +\\[comint-send-invisible] reads a line of text without echoing it, and sends it to the shell. This is useful for entering passwords. Or, add the function `comint-watch-for-password-prompt' to `comint-output-filter-functions'. @@ -568,18 +577,26 @@ buffer." (setq list-buffers-directory (expand-file-name default-directory)) ;; shell-dependent assignments. (when (ring-empty-p comint-input-ring) - (let ((shell (file-name-nondirectory (car - (process-command (get-buffer-process (current-buffer)))))) - (hsize (getenv "HISTSIZE"))) + (let ((remote (file-remote-p default-directory)) + (shell (or shell--start-prog "")) + (hsize (getenv "HISTSIZE")) + (hfile (getenv "HISTFILE"))) + (when remote + ;; `shell-snarf-envar' does not work trustworthy. + (setq hsize (shell-command-to-string "echo -n $HISTSIZE") + hfile (shell-command-to-string "echo -n $HISTFILE"))) + (and (string-equal hfile "") (setq hfile nil)) (and (stringp hsize) (integerp (setq hsize (string-to-number hsize))) (> hsize 0) (set (make-local-variable 'comint-input-ring-size) hsize)) (setq comint-input-ring-file-name - (or (getenv "HISTFILE") - (cond ((string-equal shell "bash") "~/.bash_history") - ((string-equal shell "ksh") "~/.sh_history") - (t "~/.history")))) + (concat + remote + (or hfile + (cond ((string-equal shell "bash") "~/.bash_history") + ((string-equal shell "ksh") "~/.sh_history") + (t "~/.history"))))) (if (or (equal comint-input-ring-file-name "") (equal (file-truename comint-input-ring-file-name) (file-truename "/dev/null"))) @@ -600,7 +617,7 @@ buffer." ;; Bypass a bug in certain versions of bash. (when (string-equal shell "bash") (add-hook 'comint-preoutput-filter-functions - 'shell-filter-ctrl-a-ctrl-b nil t))) + #'shell-filter-ctrl-a-ctrl-b nil t))) (comint-read-input-ring t))) (defun shell-apply-ansi-color (beg end face) @@ -714,43 +731,38 @@ Otherwise, one argument `-i' is passed to the shell. (current-buffer))) (with-current-buffer buffer - (when (file-remote-p default-directory) - ;; Apply connection-local variables. - (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))) - - ;; On remote hosts, the local `shell-file-name' might be useless. - (if (and (called-interactively-p 'any) - (null explicit-shell-file-name) - (null (getenv "ESHELL"))) - (set (make-local-variable 'explicit-shell-file-name) - (file-local-name - (expand-file-name - (read-file-name - "Remote shell path: " default-directory shell-file-name - t shell-file-name))))))) - - ;; The buffer's window must be correctly set when we call comint - ;; (so that comint sets the COLUMNS env var properly). - (pop-to-buffer buffer) - ;; Rain or shine, BUFFER must be current by now. - (unless (comint-check-proc buffer) - (let* ((prog (or explicit-shell-file-name - (getenv "ESHELL") shell-file-name)) - (name (file-name-nondirectory prog)) - (startfile (concat "~/.emacs_" name)) - (xargs-name (intern-soft (concat "explicit-" name "-args")))) - (unless (file-exists-p startfile) - (setq startfile (concat user-emacs-directory "init_" name ".sh"))) - (apply 'make-comint-in-buffer "shell" buffer prog - (if (file-exists-p startfile) startfile) - (if (and xargs-name (boundp xargs-name)) - (symbol-value xargs-name) - '("-i"))) - (shell-mode))) + (with-connection-local-variables + ;; On remote hosts, the local `shell-file-name' might be useless. + (when (file-remote-p default-directory) + (if (and (called-interactively-p 'any) + (null explicit-shell-file-name) + (null (getenv "ESHELL"))) + (set (make-local-variable 'explicit-shell-file-name) + (file-local-name + (expand-file-name + (read-file-name + "Remote shell path: " default-directory shell-file-name + t shell-file-name)))))) + + ;; The buffer's window must be correctly set when we call comint + ;; (so that comint sets the COLUMNS env var properly). + (pop-to-buffer buffer) + ;; Rain or shine, BUFFER must be current by now. + (unless (comint-check-proc buffer) + (let* ((prog (or explicit-shell-file-name + (getenv "ESHELL") shell-file-name)) + (name (file-name-nondirectory prog)) + (startfile (concat "~/.emacs_" name)) + (xargs-name (intern-soft (concat "explicit-" name "-args")))) + (unless (file-exists-p startfile) + (setq startfile (concat user-emacs-directory "init_" name ".sh"))) + (setq-local shell--start-prog (file-name-nondirectory prog)) + (apply #'make-comint-in-buffer "shell" buffer prog + (if (file-exists-p startfile) startfile) + (if (and xargs-name (boundp xargs-name)) + (symbol-value xargs-name) + '("-i"))) + (shell-mode))))) buffer) ;;; Directory tracking @@ -959,22 +971,18 @@ Environment variables are expanded, see function `substitute-in-file-name'." (and (string-match "^\\+[1-9][0-9]*$" str) (string-to-number str))) -(defvaralias 'shell-dirtrack-mode 'shell-dirtrackp) (define-minor-mode shell-dirtrack-mode "Toggle directory tracking in this shell buffer (Shell Dirtrack mode). -With a prefix argument ARG, enable Shell Dirtrack mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. The `dirtrack' package provides an alternative implementation of this feature; see the function `dirtrack-mode'." nil nil nil (setq list-buffers-directory (if shell-dirtrack-mode default-directory)) (if shell-dirtrack-mode - (add-hook 'comint-input-filter-functions 'shell-directory-tracker nil t) - (remove-hook 'comint-input-filter-functions 'shell-directory-tracker t))) + (add-hook 'comint-input-filter-functions #'shell-directory-tracker nil t) + (remove-hook 'comint-input-filter-functions #'shell-directory-tracker t))) -(define-obsolete-function-alias 'shell-dirtrack-toggle 'shell-dirtrack-mode +(define-obsolete-function-alias 'shell-dirtrack-toggle #'shell-dirtrack-mode "23.1") (defun shell-cd (dir) @@ -1167,9 +1175,12 @@ Returns t if successful." (start (if (zerop (length filename)) (point) (match-beginning 0))) (end (if (zerop (length filename)) (point) (match-end 0))) (filenondir (file-name-nondirectory filename)) - ; why cdr? see `shell-dynamic-complete-command' - (path-dirs (append (cdr (reverse exec-path)) - (if (memq system-type '(windows-nt ms-dos)) '(".")))) + (path-dirs + ;; Ignore `exec-directory', the last entry in `exec-path'. + (append (cdr (reverse (exec-path))) + (if (and (memq system-type '(windows-nt ms-dos)) + (not (file-remote-p default-directory))) + '(".")))) (cwd (file-name-as-directory (expand-file-name default-directory))) (ignored-extensions (and comint-completion-fignore diff --git a/lisp/simple.el b/lisp/simple.el index a0f2da7152c..0bc39f08c07 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -37,28 +37,6 @@ (defvar compilation-current-error) (defvar compilation-context-lines) -(defcustom shell-command-dont-erase-buffer nil - "If non-nil, output buffer is not erased between shell commands. -Also, a non-nil value sets the point in the output buffer -once the command completes. -The value `beg-last-out' sets point at the beginning of the output, -`end-last-out' sets point at the end of the buffer, `save-point' -restores the buffer position before the command." - :type '(choice - (const :tag "Erase buffer" nil) - (const :tag "Set point to beginning of last output" beg-last-out) - (const :tag "Set point to end of last output" end-last-out) - (const :tag "Save point" save-point)) - :group 'shell - :version "26.1") - -(defvar shell-command-saved-pos nil - "Record of point positions in output buffers after command completion. -The value is an alist whose elements are of the form (BUFFER . POS), -where BUFFER is the output buffer, and POS is the point position -in BUFFER once the command finishes. -This variable is used when `shell-command-dont-erase-buffer' is non-nil.") - (defcustom idle-update-delay 0.5 "Idle time delay before updating various things on the screen. Various Emacs features that update auxiliary information when point moves @@ -132,6 +110,15 @@ If non-nil, the value is passed directly to `recenter'." :type 'hook :group 'next-error) +(defcustom next-error-verbose t + "If non-nil, `next-error' always outputs the current error buffer. +If nil, the message is output only when the error buffer +changes." + :group 'next-error + :type 'boolean + :safe #'booleanp + :version "27.1") + (defvar next-error-highlight-timer nil) (defvar next-error-overlay-arrow-position nil) @@ -144,6 +131,14 @@ A buffer becomes most recent when its compilation, grep, or similar mode is started, or when it is used with \\[next-error] or \\[compile-goto-error].") +(defvar next-error-buffer nil + "The buffer-local value of the most recent `next-error' buffer.") +;; next-error-buffer is made buffer-local to keep the reference +;; to the parent buffer used to navigate to the current buffer, so the +;; next call of next-buffer will use the same parent buffer to +;; continue navigation from it. +(make-variable-buffer-local 'next-error-buffer) + (defvar next-error-function nil "Function to use to find the next error in the current buffer. The function is called with 2 parameters: @@ -191,6 +186,47 @@ rejected, and the function returns nil." (and extra-test-inclusive (funcall extra-test-inclusive)))))) +(defcustom next-error-find-buffer-function #'ignore + "Function called to find a `next-error' capable buffer. +This functions takes the same three arguments as the function +`next-error-find-buffer', and should return the buffer to be +used by the subsequent invocation of the command `next-error' +and `previous-error'. +If the function returns nil, `next-error-find-buffer' will +try to use the buffer it used previously, and failing that +all other buffers." + :type '(choice (const :tag "No default" ignore) + (const :tag "Single next-error capable buffer on selected frame" + next-error-buffer-on-selected-frame) + (function :tag "Other function")) + :group 'next-error + :version "27.1") + +(defcustom next-error-found-function #'ignore + "Function called when a next locus is found and displayed. +Function is called with two arguments: a FROM-BUFFER buffer +from which next-error navigated, and a target buffer TO-BUFFER." + :type '(choice (const :tag "No default" ignore) + (function :tag "Other function")) + :group 'next-error + :version "27.1") + +(defun next-error-buffer-on-selected-frame (&optional _avoid-current + extra-test-inclusive + extra-test-exclusive) + "Return a single visible next-error buffer on the selected frame." + (let ((window-buffers + (delete-dups + (delq nil (mapcar (lambda (w) + (if (next-error-buffer-p + (window-buffer w) + t + extra-test-inclusive extra-test-exclusive) + (window-buffer w))) + (window-list)))))) + (if (eq (length window-buffers) 1) + (car window-buffers)))) + (defun next-error-find-buffer (&optional avoid-current extra-test-inclusive extra-test-exclusive) @@ -207,28 +243,28 @@ The function EXTRA-TEST-EXCLUSIVE, if non-nil, is called in each buffer that would normally be considered usable. If it returns nil, that buffer is rejected." (or - ;; 1. If one window on the selected frame displays such buffer, return it. - (let ((window-buffers - (delete-dups - (delq nil (mapcar (lambda (w) - (if (next-error-buffer-p - (window-buffer w) - avoid-current - extra-test-inclusive extra-test-exclusive) - (window-buffer w))) - (window-list)))))) - (if (eq (length window-buffers) 1) - (car window-buffers))) - ;; 2. If next-error-last-buffer is an acceptable buffer, use that. + ;; 1. If a customizable function returns a buffer, use it. + (funcall next-error-find-buffer-function avoid-current + extra-test-inclusive + extra-test-exclusive) + ;; 2. If next-error-buffer has no buffer-local value + ;; (i.e. never navigated to the current buffer from another), + ;; and the current buffer is a `next-error' capable buffer, + ;; use it unconditionally, so next-error will always use it. + (if (and (not (local-variable-p 'next-error-buffer)) + (next-error-buffer-p (current-buffer) avoid-current + extra-test-inclusive extra-test-exclusive)) + (current-buffer)) + ;; 3. If next-error-last-buffer is an acceptable buffer, use that. (if (and next-error-last-buffer (next-error-buffer-p next-error-last-buffer avoid-current extra-test-inclusive extra-test-exclusive)) next-error-last-buffer) - ;; 3. If the current buffer is acceptable, choose it. + ;; 4. If the current buffer is acceptable, choose it. (if (next-error-buffer-p (current-buffer) avoid-current extra-test-inclusive extra-test-exclusive) (current-buffer)) - ;; 4. Look for any acceptable buffer. + ;; 5. Look for any acceptable buffer. (let ((buffers (buffer-list))) (while (and buffers (not (next-error-buffer-p @@ -236,7 +272,7 @@ that buffer is rejected." extra-test-inclusive extra-test-exclusive))) (setq buffers (cdr buffers))) (car buffers)) - ;; 5. Use the current buffer as a last resort if it qualifies, + ;; 6. Use the current buffer as a last resort if it qualifies, ;; even despite AVOID-CURRENT. (and avoid-current (next-error-buffer-p (current-buffer) nil @@ -244,7 +280,7 @@ that buffer is rejected." (progn (message "This is the only buffer with error message locations") (current-buffer))) - ;; 6. Give up. + ;; 7. Give up. (error "No buffers contain error message locations"))) (defun next-error (&optional arg reset) @@ -267,8 +303,9 @@ more generally, on any buffer in Compilation mode or with Compilation Minor mode enabled, or any buffer in which `next-error-function' is bound to an appropriate function. To specify use of a particular buffer for error messages, type -\\[next-error] in that buffer when it is the only one displayed -in the current frame. +\\[next-error] in that buffer. You can also use the command +`next-error-select-buffer' to select the buffer to use for the subsequent +invocation of `next-error'. Once \\[next-error] has chosen the buffer for error messages, it runs `next-error-hook' with `run-hooks', and stays with that buffer @@ -279,23 +316,57 @@ To control which errors are matched, customize the variable `compilation-error-regexp-alist'." (interactive "P") (if (consp arg) (setq reset t arg nil)) - (when (setq next-error-last-buffer (next-error-find-buffer)) - ;; we know here that next-error-function is a valid symbol we can funcall - (with-current-buffer next-error-last-buffer - (funcall next-error-function (prefix-numeric-value arg) reset) - (when next-error-recenter - (recenter next-error-recenter)) - (run-hooks 'next-error-hook)))) + (let ((buffer (next-error-find-buffer))) + (when buffer + ;; We know here that next-error-function is a valid symbol we can funcall + (with-current-buffer buffer + (funcall next-error-function (prefix-numeric-value arg) reset) + (let ((prev next-error-last-buffer)) + (next-error-found buffer (current-buffer)) + (when (or next-error-verbose + (not (eq prev next-error-last-buffer))) + (message "%s locus from %s" + (cond (reset "First") + ((eq (prefix-numeric-value arg) 0) "Current") + ((< (prefix-numeric-value arg) 0) "Previous") + (t "Next")) + next-error-last-buffer))))))) (defun next-error-internal () "Visit the source code corresponding to the `next-error' message at point." - (setq next-error-last-buffer (current-buffer)) - ;; we know here that next-error-function is a valid symbol we can funcall - (with-current-buffer next-error-last-buffer + (let ((buffer (current-buffer))) + ;; We know here that next-error-function is a valid symbol we can funcall (funcall next-error-function 0 nil) - (when next-error-recenter - (recenter next-error-recenter)) - (run-hooks 'next-error-hook))) + (let ((prev next-error-last-buffer)) + (next-error-found buffer (current-buffer)) + (when (or next-error-verbose + (not (eq prev next-error-last-buffer))) + (message "Current locus from %s" next-error-last-buffer))))) + +(defun next-error-found (&optional from-buffer to-buffer) + "Function to call when the next locus is found and displayed. +FROM-BUFFER is a buffer from which next-error navigated, +and TO-BUFFER is a target buffer." + (setq next-error-last-buffer (or from-buffer (current-buffer))) + (when to-buffer + (with-current-buffer to-buffer + (setq next-error-buffer from-buffer))) + (when next-error-recenter + (recenter next-error-recenter)) + (funcall next-error-found-function from-buffer to-buffer) + (run-hooks 'next-error-hook)) + +(defun next-error-select-buffer (buffer) + "Select a `next-error' capable BUFFER and set it as the last used. +This means that the selected buffer becomes the source of locations +for the subsequent invocation of `next-error' or `previous-error'. +Interactively, this command allows selection only among buffers +where `next-error-function' is bound to an appropriate function." + (interactive + (list (get-buffer + (read-buffer "Select next-error buffer: " nil nil + (lambda (b) (next-error-buffer-p (cdr b))))))) + (setq next-error-last-buffer buffer)) (defalias 'goto-next-locus 'next-error) (defalias 'next-match 'next-error) @@ -306,7 +377,9 @@ To control which errors are matched, customize the variable Prefix arg N says how many error messages to move backwards (or forwards, if negative). -This operates on the output from the \\[compile] and \\[grep] commands." +This operates on the output from the \\[compile] and \\[grep] commands. + +See `next-error' for the details." (interactive "p") (next-error (- (or n 1)))) @@ -325,9 +398,11 @@ backwards, if negative). Finds and highlights the source line like \\[next-error], but does not select the source buffer." (interactive "p") - (let ((next-error-highlight next-error-highlight-no-select)) - (next-error n)) - (pop-to-buffer next-error-last-buffer)) + (save-selected-window + (let ((next-error-highlight next-error-highlight-no-select) + (display-buffer-overriding-action + '(nil (inhibit-same-window . t)))) + (next-error n)))) (defun previous-error-no-select (&optional n) "Move point to the previous error in the `next-error' buffer and highlight match. @@ -343,9 +418,7 @@ select the source buffer." (define-minor-mode next-error-follow-minor-mode "Minor mode for compilation, occur and diff modes. -With a prefix argument ARG, enable mode if ARG is positive, and -disable it otherwise. If called from Lisp, enable mode if ARG is -omitted or nil. + When turned on, cursor motion in the compilation, grep, occur or diff buffer causes automatic display of the corresponding source code location." :group 'next-error :init-value nil :lighter " Fol" @@ -535,25 +608,43 @@ When called from Lisp code, ARG may be a prefix string to copy." (indent-to col 0) (goto-char pos))) -(defun delete-indentation (&optional arg) +(defun delete-indentation (&optional arg beg end) "Join this line to previous and fix up whitespace at join. -If there is a fill prefix, delete it from the beginning of this line. -With argument, join this line to following line." - (interactive "*P") - (beginning-of-line) - (if arg (forward-line 1)) - (if (eq (preceding-char) ?\n) - (progn - (delete-region (point) (1- (point))) - ;; If the second line started with the fill prefix, - ;; delete the prefix. - (if (and fill-prefix - (<= (+ (point) (length fill-prefix)) (point-max)) - (string= fill-prefix - (buffer-substring (point) - (+ (point) (length fill-prefix))))) - (delete-region (point) (+ (point) (length fill-prefix)))) - (fixup-whitespace)))) +If there is a fill prefix, delete it from the beginning of this +line. +With prefix ARG, join the current line to the following line. +When BEG and END are non-nil, join all lines in the region they +define. Interactively, BEG and END are, respectively, the start +and end of the region if it is active, else nil. (The region is +ignored if prefix ARG is given.)" + (interactive + (progn (barf-if-buffer-read-only) + (cons current-prefix-arg + (and (use-region-p) + (list (region-beginning) (region-end)))))) + ;; Consistently deactivate mark even when no text is changed. + (setq deactivate-mark t) + (if (and beg (not arg)) + ;; Region is active. Go to END, but only if region spans + ;; multiple lines. + (and (goto-char beg) + (> end (line-end-position)) + (goto-char end)) + ;; Region is inactive. Set a loop sentinel + ;; (subtracting 1 in order to compare less than BOB). + (setq beg (1- (line-beginning-position (and arg 2)))) + (when arg (forward-line))) + (let ((prefix (and (> (length fill-prefix) 0) + (regexp-quote fill-prefix)))) + (while (and (> (line-beginning-position) beg) + (forward-line 0) + (= (preceding-char) ?\n)) + (delete-char -1) + ;; If the appended line started with the fill prefix, + ;; delete the prefix. + (if (and prefix (looking-at prefix)) + (replace-match "" t t)) + (fixup-whitespace)))) (defalias 'join-line #'delete-indentation) ; easier to find @@ -946,12 +1037,8 @@ is supplied, or Transient Mark mode is enabled and the mark is active." (push-mark)) (let ((size (- (point-max) (point-min)))) (goto-char (if (and arg (not (consp arg))) - (+ (point-min) - (if (> size 10000) - ;; Avoid overflow for large buffer sizes! - (* (prefix-numeric-value arg) - (/ size 10)) - (/ (+ 10 (* size (prefix-numeric-value arg))) 10))) + (+ (point-min) 1 + (/ (* size (prefix-numeric-value arg)) 10)) (point-min)))) (if (and arg (not (consp arg))) (forward-line 1))) @@ -969,11 +1056,7 @@ is supplied, or Transient Mark mode is enabled and the mark is active." (let ((size (- (point-max) (point-min)))) (goto-char (if (and arg (not (consp arg))) (- (point-max) - (if (> size 10000) - ;; Avoid overflow for large buffer sizes! - (* (prefix-numeric-value arg) - (/ size 10)) - (/ (* size (prefix-numeric-value arg)) 10))) + (/ (* size (prefix-numeric-value arg)) 10)) (point-max)))) ;; If we went to a place in the middle of the buffer, ;; adjust it to the beginning of a line. @@ -1106,6 +1189,7 @@ the actual saved text might be different from what was killed." (defun mark-whole-buffer () "Put point at beginning and mark at end of buffer. +Also push mark at point before pushing mark at end of buffer. If narrowing is in effect, only uses the accessible part of the buffer. You probably should not use this function in Lisp programs; it is usually a mistake for a Lisp function to use any subroutine @@ -1356,7 +1440,7 @@ in *Help* buffer. See also the command `describe-char'." (if (or (not coding) (eq (coding-system-type coding) t)) (setq coding (default-value 'buffer-file-coding-system))) - (if (and (>= char #x3fff80) (<= char #x3fffff)) + (if (eq (char-charset char) 'eight-bit) (setq encoding-msg (format "(%d, #o%o, #x%x, raw-byte)" char char char)) ;; Check if the character is displayed with some `display' @@ -1554,12 +1638,14 @@ this command arranges for all errors to enter the debugger." (eval-expression-get-print-arguments current-prefix-arg))) (if (null eval-expression-debug-on-error) - (push (eval exp lexical-binding) values) + (push (eval (let ((lexical-binding t)) (macroexpand-all exp)) t) + values) (let ((old-value (make-symbol "t")) new-value) ;; Bind debug-on-error to something unique so that we can ;; detect when evalled code changes it. (let ((debug-on-error old-value)) - (push (eval (macroexpand-all exp) lexical-binding) values) + (push (eval (let ((lexical-binding t)) (macroexpand-all exp)) t) + values) (setq new-value debug-on-error)) ;; If evalled code has changed the value of debug-on-error, ;; propagate that change to the global binding. @@ -1591,13 +1677,10 @@ the minibuffer, then read and evaluate the result." 'command-history) ;; If command was added to command-history as a string, ;; get rid of that. We want only evaluable expressions there. - (if (stringp (car command-history)) - (setq command-history (cdr command-history))))))) + (when (stringp (car command-history)) + (pop command-history)))))) - ;; If command to be redone does not match front of history, - ;; add it to the history. - (or (equal command (car command-history)) - (setq command-history (cons command command-history))) + (add-to-history 'command-history command) (eval command))) (defun repeat-complex-command (arg) @@ -1627,13 +1710,10 @@ to get different commands to edit and resubmit." ;; If command was added to command-history as a ;; string, get rid of that. We want only ;; evaluable expressions there. - (if (stringp (car command-history)) - (setq command-history (cdr command-history)))))) + (when (stringp (car command-history)) + (pop command-history))))) - ;; If command to be redone does not match front of history, - ;; add it to the history. - (or (equal newcmd (car command-history)) - (setq command-history (cons newcmd command-history))) + (add-to-history 'command-history newcmd) (apply #'funcall-interactively (car newcmd) (mapcar (lambda (e) (eval e t)) (cdr newcmd)))) @@ -1696,14 +1776,18 @@ to get different commands to edit and resubmit." (defcustom suggest-key-bindings t "Non-nil means show the equivalent key-binding when M-x command has one. The value can be a length of time to show the message for. -If the value is non-nil and not a number, we wait 2 seconds." +If the value is non-nil and not a number, we wait 2 seconds. + +Also see `extended-command-suggest-shorter'." :group 'keyboard :type '(choice (const :tag "off" nil) (integer :tag "time" 2) (other :tag "on"))) (defcustom extended-command-suggest-shorter t - "If non-nil, show a shorter M-x invocation when there is one." + "If non-nil, show a shorter M-x invocation when there is one. + +Also see `suggest-key-bindings'." :group 'keyboard :type 'boolean :version "26.1") @@ -1786,9 +1870,11 @@ invoking, give a prefix argument to `execute-extended-command'." ;; If this command displayed something in the echo area; ;; wait a few seconds, then display our suggestion message. ;; FIXME: Wait *after* running post-command-hook! - ;; FIXME: Don't wait if execute-extended-command--shorter won't - ;; find a better answer anyway! - (when suggest-key-bindings + ;; FIXME: If execute-extended-command--shorter were + ;; faster, we could compute the result here first too. + (when (and suggest-key-bindings + (or binding + (and extended-command-suggest-shorter typed))) (sit-for (cond ((zerop (length (current-message))) 0) ((numberp suggest-key-bindings) suggest-key-bindings) @@ -1850,11 +1936,8 @@ a special event, so ignore the prefix argument and don't clear it." ;; If requested, place the macro in the command history. For ;; other sorts of commands, call-interactively takes care of this. (when record-flag - (push `(execute-kbd-macro ,final ,prefixarg) command-history) - ;; Don't keep command history around forever. - (when (and (numberp history-length) (> history-length 0)) - (let ((cell (nthcdr history-length command-history))) - (if (consp cell) (setcdr cell nil))))) + (add-to-history + 'command-history `(execute-kbd-macro ,final ,prefixarg) nil t)) (execute-kbd-macro final prefixarg)) (t ;; Pass `cmd' rather than `final', for the backtrace's sake. @@ -2353,6 +2436,29 @@ Go to the history element by the absolute history position HIST-POS." (goto-history-element hist-pos)) +(add-hook 'minibuffer-setup-hook 'minibuffer-error-initialize) + +(defun minibuffer-error-initialize () + "Set up minibuffer error processing." + (setq-local command-error-function 'minibuffer-error-function)) + +(defun minibuffer-error-function (data context caller) + "Display error messages in the active minibuffer. +The same as `command-error-default-function' but display error messages +at the end of the minibuffer using `minibuffer-message' to not obscure +the minibuffer contents." + (discard-input) + (ding) + (let ((string (error-message-string data))) + ;; If we know from where the error was signaled, show it in + ;; *Messages*. + (let ((inhibit-message t)) + (message "%s%s" (if caller (format "%s: " caller) "") string)) + ;; Display an error message at the end of the minibuffer. + (minibuffer-message (apply #'propertize (format " [%s%s]" context string) + minibuffer-prompt-properties)))) + + ;Put this on C-x u, so we can force that rather than C-_ into startup msg (define-obsolete-function-alias 'advertised-undo 'undo "23.2") @@ -2421,7 +2527,7 @@ as an argument limits undo to changes within the current region." ;; so, ask the user whether she wants to skip the redo/undo pair. (let ((equiv (gethash pending-undo-list undo-equiv-table))) (or (eq (selected-window) (minibuffer-window)) - (setq message (format "%s%s!" + (setq message (format "%s%s" (if (or undo-no-redo (not equiv)) "Undo" "Redo") (if undo-in-region " in region" "")))) @@ -2958,7 +3064,7 @@ that calls `undo-auto-amalgamate'." (defun undo-auto--ensure-boundary (cause) "Add an `undo-boundary' to the current buffer if needed. REASON describes the reason that the boundary is being added; see -`undo-auto--last-boundary' for more information." +`undo-auto--last-boundary-cause' for more information." (when (and (undo-auto--needs-boundary-p)) (let ((last-amalgamating @@ -3007,10 +3113,10 @@ default values.") "Add an `undo-boundary' in appropriate buffers." (undo-auto--boundaries (let ((amal undo-auto--this-command-amalgamating)) - (setq undo-auto--this-command-amalgamating nil) - (if amal - 'amalgamate - 'command)))) + (setq undo-auto--this-command-amalgamating nil) + (if amal + 'amalgamate + 'command)))) (defun undo-auto-amalgamate () "Amalgamate undo if necessary. @@ -3023,30 +3129,38 @@ behavior." (let ((last-amalgamating-count (undo-auto--last-boundary-amalgamating-number))) (setq undo-auto--this-command-amalgamating t) - (when - last-amalgamating-count - (if - (and - (< last-amalgamating-count 20) - (eq this-command last-command)) + (when last-amalgamating-count + (if (and (< last-amalgamating-count 20) + (eq this-command last-command)) ;; Amalgamate all buffers that have changed. + ;; This may be needed for example if some *-change-functions + ;; reflected these changes in some other buffer. (dolist (b (cdr undo-auto--last-boundary-cause)) (when (buffer-live-p b) (with-current-buffer b - (when - ;; The head of `buffer-undo-list' is nil. - ;; `car-safe' doesn't work because - ;; `buffer-undo-list' need not be a list! - (and (listp buffer-undo-list) - (not (car buffer-undo-list))) + (when (and (consp buffer-undo-list) + ;; `car-safe' doesn't work because + ;; `buffer-undo-list' need not be a list! + (null (car buffer-undo-list))) + ;; The head of `buffer-undo-list' is nil. (setq buffer-undo-list (cdr buffer-undo-list)))))) (setq undo-auto--last-boundary-cause 0))))) (defun undo-auto--undoable-change () "Called after every undoable buffer change." - (add-to-list 'undo-auto--undoably-changed-buffers (current-buffer)) + (unless (memq (current-buffer) undo-auto--undoably-changed-buffers) + (let ((bufs undo-auto--undoably-changed-buffers)) + ;; Drop dead buffers from the list, to avoid memory leak in + ;; (while t (with-temp-buffer (setq buffer-undo-list nil) (insert "a"))) + (while bufs + (let ((next (cdr bufs))) + (if (or (buffer-live-p (car bufs)) (null next)) + (setq bufs next) + (setcar bufs (car next)) + (setcdr bufs (cdr next)))))) + (push (current-buffer) undo-auto--undoably-changed-buffers)) (undo-auto--boundary-ensure-timer)) ;; End auto-boundary section @@ -3159,61 +3273,6 @@ which is defined in the `warnings' library.\n") (setq buffer-undo-list nil) t)) -(defcustom password-word-equivalents - '("password" "passcode" "passphrase" "pass phrase" - ; These are sorted according to the GNU en_US locale. - "암호" ; ko - "パスワード" ; ja - "ପ୍ରବେଶ ସଙ୍କେତ" ; or - "ពាក្យសម្ងាត់" ; km - "adgangskode" ; da - "contraseña" ; es - "contrasenya" ; ca - "geslo" ; sl - "hasło" ; pl - "heslo" ; cs, sk - "iphasiwedi" ; zu - "jelszó" ; hu - "lösenord" ; sv - "lozinka" ; hr, sr - "mật khẩu" ; vi - "mot de passe" ; fr - "parola" ; tr - "pasahitza" ; eu - "passord" ; nb - "passwort" ; de - "pasvorto" ; eo - "salasana" ; fi - "senha" ; pt - "slaptažodis" ; lt - "wachtwoord" ; nl - "كلمة السر" ; ar - "ססמה" ; he - "лозинка" ; sr - "пароль" ; kk, ru, uk - "गुप्तशब्द" ; mr - "शब्दकूट" ; hi - "પાસવર્ડ" ; gu - "సంకేతపదము" ; te - "ਪਾਸਵਰਡ" ; pa - "ಗುಪ್ತಪದ" ; kn - "கடவுச்சொல்" ; ta - "അടയാളവാക്ക്" ; ml - "গুপ্তশব্দ" ; as - "পাসওয়ার্ড" ; bn_IN - "රහස්පදය" ; si - "密码" ; zh_CN - "密碼" ; zh_TW - ) - "List of words equivalent to \"password\". -This is used by Shell mode and other parts of Emacs to recognize -password prompts, including prompts in languages other than -English. Different case choices should not be assumed to be -included; callers should bind `case-fold-search' to t." - :type '(repeat string) - :version "24.4" - :group 'processes) - (defvar shell-command-history nil "History list for some commands that read shell commands. @@ -3313,6 +3372,38 @@ is output." :group 'shell :version "26.1") +(defcustom async-shell-command-width nil + "Number of display columns available for asynchronous shell command output. +If nil, use the shell default number (usually 80 columns). +If a positive integer, tell the shell to use that number of columns for +command output." + :type '(choice (const :tag "Use system limit" nil) + (integer :tag "Fixed width" :value 80)) + :group 'shell + :version "27.1") + +(defcustom shell-command-dont-erase-buffer nil + "If non-nil, output buffer is not erased between shell commands. +Also, a non-nil value sets the point in the output buffer +once the command completes. +The value `beg-last-out' sets point at the beginning of the output, +`end-last-out' sets point at the end of the buffer, `save-point' +restores the buffer position before the command." + :type '(choice + (const :tag "Erase buffer" nil) + (const :tag "Set point to beginning of last output" beg-last-out) + (const :tag "Set point to end of last output" end-last-out) + (const :tag "Save point" save-point)) + :group 'shell + :version "26.1") + +(defvar shell-command-saved-pos nil + "Record of point positions in output buffers after command completion. +The value is an alist whose elements are of the form (BUFFER . POS), +where BUFFER is the output buffer, and POS is the point position +in BUFFER once the command finishes. +This variable is used when `shell-command-dont-erase-buffer' is non-nil.") + (defun shell-command--save-pos-or-erase () "Store a buffer position or erase the buffer. See `shell-command-dont-erase-buffer'." @@ -3393,6 +3484,8 @@ a shell (with its need to quote arguments)." (setq command (concat command " &"))) (shell-command command output-buffer error-buffer)) +(declare-function comint-output-filter "comint" (process string)) + (defun shell-command (command &optional output-buffer error-buffer) "Execute string COMMAND in inferior shell; display output, if any. With prefix argument, insert the COMMAND's output at point. @@ -3470,12 +3563,11 @@ impose the use of a shell (with its need to quote arguments)." (not (or (bufferp output-buffer) (stringp output-buffer)))) ;; Output goes in current buffer. (let ((error-file - (if error-buffer - (make-temp-file - (expand-file-name "scor" - (or small-temporary-file-directory - temporary-file-directory))) - nil))) + (and error-buffer + (make-temp-file + (expand-file-name "scor" + (or small-temporary-file-directory + temporary-file-directory)))))) (barf-if-buffer-read-only) (push-mark nil t) ;; We do not use -f for csh; we will not support broken use of @@ -3483,24 +3575,22 @@ impose the use of a shell (with its need to quote arguments)." ;; "if ($?prompt) exit" before things which are not useful ;; non-interactively. Besides, if someone wants their other ;; aliases for shell commands then they can still have them. - (call-process shell-file-name nil - (if error-file - (list t error-file) - t) - nil shell-command-switch command) + (call-process-shell-command command nil (if error-file + (list t error-file) + t)) (when (and error-file (file-exists-p error-file)) - (if (< 0 (nth 7 (file-attributes error-file))) - (with-current-buffer (get-buffer-create error-buffer) - (let ((pos-from-end (- (point-max) (point)))) - (or (bobp) - (insert "\f\n")) - ;; Do no formatting while reading error file, - ;; because that can run a shell command, and we - ;; don't want that to cause an infinite recursion. - (format-insert-file error-file nil) - ;; Put point after the inserted errors. - (goto-char (- (point-max) pos-from-end))) - (display-buffer (current-buffer)))) + (when (< 0 (file-attribute-size (file-attributes error-file))) + (with-current-buffer (get-buffer-create error-buffer) + (let ((pos-from-end (- (point-max) (point)))) + (or (bobp) + (insert "\f\n")) + ;; Do no formatting while reading error file, + ;; because that can run a shell command, and we + ;; don't want that to cause an infinite recursion. + (format-insert-file error-file nil) + ;; Put point after the inserted errors. + (goto-char (- (point-max) pos-from-end))) + (display-buffer (current-buffer)))) (delete-file error-file)) ;; This is like exchange-point-and-mark, but doesn't ;; activate the mark. It is cleaner to avoid activation, @@ -3519,24 +3609,23 @@ impose the use of a shell (with its need to quote arguments)." (let* ((buffer (get-buffer-create (or output-buffer "*Async Shell Command*"))) (bname (buffer-name buffer)) - (directory default-directory) - proc) + (proc (get-buffer-process buffer)) + (directory default-directory)) ;; Remove the ampersand. (setq command (substring command 0 (match-beginning 0))) ;; Ask the user what to do with already running process. - (setq proc (get-buffer-process buffer)) (when proc (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) - (error "Shell command in progress"))) + (user-error "Shell command in progress"))) ((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)) - (error "Shell command in progress"))) + (user-error "Shell command in progress"))) ((eq async-shell-command-buffer 'new-buffer) ;; It will create a new buffer. (setq buffer (generate-new-buffer bname))) @@ -3547,7 +3636,7 @@ impose the use of a shell (with its need to quote arguments)." (with-current-buffer buffer (rename-uniquely)) (setq buffer (get-buffer-create bname))) - (error "Shell command in progress"))) + (user-error "Shell command in progress"))) ((eq async-shell-command-buffer 'rename-buffer) ;; It will rename the buffer. (with-current-buffer buffer @@ -3556,14 +3645,19 @@ impose the use of a shell (with its need to quote arguments)." (with-current-buffer buffer (shell-command--save-pos-or-erase) (setq default-directory directory) - (setq proc (start-process "Shell" buffer shell-file-name - shell-command-switch command)) + (let ((process-environment + (if (natnump async-shell-command-width) + (cons (format "COLUMNS=%d" async-shell-command-width) + process-environment) + process-environment))) + (setq proc + (start-process-shell-command "Shell" buffer command))) (setq mode-line-process '(":%s")) (require 'shell) (shell-mode) - (set-process-sentinel proc 'shell-command-sentinel) + (set-process-sentinel proc #'shell-command-sentinel) ;; Use the comint filter for proper handling of ;; carriage motion (see comint-inhibit-carriage-motion). - (set-process-filter proc 'comint-output-filter) + (set-process-filter proc #'comint-output-filter) (if async-shell-command-display-buffer ;; Display buffer immediately. (display-buffer buffer '(nil (allow-no-window . t))) @@ -3819,7 +3913,8 @@ interactively, this is t." ;; No output; error? (let ((output (if (and error-file - (< 0 (nth 7 (file-attributes error-file)))) + (< 0 (file-attribute-size + (file-attributes error-file)))) (format "some error output%s" (if shell-command-default-error-buffer (format " to the \"%s\" buffer" @@ -3842,7 +3937,7 @@ interactively, this is t." ))))) (when (and error-file (file-exists-p error-file)) - (if (< 0 (nth 7 (file-attributes error-file))) + (if (< 0 (file-attribute-size (file-attributes error-file))) (with-current-buffer (get-buffer-create error-buffer) (let ((pos-from-end (- (point-max) (point)))) (or (bobp) @@ -3863,11 +3958,11 @@ interactively, this is t." (with-output-to-string (with-current-buffer standard-output - (process-file shell-file-name nil t nil shell-command-switch command)))) + (shell-command command t)))) (defun process-file (program &optional infile buffer display &rest args) "Process files synchronously in a separate process that runs PROGRAM. -Similar to `call-process', but may invoke a file handler based on +Similar to `call-process', but may invoke a file name handler based on `default-directory'. The current working directory of the subprocess is `default-directory'. @@ -3877,10 +3972,10 @@ by `file-local-name' before passing it to this function. File names in INFILE and BUFFER are handled normally, but file names in ARGS should be relative to `default-directory', as they are passed to the process verbatim. (This is a difference to -`call-process' which does not support file handlers for INFILE +`call-process' which does not support file name handlers for INFILE and BUFFER.) -Some file handlers might not support all variants, for example +Some file name handlers might not support all variants, for example they might behave as if DISPLAY was nil, regardless of the actual value passed." (let ((fh (find-file-name-handler default-directory 'process-file)) @@ -3904,7 +3999,7 @@ value passed." By default, this variable is always set to t, meaning that a call of `process-file' could potentially change any file on a -remote host. When set to nil, a file handler could optimize +remote host. When set to nil, a file name handler could optimize its behavior with respect to remote file attribute caching. You should only ever change this variable with a let-binding; @@ -3913,7 +4008,7 @@ never with `setq'.") (defun start-file-process (name buffer program &rest program-args) "Start a program in a subprocess. Return the process object for it. -Similar to `start-process', but may invoke a file handler based on +Similar to `start-process', but may invoke a file name handler based on `default-directory'. See Info node `(elisp)Magic File Names'. This handler ought to run PROGRAM, perhaps on the local host, @@ -3923,10 +4018,10 @@ produced from it by `file-local-name', becomes the working directory of the process on the remote host. PROGRAM and PROGRAM-ARGS might be file names. They are not -objects of file handler invocation, so they need to be obtained +objects of file name handler invocation, so they need to be obtained by calling `file-local-name', in case they are remote file names. -File handlers might not support pty association, if PROGRAM is nil." +File name handlers might not support pty association, if PROGRAM is nil." (let ((fh (find-file-name-handler default-directory 'start-file-process))) (if fh (apply fh 'start-file-process name buffer program program-args) (apply 'start-process name buffer program program-args)))) @@ -3952,8 +4047,11 @@ File handlers might not support pty association, if PROGRAM is nil." (setq tabulated-list-format [("Process" 15 t) ("PID" 7 t) ("Status" 7 t) - ("Buffer" 15 t) + ;; 25 is the length of the long standard buffer + ;; name "*Async Shell Command*<10>" (bug#30016) + ("Buffer" 25 t) ("TTY" 12 t) + ("Thread" 12 t) ("Command" 0 t)]) (make-local-variable 'process-menu-query-only) (setq tabulated-list-sort-key (cons "Process" nil)) @@ -3995,6 +4093,14 @@ Also, delete any process that is exited or signaled." action process-menu-visit-buffer) "--")) (tty (or (process-tty-name p) "--")) + (thread + (cond + ((or + (null (process-thread p)) + (not (fboundp 'thread-name))) "--") + ((eq (process-thread p) main-thread) "Main") + ((thread-name (process-thread p))) + (t "--"))) (cmd (if (memq type '(network serial)) (let ((contact (process-contact p t))) @@ -4017,7 +4123,7 @@ Also, delete any process that is exited or signaled." (format " at %s b/s" speed) ""))))) (mapconcat 'identity (process-command p) " ")))) - (push (list p (vector name pid status buf-label tty cmd)) + (push (list p (vector name pid status buf-label tty thread cmd)) tabulated-list-entries))))) (tabulated-list-init-header)) @@ -4104,7 +4210,7 @@ Runs `prefix-command-preserve-state-hook'." (when prefix-arg (concat "C-u" (pcase prefix-arg - (`(-) " -") + ('(-) " -") (`(,(and (pred integerp) n)) (let ((str "")) (while (and (> n 4) (= (mod n 4) 0)) @@ -4386,7 +4492,8 @@ argument should still be a \"useful\" string for such uses." (funcall interprogram-paste-function)))) (when interprogram-paste (dolist (s (if (listp interprogram-paste) - (nreverse interprogram-paste) + ;; Use `reverse' to avoid modifying external data. + (reverse interprogram-paste) (list interprogram-paste))) (unless (and kill-do-not-save-duplicates (equal-including-properties s (car kill-ring))) @@ -4395,9 +4502,8 @@ argument should still be a \"useful\" string for such uses." (equal-including-properties string (car kill-ring))) (if (and replace kill-ring) (setcar kill-ring string) - (push string kill-ring) - (if (> (length kill-ring) kill-ring-max) - (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil)))) + (let ((history-delete-duplicates nil)) + (add-to-history 'kill-ring string kill-ring-max t)))) (setq kill-ring-yank-pointer kill-ring) (if interprogram-cut-function (funcall interprogram-cut-function string))) @@ -4420,20 +4526,20 @@ If `interprogram-cut-function' is non-nil, call it with the resulting kill. If `kill-append-merge-undo' is non-nil, remove the last undo boundary in the current buffer." - (let* ((cur (car kill-ring))) + (let ((cur (car kill-ring))) (kill-new (if before-p (concat string cur) (concat cur string)) - (or (= (length cur) 0) - (equal nil (get-text-property 0 'yank-handler cur)))) - (when (and kill-append-merge-undo (not buffer-read-only)) - (let ((prev buffer-undo-list) - (next (cdr buffer-undo-list))) - ;; find the next undo boundary - (while (car next) - (pop next) - (pop prev)) - ;; remove this undo boundary - (when prev - (setcdr prev (cdr next))))))) + (or (string= cur "") + (null (get-text-property 0 'yank-handler cur))))) + (when (and kill-append-merge-undo (not buffer-read-only)) + (let ((prev buffer-undo-list) + (next (cdr buffer-undo-list))) + ;; Find the next undo boundary. + (while (car next) + (pop next) + (pop prev)) + ;; Remove this undo boundary. + (when prev + (setcdr prev (cdr next)))))) (defcustom yank-pop-change-selection nil "Whether rotating the kill ring changes the window system selection. @@ -4467,9 +4573,13 @@ move the yanking point; just return the Nth kill forward." ;; Disable the interprogram cut function when we add the new ;; text to the kill ring, so Emacs doesn't try to own the ;; selection, with identical text. - (let ((interprogram-cut-function nil)) + ;; Also disable the interprogram paste function, so that + ;; `kill-new' doesn't call it repeatedly. + (let ((interprogram-cut-function nil) + (interprogram-paste-function nil)) (if (listp interprogram-paste) - (mapc 'kill-new (nreverse interprogram-paste)) + ;; Use `reverse' to avoid modifying external data. + (mapc #'kill-new (reverse interprogram-paste)) (kill-new interprogram-paste))) (car kill-ring)) (or kill-ring (error "Kill ring is empty")) @@ -4862,10 +4972,11 @@ Normally set from the UNDO element of a yank-handler; see `insert-for-yank'.") (defun yank-pop (&optional arg) "Replace just-yanked stretch of killed text with a different stretch. -This command is allowed only immediately after a `yank' or a `yank-pop'. -At such a time, the region contains a stretch of reinserted -previously-killed text. `yank-pop' deletes that text and inserts in its -place a different stretch of killed text. +This command is allowed only immediately after a `yank' or a +`yank-pop'. At such a time, the region contains a stretch of +reinserted previously-killed text. `yank-pop' deletes that text +and inserts in its place a different stretch of killed text by +traversing the value of the `kill-ring' variable. With no argument, the previous kill is inserted. With argument N, insert the Nth previous kill. @@ -5148,24 +5259,14 @@ If ARG is zero, move to the beginning of the current line." (signal 'end-of-buffer nil)) ;; If the newline we just skipped is invisible, ;; don't count it. - (let ((prop - (get-char-property (1- (point)) 'invisible))) - (if (if (eq buffer-invisibility-spec t) - prop - (or (memq prop buffer-invisibility-spec) - (assq prop buffer-invisibility-spec))) - (setq arg (1+ arg)))) + (if (invisible-p (1- (point))) + (setq arg (1+ arg))) (setq arg (1- arg))) ;; If invisible text follows, and it is a number of complete lines, ;; skip it. (let ((opoint (point))) (while (and (not (eobp)) - (let ((prop - (get-char-property (point) 'invisible))) - (if (eq buffer-invisibility-spec t) - prop - (or (memq prop buffer-invisibility-spec) - (assq prop buffer-invisibility-spec))))) + (invisible-p (point))) (goto-char (if (get-text-property (point) 'invisible) (or (next-single-property-change (point) 'invisible) @@ -5182,24 +5283,14 @@ If ARG is zero, move to the beginning of the current line." ;; If the newline we just moved to is invisible, ;; don't count it. (unless (bobp) - (let ((prop - (get-char-property (1- (point)) 'invisible))) - (unless (if (eq buffer-invisibility-spec t) - prop - (or (memq prop buffer-invisibility-spec) - (assq prop buffer-invisibility-spec))) - (setq arg (1+ arg))))) + (unless (invisible-p (1- (point))) + (setq arg (1+ arg)))) (setq first nil)) ;; If invisible text follows, and it is a number of complete lines, ;; skip it. (let ((opoint (point))) (while (and (not (bobp)) - (let ((prop - (get-char-property (1- (point)) 'invisible))) - (if (eq buffer-invisibility-spec t) - prop - (or (memq prop buffer-invisibility-spec) - (assq prop buffer-invisibility-spec))))) + (invisible-p (1- (point)))) (goto-char (if (get-text-property (1- (point)) 'invisible) (or (previous-single-property-change (point) 'invisible) @@ -5219,12 +5310,7 @@ If ARG is zero, move to the beginning of the current line." (while (and (not (eobp)) (save-excursion (skip-chars-forward "^\n") - (let ((prop - (get-char-property (point) 'invisible))) - (if (eq buffer-invisibility-spec t) - prop - (or (memq prop buffer-invisibility-spec) - (assq prop buffer-invisibility-spec)))))) + (invisible-p (point)))) (skip-chars-forward "^\n") (if (get-text-property (point) 'invisible) (goto-char (or (next-single-property-change (point) 'invisible) @@ -5522,7 +5608,7 @@ see `region-noncontiguous-p' and `extract-rectangle-bounds'." "Return non-nil if the region contains several pieces. An example is a rectangular region handled as a list of separate contiguous regions for each line." - (> (length (region-bounds)) 1)) + (cdr (region-bounds))) (defvar redisplay-unhighlight-region-function (lambda (rol) (when (overlayp rol) (delete-overlay rol)))) @@ -5544,7 +5630,14 @@ separate contiguous regions for each line." (eq (overlay-start rol) start) (eq (overlay-end rol) end)) (move-overlay rol start end (current-buffer))) - rol))) + rol)) + "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 +any case, the overlay is adjusted to reflect the other three +parameters. + +The overlay is returned by the function.") (defun redisplay--update-region-highlight (window) (let ((rol (window-parameter window 'internal-region-overlay))) @@ -5708,22 +5801,23 @@ Novice Emacs Lisp programmers often try to use the mark for the wrong purposes. See the documentation of `set-mark' for more information. In Transient Mark mode, activate mark if optional third arg ACTIVATE non-nil." - (unless (null (mark t)) - (setq mark-ring (cons (copy-marker (mark-marker)) mark-ring)) - (when (> (length mark-ring) mark-ring-max) - (move-marker (car (nthcdr mark-ring-max mark-ring)) nil) - (setcdr (nthcdr (1- mark-ring-max) mark-ring) nil))) + (when (mark t) + (let ((old (nth mark-ring-max mark-ring)) + (history-delete-duplicates nil)) + (add-to-history 'mark-ring (copy-marker (mark-marker)) mark-ring-max t) + (when old + (set-marker old nil)))) (set-marker (mark-marker) (or location (point)) (current-buffer)) - ;; Now push the mark on the global mark ring. - (if (and global-mark-ring - (eq (marker-buffer (car global-mark-ring)) (current-buffer))) - ;; The last global mark pushed was in this same buffer. - ;; Don't push another one. - nil - (setq global-mark-ring (cons (copy-marker (mark-marker)) global-mark-ring)) - (when (> (length global-mark-ring) global-mark-ring-max) - (move-marker (car (nthcdr global-mark-ring-max global-mark-ring)) nil) - (setcdr (nthcdr (1- global-mark-ring-max) global-mark-ring) nil))) + ;; Don't push the mark on the global mark ring if the last global + ;; mark pushed was in this same buffer. + (unless (and global-mark-ring + (eq (marker-buffer (car global-mark-ring)) (current-buffer))) + (let ((old (nth global-mark-ring-max global-mark-ring)) + (history-delete-duplicates nil)) + (add-to-history + 'global-mark-ring (copy-marker (mark-marker)) global-mark-ring-max t) + (when old + (set-marker old nil)))) (or nomsg executing-kbd-macro (> (minibuffer-depth) 0) (message "Mark set")) (if (or activate (not transient-mark-mode)) @@ -5735,10 +5829,10 @@ In Transient Mark mode, activate mark if optional third arg ACTIVATE non-nil." Does not set point. Does nothing if mark ring is empty." (when mark-ring (setq mark-ring (nconc mark-ring (list (copy-marker (mark-marker))))) - (set-marker (mark-marker) (+ 0 (car mark-ring)) (current-buffer)) - (move-marker (car mark-ring) nil) - (if (null (mark t)) (ding)) - (setq mark-ring (cdr mark-ring))) + (set-marker (mark-marker) (car mark-ring)) + (set-marker (car mark-ring) nil) + (unless (mark t) (ding)) + (pop mark-ring)) (deactivate-mark)) (define-obsolete-function-alias @@ -5812,9 +5906,6 @@ its earlier value." (define-minor-mode transient-mark-mode "Toggle Transient Mark mode. -With a prefix argument ARG, enable Transient Mark mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -Transient Mark mode if ARG is omitted or nil. Transient Mark mode is a global minor mode. When enabled, the region is highlighted with the `region' face whenever the mark @@ -6849,12 +6940,6 @@ other purposes." (define-minor-mode visual-line-mode "Toggle visual line based editing (Visual Line mode) in the current buffer. -Interactively, with a prefix argument, enable -Visual Line mode if the prefix argument is positive, -and disable it otherwise. If called from Lisp, toggle -the mode if ARG is `toggle', disable the mode if ARG is -a non-positive integer, and enable the mode otherwise -\(including if ARG is omitted or nil or a positive integer). When Visual Line mode is enabled, `word-wrap' is turned on in this buffer, and simple editing commands are redefined to act on @@ -7238,7 +7323,7 @@ indicating whether it should use soft newlines.") (defun default-indent-new-line (&optional soft) "Break line at point and indent. -If a comment syntax is defined, call `comment-indent-new-line'. +If a comment syntax is defined, call `comment-line-break-function'. The inserted newline is marked hard if variable `use-hard-newlines' is true, unless optional argument SOFT is non-nil." @@ -7285,12 +7370,6 @@ Some major modes set this.") (define-minor-mode auto-fill-mode "Toggle automatic line breaking (Auto Fill mode). -Interactively, with a prefix argument, enable -Auto Fill mode if the prefix argument is positive, -and disable it otherwise. If called from Lisp, toggle -the mode if ARG is `toggle', disable the mode if ARG is -a non-positive integer, and enable the mode otherwise -\(including if ARG is omitted or nil or a positive integer). When Auto Fill mode is enabled, inserting a space at a column beyond `current-fill-column' automatically breaks the line at a @@ -7405,9 +7484,6 @@ if long lines are truncated." (define-minor-mode overwrite-mode "Toggle Overwrite mode. -With a prefix argument ARG, enable Overwrite mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. When Overwrite mode is enabled, printing characters typed in replace existing text on a one-for-one basis, rather than pushing @@ -7421,9 +7497,6 @@ characters when necessary." (define-minor-mode binary-overwrite-mode "Toggle Binary Overwrite mode. -With a prefix argument ARG, enable Binary Overwrite mode if ARG -is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. When Binary Overwrite mode is enabled, printing characters typed in replace existing text. Newlines are not treated specially, so @@ -7441,9 +7514,6 @@ a specialization of overwrite mode, entered by setting the (define-minor-mode line-number-mode "Toggle line number display in the mode line (Line Number mode). -With a prefix argument ARG, enable Line Number mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Line numbers do not appear for very large buffers and buffers with very long lines; see variables `line-number-display-limit' @@ -7451,27 +7521,15 @@ and `line-number-display-limit-width'." :init-value t :global t :group 'mode-line) (define-minor-mode column-number-mode - "Toggle column number display in the mode line (Column Number mode). -With a prefix argument ARG, enable Column Number mode if ARG is -positive, and disable it otherwise. - -If called from Lisp, enable the mode if ARG is omitted or nil." + "Toggle column number display in the mode line (Column Number mode)." :global t :group 'mode-line) (define-minor-mode size-indication-mode - "Toggle buffer size display in the mode line (Size Indication mode). -With a prefix argument ARG, enable Size Indication mode if ARG is -positive, and disable it otherwise. - -If called from Lisp, enable the mode if ARG is omitted or nil." + "Toggle buffer size display in the mode line (Size Indication mode)." :global t :group 'mode-line) (define-minor-mode auto-save-mode - "Toggle auto-saving in the current buffer (Auto Save mode). -With a prefix argument ARG, enable Auto Save mode if ARG is -positive, and disable it otherwise. - -If called from Lisp, enable the mode if ARG is omitted or nil." + "Toggle auto-saving in the current buffer (Auto Save mode)." :variable ((and buffer-auto-save-file-name ;; If auto-save is off because buffer has shrunk, ;; then toggling should turn it on. @@ -7884,7 +7942,7 @@ buffer buried." (eq mail-user-agent 'message-user-agent) (let (warn-vars) (dolist (var '(mail-mode-hook mail-send-hook mail-setup-hook - mail-yank-hooks mail-archive-file-name + mail-citation-hook mail-archive-file-name mail-default-reply-to mail-mailing-lists mail-self-blind)) (and (boundp var) @@ -7902,6 +7960,8 @@ To disable this warning, set `compose-mail-user-agent-warnings' to nil." warn-vars " ")))))) (let ((function (get mail-user-agent 'composefunc))) + (unless function + (error "Invalid value for `mail-user-agent'")) (funcall function to subject other-headers continue switch-function yank-action send-actions return-action))) @@ -7948,7 +8008,12 @@ For a variable defined with `defcustom', it does not pay attention to any :set property that the variable might have (if you want that, use \\[customize-set-variable] instead). -With a prefix argument, set VARIABLE to VALUE buffer-locally." +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 +makes it easier to edit it." (interactive (let* ((default-var (variable-at-point)) (var (if (custom-variable-p default-var) @@ -8380,20 +8445,18 @@ LSHIFTBY is the numeric value of this modifier, in keyboard events. PREFIX is the string that represents this modifier in an event type symbol." (if (numberp event) (cond ((eq symbol 'control) - (if (and (<= (downcase event) ?z) - (>= (downcase event) ?a)) - (- (downcase event) ?a -1) - (if (and (<= (downcase event) ?Z) - (>= (downcase event) ?A)) - (- (downcase event) ?A -1) - (logior (lsh 1 lshiftby) event)))) + (if (<= 64 (upcase event) 95) + (- (upcase event) 64) + (logior (ash 1 lshiftby) event))) ((eq symbol 'shift) + ;; FIXME: Should we also apply this "upcase" behavior of shift + ;; to non-ascii letters? (if (and (<= (downcase event) ?z) (>= (downcase event) ?a)) (upcase event) - (logior (lsh 1 lshiftby) event))) + (logior (ash 1 lshiftby) event))) (t - (logior (lsh 1 lshiftby) event))) + (logior (ash 1 lshiftby) event))) (if (memq symbol (event-modifiers event)) event (let ((event-type (if (symbolp event) event (car event)))) @@ -8548,13 +8611,16 @@ after it has been set up properly in other respects." ;; Set up other local variables. (mapc (lambda (v) - (condition-case () ;in case var is read-only + (condition-case () (if (symbolp v) (makunbound v) (set (make-local-variable (car v)) (cdr v))) - (error nil))) + (setting-constant nil))) ;E.g. for enable-multibyte-characters. lvars) + (setq mark-ring (mapcar (lambda (mk) (copy-marker (marker-position mk))) + mark-ring)) + ;; Run any hooks (typically set up by the major mode ;; for cloning to work properly). (run-hooks 'clone-buffer-hook)) @@ -8667,7 +8733,7 @@ call `normal-erase-is-backspace-mode' (which see) instead." (and (not noninteractive) (or (memq system-type '(ms-dos windows-nt)) (memq window-system '(w32 ns)) - (and (memq window-system '(x)) + (and (eq window-system 'x) (fboundp 'x-backspace-delete-keys-p) (x-backspace-delete-keys-p)) ;; If the terminal Emacs is running on has erase char @@ -8678,11 +8744,10 @@ call `normal-erase-is-backspace-mode' (which see) instead." normal-erase-is-backspace) 1 0))))) +(declare-function display-symbol-keys-p "frame" (&optional display)) + (define-minor-mode normal-erase-is-backspace-mode "Toggle the Erase and Delete mode of the Backspace and Delete keys. -With a prefix argument ARG, enable this feature if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. On window systems, when this mode is on, Delete is mapped to C-d and Backspace is mapped to DEL; when this mode is off, both @@ -8716,10 +8781,9 @@ See also `normal-erase-is-backspace'." (let ((enabled (eq 1 (terminal-parameter nil 'normal-erase-is-backspace)))) - (cond ((or (memq window-system '(x w32 ns pc)) - (memq system-type '(ms-dos windows-nt))) + (cond ((display-symbol-keys-p) (let ((bindings - `(([M-delete] [M-backspace]) + '(([M-delete] [M-backspace]) ([C-M-delete] [C-M-backspace]) ([?\e C-delete] [?\e C-backspace])))) @@ -8759,9 +8823,9 @@ See also `normal-erase-is-backspace'." (define-minor-mode read-only-mode "Change whether the current buffer is read-only. -With prefix argument ARG, make the buffer read-only if ARG is -positive, otherwise make it writable. If buffer is read-only -and `view-read-only' is non-nil, enter view mode. + +If buffer is read-only and `view-read-only' is non-nil, enter +view mode. Do not call this from a Lisp program unless you really intend to do the same thing as the \\[read-only-mode] command, including @@ -8785,9 +8849,6 @@ to a non-nil value." (define-minor-mode visible-mode "Toggle making all invisible text temporarily visible (Visible mode). -With a prefix argument ARG, enable Visible mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. This mode works by saving the value of `buffer-invisibility-spec' and setting it to nil." @@ -8979,7 +9040,7 @@ Otherwise, it calls `upcase-word', with prefix argument passed to it to upcase ARG words." (interactive "*p") (if (use-region-p) - (upcase-region (region-beginning) (region-end)) + (upcase-region (region-beginning) (region-end) (region-noncontiguous-p)) (upcase-word arg))) (defun downcase-dwim (arg) @@ -8989,7 +9050,7 @@ Otherwise, it calls `downcase-word', with prefix argument passed to it to downcase ARG words." (interactive "*p") (if (use-region-p) - (downcase-region (region-beginning) (region-end)) + (downcase-region (region-beginning) (region-end) (region-noncontiguous-p)) (downcase-word arg))) (defun capitalize-dwim (arg) @@ -9002,6 +9063,30 @@ to capitalize ARG words." (capitalize-region (region-beginning) (region-end)) (capitalize-word arg))) +;;; Accessors for `decode-time' values. + +(cl-defstruct (decoded-time + (:constructor nil) + (:copier nil) + (:type list)) + (second nil :documentation "\ +This is an integer between 0 and 60 (inclusive). (60 is a leap +second, which only some operating systems support.)") + (minute nil :documentation "This is an integer between 0 and 59 (inclusive).") + (hour nil :documentation "This is an integer between 0 and 23 (inclusive).") + (day nil :documentation "This is an integer between 1 and 31 (inclusive).") + (month nil :documentation "\ +This is an integer between 1 and 12 (inclusive). January is 1.") + (year nil :documentation "This is a four digit integer.") + (weekday nil :documentation "\ +This is a number between 0 and 6, and 0 is Sunday.") + (dst nil :documentation "\ +This is t if daylight saving time is in effect, and nil if not.") + (zone nil :documentation "\ +This is an integer indicating the UTC offset in seconds, i.e., +the number of seconds east of Greenwich.") + ) + (provide 'simple) diff --git a/lisp/skeleton.el b/lisp/skeleton.el index 77a3a6ae601..bce73d6bfef 100644 --- a/lisp/skeleton.el +++ b/lisp/skeleton.el @@ -37,13 +37,13 @@ ;; page 2: paired insertion ;; page 3: mirror-mode, an example for setting up paired insertion +(defvaralias 'skeleton-transformation 'skeleton-transformation-function) (defvar skeleton-transformation-function 'identity "If non-nil, function applied to literal strings before they are inserted. It should take strings and characters and return them transformed, or nil which means no transformation. Typical examples might be `upcase' or `capitalize'.") -(defvaralias 'skeleton-transformation 'skeleton-transformation-function) ; this should be a fourth argument to defvar (put 'skeleton-transformation-function 'variable-interactive @@ -65,11 +65,11 @@ 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) ;;;###autoload (defvar skeleton-filter-function 'identity "Function for transforming a skeleton proxy's aliases' variable value.") -(defvaralias 'skeleton-filter 'skeleton-filter-function) (defvar skeleton-untabify nil ; bug#12223 "When non-nil untabifies when deleting backwards with element -ARG.") diff --git a/lisp/so-long.el b/lisp/so-long.el new file mode 100644 index 00000000000..59c719a4ee5 --- /dev/null +++ b/lisp/so-long.el @@ -0,0 +1,1710 @@ +;;; so-long.el --- Say farewell to performance problems with minified code. -*- lexical-binding:t -*- +;; +;; Copyright (C) 2015, 2016, 2018, 2019 Free Software Foundation, Inc. + +;; Author: Phil Sainty <psainty@orcon.net.nz> +;; Maintainer: Phil Sainty <psainty@orcon.net.nz> +;; URL: https://savannah.nongnu.org/projects/so-long +;; Keywords: convenience +;; Created: 23 Dec 2015 +;; Package-Requires: ((emacs "24.4")) +;; Version: 1.0 + +;; 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: +;; +;; * Introduction +;; -------------- +;; When the lines in a file are so long that performance could suffer to an +;; unacceptable degree, we say "so long" to the slow modes and options enabled +;; in that buffer, and invoke something much more basic in their place. +;; +;; Many Emacs modes struggle with buffers which contain excessively long lines. +;; This is commonly on account of 'minified' code (i.e. code that has been +;; compacted into the smallest file size possible, which often entails removing +;; newlines should they not be strictly necessary). This can result in lines +;; which are many thousands of characters long, and most programming modes +;; simply aren't optimised (remotely) for this scenario, so performance can +;; suffer significantly. +;; +;; When such files are detected, the command `so-long' is automatically called, +;; overriding certain minor modes and variables with performance implications +;; (all configurable), in order to enhance performance in the buffer. +;; +;; The default action enables the major mode `so-long-mode' in place of the mode +;; that Emacs selected. This ensures that the original major mode cannot affect +;; performance further, as well as making the so-long activity more obvious to +;; the user. These kinds of minified files are typically not intended to be +;; edited, so not providing the usual editing mode in such cases will rarely be +;; an issue. However, should the user wish to do so, the original state of the +;; buffer may be reinstated by calling `so-long-revert' (the key binding for +;; which is advertised when the major mode change occurs). If you prefer that +;; the major mode not be changed, the `so-long-minor-mode' action can be +;; configured. +;; +;; The user options `so-long-action' and `so-long-action-alist' determine what +;; will happen when `so-long' and `so-long-revert' are invoked, allowing +;; alternative actions (including custom actions) to be configured. As well as +;; the major and minor mode actions provided by this library, `longlines-mode' +;; is also supported by default as an alternative action. +;; +;; Note that while the measures taken can improve performance dramatically when +;; dealing with such files, this library does not have any effect on the +;; fundamental limitations of the Emacs redisplay code itself; and so if you do +;; need to edit the file, performance may still degrade as you get deeper into +;; the long lines. In such circumstances you may find that `longlines-mode' is +;; the most helpful facility. +;; +;; Note also that the mitigations are automatically triggered when visiting a +;; file. The library does not automatically detect if long lines are inserted +;; into an existing buffer (although the `so-long' command can be invoked +;; manually in such situations). + +;; * Installation +;; -------------- +;; Use M-x global-so-long-mode to enable/toggle the functionality. To enable +;; the functionality by default, either customize the `global-so-long-mode' user +;; option, or add the following to your init file: +;; +;; ;; Avoid performance issues in files with very long lines. +;; (global-so-long-mode 1) +;; +;; If necessary, ensure that so-long.el is in a directory in your load-path, and +;; that the library has been loaded. (These steps are not necessary if you are +;; using Emacs 27+, or have installed the GNU ELPA package.) + +;; * Overview of modes and commands +;; -------------------------------- +;; - `global-so-long-mode' - A global minor mode which enables the automated +;; behaviour, causing the user's preferred action to be invoked whenever a +;; newly-visited file contains excessively long lines. +;; - `so-long-mode' - A major mode, and the default action. +;; - `so-long-minor-mode' - A minor mode version of the major mode, and an +;; alternative action. +;; - `longlines-mode' - A minor mode provided by the longlines.el library, +;; and another alternative action. +;; - `so-long' - Manually invoke the user's preferred action, enabling its +;; performance improvements for the current buffer. +;; - `so-long-revert' - Restore the original state of the buffer. +;; - `so-long-customize' - Configure the user options. +;; - `so-long-commentary' - Read this documentation in outline-mode. + +;; * Usage +;; ------- +;; In most cases you will simply enable `global-so-long-mode' and leave it to +;; act automatically as required, in accordance with your configuration (see +;; "Basic configuration" below). +;; +;; On rare occasions you may choose to manually invoke the `so-long' command, +;; which invokes your preferred `so-long-action' (exactly as the automatic +;; behaviour would do if it had detected long lines). You might use this if a +;; problematic file did not meet your configured criteria, and you wished to +;; trigger the performance improvements manually. +;; +;; It is also possible to directly use `so-long-mode' or `so-long-minor-mode' +;; (major and minor modes, respectively). Both of these modes are actions +;; available to `so-long' but, like any other mode, they can be invoked directly +;; if you have a need to do that (see also "Other ways of using so-long" below). +;; +;; If the behaviour ever triggers when you did not want it to, you can use the +;; `so-long-revert' command to restore the buffer to its original state. + +;; * Basic configuration +;; --------------------- +;; Use M-x customize-group RET so-long RET +;; (or M-x so-long-customize RET) +;; +;; The user options `so-long-target-modes', `so-long-threshold', and +;; `so-long-max-lines' determine whether action will be taken automatically when +;; visiting a file, and `so-long-action' determines what will be done. + +;; * Actions and menus +;; ------------------- +;; The user options `so-long-action' and `so-long-action-alist' determine what +;; will happen when `so-long' and `so-long-revert' are invoked, and you can add +;; your own custom actions if you wish. The selected action can be invoked +;; manually with M-x so-long; and in general M-x so-long-revert will undo the +;; effects of whichever action was used (which is particularly useful when the +;; action is triggered automatically, but the detection was a 'false positive'.) +;; +;; All defined actions are presented in the "So Long" menu, which is visible +;; whenever long lines have been detected. Selecting an action from the menu +;; will firstly cause the current action (if any) to be reverted, before the +;; newly-selected action is invoked. +;; +;; Aside from the menu bar, the menu is also available in the mode line -- +;; either via the major mode construct (when `so-long-mode' is active), or in +;; a separate mode line construct when some other major mode is active. + +;; * Files with a file-local 'mode' +;; -------------------------------- +;; A file-local major mode is likely to be safe even if long lines are detected +;; (as the author of the file would otherwise be unlikely to have set that mode), +;; and so these files are treated as special cases. When a file-local 'mode' is +;; present, the function defined by the `so-long-file-local-mode-function' user +;; option is called. The default value will cause the `so-long-minor-mode' +;; action to be used instead of the `so-long-mode' action, if the latter was +;; going to be used for this file. This is still a conservative default, but +;; this option can also be configured to inhibit so-long entirely in this +;; scenario, or to not treat a file-local mode as a special case at all. + +;; * Inhibiting and disabling minor modes +;; -------------------------------------- +;; Certain minor modes cause significant performance issues in the presence of +;; very long lines, and should be disabled automatically in this situation. +;; +;; The simple way to disable most buffer-local minor modes is to add the mode +;; symbol to the `so-long-minor-modes' list. Several modes are targeted by +;; default, and it is a good idea to customize this variable to add any +;; additional buffer-local minor modes that you use which you know to have +;; performance implications. +;; +;; These minor modes are disabled if `so-long-action' is set to either +;; `so-long-mode' or `so-long-minor-mode'. If `so-long-revert' is called, then +;; the original values are restored. +;; +;; In the case of globalized minor modes, be sure to specify the buffer-local +;; minor mode, and not the global mode which controls it. +;; +;; Note that `so-long-minor-modes' is not useful for other global minor modes +;; (as distinguished from globalized minor modes), but in some cases it will be +;; possible to inhibit or otherwise counter-act the behaviour of a global mode +;; by overriding variables, or by employing hooks (see below). You would need +;; to inspect the code for a given global mode (on a case by case basis) to +;; determine whether it's possible to inhibit it for a single buffer -- and if +;; so, how best to do that, as not all modes are alike. + +;; * Overriding variables +;; ---------------------- +;; `so-long-variable-overrides' is an alist mapping variable symbols to values. +;; If `so-long-action' is set to either `so-long-mode' or `so-long-minor-mode', +;; the buffer-local value for each variable in the list is set to the associated +;; value in the alist. Use this to enforce values which will improve +;; performance or otherwise avoid undesirable behaviours. If `so-long-revert' +;; is called, then the original values are restored. + +;; * Hooks +;; ------- +;; `so-long-hook' runs at the end of the `so-long' command, after the configured +;; action has been invoked. +;; +;; Likewise, if the `so-long-revert' command is used to restore the original +;; state then, once that has happened, `so-long-revert-hook' is run. +;; +;; The major and minor modes also provide the usual hooks: `so-long-mode-hook' +;; for the major mode (running between `change-major-mode-after-body-hook' and +;; `after-change-major-mode-hook'); and `so-long-minor-mode-hook' (when that +;; mode is enabled or disabled). + +;; * Troubleshooting +;; ----------------- +;; Any elisp library has the potential to cause performance problems; so while +;; the default configuration addresses some important common cases, it's +;; entirely possible that your own config introduces problem cases which are +;; unknown to this library. +;; +;; If visiting a file is still taking a very long time with so-long enabled, +;; you should test the following command: +;; +;; emacs -Q -l so-long -f global-so-long-mode <file> +;; +;; For versions of Emacs < 27, use: +;; emacs -Q -l /path/to/so-long.el -f global-so-long-mode <file> +;; +;; If the file loads quickly when that command is used, you'll know that +;; something in your personal configuration is causing problems. If this +;; turns out to be a buffer-local minor mode, or a user option, you can +;; likely alleviate the issue by customizing `so-long-minor-modes' or +;; `so-long-variable-overrides' accordingly. +;; +;; The in-built profiler can be an effective way of discovering the cause +;; of such problems. Refer to M-: (info "(elisp) Profiling") RET +;; +;; In some cases it may be useful to set a file-local `mode' variable to +;; `so-long-mode', completely bypassing the automated decision process. +;; Refer to M-: (info "(emacs) Specifying File Variables") RET +;; +;; If so-long itself is causing problems, it can be inhibited by setting the +;; `so-long-enabled' variable to nil, or by disabling the global mode with +;; M-- M-x global-so-long-mode, or M-: (global-so-long-mode 0) + +;; * Example configuration +;; ----------------------- +;; If you prefer to configure in code rather than via the customize interface, +;; then you might use something along these lines: +;; +;; ;; Enable so-long library. +;; (when (require 'so-long nil :noerror) +;; (global-so-long-mode 1) +;; ;; Basic settings. +;; (setq so-long-action 'so-long-minor-mode) +;; (setq so-long-threshold 1000) +;; (setq so-long-max-lines 100) +;; ;; Additional target major modes to trigger for. +;; (mapc (apply-partially 'add-to-list 'so-long-target-modes) +;; '(sgml-mode nxml-mode)) +;; ;; Additional buffer-local minor modes to disable. +;; (mapc (apply-partially 'add-to-list 'so-long-minor-modes) +;; '(diff-hl-mode diff-hl-amend-mode diff-hl-flydiff-mode)) +;; ;; Additional variables to override. +;; (mapc (apply-partially 'add-to-list 'so-long-variable-overrides) +;; '((show-trailing-whitespace . nil) +;; (truncate-lines . nil)))) + +;; * Other ways of using so-long +;; ----------------------------- +;; It may prove useful to automatically invoke major mode `so-long-mode' for +;; certain files, irrespective of whether they contain long lines. +;; +;; To target specific files and extensions, using `auto-mode-alist' is the +;; simplest method. To add such an entry, use: +;; (add-to-list 'auto-mode-alist (cons REGEXP 'so-long-mode)) +;; Where REGEXP is a regular expression matching the filename. e.g.: +;; +;; - Any filename with a particular extension ".foo": +;; (rx ".foo" eos) +;; +;; - Any file in a specific directory: +;; (rx bos "/path/to/directory/") +;; +;; - Only *.c filenames under that directory: +;; (rx bos "/path/to/directory/" (zero-or-more not-newline) ".c" eos) +;; +;; - Match some sub-path anywhere in a filename: +;; (rx "/sub/path/foo") +;; +;; - A specific individual file: +;; (rx bos "/path/to/file" eos) +;; +;; Another way to target individual files is to set a file-local `mode' +;; variable. Refer to M-: (info "(emacs) Specifying File Variables") RET +;; +;; `so-long-minor-mode' can also be called directly if desired. e.g.: +;; (add-hook 'FOO-mode-hook 'so-long-minor-mode) +;; +;; In Emacs 26.1 or later (see "Caveats" below) you also have the option of +;; using file-local and directory-local variables to determine how `so-long' +;; behaves. e.g. -*- so-long-action: longlines-mode; -*- +;; +;; The buffer-local `so-long-function' and `so-long-revert-function' values may +;; be set directly (in a major mode hook, for instance), as any existing value +;; for these variables will be used in preference to the values defined by the +;; selected action. For file-local or directory-local usage it is preferable to +;; set only `so-long-action', as all function variables are marked as 'risky', +;; meaning you would need to add to `safe-local-variable-values' in order to +;; avoid being queried about them. +;; +;; Finally, the `so-long-predicate' user option enables the automated behaviour +;; to be determined by a custom function, if greater control is needed. + +;; * Implementation notes +;; ---------------------- +;; This library advises `set-auto-mode' (in order to react after Emacs has +;; chosen the major mode for a buffer), and `hack-local-variables' (so that we +;; may behave differently when a file-local mode is set). In earlier versions +;; of Emacs (< 26.1) we also advise `hack-one-local-variable' (to prevent a +;; file-local mode from restoring the original major mode if we had changed it). +;; +;; Many variables are permanent-local because after the normal major mode has +;; been set, we potentially change the major mode to `so-long-mode', and it's +;; important that the values which were established prior to that are retained. + +;; * Caveats +;; --------- +;; The variables affecting the automated behavior of this library (such as +;; `so-long-action') can be used as file- or dir-local values in Emacs 26+, but +;; not in previous versions of Emacs. This is on account of improvements made +;; to `normal-mode' in 26.1, which altered the execution order with respect to +;; when local variables are processed. In earlier versions of Emacs the local +;; variables are processed too late, and hence have no effect on the decision- +;; making process for invoking `so-long'. It is unlikely that equivalent +;; support will be implemented for older versions of Emacs. The exception to +;; this caveat is the `mode' pseudo-variable, which is processed early in all +;; versions of Emacs, and can be set to `so-long-mode' if desired. + +;;; * Change Log: +;; +;; 1.0 - Included in Emacs 27.1, and in GNU ELPA for prior versions of Emacs. +;; - New global mode `global-so-long-mode' to enable/disable the library. +;; - New user option `so-long-action'. +;; - New user option `so-long-action-alist' defining alternative actions. +;; - New user option `so-long-variable-overrides'. +;; - New user option `so-long-skip-leading-comments'. +;; - New user option `so-long-file-local-mode-function'. +;; - New user option `so-long-predicate'. +;; - New variable and function `so-long-function'. +;; - New variable and function `so-long-revert-function'. +;; - New command `so-long' to invoke `so-long-function' interactively. +;; - New command `so-long-revert' to invoke `so-long-revert-function'. +;; - New minor mode action `so-long-minor-mode' facilitates retaining the +;; original major mode, while still disabling minor modes and overriding +;; variables like the major mode `so-long-mode'. +;; - Support `longlines-mode' as a `so-long-action' option. +;; - Added "So Long" menu, including all selectable actions. +;; - Added mode-line indicator, user option `so-long-mode-line-label', +;; and faces `so-long-mode-line-active', `so-long-mode-line-inactive'. +;; - New help commands `so-long-commentary' and `so-long-customize'. +;; - Renamed `so-long-mode-enabled' to `so-long-enabled'. +;; - Refactored the default hook values using variable overrides +;; (and returning all the hooks to nil default values). +;; - Performance improvements for `so-long-detected-long-line-p'. +;; - Converted defadvice to nadvice. +;; 0.7.6 - Bug fix for `so-long-mode-hook' losing its default value. +;; 0.7.5 - Documentation. +;; - Added sgml-mode and nxml-mode to `so-long-target-modes'. +;; 0.7.4 - Refactored the handling of `whitespace-mode'. +;; 0.7.3 - Added customize group `so-long' with user options. +;; - Added `so-long-original-values' to generalise the storage and +;; restoration of values from the original mode upon `so-long-revert'. +;; - Added `so-long-revert-hook'. +;; 0.7.2 - Remember the original major mode even with M-x `so-long-mode'. +;; 0.7.1 - Clarified interaction with globalized minor modes. +;; 0.7 - Handle header 'mode' declarations. +;; - Hack local variables after reverting to the original major mode. +;; - Reverted `so-long-max-lines' to a default value of 5. +;; 0.6.5 - Inhibit globalized `hl-line-mode' and `whitespace-mode'. +;; - Set `buffer-read-only' by default. +;; 0.6 - Added `so-long-minor-modes' and `so-long-hook'. +;; 0.5 - Renamed library to "so-long.el". +;; - Added explicit `so-long-enable' command to activate our advice. +;; 0.4 - Amended/documented behaviour with file-local 'mode' variables. +;; 0.3 - Defer to a file-local 'mode' variable. +;; 0.2 - Initial release to EmacsWiki. +;; 0.1 - Experimental. + +;;; Code: + +(require 'cl-lib) + +(add-to-list 'customize-package-emacs-version-alist + '(so-long ("1.0" . "27.1"))) + +(declare-function longlines-mode "longlines") +(defvar longlines-mode) + +(declare-function outline-next-visible-heading "outline") +(declare-function outline-previous-visible-heading "outline") +(declare-function outline-toggle-children "outline") +(declare-function outline-toggle-children "outline") + +(defvar so-long-enabled nil + "Set to nil to prevent `so-long' from being triggered automatically. + +Has no effect if `global-so-long-mode' is not enabled.") + +(defvar-local so-long--active nil ; internal use + "Non-nil when `so-long' mitigations are in effect.") + +(defvar so-long--set-auto-mode nil ; internal use + "Non-nil while `set-auto-mode' is executing.") + +(defvar so-long--hack-local-variables-no-mode nil ; internal use + "Non-nil to prevent `hack-local-variables' applying a 'mode' variable.") + +(defvar-local so-long--inhibited nil ; internal use + "When non-nil, prevents the `set-auto-mode' advice from calling `so-long'.") +(put 'so-long--inhibited 'permanent-local t) + +(defvar so-long--calling nil ; internal use + ;; This prevents infinite recursion if eval:(so-long) is specified + ;; as a file- or dir-local variable, and `so-long-action' is set to + ;; `so-long-mode' (as that major mode would once again process the + ;; local variables, and hence call itself). + "Non-nil while `so-long' or `so-long-revert' is executing.") + +(defvar-local so-long-detected-p nil + "Non-nil if `so-long' has been invoked (even if subsequently reverted).") +(put 'so-long-detected-p 'permanent-local t) + +(defgroup so-long nil + "Prevent unacceptable performance degradation with very long lines." + :prefix "so-long" + :group 'convenience) + +(defcustom so-long-threshold 250 + "Maximum line length permitted before invoking `so-long-function'. + +See `so-long-detected-long-line-p' for details." + :type 'integer + :package-version '(so-long . "1.0") + :group 'so-long) + +(defcustom so-long-max-lines 5 + "Number of non-blank, non-comment lines to test for excessive length. + +If nil then all lines will be tested, until either a long line is detected, +or the end of the buffer is reached. + +If `so-long-skip-leading-comments' is nil then comments and blank lines will +be counted. + +See `so-long-detected-long-line-p' for details." + :type '(choice (integer :tag "Limit") + (const :tag "Unlimited" nil)) + :package-version '(so-long . "1.0") + :group 'so-long) + +(defcustom so-long-skip-leading-comments t + "Non-nil to ignore all leading comments and whitespace. + +If the file begins with a shebang (#!), this option also causes that line to be +ignored even if it doesn't match the buffer's comment syntax, to ensure that +comments following the shebang will be ignored. + +See `so-long-detected-long-line-p' for details." + :type 'boolean + :package-version '(so-long . "1.0") + :group 'so-long) + +(defcustom so-long-target-modes + '(prog-mode css-mode sgml-mode nxml-mode) + "`so-long' affects only these modes and their derivatives. + +Our primary use-case is minified programming code, so `prog-mode' covers +most cases, but there are some exceptions to this. + +If t, then all modes are targeted. Note that this is only useful with a +custom `so-long-predicate', as many file types (archives and binary files, +for example) can safely contain long lines, and invoking `so-long' on such +files would prevent Emacs from handling them correctly." + ;; Use 'symbol', as 'function' may be unknown => mismatch. + :type '(choice (repeat :tag "Specified modes" symbol) + (const :tag "All modes" t)) + :package-version '(so-long . "1.0") + :group 'so-long) + +(defcustom so-long-predicate 'so-long-detected-long-line-p + "Function, called after `set-auto-mode' to decide whether action is needed. + +Only called if the major mode is a member of `so-long-target-modes'. + +The specified function will be called with no arguments. If it returns non-nil +then `so-long' will be invoked. + +Defaults to `so-long-detected-long-line-p'." + :type '(choice (const so-long-detected-long-line-p) + (function :tag "Custom function")) + :package-version '(so-long . "1.0") + :group 'so-long) + +;; Silence byte-compiler warning. `so-long-action-alist' is defined below +;; as a user option; but the definition sequence required for its setter +;; function means we also need to declare it beforehand. +(defvar so-long-action-alist) + +(defun so-long--action-type () + "Generate a :type for `so-long-action' based on `so-long-action-alist'." + ;; :type seemingly cannot be a form to be evaluated on demand, so we + ;; endeavour to keep it up-to-date with `so-long-action-alist' by + ;; calling this from `so-long--action-alist-setter'. + `(radio ,@(mapcar (lambda (x) (list 'const :tag (cadr x) (car x))) + (assq-delete-all nil so-long-action-alist)) + (const :tag "Do nothing" nil))) + +(defun so-long--action-alist-setter (option value) + "The customize :set function for `so-long-action-alist'." + ;; Set the value as normal. + (set-default option value) + ;; Update the :type of `so-long-action' to present the updated values. + (put 'so-long-action 'custom-type (so-long--action-type))) + +(defcustom so-long-action-alist + '((so-long-mode + "Change major mode to so-long-mode" + so-long-mode + so-long-mode-revert) + (so-long-minor-mode + "Enable so-long-minor-mode" + turn-on-so-long-minor-mode + turn-off-so-long-minor-mode) + (longlines-mode + "Enable longlines-mode" + so-long-function-longlines-mode + so-long-revert-function-longlines-mode)) + "Options for `so-long-action'. + +Each element is a list comprising (KEY LABEL ACTION REVERT) + +KEY is a symbol which is a valid value for `so-long-action', and LABEL is a +string which describes and represents the key in that option's customize +interface, and in the \"So Long\" menu. ACTION and REVERT are functions: + +ACTION will be the `so-long-function' value when `so-long' is called, and +REVERT will be the `so-long-revert-function' value, if `so-long-revert' is +subsequently called." + :type '(alist :key-type (symbol :tag "Key" :value <action>) + :value-type (list (string :tag "Label" :value "<description>") + (function :tag "Action") + (function :tag "Revert"))) + :set #'so-long--action-alist-setter + :package-version '(so-long . "1.0") + :group 'so-long) +(put 'so-long-action-alist 'risky-local-variable t) + +(defcustom so-long-action 'so-long-mode + "The action taken by `so-long' when long lines are detected. + +\(Long lines are determined by `so-long-predicate' after `set-auto-mode'.) + +The value is a key to one of the options defined by `so-long-action-alist'. + +The default action is to replace the original major mode with `so-long-mode'. +Alternatively, the `so-long-minor-mode' action retains the original major mode +while still disabling minor modes and overriding variables. These are the only +standard values for which `so-long-minor-modes' and `so-long-variable-overrides' +will be automatically processed; but custom actions can also do these things. + +The value `longlines-mode' causes that minor mode to be enabled. See +longlines.el for more details. + +Each action likewise determines the behaviour of `so-long-revert'. + +If the value is nil, or not defined in `so-long-action-alist', then no action +will be taken." + :type (so-long--action-type) + :package-version '(so-long . "1.0") + :group 'so-long) + +(defvar-local so-long-function nil + "The function called by `so-long'. + +This should be set in conjunction with `so-long-revert-function'. This usually +happens automatically, based on the value of `so-long-action'. + +The specified function will be called with no arguments, after which +`so-long-hook' runs.") +(put 'so-long-function 'permanent-local t) + +(defvar-local so-long-revert-function nil + "The function called by `so-long-revert'. + +This should be set in conjunction with `so-long-function'. This usually +happens automatically, based on the value of `so-long-action'. + +The specified function will be called with no arguments, after which +`so-long-revert-hook' runs.") +(put 'so-long-revert-function 'permanent-local t) + +(defun so-long-function (&optional action-arg) + "The value of `so-long-function', else derive from `so-long-action'. + +If ACTION-ARG is provided, it is used in place of `so-long-action'." + (or so-long-function + (and (or action-arg + (setq action-arg so-long-action)) + (let ((action (assq action-arg so-long-action-alist))) + (nth 2 action))))) + +(defun so-long-revert-function (&optional action-arg) + "The value of `so-long-revert-function', else derive from `so-long-action'. + +If ACTION-ARG is provided, it is used in place of `so-long-action'." + (or so-long-revert-function + (and (or action-arg + (setq action-arg so-long-action)) + (let ((action (assq action-arg so-long-action-alist))) + (nth 3 action))))) + +(defcustom so-long-file-local-mode-function 'so-long-mode-downgrade + "Function to call during `set-auto-mode' when a file-local mode is set. + +The specified function will be called with a single argument, being the +file-local mode which was established. + +This happens before `so-long' is called, and so this function can modify the +subsequent action. + +The value `so-long-mode-downgrade' means `so-long-minor-mode' will be used in +place of `so-long-mode' -- therefore respecting the file-local mode value, yet +still overriding minor modes and variables (as if `so-long-action' had been set +to `so-long-minor-mode'). + +The value `so-long-inhibit' means that so-long will not take any action at all +for this file. + +If nil, then do not treat files with file-local modes any differently to other +files. + +Note that this function is called if a file-local mode is set even if `so-long' +will not be called, and also if the file-local mode is `so-long-mode'. Custom +functions may need to test for these cases -- see `so-long-mode-downgrade' for +an example." + :type '(radio (const so-long-mode-downgrade) + (const so-long-inhibit) + (const :tag "nil: Use so-long-function as normal" nil) + (function :tag "Custom function")) + :package-version '(so-long . "1.0") + :group 'so-long) +(make-variable-buffer-local 'so-long-file-local-mode-function) + +;; `provided-mode-derived-p' was added in 26.1 +(unless (fboundp 'provided-mode-derived-p) + (defun provided-mode-derived-p (mode &rest modes) + "Non-nil if MODE is derived from one of MODES. +Uses the `derived-mode-parent' property of the symbol to trace backwards. +If you just want to check `major-mode', use `derived-mode-p'." + (while (and (not (memq mode modes)) + (setq mode (get mode 'derived-mode-parent)))) + mode)) + +(defun so-long-handle-file-local-mode (mode) + "Wrapper for calling `so-long-file-local-mode-function'. + +The function is called with one argument, MODE, being the file-local mode which +was established." + ;; Handle the special case whereby the file-local mode was `so-long-mode'. + ;; In this instance we set `so-long--inhibited', because the file-local mode + ;; is already going to do everything that is wanted. + (when (provided-mode-derived-p mode 'so-long-mode) + (setq so-long--inhibited t)) + ;; Call `so-long-file-local-mode-function'. + (when so-long-file-local-mode-function + (funcall so-long-file-local-mode-function mode))) + +(defcustom so-long-minor-modes + ;; In sorted groups. + '(font-lock-mode ;; (Generally the most important). + ;; Other standard minor modes: + display-line-numbers-mode + goto-address-mode + goto-address-prog-mode + hi-lock-mode + highlight-changes-mode + hl-line-mode + linum-mode + nlinum-mode + prettify-symbols-mode + visual-line-mode + whitespace-mode + ;; Known third-party modes-of-interest: + diff-hl-amend-mode + diff-hl-flydiff-mode + diff-hl-mode + dtrt-indent-mode + hl-sexp-mode + idle-highlight-mode + rainbow-delimiters-mode + ) + ;; It's not clear to me whether all of these would be problematic, but they + ;; seemed like reasonable targets. Some are certainly excessive in smaller + ;; buffers of minified code, but we should be aiming to maximise performance + ;; by default, so that Emacs is as responsive as we can manage in even very + ;; large buffers of minified code. + "List of buffer-local minor modes to explicitly disable. + +The ones which were originally enabled in the buffer are disabled by calling +them with the numeric argument 0. Unknown modes, and modes which were were not +enabled, are ignored. + +This happens after any globalized minor modes have acted, so that buffer-local +modes controlled by globalized modes can also be targeted. + +By default this happens if `so-long-action' is set to either `so-long-mode' +or `so-long-minor-mode'. If `so-long-revert' is subsequently invoked, then the +disabled modes are re-enabled by calling them with the numeric argument 1. + +`so-long-hook' can be used where more custom behaviour is desired. + +Please submit bug reports to recommend additional modes for this list, whether +they are in Emacs core, GNU ELPA, or elsewhere." + :type '(repeat symbol) ;; not function, as may be unknown => mismatch. + :package-version '(so-long . "1.0") + :group 'so-long) + +(defcustom so-long-variable-overrides + '((bidi-paragraph-direction . left-to-right) + (buffer-read-only . t) + (global-hl-line-mode . nil) + (line-move-visual . t) + (show-paren-mode . nil) + (truncate-lines . nil) + (which-func-mode . nil)) + "Variables to override, and the values to override them with. + +The variables are given buffer-local values. By default this happens if +`so-long-action' is set to either `so-long-mode' or `so-long-minor-mode'. + +If `so-long-revert' is subsequently invoked, then the variables are restored +to their original states. + +The combination of `line-move-visual' (enabled) and `truncate-lines' (disabled) +is important for avoiding performance hits when moving vertically between +excessively long lines, as otherwise the full length of the line may need to be +scanned to find the next position." + :type '(alist :key-type (variable :tag "Variable") + :value-type (sexp :tag "Value")) + :options '((bidi-paragraph-direction (choice (const left-to-right) + (const right-to-left) + (const nil))) + (buffer-read-only boolean) + (global-hl-line-mode boolean) + (line-move-visual boolean) + (show-paren-mode boolean) + (truncate-lines boolean) + (which-func-mode boolean)) + :package-version '(so-long . "1.0") + :group 'so-long) + +(defcustom so-long-hook nil + "List of functions to call after `so-long' is called. + +See also `so-long-revert-hook'." + :type 'hook + :package-version '(so-long . "1.0") + :group 'so-long) + +(defcustom so-long-revert-hook nil + "List of functions to call after `so-long-revert' is called. + +See also `so-long-hook'." + :type 'hook + :package-version '(so-long . "1.0") + :group 'so-long) + +(defcustom so-long-mode-line-label "So Long" + "Text label of `so-long-mode-line-info' when long lines are detected. + +If nil, no mode line indicator will be displayed." + :type '(choice (string :tag "String") + (const :tag "None" nil)) + :package-version '(so-long . "1.0") + :group 'so-long) + +(defface so-long-mode-line-active + '((t :inherit mode-line-emphasis)) + "Face for `so-long-mode-line-info' when mitigations are active." + :package-version '(so-long . "1.0") + :group 'so-long) + +(defface so-long-mode-line-inactive + '((t :inherit mode-line-inactive)) + "Face for `so-long-mode-line-info' when mitigations have been reverted." + :package-version '(so-long . "1.0") + :group 'so-long) + +;; Modes that go slowly and line lengths excessive +;; Font-lock performance becoming oppressive +;; All of my CPU tied up with strings +;; These are a few of my least-favourite things + +(defvar-local so-long-original-values nil + "Alist holding the buffer's original `major-mode' value, and other data. + +Any values to be restored by `so-long-revert' can be stored here by the +`so-long-function' or during `so-long-hook'. `so-long' itself stores the +original states for `so-long-variable-overrides' and `so-long-minor-modes', +so these values are available to custom actions by default. + +See also `so-long-remember' and `so-long-original'.") +(put 'so-long-original-values 'permanent-local t) + +(defun so-long-original (key &optional exists) + "Return the current value for KEY in `so-long-original-values'. + +If you need to differentiate between a stored value of nil and no stored value +at all, make EXISTS non-nil. This then returns the result of `assq' directly: +nil if no value was set, and a cons cell otherwise." + (if exists + (assq key so-long-original-values) + (cadr (assq key so-long-original-values)))) + +(defun so-long-remember (variable) + "Store the value of VARIABLE in `so-long-original-values'. + +We additionally store a boolean value which indicates whether that value was +buffer-local." + (when (boundp variable) + (setq so-long-original-values + (assq-delete-all variable so-long-original-values)) + (push (list variable + (symbol-value variable) + (local-variable-p variable)) + so-long-original-values))) + +(defun so-long-remember-all (&optional reset) + "Remember the current variable and minor mode values. + +Stores the existing value for each entry in `so-long-variable-overrides'. +Stores the name of each enabled mode from the list `so-long-minor-modes'. + +If RESET is non-nil, remove any existing values before storing the new ones." + (when reset + (setq so-long-original-values nil)) + (dolist (ovar so-long-variable-overrides) + (so-long-remember (car ovar))) + (dolist (mode so-long-minor-modes) + (when (and (boundp mode) mode) + (so-long-remember mode)))) + +(defun so-long-menu () + "Dynamically generate the \"So Long\" menu." + ;; (info "(elisp) Menu Example") + (let ((map (make-sparse-keymap "So Long")) + (help-map (make-sparse-keymap "Help"))) + ;; `so-long-revert'. + (define-key-after map [so-long-revert] + '(menu-item "Revert to normal" so-long-menu-item-revert + :enable (and so-long-revert-function + so-long--active))) + ;; `so-long-menu-item-replace-action' over `so-long-action-alist'. + (define-key-after map [so-long-actions-separator] + '(menu-item "--")) + (dolist (item so-long-action-alist) + (cl-destructuring-bind (key label actionfunc revertfunc) + item + (define-key-after map (vector key) + `(menu-item + ,label + ,(let ((sym (make-symbol "so-long-menu-item-replace-action"))) + ;; Using a symbol here, so that `describe-key' on the menu item + ;; produces the `so-long-menu-item-replace-action' documentation. + (defalias sym + (apply-partially #'so-long-menu-item-replace-action item) + (documentation #'so-long-menu-item-replace-action)) + (put sym 'interactive-form '(interactive)) + sym) + :enable (not (and so-long--active + (eq ',actionfunc so-long-function) + (eq ',revertfunc so-long-revert-function))))))) + ;; "Help" sub-menu. + (define-key-after map [so-long-help-separator] + '(menu-item "--")) + (define-key-after map [so-long-help] + `(menu-item "Help" ,help-map)) + (define-key-after help-map [so-long-commentary] + '(menu-item "Commentary" so-long-commentary)) + (define-key-after help-map [so-long-customize] + '(menu-item "Customize" so-long-customize)) + map)) + +(defun so-long-menu-click-window () + "Return the window for a click in the So Long menu. + +Commands in the mode-line menu may be triggered by mouse when some other window +is selected, so we need to make sure we are acting on the correct buffer." + ;; Refer to (info "(elisp) Click Events") regarding the form of the mouse + ;; position list for clicks in the mode line. + (or (and (mouse-event-p last-nonmenu-event) + (windowp (car (cadr last-nonmenu-event))) ; cXXXr only available + (car (cadr last-nonmenu-event))) ; since Emacs 26.1 + (selected-window))) + +(defun so-long-menu-item-revert () + "Invoke `so-long-revert'." + (interactive) + (with-selected-window (so-long-menu-click-window) + (so-long-revert))) + +(defun so-long-menu-item-replace-action (replacement) + "Revert the current action and invoke the specified replacement. + +REPLACEMENT is a `so-long-action-alist' item." + (interactive) + (with-selected-window (so-long-menu-click-window) + (when so-long--active + (so-long-revert)) + (cl-destructuring-bind (_key _label actionfunc revertfunc) + replacement + (setq so-long-function actionfunc) + (setq so-long-revert-function revertfunc) + (setq this-command 'so-long) + (so-long)))) + +;;;###autoload +(defun so-long-commentary () + "View the so-long documentation in `outline-mode'." + (interactive) + (let ((buf "*So Long: Commentary*")) + (when (buffer-live-p (get-buffer buf)) + (kill-buffer buf)) + ;; Use `finder-commentary' to generate the buffer. + (require 'finder) + (cl-letf (((symbol-function 'finder-summary) #'ignore)) + (finder-commentary "so-long")) + (let ((inhibit-read-only t)) + (when (looking-at "^Commentary:\n\n") + (replace-match "so-long.el\n\n")) + (save-excursion + (while (re-search-forward "^-+$" nil :noerror) + (replace-match "")))) + (rename-buffer buf) + ;; Enable `outline-mode' and `view-mode' for user convenience. + (outline-mode) + (view-mode 1) + ;; Add some custom local bindings. + (let ((map (make-sparse-keymap))) + (define-key map (kbd "TAB") #'outline-toggle-children) + (define-key map (kbd "<M-tab>") #'outline-toggle-children) + (define-key map (kbd "M-n") #'outline-next-visible-heading) + (define-key map (kbd "M-p") #'outline-previous-visible-heading) + (set-keymap-parent map (current-local-map)) + (use-local-map map)) + ;; Display the So Long menu. + (so-long--ensure-enabled) + (let ((so-long-action nil)) + (so-long)))) + +;;;###autoload +(defun so-long-customize () + "Open the so-long `customize' group." + (interactive) + (customize-group 'so-long)) + +(defvar-local so-long-mode-line-info nil + "Mode line construct displayed when `so-long' has been triggered. + +Displayed as part of `mode-line-misc-info'. + +`so-long-mode-line-label' defines the text to be displayed (if any). + +Face `so-long-mode-line-active' is used while mitigations are active, and +`so-long-mode-line-inactive' is used if `so-long-revert' is called. + +Not displayed when `so-long-mode' is enabled, as the major mode construct +serves the same purpose.") + +;; Ensure we can display text properties on this value in the mode line. +;; See (info "(elisp) Mode Line Data") or (info "(elisp) Properties in Mode"). +(put 'so-long-mode-line-info 'risky-local-variable t) + +(defun so-long-mode-line-info () + "Returns the mode line construct for variable `so-long-mode-line-info'." + (let ((map (make-sparse-keymap))) + (define-key map (kbd "<mode-line> <down-mouse-1>") + `(menu-item "" nil + :filter ,(lambda (_cmd) (so-long-menu)))) + ;; Mode line construct. + ;; n.b. It's necessary for `so-long-mode-line-info' to have a non-nil + ;; risky-local-variable property, as otherwise the text properties won't + ;; be rendered. + `(so-long-mode-line-label + ("" (:eval (propertize so-long-mode-line-label + 'mouse-face 'highlight + 'keymap ',map + 'help-echo t ;; Suppress the mode-line value + 'face (if so-long--active + 'so-long-mode-line-active + 'so-long-mode-line-inactive))) + " ")))) + +;; When the line's long +;; When the mode's slow +;; When Emacs is sad +;; We change automatically to faster code +;; And then I won't feel so mad + +(defun so-long-detected-long-line-p () + "Determine whether the current buffer contains long lines. + +Following any initial comments and blank lines, the next N lines of the buffer +will be tested for excessive length (where \"excessive\" means above +`so-long-threshold', and N is `so-long-max-lines'). + +Returns non-nil if any such excessive-length line is detected. + +If `so-long-skip-leading-comments' is nil then the N lines will be counted +starting from the first line of the buffer. In this instance you will likely +want to increase `so-long-max-lines' to allow for possible comments. + +This is the default value of `so-long-predicate'." + (let ((count 0) start) + (save-excursion + (goto-char (point-min)) + (when so-long-skip-leading-comments + ;; Skip the shebang line, if any. This is not necessarily comment + ;; syntax, so we need to treat it specially. + (when (looking-at "#!") + (forward-line 1)) + ;; Move past any leading whitespace and/or comments. + ;; We use narrowing to limit the amount of text being processed at any + ;; given time, where possible, as this makes things more efficient. + (setq start (point)) + (while (save-restriction + (narrow-to-region start (min (+ (point) so-long-threshold) + (point-max))) + (goto-char start) + ;; Possibilities for `comment-forward' are: + ;; 0. No comment; no movement; return nil. + ;; 1. Comment is <= point-max; move end of comment; return t. + ;; 2. Comment is truncated; move point-max; return nil. + ;; 3. Only whitespace; move end of WS; return nil. + (prog1 (or (comment-forward 1) ;; Moved past a comment. + (and (eobp) ;; Truncated, or WS up to point-max. + (progn ;; Widen and retry. + (widen) + (goto-char start) + (comment-forward 1)))) + ;; Otherwise there was no comment, and we return nil. + ;; If there was whitespace, we moved past it. + (setq start (point))))) + ;; We're at the first non-comment line, but we may have moved past + ;; indentation whitespace, so move back to the beginning of the line + ;; unless we're at the end of the buffer (in which case there was no + ;; non-comment/whitespace content in the buffer at all). + (unless (eobp) + (forward-line 0))) + ;; Start looking for long lines. + ;; `while' will ultimately return nil if we do not `throw' a result. + (catch 'excessive + (while (and (not (eobp)) + (or (not so-long-max-lines) + (< count so-long-max-lines))) + (setq start (point)) + (save-restriction + (narrow-to-region start (min (+ start 1 so-long-threshold) + (point-max))) + (forward-line 1)) + ;; If point is not now at the beginning of a line, then the previous + ;; line was long -- with the exception of when point is at the end of + ;; the buffer (bearing in mind that we have widened again), in which + ;; case there was a short final line with no newline. There is an + ;; edge case when such a final line is exactly (1+ so-long-threshold) + ;; chars long, so if we're at (eobp) we need to verify the length in + ;; order to be consistent. + (unless (or (bolp) + (and (eobp) (<= (- (point) start) + so-long-threshold))) + (throw 'excessive t)) + (setq count (1+ count))))))) + +(defun so-long-function-longlines-mode () + "Enable minor mode `longlines-mode'." + (require 'longlines) + (so-long-remember 'longlines-mode) + (longlines-mode 1)) + +(defun so-long-revert-function-longlines-mode () + "Restore original state of `longlines-mode'." + (require 'longlines) + (let ((state (so-long-original 'longlines-mode :exists))) + (if state + (unless (equal (cadr state) longlines-mode) + (longlines-mode (if (cadr state) 1 0))) + (longlines-mode 0)))) + +(defun turn-on-so-long-minor-mode () + "Enable minor mode `so-long-minor-mode'." + (so-long-minor-mode 1)) + +(defun turn-off-so-long-minor-mode () + "Disable minor mode `so-long-minor-mode'." + (so-long-minor-mode 0)) + +;;;###autoload +(define-minor-mode so-long-minor-mode + "This is the minor mode equivalent of `so-long-mode'. + +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." + nil nil nil + (if so-long-minor-mode ;; We are enabling the mode. + (progn + ;; Housekeeping. `so-long-minor-mode' might be invoked directly rather + ;; than via `so-long', so replicate the necessary behaviours. The minor + ;; mode also cares about whether `so-long' was already active, as we do + ;; not want to remember values which were potentially overridden already. + (unless (or so-long--calling so-long--active) + (so-long--ensure-enabled) + (setq so-long--active t + so-long-detected-p t + so-long-function 'turn-on-so-long-minor-mode + so-long-revert-function 'turn-off-so-long-minor-mode) + (so-long-remember-all :reset) + (unless (derived-mode-p 'so-long-mode) + (setq so-long-mode-line-info (so-long-mode-line-info)))) + ;; Now perform the overrides. + (so-long-disable-minor-modes) + (so-long-override-variables)) + ;; We are disabling the mode. + (unless so-long--calling ;; Housekeeping. + (when (eq so-long-function 'turn-on-so-long-minor-mode) + (setq so-long--active nil)) + (unless (derived-mode-p 'so-long-mode) + (setq so-long-mode-line-info (so-long-mode-line-info)))) + ;; Restore the overridden settings. + (so-long-restore-minor-modes) + (so-long-restore-variables))) + +;; How do you solve a problem like a long line? +;; How do you stop a mode from slowing down? +;; How do you cope with processing a long line? +;; A bit of advice! A mode! A workaround! + +(defvar so-long-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-c") 'so-long-revert) + ;; Define the major mode menu. We have an awkward issue whereby + ;; [menu-bar so-long] is already defined in the global map and is + ;; :visible so-long-detected-p, but we also want this to be + ;; available via the major mode construct in the mode line. + ;; The following achieves the desired end result, as :visible nil + ;; prevents this from duplicating its contents in the menu bar, + ;; but still includes it in the mode line. + (define-key map [menu-bar so-long] + `(menu-item "" nil + :visible nil + :filter ,(lambda (_cmd) (so-long-menu)))) + map) + "Major mode keymap and menu for `so-long-mode'.") + +;;;###autoload +(define-derived-mode so-long-mode nil "So Long" + "This major mode is the default `so-long-action' option. + +The normal reason for this mode being active is that `global-so-long-mode' is +enabled, and `so-long-predicate' has detected that the file contains long lines. + +Many Emacs modes struggle with buffers which contain excessively long lines, +and may consequently cause unacceptable performance issues. + +This is commonly on account of 'minified' code (i.e. code has been compacted +into the smallest file size possible, which often entails removing newlines +should they not be strictly necessary). These kinds of files are typically +not intended to be edited, so not providing the usual editing mode in these +cases will rarely be an issue. + +This major mode disables any active minor modes listed in `so-long-minor-modes' +for the current buffer, and buffer-local values are assigned to variables in +accordance with `so-long-variable-overrides'. + +To restore the original major mode (along with the minor modes and variable +values), despite potential performance issues, type \\[so-long-revert]. + +Use \\[so-long-commentary] for more information. + +Use \\[so-long-customize] to configure the behaviour." + ;; Housekeeping. `so-long-mode' might be invoked directly rather than via + ;; `so-long', so replicate the necessary behaviours. We could use this same + ;; test in `so-long-after-change-major-mode' to run `so-long-hook', but that's + ;; not so obviously the right thing to do, so I've omitted it for now. + (unless so-long--calling + (so-long--ensure-enabled) + (setq so-long--active t + so-long-detected-p t + so-long-function 'so-long-mode + so-long-revert-function 'so-long-mode-revert)) + ;; Use `after-change-major-mode-hook' to disable minor modes and override + ;; variables. Append, to act after any globalized modes have acted. + (add-hook 'after-change-major-mode-hook + 'so-long-after-change-major-mode :append :local) + ;; Override variables. This is the first of two instances where we do this + ;; (the other being `so-long-after-change-major-mode'). It is desirable to + ;; set variables here in order to cover cases where the setting of a variable + ;; influences how a global minor mode behaves in this buffer. + (so-long-override-variables) + ;; Hide redundant mode-line information (our major mode info replicates this). + (setq so-long-mode-line-info nil) + ;; Inform the user about our major mode hijacking. + (unless (or so-long--inhibited so-long--set-auto-mode) + (message (concat "Changed to %s (from %s)" + (unless (or (eq this-command 'so-long) + (and (symbolp this-command) + (provided-mode-derived-p this-command + 'so-long-mode))) + " on account of line length") + ". %s to revert.") + major-mode + (or (so-long-original 'major-mode) "<unknown>") + (substitute-command-keys "\\[so-long-revert]")))) + +(defun so-long--change-major-mode () + ;; Advice, enabled with: + ;; (advice-add 'so-long-mode :before #'so-long--change-major-mode) + ;; + ;; n.b. `major-mode-suspend' and `major-mode-restore' are new in Emacs 27, and + ;; related to what we're doing here; but it's not worth going to the effort of + ;; using those (conditionally, only for 27+) when we have our own framework + ;; for remembering and restoring this buffer state (amongst other things). + "Ensure that `so-long-mode' knows the original `major-mode'. + +This advice acts before `so-long-mode', with the previous mode still active." + (unless (derived-mode-p 'so-long-mode) + ;; Housekeeping. `so-long-mode' might be invoked directly rather than + ;; via `so-long', so replicate the necessary behaviours. + (unless so-long--calling + (so-long-remember-all :reset)) + ;; Remember the original major mode, regardless. + (so-long-remember 'major-mode))) + +(advice-add 'so-long-mode :before #'so-long--change-major-mode) + +(defun so-long-after-change-major-mode () + "Run by `so-long-mode' in `after-change-major-mode-hook'. + +Calls `so-long-disable-minor-modes' and `so-long-override-variables'." + ;; Disable minor modes. + (so-long-disable-minor-modes) + ;; Override variables (again). We already did this in `so-long-mode' in + ;; order that variables which affect global/globalized minor modes can have + ;; that effect; however it's feasible that one of the minor modes disabled + ;; above might have reverted one of these variables, so we re-enforce them. + ;; (For example, disabling `visual-line-mode' sets `line-move-visual' to + ;; nil, when for our purposes it is preferable for it to be non-nil). + (so-long-override-variables)) + +(defun so-long-disable-minor-modes () + "Disable any active minor modes listed in `so-long-minor-modes'." + (dolist (mode so-long-minor-modes) + (when (and (boundp mode) mode) + (funcall mode 0)))) + +(defun so-long-restore-minor-modes () + "Restore the minor modes which were disabled. + +The modes are enabled in accordance with what was remembered in `so-long'." + (dolist (mode so-long-minor-modes) + (when (and (so-long-original mode) + (boundp mode) + (not (symbol-value mode))) + (funcall mode 1)))) + +(defun so-long-override-variables () + "Set the buffer-local values defined by `so-long-variable-overrides'." + (dolist (ovar so-long-variable-overrides) + (set (make-local-variable (car ovar)) (cdr ovar)))) + +(defun so-long-restore-variables () + "Restore the remembered values for the overridden variables. + +The variables are set in accordance with what was remembered in `so-long'." + (dolist (ovar so-long-variable-overrides) + (so-long-restore-variable (car ovar)))) + +(defun so-long-restore-variable (variable) + "Restore the remembered value (if any) for VARIABLE." + ;; In the instance where `so-long-mode-revert' has just reverted the major + ;; mode, note that `kill-all-local-variables' was already called by the + ;; original mode function, and so these 'overridden' variables may now have + ;; global rather than buffer-local values. + (let* ((remembered (so-long-original variable :exists)) + (originally-local (nth 2 remembered))) + (if originally-local + ;; The variable originally existed with a buffer-local value, so we + ;; restore it as such (even if the global value is a match). + (set (make-local-variable variable) (cadr remembered)) + ;; Either this variable did not exist initially, or it did not have a + ;; buffer-local value at that time. In either case we kill the current + ;; buffer-local value (if any) in order to restore the original state. + ;; + ;; It's possible that the global value has *changed* in the interim; but + ;; we can't know whether it's best to use the new global value, or retain + ;; the old value as a buffer-local value, so we keep it simple. + (kill-local-variable variable)))) + +(defun so-long-mode-revert () + "Call the `major-mode' which was selected before `so-long-mode' replaced it. + +Re-process local variables, and restore overridden variables and minor modes. + +This is the `so-long-revert-function' for `so-long-mode'." + (interactive) + (let ((so-long-original-mode (so-long-original 'major-mode))) + (unless so-long-original-mode + (error "Original mode unknown.")) + (funcall so-long-original-mode) + ;; Emacs 26+ has already called `hack-local-variables' (during + ;; `run-mode-hooks'; provided there was a `buffer-file-name'), but for older + ;; versions we need to call it here. In Emacs 26+ the revised 'HANDLE-MODE' + ;; argument is set to `no-mode' (being the non-nil-and-non-t behaviour), + ;; which we mimic here by binding `so-long--hack-local-variables-no-mode', + ;; in order to prevent a local 'mode' variable from clobbering the major + ;; mode we have just called. + (when (< emacs-major-version 26) + (let ((so-long--hack-local-variables-no-mode t)) + (hack-local-variables))) + ;; Restore minor modes. + (so-long-restore-minor-modes) + ;; Restore overridden variables. + ;; `kill-all-local-variables' was already called by the original mode + ;; function, so we may be seeing global values. + (so-long-restore-variables) + ;; Restore the mode line construct. + (unless (derived-mode-p 'so-long-mode) + (setq so-long-mode-line-info (so-long-mode-line-info))))) + +(defun so-long-mode-downgrade (&optional mode) + "The default value for `so-long-file-local-mode-function'. + +A buffer-local 'downgrade' from `so-long-mode' to `so-long-minor-mode'. + +When `so-long-function' is set to `so-long-mode', then we change it to to +`turn-on-so-long-minor-mode' instead -- retaining the file-local major +mode, but still doing everything else that `so-long-mode' would have done. +`so-long-revert-function' is likewise updated. + +If `so-long-function' has any value other than `so-long-mode', we do nothing, +as if `so-long-file-local-mode-function' was nil. + +We also do nothing if MODE (the file-local mode) has the value `so-long-mode', +because we do not want to downgrade the major mode in that scenario." + ;; Do nothing if the file-local mode was `so-long-mode'. + (unless (provided-mode-derived-p mode 'so-long-mode) + ;; Act only if `so-long-mode' would be enabled by the current action. + (when (and (symbolp (so-long-function)) + (provided-mode-derived-p (so-long-function) 'so-long-mode)) + ;; Downgrade from `so-long-mode' to the `so-long-minor-mode' behaviour. + (setq so-long-function 'turn-on-so-long-minor-mode + so-long-revert-function 'turn-off-so-long-minor-mode)))) + +(defun so-long-inhibit (&optional _mode) + "Prevent so-long from having any effect at all. + +This is a `so-long-file-local-mode-function' option." + (setq so-long--inhibited t)) + +(defun so-long--check-header-modes () + ;; See also "Files with a file-local 'mode'" in the Commentary. + "Handles the header-comments processing in `set-auto-mode'. + +`set-auto-mode' has some special-case code to handle the 'mode' pseudo-variable +when set in the header comment. This runs outside of `hack-local-variables' +and cannot be conveniently intercepted, so we are forced to replicate it here. + +This special-case code will ultimately be removed from Emacs, as it exists to +deal with a deprecated feature; but until then we need to replicate it in order +to inhibit our own behaviour in the presence of a header comment 'mode' +declaration. + +If a file-local mode is detected in the header comment, then we call the +function defined by `so-long-file-local-mode-function'." + ;; The following code for processing MODE declarations in the header + ;; comments is copied verbatim from `set-auto-mode', because we have + ;; no way of intercepting it. + ;; + (let ((try-locals (not (inhibit-local-variables-p))) + end _done _mode modes) + ;; Once we drop the deprecated feature where mode: is also allowed to + ;; specify minor-modes (ie, there can be more than one "mode:"), we can + ;; remove this section and just let (hack-local-variables t) handle it. + ;; Find a -*- mode tag. + (save-excursion + (goto-char (point-min)) + (skip-chars-forward " \t\n") + ;; Note by design local-enable-local-variables does not matter here. + (and enable-local-variables + try-locals + (setq end (set-auto-mode-1)) + (if (save-excursion (search-forward ":" end t)) + ;; Find all specifications for the `mode:' variable + ;; and execute them left to right. + (while (let ((case-fold-search t)) + (or (and (looking-at "mode:") + (goto-char (match-end 0))) + (re-search-forward "[ \t;]mode:" end t))) + (skip-chars-forward " \t") + (let ((beg (point))) + (if (search-forward ";" end t) + (forward-char -1) + (goto-char end)) + (skip-chars-backward " \t") + (push (intern (concat (downcase (buffer-substring + beg (point))) + "-mode")) + modes))) + ;; Simple -*-MODE-*- case. + (push (intern (concat (downcase (buffer-substring (point) end)) + "-mode")) + modes)))) + + ;; `so-long' now processes the resulting mode list. If any modes were + ;; listed, we assume that one of them is a major mode. It's possible that + ;; this isn't true, but the buffer would remain in fundamental-mode if that + ;; were the case, so it is very unlikely. For the purposes of passing a + ;; value to `so-long-handle-file-local-mode' we assume the major mode was + ;; the first mode specified (in which case it is the last in the list). + (when modes + (so-long-handle-file-local-mode (car (last modes)))))) + +;; Lisp advice, Lisp advice +;; Every calling you greet me +;; Code of mine, redefined +;; You look happy to tweak me + +(defun so-long--hack-local-variables (orig-fun &optional handle-mode &rest args) + ;; Advice, enabled with: + ;; (advice-add 'hack-local-variables :around #'so-long--hack-local-variables) + ;; + ;; See also "Files with a file-local 'mode'" in the Commentary. + "Ensure that `so-long' defers to file-local mode declarations if necessary. + +If a file-local mode is detected, then we call the function defined by +`so-long-file-local-mode-function'. + +This advice acts after the HANDLE-MODE:t call to `hack-local-variables'. +\(MODE-ONLY in Emacs versions < 26). + +File-local header comments are currently an exception, and are processed by +`so-long--check-header-modes' (see which for details)." + ;; The first arg to `hack-local-variables' is HANDLE-MODE since Emacs 26.1, + ;; and MODE-ONLY in earlier versions. In either case we are interested in + ;; whether it has the value `t'. + (let ((retval (apply orig-fun handle-mode args))) + (and (eq handle-mode t) + retval ; A file-local mode was set. + (so-long-handle-file-local-mode retval)) + retval)) + +(defun so-long--set-auto-mode (orig-fun &rest args) + ;; Advice, enabled with: + ;; (advice-add 'set-auto-mode :around #'so-long--set-auto-mode) + "Maybe call `so-long' for files with very long lines. + +This advice acts after `set-auto-mode' has set the buffer's major mode. + +We can't act before this point, because some major modes must be exempt +\(binary file modes, for example). Instead, we act only when the selected +major mode is a member (or derivative of a member) of `so-long-target-modes'. + +`so-long-predicate' then determines whether the mode change is needed." + (setq so-long--inhibited nil) ; is permanent-local + (when so-long-enabled + (so-long--check-header-modes)) ; may cause `so-long--inhibited' to be set. + (let ((so-long--set-auto-mode t)) + ;; Call `set-auto-mode'. + (apply orig-fun args)) ; may cause `so-long--inhibited' to be set. + ;; Test the new major mode for long lines. + (and so-long-enabled + (not so-long--inhibited) + (not so-long--calling) + (or (eq so-long-target-modes t) + (apply #'derived-mode-p so-long-target-modes)) + (setq so-long-detected-p (funcall so-long-predicate)) + (so-long))) + +(defun so-long--hack-one-local-variable (orig-fun var val) + ;; Advice, enabled with: + ;; (advice-add 'hack-one-local-variable :around + ;; #'so-long--hack-one-local-variable) + "Prevent the original major mode being restored after `so-long-mode'. + +This advice is needed and enabled only for Emacs versions < 26.1. + +If the local 'mode' pseudo-variable is used, `set-auto-mode-0' will call it +firstly, and subsequently `hack-one-local-variable' may call it again. + +Usually `hack-one-local-variable' tries to avoid processing that second call, +by testing the value against `major-mode'; but as we may have changed the +major mode to `so-long-mode' by this point, that protection is insufficient +and so we need to perform our own test. + +We likewise need to support an equivalent of the `no-mode' behaviour in 26.1+ +to ensure that `so-long-mode-revert' will not restore a file-local mode again +after it has already reverted to the original mode. + +The changes to `normal-mode' in Emacs 26.1 modified the execution order, and +makes this advice unnecessary. The relevant NEWS entry is: + +** File local and directory local variables are now initialized each +time the major mode is set, not just when the file is first visited. +These local variables will thus not vanish on setting a major mode." + (if (eq var 'mode) + ;; Adapted directly from `hack-one-local-variable' + (let ((mode (intern (concat (downcase (symbol-name val)) + "-mode")))) + (unless (or so-long--hack-local-variables-no-mode + (let ((origmode (so-long-original 'major-mode))) + ;; We bind origmode because (indirect-function nil) is an + ;; error in Emacs versions < 25.1, and so we need to test + ;; it first. + (and origmode + (eq (indirect-function mode) + (indirect-function origmode))))) + (funcall orig-fun var val))) + ;; VAR is not the 'mode' pseudo-variable. + (funcall orig-fun var val))) + +;;;###autoload +(defun so-long (&optional action) + "Invoke `so-long-action' and run `so-long-hook'. + +This command is called automatically when long lines are detected, when +`global-so-long-mode' is enabled. + +The effects of the action can be undone by calling `so-long-revert'. + +If ACTION is provided, it is used instead of `so-long-action'. With a prefix +argument, select the action to use interactively." + (interactive + (list (and current-prefix-arg + (intern + (completing-read "Action (none): " + (mapcar #'car so-long-action-alist) + nil :require-match))))) + (unless so-long--calling + (let ((so-long--calling t)) + (so-long--ensure-enabled) + ;; ACTION takes precedence if supplied. + (when action + (setq so-long-function nil + so-long-revert-function nil)) + ;; Some of these settings need to be duplicated in `so-long-mode' to cover + ;; the case when that mode is invoked directly. + (setq so-long-detected-p t) ;; ensure menu is present. + (unless so-long-function + (setq so-long-function (so-long-function action))) + (unless so-long-revert-function + (setq so-long-revert-function (so-long-revert-function action))) + ;; Remember original settings. + (so-long-remember-all :reset) + ;; Call the configured `so-long-function'. + (when so-long-function + (funcall so-long-function) + ;; Set `so-long--active' last, as it isn't permanent-local. + (setq so-long--active t)) + ;; Display mode line info, unless we are in `so-long-mode' (which provides + ;; equivalent information in the mode line construct for the major mode). + (unless (derived-mode-p 'so-long-mode) + (setq so-long-mode-line-info (so-long-mode-line-info))) + ;; Run `so-long-hook'. + ;; By default we set `buffer-read-only', which can cause problems if hook + ;; functions need to modify the buffer. We use `inhibit-read-only' to + ;; side-step the issue (and likewise in `so-long-revert'). + (let ((inhibit-read-only t)) + (run-hooks 'so-long-hook))))) + +(defun so-long-revert () + "Revert the active `so-long-action' and run `so-long-revert-hook'. + +This undoes the effects of the `so-long' command (which is normally called +automatically by `global-so-long-mode'). + +For the default action, reverting will restore the original major mode, and +restore the minor modes and settings which were overridden when `so-long' was +invoked." + (interactive) + (unless so-long--calling + (let ((so-long--calling t)) + (when so-long-revert-function + (funcall so-long-revert-function) + (setq so-long--active nil)) + (let ((inhibit-read-only t)) + (run-hooks 'so-long-revert-hook))))) + +;; Duplicate the `so-long-revert' documentation for the menu item. +(put 'so-long-menu-item-revert 'function-documentation + (documentation 'so-long-revert t)) + +;;;###autoload +(defun so-long-enable () + "Enable the so-long library's functionality. + +Equivalent to calling (global-so-long-mode 1)" + (interactive) + (global-so-long-mode 1)) + +(defun so-long-disable () + "Disable the so-long library's functionality. + +Equivalent to calling (global-so-long-mode 0)" + (interactive) + (global-so-long-mode 0)) + +(make-obsolete 'so-long-enable 'global-so-long-mode "so-long 1.0") +(make-obsolete 'so-long-disable 'global-so-long-mode "so-long 1.0") + +;;;###autoload +(define-minor-mode global-so-long-mode + "Toggle automated performance mitigations for files with long lines. + +Many Emacs modes struggle with buffers which contain excessively long lines, +and may consequently cause unacceptable performance issues. + +This is commonly on account of 'minified' code (i.e. code that has been +compacted into the smallest file size possible, which often entails removing +newlines should they not be strictly necessary). + +When such files are detected by `so-long-predicate', we invoke the selected +`so-long-action' to mitigate potential performance problems in the buffer. + +Use \\[so-long-commentary] for more information. + +Use \\[so-long-customize] to configure the behaviour." + :global t + :group 'so-long + (if global-so-long-mode + ;; Enable + (progn + (so-long--enable) + (advice-add 'hack-local-variables :around + #'so-long--hack-local-variables) + (advice-add 'set-auto-mode :around + #'so-long--set-auto-mode) + (when (< emacs-major-version 26) + (advice-add 'hack-one-local-variable :around + #'so-long--hack-one-local-variable))) + ;; Disable + (so-long--disable) + (advice-remove 'hack-local-variables #'so-long--hack-local-variables) + (advice-remove 'set-auto-mode #'so-long--set-auto-mode) + (when (< emacs-major-version 26) + (advice-remove 'hack-one-local-variable + #'so-long--hack-one-local-variable)))) + +(put 'global-so-long-mode 'variable-documentation + "Non-nil if the so-long library's automated functionality is enabled. + +Use \\[so-long-commentary] for more information. + +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `global-so-long-mode'.") + +(defun so-long--ensure-enabled () + "Enable essential functionality, if not already enabled." + (unless so-long-enabled + (so-long--enable))) + +(defun so-long--enable () + "Enable functionality other than `global-so-long-mode'." + (add-to-list 'mode-line-misc-info '("" so-long-mode-line-info)) + (define-key-after (current-global-map) [menu-bar so-long] + `(menu-item "So Long" nil + ;; See also `so-long-mode-map'. + :visible (or so-long--active + so-long-detected-p + (derived-mode-p 'so-long-mode)) + :filter ,(lambda (_cmd) (so-long-menu)))) + (setq so-long-enabled t)) + +(defun so-long--disable () + "Disable functionality other than `global-so-long-mode'." + (setq mode-line-misc-info + (delete '("" so-long-mode-line-info) mode-line-misc-info)) + (define-key (current-global-map) [menu-bar so-long] nil) + (setq so-long-enabled nil)) + +(defun so-long-unload-function () + "Handler for `unload-feature'." + (global-so-long-mode 0) + nil) + +(provide 'so-long) + +;; Local Variables: +;; emacs-lisp-docstring-fill-column: 80 +;; fill-column: 80 +;; indent-tabs-mode: nil +;; End: + +;; So long, farewell, auf wiedersehen, goodbye +;; You have to go, this code is minified +;; Goodbye! + +;;; so-long.el ends here diff --git a/lisp/speedbar.el b/lisp/speedbar.el index c43db0f678f..451c57fe066 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -341,7 +341,7 @@ attached to and added to this list before the new frame is initialized." (symbol :tag "Parameter") (sexp :tag "Value")))) -;; These values by Hrvoje Niksic <hniksic@srce.hr> +;; These values by Hrvoje Nikšić <hrvoje.niksic@avl.com> (defcustom speedbar-frame-plist '(minibuffer nil width 20 border-width 0 internal-border-width 0 unsplittable t @@ -637,9 +637,6 @@ Created from `speedbar-ignored-directory-expressions' with the function Use the function `speedbar-add-ignored-directory-regexp', or customize the variable `speedbar-ignored-directory-expressions' to modify this variable.") -(define-obsolete-variable-alias 'speedbar-ignored-path-expressions - 'speedbar-ignored-directory-expressions "22.1") - (defcustom speedbar-ignored-directory-expressions '("[/\\]logs?[/\\]\\'") "List of regular expressions matching directories speedbar will ignore. @@ -650,9 +647,9 @@ speedbar is loaded. You may place anything you like in this list before speedbar has been loaded." :group 'speedbar :type '(repeat (regexp :tag "Directory Regexp")) - :set (lambda (_sym val) - (setq speedbar-ignored-directory-expressions val - speedbar-ignored-directory-regexp + :set (lambda (sym val) + (set sym val) + (setq speedbar-ignored-directory-regexp (speedbar-extension-list-to-regex val)))) (defcustom speedbar-directory-unshown-regexp "^\\(\\..*\\)\\'" @@ -704,9 +701,9 @@ need to also modify `completion-ignored-extension' which will also help file completion." :group 'speedbar :type '(repeat (regexp :tag "Extension Regexp")) - :set (lambda (_sym val) - (set 'speedbar-supported-extension-expressions val) - (set 'speedbar-file-regexp (speedbar-extension-list-to-regex val)))) + :set (lambda (sym val) + (set sym val) + (setq speedbar-file-regexp (speedbar-extension-list-to-regex val)))) (setq speedbar-file-regexp (speedbar-extension-list-to-regex speedbar-supported-extension-expressions)) @@ -744,13 +741,6 @@ DIRECTORY-EXPRESSION to `speedbar-ignored-directory-expressions'." (setq speedbar-ignored-directory-regexp (speedbar-extension-list-to-regex speedbar-ignored-directory-expressions))) -;; If we don't have custom, then we set it here by hand. -(if (not (fboundp 'custom-declare-variable)) - (setq speedbar-file-regexp (speedbar-extension-list-to-regex - speedbar-supported-extension-expressions) - speedbar-ignored-directory-regexp (speedbar-extension-list-to-regex - speedbar-ignored-directory-expressions))) - (defcustom speedbar-update-flag dframe-have-timer-flag "Non-nil means to automatically update the display. When this is nil then speedbar will not follow the attached frame's directory. @@ -982,9 +972,8 @@ supported at a time. (interactive "P") ;; Get the buffer to play with (if (not (buffer-live-p speedbar-buffer)) - (save-excursion - (setq speedbar-buffer (get-buffer-create " SPEEDBAR")) - (set-buffer speedbar-buffer) + (with-current-buffer + (setq speedbar-buffer (get-buffer-create " SPEEDBAR")) (speedbar-mode))) ;; Do the frame thing (dframe-frame-mode arg @@ -1476,66 +1465,69 @@ Return nil if not applicable. If FILENAME, then use that instead of reading it from the speedbar buffer." (let* ((item (or filename (speedbar-line-file))) (attr (if item (file-attributes item) nil))) - (if (and item attr) (dframe-message "%s %-6d %s" (nth 8 attr) - (nth 7 attr) item) - nil))) + (if (and item attr) + (dframe-message "%s %-6d %s" + (file-attribute-modes attr) + (file-attribute-size attr) item)))) (defun speedbar-item-info-tag-helper () "Display info about a tag that is on the current line. Return nil if not applicable." (save-excursion (beginning-of-line) - (if (re-search-forward " [-+=]?> \\([^\n]+\\)" (line-end-position) t) - (let* ((tag (match-string 1)) - (attr (speedbar-line-token)) - (item nil) - (semantic-tagged (if (fboundp 'semantic-tag-p) - (semantic-tag-p attr)))) - (if semantic-tagged - (with-no-warnings - (save-excursion - (when (and (semantic-tag-overlay attr) - (semantic-tag-buffer attr)) - (set-buffer (semantic-tag-buffer attr))) - (dframe-message - (funcall semantic-sb-info-format-tag-function attr) - ))) - (looking-at "\\([0-9]+\\):") - (setq item (file-name-nondirectory (speedbar-line-directory))) - (dframe-message "Tag: %s in %s" tag item))) - (if (re-search-forward "{[+-]} \\([^\n]+\\)$" (line-end-position) t) - (dframe-message "Group of tags \"%s\"" (match-string 1)) - (if (re-search-forward " [+-]?[()|@] \\([^\n]+\\)$" nil t) - (let* ((detailtext (match-string 1)) - (detail (or (speedbar-line-token) detailtext)) - (parent (save-excursion - (beginning-of-line) - (let ((dep (if (looking-at "[0-9]+:") - (1- (string-to-number (match-string 0))) - 0))) - (re-search-backward (concat "^" - (int-to-string dep) - ":") - nil t)) - (if (looking-at "[0-9]+: +[-+=>]> \\([^\n]+\\)$") - (speedbar-line-token) - nil)))) - (if (featurep 'semantic) - (with-no-warnings - (if (semantic-tag-p detail) - (dframe-message - (funcall semantic-sb-info-format-tag-function detail parent)) - (if parent - (dframe-message "Detail: %s of tag %s" detail - (if (semantic-tag-p parent) - (semantic-format-tag-name parent nil t) - parent)) - (dframe-message "Detail: %s" detail)))) - ;; Not using `semantic': - (if parent - (dframe-message "Detail: %s of tag %s" detail parent) - (dframe-message "Detail: %s" detail)))) - nil))))) + (cond + ((re-search-forward " [-+=]?> \\([^\n]+\\)" (line-end-position) t) + (let* ((tag (match-string 1)) + (attr (speedbar-line-token)) + (item nil) + (semantic-tagged (if (fboundp 'semantic-tag-p) + (semantic-tag-p attr)))) + (if semantic-tagged + (with-no-warnings + (save-excursion + (when (and (semantic-tag-overlay attr) + (semantic-tag-buffer attr)) + (set-buffer (semantic-tag-buffer attr))) + (dframe-message + (funcall semantic-sb-info-format-tag-function attr) + ))) + (looking-at "\\([0-9]+\\):") + (setq item (file-name-nondirectory (speedbar-line-directory))) + (dframe-message "Tag: %s in %s" tag item)))) + ((re-search-forward "{[+-]} \\([^\n]+\\)$" (line-end-position) t) + (dframe-message "Group of tags \"%s\"" (match-string 1))) + ((re-search-forward " [+-]?[()|@] \\([^\n]+\\)$" nil t) + (let* ((detailtext (match-string 1)) + (detail (or (speedbar-line-token) detailtext)) + (parent (save-excursion + (beginning-of-line) + (let ((dep (if (looking-at "[0-9]+:") + (1- (string-to-number (match-string 0))) + 0))) + (re-search-backward (concat "^" + (int-to-string dep) + ":") + nil t)) + (if (looking-at "[0-9]+: +[-+=>]> \\([^\n]+\\)$") + (speedbar-line-token) + nil)))) + (cond + ((featurep 'semantic) + (with-no-warnings + (if (semantic-tag-p detail) + (dframe-message + (funcall semantic-sb-info-format-tag-function detail parent)) + (if parent + (dframe-message "Detail: %s of tag %s" detail + (if (semantic-tag-p parent) + (semantic-format-tag-name parent nil t) + parent)) + (dframe-message "Detail: %s" detail))))) + ;; Not using `semantic': + (parent + (dframe-message "Detail: %s of tag %s" detail parent)) + (t + (dframe-message "Detail: %s" detail)))))))) (defun speedbar-files-item-info () "Display info in the minibuffer about the button the mouse is over." @@ -2857,7 +2849,7 @@ indicator, then do not add a space." (progn (goto-char speedbar-ro-to-do-point) (while (and (not (input-pending-p)) - (re-search-forward "^\\([0-9]+\\):\\s-*[[<][+-?][]>] " + (re-search-forward "^\\([0-9]+\\):\\s-*[[<][+?-][]>] " nil t)) (setq speedbar-ro-to-do-point (point)) (let ((f (speedbar-line-file))) @@ -2908,7 +2900,7 @@ to add more types of version control systems." (progn (goto-char speedbar-vc-to-do-point) (while (and (not (input-pending-p)) - (re-search-forward "^\\([0-9]+\\):\\s-*\\[[+-?]\\] " + (re-search-forward "^\\([0-9]+\\):\\s-*\\[[+?-]\\] " nil t)) (setq speedbar-vc-to-do-point (point)) (if (speedbar-check-vc-this-line (match-string 1)) @@ -3018,13 +3010,13 @@ the file being checked." (cdr (car oa)))))) nil ;; Find out if the object is out of date or not. - (let ((date1 (nth 5 (file-attributes fulln))) - (date2 (nth 5 (file-attributes (concat - (file-name-sans-extension fulln) - (cdr (car oa))))))) - (if (or (< (car date1) (car date2)) - (and (= (car date1) (car date2)) - (< (nth 1 date1) (nth 1 date2)))) + (let ((date1 (file-attribute-modification-time + (file-attributes fulln))) + (date2 (file-attribute-modification-time + (file-attributes (concat + (file-name-sans-extension fulln) + (cdr (car oa))))))) + (if (time-less-p date1 date2) (car speedbar-obj-indicator) (cdr speedbar-obj-indicator))))))) @@ -3362,7 +3354,7 @@ Handles end-of-sublist smartly." Clicking this button expands or contracts a directory. TEXT is the button clicked which has either a + or -. TOKEN is the directory to be expanded. INDENT is the current indentation level." - (cond ((string-match "+" text) ;we have to expand this dir + (cond ((string-match "\\+" text) ;we have to expand this dir (setq speedbar-shown-directories (cons (expand-file-name (concat (speedbar-line-directory indent) token "/")) @@ -3397,9 +3389,7 @@ expanded. INDENT is the current indentation level." "Speedbar click handler for default directory buttons. TEXT is the button clicked on. TOKEN is the directory to follow. INDENT is the current indentation level and is unused." - (if (string-match "^[A-z]:$" token) - (setq default-directory (concat token "/")) - (setq default-directory token)) + (setq default-directory (file-name-as-directory token)) ;; Because we leave speedbar as the current buffer, ;; update contents will change directory without ;; having to touch the attached frame. @@ -3411,7 +3401,7 @@ INDENT is the current indentation level and is unused." The parameter TEXT and TOKEN are required, where TEXT is the button clicked, and TOKEN is the file to expand. INDENT is the current indentation level." - (cond ((string-match "+" text) ;we have to expand this file + (cond ((string-match "\\+" text) ;we have to expand this file (let* ((fn (expand-file-name (concat (speedbar-line-directory indent) token))) (lst (speedbar-fetch-dynamic-tags fn))) @@ -3452,7 +3442,7 @@ INDENT is the current indentation level." "Expand a tag sublist. Imenu will return sub-lists of specialized tag types. Etags does not support this feature. TEXT will be the button string. TOKEN will be the list, and INDENT is the current indentation level." - (cond ((string-match "+" text) ;we have to expand this file + (cond ((string-match "\\+" text) ;we have to expand this file (speedbar-change-expand-button-char ?-) (speedbar-with-writable (save-excursion @@ -3973,7 +3963,7 @@ TEXT is the buffer's name, TOKEN and INDENT are unused." (speedbar-unhighlight-one-tag-line) (setq speedbar-highlight-one-tag-line (speedbar-make-overlay (line-beginning-position) - (1+ (line-end-position)))) + (line-beginning-position 2))) (speedbar-overlay-put speedbar-highlight-one-tag-line 'face 'speedbar-highlight-face) (add-hook 'pre-command-hook 'speedbar-unhighlight-one-tag-line)) @@ -4077,26 +4067,6 @@ TEXT is the buffer's name, TOKEN and INDENT are unused." (setq font-lock-global-modes (delq 'speedbar-mode font-lock-global-modes))))) -;;; Obsolete variables and functions - -(define-obsolete-variable-alias - 'speedbar-ignored-path-regexp 'speedbar-ignored-directory-regexp "22.1") - -(define-obsolete-function-alias 'speedbar-add-ignored-path-regexp - 'speedbar-add-ignored-directory-regexp "22.1") - -(define-obsolete-function-alias 'speedbar-line-path - 'speedbar-line-directory "22.1") - -(define-obsolete-function-alias 'speedbar-buffers-line-path - 'speedbar-buffers-line-directory "22.1") - -(define-obsolete-function-alias 'speedbar-path-line - 'speedbar-directory-line "22.1") - -(define-obsolete-function-alias 'speedbar-buffers-line-path - 'speedbar-buffers-line-directory "22.1") - (provide 'speedbar) ;; run load-time hooks diff --git a/lisp/startup.el b/lisp/startup.el index 32051c232ca..564428580b1 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -1,4 +1,4 @@ -;;; startup.el --- process Emacs shell arguments -*- lexical-binding: t -*- +;; startup.el --- process Emacs shell arguments -*- lexical-binding: t -*- ;; Copyright (C) 1985-1986, 1992, 1994-2019 Free Software Foundation, ;; Inc. @@ -60,19 +60,17 @@ string or function value that this variable has." (const :tag "Remember Mode notes buffer" remember-notes) (function :tag "Function") (const :tag "Lisp scratch buffer" t)) - :version "23.1" - :group 'initialization) + :version "23.1") + +(defvaralias 'inhibit-splash-screen 'inhibit-startup-screen) +(defvaralias 'inhibit-startup-message 'inhibit-startup-screen) (defcustom inhibit-startup-screen nil "Non-nil inhibits the startup screen. This is for use in your personal init file (but NOT site-start.el), once you are familiar with the contents of the startup screen." - :type 'boolean - :group 'initialization) - -(defvaralias 'inhibit-splash-screen 'inhibit-startup-screen) -(defvaralias 'inhibit-startup-message 'inhibit-startup-screen) + :type 'boolean) (defvar startup-screen-inhibit-startup-screen nil) @@ -101,18 +99,15 @@ instead: Thus, someone else using a copy of your init file will see the startup message unless he personally acts to inhibit it." :type '(choice (const :tag "Don't inhibit") - (string :tag "Enter your user name, to inhibit")) - :group 'initialization) + (string :tag "Enter your user name, to inhibit"))) (defcustom inhibit-default-init nil "Non-nil inhibits loading the `default' library." - :type 'boolean - :group 'initialization) + :type 'boolean) (defcustom inhibit-startup-buffer-menu nil "Non-nil inhibits display of buffer list when more than 2 files are loaded." - :type 'boolean - :group 'initialization) + :type 'boolean) (defvar command-switch-alist nil "Alist of command-line switches. @@ -120,18 +115,20 @@ Elements look like (SWITCH-STRING . HANDLER-FUNCTION). HANDLER-FUNCTION receives the switch string as its sole argument; the remaining command-line args are in the variable `command-line-args-left'.") -(defvar command-line-args-left nil - "List of command-line args not yet processed.") - -(defvaralias 'argv 'command-line-args-left - "List of command-line args not yet processed. -This is a convenience alias, so that one can write \(pop argv) +(with-no-warnings + (defvaralias 'argv 'command-line-args-left + "List of command-line args not yet processed. +This is a convenience alias, so that one can write (pop argv) inside of --eval command line arguments in order to access -following arguments.") +following arguments.")) (internal-make-var-non-special 'argv) -(defvar argi nil - "Current command-line argument.") +(defvar command-line-args-left nil + "List of command-line args not yet processed.") + +(with-no-warnings + (defvar argi nil + "Current command-line argument.")) (internal-make-var-non-special 'argi) (defvar command-line-functions nil ;; lrs 7/31/89 @@ -312,6 +309,12 @@ see `tty-setup-hook'.") Currently this applies to: `emacs-startup-hook', `term-setup-hook', and `window-setup-hook'.") +(defvar early-init-file nil + "File name, including directory, of user's early init file. +See `user-init-file'. The only difference is that +`early-init-file' is not set during the course of evaluating the +early init file.") + (defvar keyboard-type nil "The brand of keyboard you are using. This variable is used to define the proper function and keypad @@ -328,8 +331,7 @@ is due to historical reasons, and does not reflect its purpose very well.)") (defcustom initial-major-mode 'lisp-interaction-mode "Major mode command symbol to use for the initial `*scratch*' buffer." - :type 'function - :group 'initialization) + :type 'function) (defvar init-file-user nil "Identity of user whose init file is or was read. @@ -352,8 +354,8 @@ Setting `init-file-user' does not prevent Emacs from loading "File containing site-wide run-time initializations. This file is loaded at run-time before `~/.emacs'. It contains inits that need to be in place for the entire site, but which, due to their -higher incidence of change, don't make sense to load into Emacs's -dumped image. Thus, the run-time load order is: 1. file described in +higher incidence of change, don't make sense to put into Emacs's +dump file. Thus, the run-time load order is: 1. file described in this variable, if non-nil; 2. `~/.emacs'; 3. `default.el'. Don't use the `site-start.el' file for things some users may not like. @@ -368,7 +370,6 @@ it visible in the relevant context. However, actually customizing it is not allowed, since it would not work anyway. The only way to set this variable usefully is to set it while building and dumping Emacs." :type '(choice (const :tag "none" nil) string) - :group 'initialization :initialize #'custom-initialize-default :set (lambda (_variable _value) (error "Customizing `site-run-file' does not work"))) @@ -789,7 +790,7 @@ to prepare for opening the first frame (e.g. open a connection to an X server)." argval (let ((case-fold-search t) i) - (setq argval (invocation-name)) + (setq argval (copy-sequence invocation-name)) ;; Change any . or * characters in name to ;; hyphens, so as to emulate behavior on X. @@ -878,6 +879,107 @@ If STYLE is nil, display appropriately for the terminal." (when standard-display-table (aset standard-display-table char nil))))))) +(defun startup--load-user-init-file + (filename-function &optional alternate-filename-function load-defaults) + "Load a user init-file. +FILENAME-FUNCTION is called with no arguments and should return +the name of the init-file to load. If this file cannot be +loaded, and ALTERNATE-FILENAME-FUNCTION is non-nil, then it is +called with no arguments and should return the name of an +alternate init-file to load. If LOAD-DEFAULTS is non-nil, then +load default.el after the init-file. + +This function sets `user-init-file' to the name of the loaded +init-file, or to a default value if loading is not possible." + (let ((debug-on-error-from-init-file nil) + (debug-on-error-should-be-set nil) + (debug-on-error-initial + (if (eq init-file-debug t) + 'startup + init-file-debug))) + (let ((debug-on-error debug-on-error-initial)) + (condition-case-unless-debug error + (when init-file-user + (let ((init-file-name (funcall filename-function))) + + ;; If `user-init-file' is t, then `load' will store + ;; the name of the file that it loads into + ;; `user-init-file'. + (setq user-init-file t) + (load (if (equal (file-name-extension init-file-name) + "el") + (file-name-sans-extension init-file-name) + init-file-name) + 'noerror 'nomessage) + + (when (and (eq user-init-file t) alternate-filename-function) + (let ((alt-file (funcall alternate-filename-function))) + (and (equal (file-name-extension alt-file) "el") + (setq alt-file (file-name-sans-extension alt-file))) + (load alt-file 'noerror 'nomessage))) + + ;; If we did not find the user's init file, set + ;; user-init-file conclusively. Don't let it be + ;; set from default.el. + (when (eq user-init-file t) + (setq user-init-file init-file-name))) + + ;; If we loaded a compiled file, set `user-init-file' to + ;; the source version if that exists. + (when (equal (file-name-extension user-init-file) + "elc") + (let* ((source (file-name-sans-extension user-init-file)) + (alt (concat source ".el"))) + (setq source (cond ((file-exists-p alt) alt) + ((file-exists-p source) source) + (t nil))) + (when source + (when (file-newer-than-file-p source user-init-file) + (message "Warning: %s is newer than %s" + source user-init-file) + (sit-for 1)) + (setq user-init-file source)))) + + (when load-defaults + + ;; Prevent default.el from changing the value of + ;; `inhibit-startup-screen'. + (let ((inhibit-startup-screen nil)) + (load "default" 'noerror 'nomessage)))) + (error + (display-warning + 'initialization + (format-message "\ +An error occurred while loading `%s':\n\n%s%s%s\n\n\ +To ensure normal operation, you should investigate and remove the +cause of the error in your initialization file. Start Emacs with +the `--debug-init' option to view a complete error backtrace." + user-init-file + (get (car error) 'error-message) + (if (cdr error) ": " "") + (mapconcat (lambda (s) (prin1-to-string s t)) + (cdr error) ", ")) + :warning) + (setq init-file-had-error t))) + + ;; If we can tell that the init file altered debug-on-error, + ;; arrange to preserve the value that it set up. + (or (eq debug-on-error debug-on-error-initial) + (setq debug-on-error-should-be-set t + debug-on-error-from-init-file debug-on-error))) + + (when debug-on-error-should-be-set + (setq debug-on-error debug-on-error-from-init-file)))) + +(defun find-init-path (fn) + "Look in ~/.config/FOO or ~/.FOO for the dotfile or dot directory FOO. +It is expected that the output will undergo ~ expansion. Implements the +XDG convention for dotfiles." + (let* ((xdg-path (concat "~" init-file-user "/.config/" fn)) + (oldstyle-path (concat "~" init-file-user "/." fn)) + (found-path (if (file-exists-p xdg-path) xdg-path oldstyle-path))) + found-path)) + (defun command-line () "A subroutine of `normal-top-level'. Amongst another things, it parses the command-line arguments." @@ -962,7 +1064,8 @@ please check its value") (let* ((longopts '(("--no-init-file") ("--no-site-file") ("--no-x-resources") ("--debug-init") ("--user") ("--iconic") ("--icon-type") ("--quick") - ("--no-blinking-cursor") ("--basic-display"))) + ("--no-blinking-cursor") ("--basic-display") + ("--dump-file") ("--temacs"))) (argi (pop args)) (orig-argi argi) argval) @@ -1014,6 +1117,9 @@ please check its value") (push '(visibility . icon) initial-frame-alist)) ((member argi '("-nbc" "-no-blinking-cursor")) (setq no-blinking-cursor t)) + ((member argi '("-dump-file" "-temacs")) ; Handled in C + (or argval (pop args)) + (setq argval nil)) ;; Push the popped arg back on the list of arguments. (t (push argi args) @@ -1029,6 +1135,82 @@ please check its value") (and command-line-args (setcdr command-line-args args))) + ;; Re-evaluate predefined variables whose initial value depends on + ;; the runtime context. + (let (current-load-list) ; c-r-s may call defvar, and hence LOADHIST_ATTACH + (setq custom-delayed-init-variables + ;; Initialize them in the same order they were loaded, in case there + ;; are dependencies between them. + (nreverse custom-delayed-init-variables)) + (mapc 'custom-reevaluate-setting custom-delayed-init-variables)) + + ;; Warn for invalid user name. + (when init-file-user + (if (string-match "[~/:\n]" init-file-user) + (display-warning 'initialization + (format "Invalid user name %s" + init-file-user) + :error) + (if (file-directory-p (expand-file-name + ;; We don't support ~USER on MS-Windows + ;; and MS-DOS except for the current + ;; user, and always load .emacs from + ;; the current user's home directory + ;; (see below). So always check "~", + ;; even if invoked with "-u USER", or + ;; if $USER or $LOGNAME are set to + ;; something different. + (if (memq system-type '(windows-nt ms-dos)) + "~" + (concat "~" init-file-user)))) + nil + (display-warning 'initialization + (format "User %s has no home directory" + (if (equal init-file-user "") + (user-real-login-name) + init-file-user)) + :error)))) + + ;; Load the early init file, if found. + (startup--load-user-init-file + (lambda () + (expand-file-name + ;; We use an explicit .el extension here to force + ;; startup--load-user-init-file to set user-init-file to "early-init.el", + ;; with the .el extension, if the file doesn't exist, not just + ;; "early-init" without an extension, as it does for ".emacs". + "early-init.el" + (file-name-as-directory + (find-init-path "emacs.d"))))) + (setq early-init-file user-init-file) + + ;; If any package directory exists, initialize the package system. + (and user-init-file + package-enable-at-startup + (catch 'package-dir-found + (let (dirs) + (if (boundp 'package-directory-list) + (setq dirs package-directory-list) + (dolist (f load-path) + (and (stringp f) + (equal (file-name-nondirectory f) "site-lisp") + (push (expand-file-name "elpa" f) dirs)))) + (push (if (boundp 'package-user-dir) + package-user-dir + (locate-user-emacs-file "elpa")) + dirs) + (dolist (dir dirs) + (when (file-directory-p dir) + (dolist (subdir (directory-files dir)) + (when (let ((subdir (expand-file-name subdir dir))) + (and (file-directory-p subdir) + (file-exists-p + (expand-file-name + (package--description-file subdir) + subdir)))) + (throw 'package-dir-found t))))))) + (package-activate-all)) + ;; Make sure window system's init file was loaded in loadup.el if ;; using a window system. ;; Initialize the window-system only after processing the command-line @@ -1096,14 +1278,12 @@ please check its value") (startup--setup-quote-display) (setq internal--text-quoting-flag t)) - ;; Re-evaluate predefined variables whose initial value depends on - ;; the runtime context. + ;; Re-evaluate again the predefined variables whose initial value + ;; depends on the runtime context, in case some of them depend on + ;; the window-system features. Example: blink-cursor-mode. (let (current-load-list) ; c-r-s may call defvar, and hence LOADHIST_ATTACH - (mapc 'custom-reevaluate-setting - ;; Initialize them in the same order they were loaded, in case there - ;; are dependencies between them. - (prog1 (nreverse custom-delayed-init-variables) - (setq custom-delayed-init-variables nil)))) + (mapc 'custom-reevaluate-setting custom-delayed-init-variables) + (setq custom-delayed-init-variables nil)) (normal-erase-is-backspace-setup-frame) @@ -1130,176 +1310,52 @@ please check its value") ;; should check init-file-user instead, since that is already set. ;; See cus-edit.el for an example. (if site-run-file - (load site-run-file t t)) - - ;; Sites should not disable this. Only individuals should disable - ;; the startup screen. - (setq inhibit-startup-screen nil) - - ;; Warn for invalid user name. - (when init-file-user - (if (string-match "[~/:\n]" init-file-user) - (display-warning 'initialization - (format "Invalid user name %s" - init-file-user) - :error) - (if (file-directory-p (expand-file-name - ;; We don't support ~USER on MS-Windows - ;; and MS-DOS except for the current - ;; user, and always load .emacs from - ;; the current user's home directory - ;; (see below). So always check "~", - ;; even if invoked with "-u USER", or - ;; if $USER or $LOGNAME are set to - ;; something different. - (if (memq system-type '(windows-nt ms-dos)) - "~" - (concat "~" init-file-user)))) - nil - (display-warning 'initialization - (format "User %s has no home directory" - (if (equal init-file-user "") - (user-real-login-name) - init-file-user)) - :error)))) + ;; Sites should not disable the startup screen. + ;; Only individuals should disable the startup screen. + (let ((inhibit-startup-screen inhibit-startup-screen)) + (load site-run-file t t))) ;; Load that user's init file, or the default one, or none. - (let (debug-on-error-from-init-file - debug-on-error-should-be-set - (debug-on-error-initial - (if (eq init-file-debug t) 'startup init-file-debug)) - (orig-enable-multibyte (default-value 'enable-multibyte-characters))) - (let ((debug-on-error debug-on-error-initial) - ;; This function actually reads the init files. - (inner - (function - (lambda () - (if init-file-user - (let ((user-init-file-1 - (cond - ((eq system-type 'ms-dos) - (concat "~" init-file-user "/_emacs")) - ((not (eq system-type 'windows-nt)) - (concat "~" init-file-user "/.emacs")) - ;; Else deal with the Windows situation - ((directory-files "~" nil "^\\.emacs\\(\\.elc?\\)?$") - ;; Prefer .emacs on Windows. - "~/.emacs") - ((directory-files "~" nil "^_emacs\\(\\.elc?\\)?$") - ;; Also support _emacs for compatibility, but warn about it. - (push `(initialization - ,(format-message - "`_emacs' init file is deprecated, please use `.emacs'")) - delayed-warnings-list) - "~/_emacs") - (t ;; But default to .emacs if _emacs does not exist. - "~/.emacs")))) - ;; This tells `load' to store the file name found - ;; into user-init-file. - (setq user-init-file t) - (load user-init-file-1 t t) - - (when (eq user-init-file t) - ;; If we did not find ~/.emacs, try - ;; ~/.emacs.d/init.el. - (let ((otherfile - (expand-file-name - "init" - (file-name-as-directory - (concat "~" init-file-user "/.emacs.d"))))) - (load otherfile t t) - - ;; If we did not find the user's init file, - ;; set user-init-file conclusively. - ;; Don't let it be set from default.el. - (when (eq user-init-file t) - (setq user-init-file user-init-file-1)))) - - ;; If we loaded a compiled file, set - ;; `user-init-file' to the source version if that - ;; exists. - (when (and user-init-file - (equal (file-name-extension user-init-file) - "elc")) - (let* ((source (file-name-sans-extension user-init-file)) - (alt (concat source ".el"))) - (setq source (cond ((file-exists-p alt) alt) - ((file-exists-p source) source) - (t nil))) - (when source - (when (file-newer-than-file-p source user-init-file) - (message "Warning: %s is newer than %s" - source user-init-file) - (sit-for 1)) - (setq user-init-file source)))) - - (unless inhibit-default-init - (let ((inhibit-startup-screen nil)) - ;; Users are supposed to be told their rights. - ;; (Plus how to get help and how to undo.) - ;; Don't you dare turn this off for anyone - ;; except yourself. - (load "default" t t))))))))) - (if init-file-debug - ;; Do this without a condition-case if the user wants to debug. - (funcall inner) - (condition-case error - (progn - (funcall inner) - (setq init-file-had-error nil)) - (error - (display-warning - 'initialization - (format-message "\ -An error occurred while loading `%s':\n\n%s%s%s\n\n\ -To ensure normal operation, you should investigate and remove the -cause of the error in your initialization file. Start Emacs with -the `--debug-init' option to view a complete error backtrace." - user-init-file - (get (car error) 'error-message) - (if (cdr error) ": " "") - (mapconcat (lambda (s) (prin1-to-string s t)) - (cdr error) ", ")) - :warning) - (setq init-file-had-error t)))) - - (if (and deactivate-mark transient-mark-mode) - (with-current-buffer (window-buffer) - (deactivate-mark))) - - ;; If the user has a file of abbrevs, read it (unless -batch). - (when (and (not noninteractive) - (file-exists-p abbrev-file-name) - (file-readable-p abbrev-file-name)) - (quietly-read-abbrev-file abbrev-file-name)) - - ;; If the abbrevs came entirely from the init file or the - ;; abbrevs file, they do not need saving. - (setq abbrevs-changed nil) - - ;; If we can tell that the init file altered debug-on-error, - ;; arrange to preserve the value that it set up. - (or (eq debug-on-error debug-on-error-initial) - (setq debug-on-error-should-be-set t - debug-on-error-from-init-file debug-on-error))) - (if debug-on-error-should-be-set - (setq debug-on-error debug-on-error-from-init-file)) - (unless (or (default-value 'enable-multibyte-characters) - (eq orig-enable-multibyte (default-value - 'enable-multibyte-characters))) - ;; Init file changed to unibyte. Reset existing multibyte - ;; buffers (probably *scratch*, *Messages*, *Minibuf-0*). - ;; Arguably this should only be done if they're free of - ;; multibyte characters. - (mapc (lambda (buffer) - (with-current-buffer buffer - (if enable-multibyte-characters - (set-buffer-multibyte nil)))) - (buffer-list)) - ;; Also re-set the language environment in case it was - ;; originally done before unibyte was set and is sensitive to - ;; unibyte (display table, terminal coding system &c). - (set-language-environment current-language-environment))) + (startup--load-user-init-file + (lambda () + (cond + ((eq system-type 'ms-dos) + (concat "~" init-file-user "/_emacs")) + ((not (eq system-type 'windows-nt)) + (find-init-path "emacs")) + ;; Else deal with the Windows situation. + ((directory-files "~" nil "^\\.emacs\\(\\.elc?\\)?$") + ;; Prefer .emacs on Windows. + "~/.emacs") + ((directory-files "~" nil "^_emacs\\(\\.elc?\\)?$") + ;; Also support _emacs for compatibility, but warn about it. + (push `(initialization + ,(format-message + "`_emacs' init file is deprecated, please use `.emacs'")) + delayed-warnings-list) + "~/_emacs") + (t ;; But default to .emacs if _emacs does not exist. + "~/.emacs"))) + (lambda () + (expand-file-name + "init" + (file-name-as-directory + (find-init-path "emacs.d")))) + (not inhibit-default-init)) + + (when (and deactivate-mark transient-mark-mode) + (with-current-buffer (window-buffer) + (deactivate-mark))) + + ;; If the user has a file of abbrevs, read it (unless -batch). + (when (and (not noninteractive) + (file-exists-p abbrev-file-name) + (file-readable-p abbrev-file-name)) + (quietly-read-abbrev-file abbrev-file-name)) + + ;; If the abbrevs came entirely from the init file or the + ;; abbrevs file, they do not need saving. + (setq abbrevs-changed nil) ;; Do this here in case the init file sets mail-host-address. (and mail-host-address @@ -1321,33 +1377,6 @@ the `--debug-init' option to view a complete error backtrace." (eq face-ignored-fonts old-face-ignored-fonts)) (clear-face-cache))) - ;; If any package directory exists, initialize the package system. - (and user-init-file - package-enable-at-startup - (catch 'package-dir-found - (let (dirs) - (if (boundp 'package-directory-list) - (setq dirs package-directory-list) - (dolist (f load-path) - (and (stringp f) - (equal (file-name-nondirectory f) "site-lisp") - (push (expand-file-name "elpa" f) dirs)))) - (push (if (boundp 'package-user-dir) - package-user-dir - (locate-user-emacs-file "elpa")) - dirs) - (dolist (dir dirs) - (when (file-directory-p dir) - (dolist (subdir (directory-files dir)) - (when (let ((subdir (expand-file-name subdir dir))) - (and (file-directory-p subdir) - (file-exists-p - (expand-file-name - (package--description-file subdir) - subdir)))) - (throw 'package-dir-found t))))))) - (package-initialize)) - (setq after-init-time (current-time)) ;; Display any accumulated warnings after all functions in ;; `after-init-hook' like `desktop-read' have finalized possible @@ -1358,7 +1387,8 @@ the `--debug-init' option to view a complete error backtrace." (if (get-buffer "*scratch*") (with-current-buffer "*scratch*" (if (eq major-mode 'fundamental-mode) - (funcall initial-major-mode)))) + (funcall initial-major-mode)) + (setq-local lexical-binding t))) ;; Load library for our terminal type. ;; User init file can set term-file-prefix to nil to prevent this. @@ -1460,8 +1490,7 @@ settings will be marked as \"CHANGED outside of Customize\"." "Initial documentation displayed in *scratch* buffer at startup. If this is nil, no message will be displayed." :type '(choice (text :tag "Message") - (const :tag "none" nil)) - :group 'initialization) + (const :tag "none" nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1615,13 +1644,13 @@ Each element in the list should be a list of strings or pairs (defgroup fancy-splash-screen () + ;; FIXME: Do we really need this group with a single custom var? "Fancy splash screen when Emacs starts." :version "21.1" :group 'initialization) (defcustom fancy-splash-image nil "The image to show in the splash screens, or nil for defaults." - :group 'fancy-splash-screen :type '(choice (const :tag "Default" nil) (file :tag "File"))) @@ -1742,7 +1771,7 @@ a face or button specification." :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) + (fancy-splash-insert :face '(variable-pitch font-lock-builtin-face) "\nThis is " (emacs-version) "\n" @@ -1890,7 +1919,8 @@ we put it on this frame." (if (and (frame-visible-p frame) (not (window-minibuffer-p (frame-selected-window frame)))) (setq chosen-frame frame))) - chosen-frame)) + ;; If there are no visible frames yet, try the selected one. + (or chosen-frame (selected-frame)))) (defun use-fancy-splash-screens-p () "Return t if fancy splash screens should be used." @@ -2104,7 +2134,7 @@ 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 - (get-buffer-create "*scratch*"))) + (startup--get-buffer-create-scratch))) 'follow-link t) (insert "\n") (insert "\n" (emacs-version) "\n" emacs-copyright "\n") @@ -2230,6 +2260,13 @@ 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)) + (setq-local lexical-binding t) + (current-buffer)))) + (defun command-line-1 (args-left) "A subroutine of `command-line'." (display-startup-echo-area-message) @@ -2376,10 +2413,12 @@ nil default-directory" name) (read-data (read-from-string str-expr)) (expr (car read-data)) (end (cdr read-data))) - (unless (= end (length str-expr)) + ;; Allow same trailing chars as minibuf.c's + ;; `string_to_object'. + (unless (string-match-p "[\s\t\n]*\\'" str-expr end) (error "Trailing garbage following expression: %s" (substring str-expr end))) - (eval expr))) + (eval expr t))) ((member argi '("-L" "-directory")) ;; -L :/foo adds /foo to the _end_ of load-path. @@ -2494,7 +2533,7 @@ nil default-directory" name) (when (eq initial-buffer-choice t) ;; When `initial-buffer-choice' equals t make sure that *scratch* ;; exists. - (get-buffer-create "*scratch*")) + (startup--get-buffer-create-scratch)) ;; If *scratch* exists and is empty, insert initial-scratch-message. ;; Do this before switching to *scratch* below to handle bug#9605. @@ -2505,7 +2544,12 @@ nil default-directory" name) (insert (substitute-command-keys initial-scratch-message)) (set-buffer-modified-p nil)))) - ;; Prepend `initial-buffer-choice' to `displayable-buffers'. + ;; Prepend `initial-buffer-choice' to `displayable-buffers'. If + ;; the buffer is already a member of that list then shift the + ;; buffer to the head of the list. The shift behavior is intended + ;; to prevent the same buffer being displayed in two windows when + ;; an `initial-buffer-choice' function happens to return the head + ;; of `displayable-buffers'. (when initial-buffer-choice (let ((buf (cond ((stringp initial-buffer-choice) @@ -2513,12 +2557,12 @@ nil default-directory" name) ((functionp initial-buffer-choice) (funcall initial-buffer-choice)) ((eq initial-buffer-choice t) - (get-buffer-create "*scratch*")) + (startup--get-buffer-create-scratch)) (t (error "`initial-buffer-choice' must be a string, a function, or t"))))) (unless (buffer-live-p buf) (error "Value returned by `initial-buffer-choice' is not a live buffer: %S" buf)) - (setq displayable-buffers (cons buf displayable-buffers)))) + (setq displayable-buffers (cons buf (delq buf displayable-buffers))))) ;; Display the first two buffers in `displayable-buffers'. If ;; `initial-buffer-choice' is non-nil, its buffer will be the diff --git a/lisp/strokes.el b/lisp/strokes.el index c480efdfbfe..0c671c43ac2 100644 --- a/lisp/strokes.el +++ b/lisp/strokes.el @@ -155,7 +155,7 @@ ;; Euna Kim for her help in Korean, and massive thanks to the helpful ;; guys on the help instance on athena (zeno, jered, amu, gsstark, ;; ghudson, etc) Special thanks to Steve Baur, Kyle Jones, and Hrvoje -;; Niksic for all their help. And special thanks to Dave Gillespie +;; Nikšić for all their help. And special thanks to Dave Gillespie ;; for all the elisp help--he is responsible for helping me use the cl ;; macros at (near) max speed. @@ -1388,9 +1388,6 @@ If STROKES-MAP is not given, `strokes-global-map' will be used instead." ;;;###autoload (define-minor-mode strokes-mode "Toggle Strokes mode, a global minor mode. -With a prefix argument ARG, enable Strokes mode if ARG is -positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. \\<strokes-mode-map> Strokes are pictographic mouse gestures which invoke commands. diff --git a/lisp/subr.el b/lisp/subr.el index 5a08cebf556..eea4e045dde 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -22,9 +22,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. -;; Beware: while this file has tag `utf-8', before it's compiled, it gets -;; loaded as "raw-text", so non-ASCII chars won't work right during bootstrap. - +;;; Code: ;; declare-function's args use &rest, not &optional, for compatibility ;; with byte-compile-macroexpand-declare-function. @@ -78,8 +76,8 @@ If FORM does return, signal an error." (defmacro 1value (form) "Evaluate FORM, expecting a constant return value. -This is the global do-nothing version. There is also `testcover-1value' -that complains if FORM ever does return differing values." +If FORM returns differing values when running under Testcover, +Testcover will raise an error." (declare (debug t)) form) @@ -118,6 +116,33 @@ BODY should be a list of Lisp expressions. ;; depend on backquote.el. (list 'function (cons 'lambda cdr))) +(defmacro prog2 (form1 form2 &rest body) + "Eval FORM1, FORM2 and BODY sequentially; return value from FORM2. +The value of FORM2 is saved during the evaluation of the +remaining args, whose values are discarded." + (declare (indent 2) (debug t)) + `(progn ,form1 (prog1 ,form2 ,@body))) + +(defmacro setq-default (&rest args) + "Set the default value of variable VAR to VALUE. +VAR, the variable name, is literal (not evaluated); +VALUE is an expression: it is evaluated and its value returned. +The default value of a variable is seen in buffers +that do not have their own values for the variable. + +More generally, you can use multiple variables and values, as in + (setq-default VAR VALUE VAR VALUE...) +This sets each VAR's default value to the corresponding VALUE. +The VALUE for the Nth VAR can refer to the new default values +of previous VARs. + +\(fn [VAR VALUE]...)" + (declare (debug setq)) + (let ((exps nil)) + (while args + (push `(set-default ',(pop args) ,(pop args)) exps)) + `(progn . ,(nreverse exps)))) + (defmacro setq-local (var val) "Set variable VAR to value VAL in current buffer." ;; Can't use backquote here, it's too early in the bootstrap. @@ -224,7 +249,7 @@ Then evaluate RESULT to get return value, default nil. "Loop a certain number of times. Evaluate BODY with VAR bound to successive integers running from 0, inclusive, to COUNT, exclusive. Then evaluate RESULT to get -the return value (nil if RESULT is omitted). +the return value (nil if RESULT is omitted). Its use is deprecated. \(fn (VAR COUNT [RESULT]) BODY...)" (declare (indent 1) (debug dolist)) @@ -277,6 +302,14 @@ See also `with-demoted-errors' that does something similar without silencing all errors." (declare (debug t) (indent 0)) `(condition-case nil (progn ,@body) (error nil))) + +(defmacro ignore-error (condition &rest body) + "Execute BODY; if the error CONDITION occurs, return nil. +Otherwise, return result of last form in BODY. + +CONDITION can also be a list of error conditions." + (declare (debug t) (indent 1)) + `(condition-case nil (progn ,@body) (,condition nil))) ;;;; Basic Lisp functions. @@ -299,27 +332,31 @@ This function accepts any number of arguments, but ignores them." ;; Signal a compile-error if the first arg is missing. (defun error (&rest args) - "Signal an error, making a message by passing args to `format-message'. + "Signal an error, making a message by passing ARGS to `format-message'. +Errors cause entry to the debugger when `debug-on-error' is non-nil. +This can be overridden by `debug-ignored-errors'. + +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. - -Note: (error \"%s\" VALUE) makes the message VALUE without -interpreting format characters like `%', `\\=`', and `\\=''." +for the sake of consistency." (declare (advertised-calling-convention (string &rest args) "23.1")) (signal 'error (list (apply #'format-message args)))) (defun user-error (format &rest args) - "Signal a pilot error, making a message by passing args to `format-message'. + "Signal a user error, making a message by passing ARGS to `format-message'. +This is like `error' except that a user error (or \"pilot error\") comes +from an incorrect manipulation by the user, not from an actual problem. +In contrast with other errors, user errors normally do not cause +entry to the debugger, even when `debug-on-error' is non-nil. +This can be overridden by `debug-ignored-errors'. + +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. -This is just like `error' except that `user-error's are expected to be the -result of an incorrect manipulation on the part of the user, rather than the -result of an actual problem. - -Note: (user-error \"%s\" VALUE) makes the message VALUE without -interpreting format characters like `%', `\\=`', and `\\=''." +for the sake of consistency." (signal 'user-error (list (apply #'format-message format args)))) (defun define-error (name message &optional parent) @@ -360,6 +397,34 @@ was called." (lambda (&rest args2) (apply fun (append args args2)))) +(defun zerop (number) + "Return t if NUMBER is zero." + ;; Used to be in C, but it's pointless since (= 0 n) is faster anyway because + ;; = has a byte-code. + (declare (compiler-macro (lambda (_) `(= 0 ,number)))) + (= 0 number)) + +(defun fixnump (object) + "Return t if OBJECT is a fixnum." + (and (integerp object) + (<= most-negative-fixnum object most-positive-fixnum))) + +(defun bignump (object) + "Return t if OBJECT is a bignum." + (and (integerp object) (not (fixnump object)))) + +(defun lsh (value count) + "Return VALUE with its bits shifted left by COUNT. +If COUNT is negative, shifting is actually to the right. +In this case, if VALUE is a negative fixnum treat it as unsigned, +i.e., subtract 2 * most-negative-fixnum from VALUE before shifting it." + (when (and (< value 0) (< count 0)) + (when (< value most-negative-fixnum) + (signal 'args-out-of-range (list value count))) + (setq value (logand (ash value -1) most-positive-fixnum)) + (setq count (1+ count))) + (ash value count)) + ;;;; List functions. @@ -525,6 +590,7 @@ was called." If LIST is nil, return nil. If N is non-nil, return the Nth-to-last link of LIST. If N is bigger than the length of LIST, return LIST." + (declare (side-effect-free t)) (if n (and (>= n 0) (let ((m (safe-length list))) @@ -536,6 +602,7 @@ If N is bigger than the length of LIST, return LIST." "Return a copy of LIST with the last N elements removed. If N is omitted or nil, the last element is removed from the copy." + (declare (side-effect-free t)) (if (and n (<= n 0)) list (nbutlast (copy-sequence list) n))) @@ -549,12 +616,10 @@ If N is omitted or nil, remove the last element." (if (> n 0) (setcdr (nthcdr (- (1- m) n) list) nil)) list)))) -(defun zerop (number) - "Return t if NUMBER is zero." - ;; Used to be in C, but it's pointless since (= 0 n) is faster anyway because - ;; = has a byte-code. - (declare (compiler-macro (lambda (_) `(= 0 ,number)))) - (= 0 number)) +;; The function's definition was moved to fns.c, +;; but it's easier to set properties here. +(put 'proper-list-p 'pure t) +(put 'proper-list-p 'side-effect-free 'error-free) (defun delete-dups (list) "Destructively remove `equal' duplicates from LIST. @@ -622,16 +687,13 @@ of course, also replace TO with a slightly larger value (list from) (or inc (setq inc 1)) (when (zerop inc) (error "The increment can not be zero")) - (let (seq (n 0) (next from) (last from)) + (let (seq (n 0) (next from)) (if (> inc 0) - ;; The (>= next last) condition protects against integer - ;; overflow in computing NEXT. - (while (and (>= next last) (<= next to)) + (while (<= next to) (setq seq (cons next seq) n (1+ n) - last next next (+ from (* n inc)))) - (while (and (<= next last) (>= next to)) + (while (>= next to) (setq seq (cons next seq) n (1+ n) next (+ from (* n inc))))) @@ -673,6 +735,7 @@ If that is non-nil, the element matches; then `assoc-default' If no element matches, the value is nil. If TEST is omitted or nil, `equal' is used." + (declare (side-effect-free t)) (let (found (tail alist) value) (while (and tail (not found)) (let ((elt (car tail))) @@ -681,42 +744,31 @@ If TEST is omitted or nil, `equal' is used." (setq tail (cdr tail))) value)) -(defun assoc-ignore-case (key alist) - "Like `assoc', but ignores differences in case and text representation. -KEY must be a string. Upper-case and lower-case letters are treated as equal. -Unibyte strings are converted to multibyte for comparison." - (declare (obsolete assoc-string "22.1")) - (assoc-string key alist t)) - -(defun assoc-ignore-representation (key alist) - "Like `assoc', but ignores differences in text representation. -KEY must be a string. -Unibyte strings are converted to multibyte for comparison." - (declare (obsolete assoc-string "22.1")) - (assoc-string key alist nil)) - (defun member-ignore-case (elt list) "Like `member', but ignore differences in case and text representation. ELT must be a string. Upper-case and lower-case letters are treated as equal. Unibyte strings are converted to multibyte for comparison. Non-strings in LIST are ignored." + (declare (side-effect-free t)) (while (and list (not (and (stringp (car list)) (eq t (compare-strings elt 0 nil (car list) 0 nil t))))) (setq list (cdr list))) list) -(defun assoc-delete-all (key alist) - "Delete from ALIST all elements whose car is `equal' to KEY. +(defun assoc-delete-all (key alist &optional test) + "Delete from ALIST all elements whose car is KEY. +Compare keys with TEST. Defaults to `equal'. Return the modified alist. Elements of ALIST that are not conses are ignored." + (unless test (setq test #'equal)) (while (and (consp (car alist)) - (equal (car (car alist)) key)) + (funcall test (caar alist) key)) (setq alist (cdr alist))) (let ((tail alist) tail-cdr) (while (setq tail-cdr (cdr tail)) (if (and (consp (car tail-cdr)) - (equal (car (car tail-cdr)) key)) + (funcall test (caar tail-cdr) key)) (setcdr tail (cdr tail-cdr)) (setq tail tail-cdr)))) alist) @@ -725,16 +777,7 @@ Elements of ALIST that are not conses are ignored." "Delete from ALIST all elements whose car is `eq' to KEY. Return the modified alist. Elements of ALIST that are not conses are ignored." - (while (and (consp (car alist)) - (eq (car (car alist)) key)) - (setq alist (cdr alist))) - (let ((tail alist) tail-cdr) - (while (setq tail-cdr (cdr tail)) - (if (and (consp (car tail-cdr)) - (eq (car (car tail-cdr)) key)) - (setcdr tail (cdr tail-cdr)) - (setq tail tail-cdr)))) - alist) + (assoc-delete-all key alist #'eq)) (defun rassq-delete-all (value alist) "Delete from ALIST all elements whose cdr is `eq' to VALUE. @@ -756,9 +799,31 @@ Elements of ALIST that are not conses are ignored." If KEY is not found in ALIST, return DEFAULT. Equality with KEY is tested by TESTFN, defaulting to `eq'. -This is a generalized variable suitable for use with `setf'. +You can use `alist-get' in PLACE expressions. This will modify +an existing association (more precisely, the first one if +multiple exist), or add a new element to the beginning of ALIST, +destructively modifying the list stored in ALIST. + +Example: + + (setq foo '((a . 0))) + (setf (alist-get 'a foo) 1 + (alist-get 'b foo) 2) + + foo => ((b . 2) (a . 1)) + + When using it to set a value, optional argument REMOVE non-nil -means to remove KEY from ALIST if the new value is `eql' to DEFAULT." +means to remove KEY from ALIST if the new value is `eql' to +DEFAULT (more precisely the first found association will be +deleted from the alist). + +Example: + + (setq foo '((a . 1) (b . 2))) + (setf (alist-get 'b foo nil 'remove) nil) + + foo => ((a . 1))" (ignore remove) ;;Silence byte-compiler. (let ((x (if (not testfn) (assq key alist) @@ -768,6 +833,7 @@ means to remove KEY from ALIST if the new value is `eql' to DEFAULT." (defun remove (elt seq) "Return a copy of SEQ with all occurrences of ELT removed. SEQ must be a list, vector, or string. The comparison is done with `equal'." + (declare (side-effect-free t)) (if (nlistp seq) ;; If SEQ isn't a list, there's no need to copy SEQ because ;; `delete' will return a new object. @@ -778,6 +844,7 @@ SEQ must be a list, vector, or string. The comparison is done with `equal'." "Return LIST with all occurrences of ELT removed. The comparison is done with `eq'. Contrary to `delq', this does not use side-effects, and the argument LIST is not modified." + (declare (side-effect-free t)) (while (and (eq elt (car list)) (setq list (cdr list)))) (if (memq elt list) (delq elt (copy-sequence list)) @@ -1178,12 +1245,14 @@ The normal global definition of the character C-x indirects to this keymap.") c))) key))) -(defun eventp (obj) - "True if the argument is an event object." - (when obj - (or (integerp obj) - (and (symbolp obj) obj (not (keywordp obj))) - (and (consp obj) (symbolp (car obj)))))) +(defun eventp (object) + "Return non-nil if OBJECT is an input event or event object." + (or (integerp object) + (and (if (consp object) + (setq object (car object)) + object) + (symbolp object) + (not (keywordp object))))) (defun event-modifiers (event) "Return a list of symbols representing the modifier keys in event EVENT. @@ -1456,11 +1525,22 @@ be a list of the form returned by `event-start' and `event-end'." (make-obsolete 'forward-point "use (+ (point) N) instead." "23.1") (make-obsolete 'buffer-has-markers-at nil "24.3") +(make-obsolete 'invocation-directory "use the variable of the same name." + "27.1") +(make-obsolete 'invocation-name "use the variable of the same name." "27.1") + +;; We used to declare string-to-unibyte obsolete, but it is a valid +;; way of getting a unibyte string that can be indexed by bytes, when +;; the original string has raw bytes in their internal multibyte +;; representation. This can be useful when one needs to examine +;; individual bytes at known offsets from the string beginning. +;; (make-obsolete 'string-to-unibyte "use `encode-coding-string'." "26.1") +;; string-to-multibyte is also sometimes useful (and there's no good +;; general replacement for it), so it's also been unobsoleted in Emacs 27.1. +;; (make-obsolete 'string-to-multibyte "use `decode-coding-string'." "26.1") ;; bug#23850 -(make-obsolete 'string-to-unibyte "use `encode-coding-string'." "26.1") (make-obsolete 'string-as-unibyte "use `encode-coding-string'." "26.1") (make-obsolete 'string-make-unibyte "use `encode-coding-string'." "26.1") -(make-obsolete 'string-to-multibyte "use `decode-coding-string'." "26.1") (make-obsolete 'string-as-multibyte "use `decode-coding-string'." "26.1") (make-obsolete 'string-make-multibyte "use `decode-coding-string'." "26.1") @@ -1469,17 +1549,13 @@ be a list of the form returned by `event-start' and `event-end'." (declare (obsolete log "24.4")) (log x 10)) -;; These are used by VM and some old programs -(defalias 'focus-frame 'ignore "") -(make-obsolete 'focus-frame "it does nothing." "22.1") -(defalias 'unfocus-frame 'ignore "") -(make-obsolete 'unfocus-frame "it does nothing." "22.1") - (set-advertised-calling-convention 'all-completions '(string collection &optional predicate) "23.1") (set-advertised-calling-convention 'unintern '(name obarray) "23.3") (set-advertised-calling-convention 'indirect-function '(object) "25.1") (set-advertised-calling-convention 'redirect-frame-focus '(frame focus-frame) "24.3") +(set-advertised-calling-convention 'libxml-parse-xml-region '(start end &optional base-url) "27.1") +(set-advertised-calling-convention 'libxml-parse-html-region '(start end &optional base-url) "27.1") ;;;; Obsolescence declarations for variables, and aliases. @@ -1497,15 +1573,6 @@ be a list of the form returned by `event-start' and `event-end'." (make-obsolete-variable 'command-debug-status "expect it to be removed in a future version." "25.2") -;; Lisp manual only updated in 22.1. -(define-obsolete-variable-alias 'executing-macro 'executing-kbd-macro - "before 19.34") - -(define-obsolete-variable-alias 'x-lost-selection-hooks - 'x-lost-selection-functions "22.1") -(define-obsolete-variable-alias 'x-sent-selection-hooks - 'x-sent-selection-functions "22.1") - ;; This was introduced in 21.4 for pre-unicode unification. That ;; usage was rendered obsolete in 23.1 which uses Unicode internally. ;; Other uses are possible, so this variable is not _really_ obsolete, @@ -1515,6 +1582,8 @@ be a list of the form returned by `event-start' and `event-end'." (make-obsolete-variable 'x-gtk-use-window-move nil "26.1") (defvaralias 'messages-buffer-max-lines 'message-log-max) +(define-obsolete-variable-alias 'inhibit-null-byte-detection + 'inhibit-nul-byte-detection "27.1") ;;;; Alternate names for functions - these are not being phased out. @@ -1544,12 +1613,23 @@ be a list of the form returned by `event-start' and `event-end'." ;;;; Hook manipulation functions. -(defun add-hook (hook function &optional append local) +(defun add-hook (hook function &optional depth local) + ;; Note: the -100..100 depth range is arbitrary and was chosen to match the + ;; range used in add-function. "Add to the value of HOOK the function FUNCTION. FUNCTION is not added if already present. -FUNCTION is added (if necessary) at the beginning of the hook list -unless the optional argument APPEND is non-nil, in which case -FUNCTION is added at the end. + +The place where the function is added depends on the DEPTH +parameter. DEPTH defaults to 0. By convention, it should be +a number between -100 and 100 where 100 means that the function +should be at the very end of the list, whereas -100 means that +the function should always come first. +Since nothing is \"always\" true, don't use 100 nor -100. +When two functions have the same depth, the new one gets added after the +old one if depth is strictly positive and before otherwise. + +For backward compatibility reasons, a symbol other than nil is +interpreted as a DEPTH of 90. The optional fourth argument, LOCAL, if non-nil, says to modify the hook's buffer-local value rather than its global value. @@ -1562,6 +1642,7 @@ HOOK is void, it is first set to nil. If HOOK's value is a single function, it is changed to a list of functions." (or (boundp hook) (set hook nil)) (or (default-boundp hook) (set-default hook nil)) + (unless (numberp depth) (setq depth (if depth 90 0))) (if local (unless (local-variable-if-set-p hook) (set (make-local-variable hook) (list t))) ;; Detect the case where make-local-variable was used on a hook @@ -1574,12 +1655,25 @@ function, it is changed to a list of functions." (setq hook-value (list hook-value))) ;; Do the actual addition if necessary (unless (member function hook-value) - (when (stringp function) + (when (stringp function) ;FIXME: Why? (setq function (purecopy function))) + (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. + (setf (alist-get function (get hook 'hook--depth-alist) + 0 'remove #'equal) + depth)) (setq hook-value - (if append + (if (< 0 depth) (append hook-value (list function)) - (cons function hook-value)))) + (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 #'equal) + (alist-get f2 depth-alist 0 nil #'equal)))))))) ;; Set the actual variable (if local (progn @@ -1829,7 +1923,7 @@ variable. The possible values of maximum length have the same meaning as the values of `history-length'. Remove duplicates of NEWELT if `history-delete-duplicates' is non-nil. If optional fourth arg KEEP-ALL is non-nil, add NEWELT to history even -if it is empty or a duplicate." +if it is empty or duplicates the most recent entry in the history." (unless maxelt (setq maxelt (or (get history-var 'history-length) history-length))) @@ -1845,27 +1939,25 @@ if it is empty or a duplicate." (setq history (delete newelt history))) (setq history (cons newelt history)) (when (integerp maxelt) - (if (= 0 maxelt) + (if (>= 0 maxelt) (setq history nil) (setq tail (nthcdr (1- maxelt) history)) (when (consp tail) - (setcdr tail nil))))) - (set history-var history))) + (setcdr tail nil)))) + (set history-var history)))) ;;;; Mode hooks. (defvar delay-mode-hooks nil "If non-nil, `run-mode-hooks' should delay running the hooks.") -(defvar delayed-mode-hooks nil +(defvar-local delayed-mode-hooks nil "List of delayed mode hooks waiting to be run.") -(make-variable-buffer-local 'delayed-mode-hooks) (put 'delay-mode-hooks 'permanent-local t) -(defvar delayed-after-hook-functions nil +(defvar-local delayed-after-hook-functions nil "List of delayed :after-hook forms waiting to be run. These forms come from `define-derived-mode'.") -(make-variable-buffer-local 'delayed-after-hook-functions) (defvar change-major-mode-after-body-hook nil "Normal hook run in major mode functions, before the mode hooks.") @@ -1894,15 +1986,22 @@ running their FOO-mode-hook." (push hook delayed-mode-hooks)) ;; Normal case, just run the hook as before plus any delayed hooks. (setq hooks (nconc (nreverse delayed-mode-hooks) hooks)) + (and (bound-and-true-p syntax-propertize-function) + (not (local-variable-p 'parse-sexp-lookup-properties)) + ;; `syntax-propertize' sets `parse-sexp-lookup-properties' for us, but + ;; in order for the sexp primitives to automatically call + ;; `syntax-propertize' we need `parse-sexp-lookup-properties' to be + ;; set first. + (setq-local parse-sexp-lookup-properties t)) (setq delayed-mode-hooks nil) - (apply 'run-hooks (cons 'change-major-mode-after-body-hook hooks)) + (apply #'run-hooks (cons 'change-major-mode-after-body-hook hooks)) (if (buffer-file-name) (with-demoted-errors "File local-variables error: %s" (hack-local-variables 'no-mode))) (run-hooks 'after-change-major-mode-hook) - (dolist (fun (nreverse delayed-after-hook-functions)) - (funcall fun)) - (setq delayed-after-hook-functions nil))) + (dolist (fun (prog1 (nreverse delayed-after-hook-functions) + (setq delayed-after-hook-functions nil))) + (funcall fun)))) (defmacro delay-mode-hooks (&rest body) "Execute BODY, but delay any `run-mode-hooks'. @@ -1918,17 +2017,51 @@ Only affects hooks run in the current buffer." ;; PUBLIC: find if the current mode derives from another. (defun provided-mode-derived-p (mode &rest modes) - "Non-nil if MODE is derived from one of MODES. + "Non-nil if MODE is derived from one of MODES or their aliases. Uses the `derived-mode-parent' property of the symbol to trace backwards. If you just want to check `major-mode', use `derived-mode-p'." - (while (and (not (memq mode modes)) - (setq mode (get mode 'derived-mode-parent)))) + (while + (and + (not (memq mode modes)) + (let* ((parent (get mode 'derived-mode-parent)) + (parentfn (symbol-function parent))) + (setq mode (if (and parentfn (symbolp parentfn)) parentfn parent))))) mode) (defun derived-mode-p (&rest modes) "Non-nil if the current major mode is derived from one of MODES. Uses the `derived-mode-parent' property of the symbol to trace backwards." (apply #'provided-mode-derived-p major-mode modes)) + +(defvar-local major-mode--suspended nil) +(put 'major-mode--suspended 'permanent-local t) + +(defun major-mode-suspend () + "Exit current major, remembering it." + (let* ((prev-major-mode (or major-mode--suspended + (unless (eq major-mode 'fundamental-mode) + major-mode)))) + (kill-all-local-variables) + (setq-local major-mode--suspended prev-major-mode))) + +(defun major-mode-restore (&optional avoided-modes) + "Restore major mode earlier suspended with `major-mode-suspend'. +If there was no earlier suspended major mode, then fallback to `normal-mode', +tho trying to avoid AVOIDED-MODES." + (if major-mode--suspended + (funcall (prog1 major-mode--suspended + (kill-local-variable 'major-mode--suspended))) + (let ((auto-mode-alist + (let ((alist (copy-sequence auto-mode-alist))) + (dolist (mode avoided-modes) + (setq alist (rassq-delete-all mode alist))) + alist)) + (magic-fallback-mode-alist + (let ((alist (copy-sequence magic-fallback-mode-alist))) + (dolist (mode avoided-modes) + (setq alist (rassq-delete-all mode alist))) + alist))) + (normal-mode)))) ;;;; Minor modes. @@ -2178,19 +2311,6 @@ process." (memq (process-status process) '(run open listen connect stop)))) -;; compatibility - -(defun process-kill-without-query (process &optional _flag) - "Say no query needed if PROCESS is running when Emacs is exited. -Optional second argument if non-nil says to require a query. -Value is t if a query was formerly required." - (declare (obsolete - "use `process-query-on-exit-flag' or `set-process-query-on-exit-flag'." - "22.1")) - (let ((old (process-query-on-exit-flag process))) - (set-process-query-on-exit-flag process nil) - old)) - (defun process-kill-buffer-query-function () "Ask before killing a buffer that has a running process." (let ((process (get-buffer-process (current-buffer)))) @@ -2216,6 +2336,10 @@ It can be retrieved with `(process-get PROCESS PROPNAME)'." (set-process-plist process (plist-put (process-plist process) propname value))) +(defun memory-limit () + "Return an estimate of Emacs virtual memory usage, divided by 1024." + (or (cdr (assq 'vsize (process-attributes (emacs-pid)))) 0)) + ;;;; Input and display facilities. @@ -2299,7 +2423,7 @@ some sort of escape sequence, the ambiguity is resolved via `read-key-delay'." If optional CONFIRM is non-nil, read the password twice to make sure. Optional DEFAULT is a default password to use instead of empty input. -This function echoes `.' for each character that the user types. +This function echoes `*' for each character that the user types. You could let-bind `read-hide-char' to another hiding character, though. Once the caller uses the password, it can erase the password @@ -2325,7 +2449,7 @@ by doing (clear-string STRING)." beg))) (dotimes (i (- end beg)) (put-text-property (+ i beg) (+ 1 i beg) - 'display (string (or read-hide-char ?.)))))) + 'display (string (or read-hide-char ?*)))))) minibuf) (minibuffer-with-setup-hook (lambda () @@ -2340,7 +2464,7 @@ by doing (clear-string STRING)." (add-hook 'after-change-functions hide-chars-fun nil 'local)) (unwind-protect (let ((enable-recursive-minibuffers t) - (read-hide-char (or read-hide-char ?.))) + (read-hide-char (or read-hide-char ?*))) (read-string prompt nil t default)) ; t = "no history" (when (buffer-live-p minibuf) (with-current-buffer minibuf @@ -2591,7 +2715,7 @@ is nil and `use-dialog-box' is non-nil." ;;; Atomic change groups. (defmacro atomic-change-group (&rest body) - "Perform BODY as an atomic change group. + "Like `progn' but perform BODY as an atomic change group. This means that if BODY exits abnormally, all of its changes to the current buffer are undone. This works regardless of whether undo is enabled in the buffer. @@ -2614,8 +2738,8 @@ user can undo the change normally." ;; it enables undo if that was disabled; we need ;; to make sure that it gets disabled again. (activate-change-group ,handle) - ,@body - (setq ,success t)) + (prog1 ,(macroexp-progn body) + (setq ,success t))) ;; Either of these functions will disable undo ;; if it was disabled before. (if ,success @@ -3064,6 +3188,8 @@ This function is like `insert', except it honors the variables (inhibit-read-only inhibit-read-only) end) + ;; FIXME: This throws away any yank-undo-function set by previous calls + ;; to insert-for-yank-1 within the loop of insert-for-yank! (setq yank-undo-function t) (if (nth 0 handler) ; FUNCTION (funcall (car handler) param) @@ -3157,11 +3283,12 @@ discouraged." "Start a program in a subprocess. Return the process object for it. Similar to `start-process-shell-command', but calls `start-file-process'." (declare (advertised-calling-convention (name buffer command) "23.1")) - (start-file-process - name buffer - (if (file-remote-p default-directory) "/bin/sh" shell-file-name) - (if (file-remote-p default-directory) "-c" shell-command-switch) - (mapconcat 'identity args " "))) + ;; On remote hosts, the local `shell-file-name' might be useless. + (with-connection-local-variables + (start-file-process + name buffer + shell-file-name shell-command-switch + (mapconcat 'identity args " ")))) (defun call-process-shell-command (command &optional infile buffer display &rest args) @@ -3202,11 +3329,11 @@ discouraged." Similar to `call-process-shell-command', but calls `process-file'." (declare (advertised-calling-convention (command &optional infile buffer display) "24.5")) - (process-file - (if (file-remote-p default-directory) "/bin/sh" shell-file-name) - infile buffer display - (if (file-remote-p default-directory) "-c" shell-command-switch) - (mapconcat 'identity (cons command args) " "))) + ;; On remote hosts, the local `shell-file-name' might be useless. + (with-connection-local-variables + (process-file + shell-file-name infile buffer display shell-command-switch + (mapconcat 'identity (cons command args) " ")))) (defun call-shell-region (start end command &optional delete buffer) "Send text from START to END as input to an inferior shell running COMMAND. @@ -3554,9 +3681,31 @@ If BODY finishes, `while-no-input' returns whatever value BODY produced." (let ((catch-sym (make-symbol "input"))) `(with-local-quit (catch ',catch-sym - (let ((throw-on-input ',catch-sym)) - (or (input-pending-p) - (progn ,@body))))))) + (let ((throw-on-input ',catch-sym) + val) + (setq val (or (input-pending-p) + (progn ,@body))) + (cond + ;; When input arrives while throw-on-input is non-nil, + ;; kbd_buffer_store_buffered_event sets quit-flag to the + ;; value of throw-on-input. If, when BODY finishes, + ;; quit-flag still has the same value as throw-on-input, it + ;; means BODY never tested quit-flag, and therefore ran to + ;; completion even though input did arrive before it + ;; finished. In that case, we must manually simulate what + ;; 'throw' in process_quit_flag would do, and we must + ;; reset quit-flag, because leaving it set will cause us + ;; quit to top-level, which has undesirable consequences, + ;; such as discarding input etc. We return t in that case + ;; because input did arrive during execution of BODY. + ((eq quit-flag throw-on-input) + (setq quit-flag nil) + t) + ;; This is for when the user actually QUITs during + ;; execution of BODY. + (quit-flag + nil) + (t val))))))) (defmacro condition-case-unless-debug (var bodyform &rest handlers) "Like `condition-case' except that it does not prevent debugging. @@ -3613,6 +3762,126 @@ in BODY." . ,body) (combine-after-change-execute))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar undo--combining-change-calls nil + "Non-nil when `combine-change-calls-1' is running.") + +(defun combine-change-calls-1 (beg end body) + "Evaluate BODY, running the change hooks just once, for region \(BEG END). + +Firstly, `before-change-functions' is invoked for the region +\(BEG END), then BODY (a function) is evaluated with +`before-change-functions' and `after-change-functions' bound to +nil, then finally `after-change-functions' is invoked on the +updated region (BEG NEW-END) with a calculated OLD-LEN argument. +If `inhibit-modification-hooks' is initially non-nil, the change +hooks are not run. + +The result of `combine-change-calls-1' is the value returned by +BODY. BODY must not make a different buffer current, except +temporarily. It must not make any changes to the buffer outside +the specified region. It must not change +`before-change-functions' or `after-change-functions'. + +Additionally, the buffer modifications of BODY are recorded on +the buffer's undo list as a single (apply ...) entry containing +the function `undo--wrap-and-run-primitive-undo'." + (let ((old-bul buffer-undo-list) + (end-marker (copy-marker end t)) + result) + (if undo--combining-change-calls + (setq result (funcall body)) + (let ((undo--combining-change-calls t)) + (if (not inhibit-modification-hooks) + (run-hook-with-args 'before-change-functions beg end)) + (if (eq buffer-undo-list t) + (setq result (funcall body)) + (let (;; (inhibit-modification-hooks t) + (before-change-functions + ;; Ugly Hack: if the body uses syntax-ppss/syntax-propertize + ;; (e.g. via a regexp-search or sexp-movement trigerring + ;; on-the-fly syntax-propertize), make sure that this gets + ;; properly refreshed after subsequent changes. + (if (memq #'syntax-ppss-flush-cache before-change-functions) + '(syntax-ppss-flush-cache))) + after-change-functions) + (setq result (funcall body))) + (let ((ap-elt + (list 'apply + (- end end-marker) + beg + (marker-position end-marker) + #'undo--wrap-and-run-primitive-undo + beg (marker-position end-marker) buffer-undo-list)) + (ptr buffer-undo-list)) + (if (not (eq buffer-undo-list old-bul)) + (progn + (while (and (not (eq (cdr ptr) old-bul)) + ;; In case garbage collection has removed OLD-BUL. + (cdr ptr) + ;; Don't include a timestamp entry. + (not (and (consp (cdr ptr)) + (consp (cadr ptr)) + (eq (caadr ptr) t) + (setq old-bul (cdr ptr))))) + (setq ptr (cdr ptr))) + (unless (cdr ptr) + (message "combine-change-calls: buffer-undo-list broken")) + (setcdr ptr nil) + (push ap-elt buffer-undo-list) + (setcdr buffer-undo-list old-bul))))) + (if (not inhibit-modification-hooks) + (run-hook-with-args 'after-change-functions + beg (marker-position end-marker) + (- end beg))))) + (set-marker end-marker nil) + result)) + +(defmacro combine-change-calls (beg end &rest body) + "Evaluate BODY, running the change hooks just once. + +BODY is a sequence of lisp forms to evaluate. BEG and END bound +the region the change hooks will be run for. + +Firstly, `before-change-functions' is invoked for the region +\(BEG END), then the BODY forms are evaluated with +`before-change-functions' and `after-change-functions' bound to +nil, and finally `after-change-functions' is invoked on the +updated region. The change hooks are not run if +`inhibit-modification-hooks' is initially non-nil. + +The result of `combine-change-calls' is the value returned by the +last of the BODY forms to be evaluated. BODY may not make a +different buffer current, except temporarily. BODY may not +change the buffer outside the specified region. It must not +change `before-change-functions' or `after-change-functions'. + +Additionally, the buffer modifications of BODY are recorded on +the buffer's undo list as a single \(apply ...) entry containing +the function `undo--wrap-and-run-primitive-undo'. " + `(combine-change-calls-1 ,beg ,end (lambda () ,@body))) + +(defun undo--wrap-and-run-primitive-undo (beg end list) + "Call `primitive-undo' on the undo elements in LIST. + +This function is intended to be called purely by `undo' as the +function in an \(apply DELTA BEG END FUNNAME . ARGS) undo +element. It invokes `before-change-functions' and +`after-change-functions' once each for the entire region \(BEG +END) rather than once for each individual change. + +Additionally the fresh \"redo\" elements which are generated on +`buffer-undo-list' will themselves be \"enclosed\" in +`undo--wrap-and-run-primitive-undo'. + +Undo elements of this form are generated by the macro +`combine-change-calls'." + (combine-change-calls beg end + (while list + (setq list (primitive-undo 1 list))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (defmacro with-case-table (table &rest body) "Execute the forms in BODY with TABLE as the current case table. The value returned is the value of the last form in BODY." @@ -3671,6 +3940,7 @@ Zero means the entire text matched by the whole regexp or whole string. STRING should be given if the last search was by `string-match' on STRING. If STRING is nil, the current buffer should be the same buffer the search/match was performed in." + (declare (side-effect-free t)) (if (match-beginning num) (if string (substring string (match-beginning num) (match-end num)) @@ -3684,6 +3954,7 @@ Zero means the entire text matched by the whole regexp or whole string. STRING should be given if the last search was by `string-match' on STRING. If STRING is nil, the current buffer should be the same buffer the search/match was performed in." + (declare (side-effect-free t)) (if (match-beginning num) (if string (substring-no-properties string (match-beginning num) @@ -3946,7 +4217,8 @@ Return a new string containing the replacements. Optional arguments FIXEDCASE, LITERAL and SUBEXP are like the arguments with the same names of function `replace-match'. If START -is non-nil, start replacements at that index in STRING. +is non-nil, start replacements at that index in STRING, and omit +the first START characters of STRING from the return value. REP is either a string used as the NEWTEXT arg of `replace-match' or a function. If it is a function, it is called with the actual text of each @@ -4178,25 +4450,28 @@ This function is called directly from the C code." (when (string-match-p "/obsolete/\\([^/]*\\)\\'" abs-file) ;; Maybe we should just use display-warning? This seems yucky... (let* ((file (file-name-nondirectory abs-file)) - (msg (format "Package %s is obsolete!" - (substring file 0 - (string-match "\\.elc?\\>" file))))) + (package (intern (substring file 0 + (string-match "\\.elc?\\>" file)) + obarray)) + (msg (format "Package %s is obsolete" package))) ;; Cribbed from cl--compiling-file. - (if (and (boundp 'byte-compile--outbuffer) - (bufferp (symbol-value 'byte-compile--outbuffer)) - (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) - " *Compiler Output*")) - ;; Don't warn about obsolete files using other obsolete files. - (unless (and (stringp byte-compile-current-file) - (string-match-p "/obsolete/[^/]*\\'" - (expand-file-name - byte-compile-current-file - byte-compile-root-dir))) - (byte-compile-warn "%s" msg)) - (run-with-timer 0 nil - (lambda (msg) - (message "%s" msg)) - msg)))) + (when (or (not (fboundp 'byte-compile-warning-enabled-p)) + (byte-compile-warning-enabled-p 'obsolete package)) + (if (and (boundp 'byte-compile--outbuffer) + (bufferp (symbol-value 'byte-compile--outbuffer)) + (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) + " *Compiler Output*")) + ;; Don't warn about obsolete files using other obsolete files. + (unless (and (stringp byte-compile-current-file) + (string-match-p "/obsolete/[^/]*\\'" + (expand-file-name + byte-compile-current-file + byte-compile-root-dir))) + (byte-compile-warn "%s" msg)) + (run-with-timer 0 nil + (lambda (msg) + (message "%s" msg)) + msg))))) ;; Finally, run any other hook. (run-hook-with-args 'after-load-functions abs-file)) @@ -4254,14 +4529,24 @@ to `display-warning'." (defun add-to-invisibility-spec (element) "Add ELEMENT to `buffer-invisibility-spec'. See documentation for `buffer-invisibility-spec' for the kind of elements -that can be added." +that can be added. + +If `buffer-invisibility-spec' isn't a list before calling this +function, `buffer-invisibility-spec' will afterwards be a list +with the value `(t ELEMENT)'. This means that if text exists +that invisibility values that aren't either `t' or ELEMENT, that +text will become visible." (if (eq buffer-invisibility-spec t) (setq buffer-invisibility-spec (list t))) (setq buffer-invisibility-spec (cons element buffer-invisibility-spec))) (defun remove-from-invisibility-spec (element) - "Remove ELEMENT from `buffer-invisibility-spec'." + "Remove ELEMENT from `buffer-invisibility-spec'. +If `buffer-invisibility-spec' isn't a list before calling this +function, it will be made into a list containing just `t' as the +only list member. This means that if text exists with non-`t' +invisibility values, that text will become visible." (setq buffer-invisibility-spec (if (consp buffer-invisibility-spec) (delete element buffer-invisibility-spec) @@ -4540,25 +4825,6 @@ The properties used on SYMBOL are `composefunc', `sendfunc', (put symbol 'hookvar (or hookvar 'mail-send-hook))) -(defun backtrace--print-frame (evald func args flags) - "Print a trace of a single stack frame to `standard-output'. -EVALD, FUNC, ARGS, FLAGS are as in `mapbacktrace'." - (princ (if (plist-get flags :debug-on-exit) "* " " ")) - (cond - ((and evald (not debugger-stack-frame-as-list)) - (prin1 func) - (if args (prin1 args) (princ "()"))) - (t - (prin1 (cons func args)))) - (princ "\n")) - -(defun backtrace () - "Print a trace of Lisp function calls currently active. -Output stream used is value of `standard-output'." - (let ((print-level (or print-level 8)) - (print-escape-control-characters t)) - (mapbacktrace #'backtrace--print-frame 'backtrace))) - (defun backtrace-frames (&optional base) "Collect all frames of current backtrace into a list. If non-nil, BASE should be a function, and frames before its @@ -4661,8 +4927,8 @@ command is called from a keyboard macro?" 'called-interactively-p-functions i frame nextframe))) (pcase skip - (`nil nil) - (`0 t) + ('nil nil) + (0 t) (_ (setq i (+ i skip -1)) (funcall get-next-frame))))))) ;; Now `frame' should be "the function from which we were called". (pcase (cons frame nextframe) @@ -4783,7 +5049,8 @@ to deactivate this transient map, regardless of KEEP-PRED." ;; MAX-VALUE ;; MESSAGE ;; MIN-CHANGE -;; MIN-TIME]) +;; MIN-TIME +;; MESSAGE-SUFFIX]) ;; ;; This weirdness is for optimization reasons: we want ;; `progress-reporter-update' to be as fast as possible, so @@ -4793,7 +5060,7 @@ to deactivate this transient map, regardless of KEEP-PRED." ;; digits of precision, it doesn't really matter here. On the other ;; hand, it greatly simplifies the code. -(defsubst progress-reporter-update (reporter &optional value) +(defsubst progress-reporter-update (reporter &optional value suffix) "Report progress of an operation in the echo area. REPORTER should be the result of a call to `make-progress-reporter'. @@ -4802,14 +5069,17 @@ If REPORTER is a numerical progress reporter---i.e. if it was `make-progress-reporter'---then VALUE should be a number between MIN-VALUE and MAX-VALUE. -If REPORTER is a non-numerical reporter, VALUE should be nil. +Optional argument SUFFIX is a string to be displayed after +REPORTER's main message and progress text. If REPORTER is a +non-numerical reporter, then VALUE should be nil, or a string to +use instead of SUFFIX. This function is relatively inexpensive. If the change since last update is too small or insufficient time has passed, it does nothing." (when (or (not (numberp value)) ; For pulsing reporter (>= value (car reporter))) ; For numerical reporter - (progress-reporter-do-update reporter value))) + (progress-reporter-do-update reporter value suffix))) (defun make-progress-reporter (message &optional min-value max-value current-value min-change min-time) @@ -4853,26 +5123,28 @@ effectively rounded up." max-value message (if min-change (max (min min-change 50) 1) 1) - min-time)))) + min-time + ;; SUFFIX + nil)))) (progress-reporter-update reporter (or current-value min-value)) reporter)) -(defun progress-reporter-force-update (reporter &optional value new-message) +(defun progress-reporter-force-update (reporter &optional value new-message suffix) "Report progress of an operation in the echo area unconditionally. -The first two arguments are the same as in `progress-reporter-update'. +REPORTER, VALUE, and SUFFIX are the same as in `progress-reporter-update'. NEW-MESSAGE, if non-nil, sets a new message for the reporter." (let ((parameters (cdr reporter))) (when new-message (aset parameters 3 new-message)) (when (aref parameters 0) (aset parameters 0 (float-time))) - (progress-reporter-do-update reporter value))) + (progress-reporter-do-update reporter value suffix))) (defvar progress-reporter--pulse-characters ["-" "\\" "|" "/"] "Characters to use for pulsing progress reporters.") -(defun progress-reporter-do-update (reporter value) +(defun progress-reporter-do-update (reporter value &optional suffix) (let* ((parameters (cdr reporter)) (update-time (aref parameters 0)) (min-value (aref parameters 1)) @@ -4881,7 +5153,7 @@ NEW-MESSAGE, if non-nil, sets a new message for the reporter." (enough-time-passed ;; See if enough time has passed since the last update. (or (not update-time) - (when (>= (float-time) update-time) + (when (time-less-p update-time nil) ;; Calculate time for the next update (aset parameters 0 (+ update-time (aref parameters 5))))))) (cond ((and min-value max-value) @@ -4907,49 +5179,86 @@ NEW-MESSAGE, if non-nil, sets a new message for the reporter." (setcar reporter (ceiling (car reporter)))) ;; Only print message if enough time has passed (when enough-time-passed - (if (> percentage 0) - (message "%s%d%%" text percentage) - (message "%s" text))))) + (if suffix + (aset parameters 6 suffix) + (setq suffix (or (aref parameters 6) ""))) + (if (> percentage 0) + (message "%s%d%% %s" text percentage suffix) + (message "%s %s" text suffix))))) ;; Pulsing indicator (enough-time-passed - (let ((index (mod (1+ (car reporter)) 4)) - (message-log-max nil)) + (when (and value (not suffix)) + (setq suffix value)) + (if suffix + (aset parameters 6 suffix) + (setq suffix (or (aref parameters 6) ""))) + (let* ((index (mod (1+ (car reporter)) 4)) + (message-log-max nil) + (pulse-char (aref progress-reporter--pulse-characters + index))) (setcar reporter index) - (message "%s %s" - text - (aref progress-reporter--pulse-characters - index))))))) + (message "%s %s %s" text pulse-char suffix)))))) (defun progress-reporter-done (reporter) "Print reporter's message followed by word \"done\" in echo area." (message "%sdone" (aref (cdr reporter) 3))) -(defmacro dotimes-with-progress-reporter (spec message &rest body) +(defmacro dotimes-with-progress-reporter (spec reporter-or-message &rest body) "Loop a certain number of times and report progress in the echo area. Evaluate BODY with VAR bound to successive integers running from 0, inclusive, to COUNT, exclusive. Then evaluate RESULT to get the return value (nil if RESULT is omitted). -At each iteration MESSAGE followed by progress percentage is -printed in the echo area. After the loop is finished, MESSAGE -followed by word \"done\" is printed. This macro is a -convenience wrapper around `make-progress-reporter' and friends. +REPORTER-OR-MESSAGE is a progress reporter object or a string. In the latter +case, use this string to create a progress reporter. + +At each iteration, print the reporter message followed by progress +percentage in the echo area. After the loop is finished, +print the reporter message followed by the word \"done\". + +This macro is a convenience wrapper around `make-progress-reporter' and friends. -\(fn (VAR COUNT [RESULT]) MESSAGE BODY...)" +\(fn (VAR COUNT [RESULT]) REPORTER-OR-MESSAGE BODY...)" (declare (indent 2) (debug ((symbolp form &optional form) form body))) - (let ((temp (make-symbol "--dotimes-temp--")) - (temp2 (make-symbol "--dotimes-temp2--")) - (start 0) - (end (nth 1 spec))) - `(let ((,temp ,end) - (,(car spec) ,start) - (,temp2 (make-progress-reporter ,message ,start ,end))) - (while (< ,(car spec) ,temp) - ,@body - (progress-reporter-update ,temp2 - (setq ,(car spec) (1+ ,(car spec))))) - (progress-reporter-done ,temp2) - nil ,@(cdr (cdr spec))))) + (let ((prep (make-symbol "--dotimes-prep--")) + (end (make-symbol "--dotimes-end--"))) + `(let ((,prep ,reporter-or-message) + (,end ,(cadr spec))) + (when (stringp ,prep) + (setq ,prep (make-progress-reporter ,prep 0 ,end))) + (dotimes (,(car spec) ,end) + ,@body + (progress-reporter-update ,prep (1+ ,(car spec)))) + (progress-reporter-done ,prep) + (or ,@(cdr (cdr spec)) nil)))) + +(defmacro dolist-with-progress-reporter (spec reporter-or-message &rest body) + "Loop over a list and report progress in the echo area. +Evaluate BODY with VAR bound to each car from LIST, in turn. +Then evaluate RESULT to get return value, default nil. + +REPORTER-OR-MESSAGE is a progress reporter object or a string. In the latter +case, use this string to create a progress reporter. + +At each iteration, print the reporter message followed by progress +percentage in the echo area. After the loop is finished, +print the reporter message followed by the word \"done\". + +\(fn (VAR LIST [RESULT]) REPORTER-OR-MESSAGE BODY...)" + (declare (indent 2) (debug ((symbolp form &optional form) form body))) + (let ((prep (make-symbol "--dolist-progress-reporter--")) + (count (make-symbol "--dolist-count--")) + (list (make-symbol "--dolist-list--"))) + `(let ((,prep ,reporter-or-message) + (,count 0) + (,list ,(cadr spec))) + (when (stringp ,prep) + (setq ,prep (make-progress-reporter ,prep 0 (1- (length ,list))))) + (dolist (,(car spec) ,list) + ,@body + (progress-reporter-update ,prep (setq ,count (1+ ,count)))) + (progress-reporter-done ,prep) + (or ,@(cdr (cdr spec)) nil)))) ;;;; Comparing version strings. @@ -5264,5 +5573,30 @@ This function is called from lisp/Makefile and leim/Makefile." (setq file (concat (substring file 1 2) ":" (substring file 2)))) file) +(defun flatten-tree (tree) + "Return a \"flattened\" copy of TREE. +In other words, return a list of the non-nil terminal nodes, or +leaves, of the tree of cons cells rooted at TREE. Leaves in the +returned list are in the same order as in TREE. + +\(flatten-tree \\='(1 (2 . 3) nil (4 5 (6)) 7)) +=> (1 2 3 4 5 6 7)" + (let (elems) + (while (consp tree) + (let ((elem (pop tree))) + (while (consp elem) + (push (cdr elem) tree) + (setq elem (car elem))) + (if elem (push elem elems)))) + (if tree (push tree elems)) + (nreverse elems))) + +;; Technically, `flatten-list' is a misnomer, but we provide it here +;; for discoverability: +(defalias 'flatten-list 'flatten-tree) + +;; The initial anchoring is for better performance in searching matches. +(defconst regexp-unmatchable "\\`a\\`" + "Standard regexp guaranteed not to match any string at all.") ;;; subr.el ends here diff --git a/lisp/svg.el b/lisp/svg.el index 1f717293358..86b56a03d56 100644 --- a/lisp/svg.el +++ b/lisp/svg.el @@ -1,10 +1,11 @@ ;;; svg.el --- SVG image creation functions -*- lexical-binding: t -*- -;; Copyright (C) 2016-2019 Free Software Foundation, Inc. +;; Copyright (C) 2014-2019 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: image -;; Version: 0.5 +;; Version: 1.0 +;; Package-Requires: ((emacs "25")) ;; This file is part of GNU Emacs. @@ -23,12 +24,41 @@ ;;; Commentary: +;; This package allows creating SVG images in Emacs. SVG images are +;; vector-based XML files, really, so you could create them directly +;; as XML. However, that's really tedious, as there are some fiddly +;; bits. + +;; In addition, the `svg-insert-image' function allows inserting an +;; SVG image into a buffer that's updated "on the fly" as you +;; add/alter elements to the image, which is useful when composing the +;; images. + +;; Here are some usage examples: + +;; Create the base image structure, add a gradient spec, and insert it +;; into the buffer: +;; +;; (setq svg (svg-create 800 800 :stroke "orange" :stroke-width 5)) +;; (svg-gradient svg "gradient" 'linear '(0 . "red") '(100 . "blue")) +;; (save-excursion (goto-char (point-max)) (svg-insert-image svg)) + +;; Then add various elements to the structure: +;; +;; (svg-rectangle svg 100 100 500 500 :gradient "gradient" :id "rec1") +;; (svg-circle svg 500 500 100 :id "circle1") +;; (svg-ellipse svg 100 100 50 90 :stroke "red" :id "ellipse1") +;; (svg-line svg 100 190 50 100 :id "line1" :stroke "yellow") +;; (svg-polyline svg '((200 . 100) (500 . 450) (80 . 100)) +;; :stroke "green" :id "poly1") +;; (svg-polygon svg '((100 . 100) (200 . 150) (150 . 90)) +;; :stroke "blue" :fill "red" :id "gon1") + ;;; Code: (require 'cl-lib) (require 'xml) (require 'dom) -(eval-when-compile (require 'subr-x)) (defun svg-create (width height &rest args) "Create a new, empty SVG image with dimensions WIDTH x HEIGHT. @@ -103,7 +133,7 @@ X/Y denote the center of the ellipse." ,@(svg--arguments svg args))))) (defun svg-line (svg x1 y1 x2 y2 &rest args) - "Create a line of starting in X1/Y1, ending at X2/Y2 in SVG." + "Create a line starting in X1/Y1, ending at X2/Y2 on SVG." (svg--append svg (dom-node 'line @@ -158,7 +188,27 @@ otherwise. IMAGE-TYPE should be a MIME image type, like (dom-node 'text `(,@(svg--arguments svg args)) - text))) + (svg--encode-text text)))) + +(defun svg--encode-text (text) + ;; Apparently the SVG renderer needs to have all non-ASCII + ;; characters encoded, and only certain special characters. + (with-temp-buffer + (insert text) + (dolist (substitution '(("&" . "&") + ("<" . "<") + (">" . ">"))) + (goto-char (point-min)) + (while (search-forward (car substitution) nil t) + (replace-match (cdr substitution) t t nil))) + (goto-char (point-min)) + (while (not (eobp)) + (let ((char (following-char))) + (if (< char 128) + (forward-char 1) + (delete-char 1) + (insert "&#" (format "%d" char) ";")))) + (buffer-string))) (defun svg--append (svg node) (let ((old (and (dom-attr node 'id) @@ -166,6 +216,9 @@ otherwise. IMAGE-TYPE should be a MIME image type, like (concat "\\`" (regexp-quote (dom-attr node 'id)) "\\'"))))) (if old + ;; FIXME: This was (dom-set-attributes old (dom-attributes node)) + ;; and got changed by commit f7ea7aa11f6211b5142bbcfc41c580d75485ca56 + ;; without any explanation. (setcdr (car old) (cdr node)) (dom-append-child svg node))) (svg-possibly-update-image svg)) @@ -265,11 +318,11 @@ If the SVG is later changed, the image will also be updated." (defun svg-remove (svg id) "Remove the element identified by ID from SVG." - (when-let* ((node (car (dom-by-id - svg - (concat "\\`" (regexp-quote id) - "\\'"))))) - (dom-remove-node svg node))) + (let* ((node (car (dom-by-id + svg + (concat "\\`" (regexp-quote id) + "\\'"))))) + (when node (dom-remove-node svg node)))) (provide 'svg) diff --git a/lisp/t-mouse.el b/lisp/t-mouse.el index bf668c385ad..14b292d4414 100644 --- a/lisp/t-mouse.el +++ b/lisp/t-mouse.el @@ -67,9 +67,6 @@ ;;;###autoload (define-minor-mode gpm-mouse-mode "Toggle mouse support in GNU/Linux consoles (GPM Mouse mode). -With a prefix argument ARG, enable GPM Mouse mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. 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. diff --git a/lisp/tabify.el b/lisp/tabify.el index 37cd8fb2fdd..e2df8fc4056 100644 --- a/lisp/tabify.el +++ b/lisp/tabify.el @@ -1,4 +1,4 @@ -;;; tabify.el --- tab conversion commands for Emacs +;;; tabify.el --- tab conversion commands for Emacs -*- lexical-binding: t -*- ;; Copyright (C) 1985, 1994, 2001-2019 Free Software Foundation, Inc. diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el index a73fa917e4b..cf777817666 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -1,4 +1,4 @@ -;;; tar-mode.el --- simple editing of tar files from GNU Emacs +;;; tar-mode.el --- simple editing of tar files from GNU Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1990-1991, 1993-2019 Free Software Foundation, Inc. @@ -95,6 +95,7 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) +(require 'arc-mode) (defgroup tar nil "Simple editing of tar files." @@ -109,8 +110,7 @@ this is the size of the *tape* blocks, but when writing to a file, it doesn't matter much. The only noticeable difference is that if a tar file does not have a blocksize of 20, tar will tell you that; all this really controls is how many null padding bytes go on the end of the tar file." - :type '(choice integer (const nil)) - :group 'tar) + :type '(choice integer (const nil))) (defcustom tar-update-datestamp nil "Non-nil means Tar mode should play fast and loose with sub-file datestamps. @@ -120,14 +120,12 @@ You may or may not want this - it is good in that you can tell when a file in a tar archive has been changed, but it is bad for the same reason that editing a file in the tar archive at all is bad - the changed version of the file never exists on disk." - :type 'boolean - :group 'tar) + :type 'boolean) (defcustom tar-mode-show-date nil "Non-nil means Tar mode should show the date/time of each subfile. This information is useful, but it takes screen space away from file names." - :type 'boolean - :group 'tar) + :type 'boolean) (defvar tar-parse-info nil) (defvar tar-superior-buffer nil @@ -265,11 +263,10 @@ write-date, checksum, link-type, and link-name." (setq name (concat (substring string tar-prefix-offset (1- (match-end 0))) "/" name))) - (if (default-value 'enable-multibyte-characters) - (setq name - (decode-coding-string name coding) - linkname - (decode-coding-string linkname coding))) + (setq name + (decode-coding-string name coding) + linkname + (decode-coding-string linkname coding)) (if (and (null link-p) (string-match "/\\'" name)) (setq link-p 5)) ; directory @@ -305,7 +302,7 @@ write-date, checksum, link-type, and link-name." (tar-parse-octal-integer string tar-uid-offset tar-gid-offset) (tar-parse-octal-integer string tar-gid-offset tar-size-offset) (tar-parse-octal-integer string tar-size-offset tar-time-offset) - (tar-parse-octal-long-integer string tar-time-offset tar-chk-offset) + (tar-parse-octal-integer string tar-time-offset tar-chk-offset) (tar-parse-octal-integer string tar-chk-offset tar-linkp-offset) link-p linkname @@ -343,20 +340,8 @@ write-date, checksum, link-type, and link-name." start (1+ start))) n))) -(defun tar-parse-octal-long-integer (string &optional start end) - (if (null start) (setq start 0)) - (if (null end) (setq end (length string))) - (if (= (aref string start) 0) - (list 0 0) - (let ((lo 0) - (hi 0)) - (while (< start end) - (if (>= (aref string start) ?0) - (setq lo (+ (* lo 8) (- (aref string start) ?0)) - hi (+ (* hi 8) (ash lo -16)) - lo (logand lo 65535))) - (setq start (1+ start))) - (list hi lo)))) +(define-obsolete-function-alias 'tar-parse-octal-long-integer + #'tar-parse-octal-integer "27.1") (defun tar-parse-octal-integer-safe (string) (if (zerop (length string)) (error "empty string")) @@ -535,30 +520,38 @@ MODE should be an integer which is a file mode value." "Extract all archive members in the tar-file into the current directory." (interactive) ;; FIXME: make it work even if we're not in tar-mode. - (let ((descriptors tar-parse-info)) ;Read the var in its buffer. - (with-current-buffer - (if (tar-data-swapped-p) tar-data-buffer (current-buffer)) - (set-buffer-multibyte nil) ;Hopefully, a no-op. - (dolist (descriptor descriptors) - (let* ((name (tar-header-name descriptor)) - (dir (if (eq (tar-header-link-type descriptor) 5) - name - (file-name-directory name))) - (link-desc (tar--describe-as-link descriptor)) - (start (tar-header-data-start descriptor)) - (end (+ start (tar-header-size descriptor)))) + (let ((data-buf (if (tar-data-swapped-p) tar-data-buffer + (current-buffer))) + (reporter (make-progress-reporter "Extracting"))) + (with-current-buffer data-buf + (cl-assert (not enable-multibyte-characters))) + (dolist (descriptor tar-parse-info) + (let* ((orig (tar-header-name descriptor)) + ;; Note that default-directory may have different values + ;; in the tar-mode and data buffers, so we stick to the + ;; absolute file name from now on. + (name (expand-file-name orig)) + (dir (if (eq (tar-header-link-type descriptor) 5) + name + (file-name-directory name))) + (link-desc (tar--describe-as-link descriptor)) + (start (tar-header-data-start descriptor)) + (end (+ start (tar-header-size descriptor)))) + (unless (file-directory-p name) + (progress-reporter-update reporter name) + (if (and dir (not (file-exists-p dir))) + (make-directory dir t)) (unless (file-directory-p name) - (message "Extracting %s" name) - (if (and dir (not (file-exists-p dir))) - (make-directory dir t)) - (unless (file-directory-p name) - (let ((coding-system-for-write 'no-conversion)) + (with-current-buffer data-buf + (let ((coding-system-for-write 'no-conversion) + (write-region-inhibit-fsync t)) (when link-desc (lwarn '(tar link) :warning "Extracted `%s', %s, as a normal file" name link-desc)) - (write-region start end name))) - (set-file-modes name (tar-header-mode descriptor)))))))) + (write-region start end name nil :nomessage))) + (set-file-modes name (tar-header-mode descriptor)))))) + (progress-reporter-done reporter))) (defun tar-summarize-buffer () "Parse the contents of the tar file in the current buffer." @@ -596,10 +589,10 @@ MODE should be an integer which is a file mode value." (progress-reporter-done progress-reporter) (message "Warning: premature EOF parsing tar file")) (goto-char (point-min)) - (let ((buffer-file-truename nil) ; avoid changing dir mtime by lock_file + (let ((create-lockfiles nil) ; avoid changing dir mtime by lock_file (inhibit-read-only t) (total-summaries - (mapconcat 'tar-header-block-summarize tar-parse-info "\n"))) + (mapconcat #'tar-header-block-summarize tar-parse-info "\n"))) (insert total-summaries "\n") (goto-char (point-min)) (restore-buffer-modified-p modified)))) @@ -733,13 +726,13 @@ See also: variables `tar-update-datestamp' and `tar-anal-blocksize'. ;; Now move the Tar data into an auxiliary buffer, so we can use the main ;; buffer for the summary. (cl-assert (not (tar-data-swapped-p))) - (set (make-local-variable 'revert-buffer-function) 'tar-mode-revert) + (set (make-local-variable 'revert-buffer-function) #'tar-mode-revert) ;; We started using write-contents-functions, but this hook is not ;; used during auto-save, so we now use ;; write-region-annotate-functions which hooks at a lower-level. - (add-hook 'write-region-annotate-functions 'tar-write-region-annotate nil t) - (add-hook 'kill-buffer-hook 'tar-mode-kill-buffer-hook nil t) - (add-hook 'change-major-mode-hook 'tar-change-major-mode-hook nil t) + (add-hook 'write-region-annotate-functions #'tar-write-region-annotate nil t) + (add-hook 'kill-buffer-hook #'tar-mode-kill-buffer-hook nil t) + (add-hook 'change-major-mode-hook #'tar-change-major-mode-hook nil t) ;; Tar data is made of bytes, not chars. (set-buffer-multibyte nil) ;Hopefully a no-op. (set (make-local-variable 'tar-data-buffer) @@ -763,24 +756,22 @@ See also: variables `tar-update-datestamp' and `tar-anal-blocksize'. (define-minor-mode tar-subfile-mode "Minor mode for editing an element of a tar-file. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. This mode arranges for \"saving\" this -buffer to write the data into the tar-file buffer that it came -from. The changes will actually appear on disk when you save the -tar-file's buffer." + +This mode arranges for \"saving\" this buffer to write the data +into the tar-file buffer that it came from. The changes will +actually appear on disk when you save the tar-file's buffer." ;; Don't do this, because it is redundant and wastes mode line space. ;; :lighter " TarFile" nil nil nil (or (and (boundp 'tar-superior-buffer) tar-superior-buffer) (error "This buffer is not an element of a tar file")) (cond (tar-subfile-mode - (add-hook 'write-file-functions 'tar-subfile-save-buffer nil t) + (add-hook 'write-file-functions #'tar-subfile-save-buffer nil t) ;; turn off auto-save. (auto-save-mode -1) (setq buffer-auto-save-file-name nil)) (t - (remove-hook 'write-file-functions 'tar-subfile-save-buffer t)))) + (remove-hook 'write-file-functions #'tar-subfile-save-buffer t)))) ;; Revert the buffer and recompute the dired-like listing. @@ -907,8 +898,7 @@ tar-file's buffer." (if (or (not coding) (eq (coding-system-type coding) 'undecided)) (setq coding (detect-coding-region start end t))) - (if (and (default-value 'enable-multibyte-characters) - (coding-system-get coding :for-unibyte)) + (if (coding-system-get coding :for-unibyte) (with-current-buffer buffer (set-buffer-multibyte nil))) (widen) @@ -947,6 +937,7 @@ tar-file's buffer." (setq buffer-file-name new-buffer-file-name) (setq buffer-file-truename (abbreviate-file-name buffer-file-name)) + (archive-try-jka-compr) ;Pretty ugly hack :-( ;; Force buffer-file-coding-system to what ;; decode-coding-region actually used. (set-buffer-file-coding-system last-coding-system-used t) @@ -1036,8 +1027,7 @@ the current tar-entry." (defun tar-new-entry (filename &optional index) "Insert a new empty regular file before point." (interactive "*sFile name: ") - (let* ((buffer (current-buffer)) - (index (or index (tar-current-position))) + (let* ((index (or index (tar-current-position))) (d-list (and (not (zerop index)) (nthcdr (+ -1 index) tar-parse-info))) (pos (if d-list @@ -1069,7 +1059,7 @@ the current tar-entry." With a prefix argument, mark that many files." (interactive "p") (beginning-of-line) - (dotimes (i (abs p)) + (dotimes (_ (abs p)) (if (tar-current-descriptor unflag) ; barf if we're not on an entry-line. (progn (delete-char 1) @@ -1280,14 +1270,8 @@ for this to be permanent." (defun tar-octal-time (timeval) - ;; Format a timestamp as 11 octal digits. Ghod, I hope this works... - (let ((hibits (car timeval)) (lobits (car (cdr timeval)))) - (format "%05o%01o%05o" - (lsh hibits -2) - (logior (lsh (logand 3 hibits) 1) - (if (> (logand lobits 32768) 0) 1 0)) - (logand 32767 lobits) - ))) + ;; Format a timestamp as 11 octal digits. + (format "%011o" (encode-time timeval 'integer))) (defun tar-subfile-save-buffer () "In tar subfile mode, save this buffer into its parent tar-file buffer. diff --git a/lisp/tempo.el b/lisp/tempo.el index 28afbec0f49..e28ef326884 100644 --- a/lisp/tempo.el +++ b/lisp/tempo.el @@ -1,11 +1,11 @@ -;;; tempo.el --- Flexible template insertion +;;; tempo.el --- Flexible template insertion -*- lexical-binding: t; -*- ;; Copyright (C) 1994-1995, 2001-2019 Free Software Foundation, Inc. ;; Author: David Kågedal <davidk@lysator.liu.se> ;; Created: 16 Feb 1994 ;; Kågedal's last version number: 1.2.4 -;; Keywords: extensions, languages, tools +;; Keywords: abbrev, extensions, languages, tools ;; This file is part of GNU Emacs. @@ -152,7 +152,7 @@ setting it to (upcase), for example.") (defvar tempo-tags nil "An association list with tags and corresponding templates.") -(defvar tempo-local-tags '((tempo-tags . nil)) +(defvar-local tempo-local-tags '((tempo-tags . nil)) "A list of locally installed tag completion lists. It is an association list where the car of every element is a symbol whose variable value is a template list. The cdr part, if non-nil, @@ -161,16 +161,16 @@ documentation for the function `tempo-complete-tag' for more info. `tempo-tags' is always in the last position in this list.") -(defvar tempo-collection nil +(defvar-local tempo-collection nil "A collection of all the tags defined for the current buffer.") -(defvar tempo-dirty-collection t +(defvar-local tempo-dirty-collection t "Indicates if the tag collection needs to be rebuilt.") -(defvar tempo-marks nil +(defvar-local tempo-marks nil "A list of marks to jump to with `\\[tempo-forward-mark]' and `\\[tempo-backward-mark]'.") -(defvar tempo-match-finder "\\b\\([[:word:]]+\\)\\=" +(defvar-local tempo-match-finder "\\b\\([[:word:]]+\\)\\=" "The regexp or function used to find the string to match against tags. If `tempo-match-finder' is a string, it should contain a regular @@ -195,23 +195,15 @@ A list of symbols which are bound to functions that take one argument. This function should return something to be sent to `tempo-insert' if it recognizes the argument, and nil otherwise.") -(defvar tempo-named-insertions nil +(defvar-local tempo-named-insertions nil "Temporary storage for named insertions.") -(defvar tempo-region-start (make-marker) +(defvar-local tempo-region-start (make-marker) "Region start when inserting around the region.") -(defvar tempo-region-stop (make-marker) +(defvar-local tempo-region-stop (make-marker) "Region stop when inserting around the region.") -;; Make some variables local to every buffer - -(make-variable-buffer-local 'tempo-marks) -(make-variable-buffer-local 'tempo-local-tags) -(make-variable-buffer-local 'tempo-match-finder) -(make-variable-buffer-local 'tempo-collection) -(make-variable-buffer-local 'tempo-dirty-collection) - ;;; Functions ;; @@ -268,11 +260,14 @@ The elements in ELEMENTS can be of several types: - `n>': Inserts a newline and indents line. - `o': Like `%' but leaves the point before the newline. - nil: It is ignored. - - Anything else: It is evaluated and the result is treated as an - element to be inserted. One additional tag is useful for these - cases. If an expression returns a list (l foo bar), the elements - after `l' will be inserted according to the usual rules. This makes - it possible to return several elements from one expression." + - Anything else: Each function in `tempo-user-elements' is called + with it as argument until one of them returns non-nil, and the + result is inserted. If all of them return nil, it is evaluated and + the result is treated as an element to be inserted. One additional + tag is useful for these cases. If an expression returns a list (l + foo bar), the elements after `l' will be inserted according to the + usual rules. This makes it possible to return several elements + from one expression." (let* ((template-name (intern (concat "tempo-template-" name))) (command-name template-name)) @@ -299,11 +294,8 @@ TEMPLATE is the template to be inserted. If ON-REGION is non-nil the mode, ON-REGION is ignored and assumed true if the region is active." (unwind-protect (progn - (if (or (and (boundp 'transient-mark-mode) ; For Emacs - transient-mark-mode - mark-active) - (if (featurep 'xemacs) - (and zmacs-regions (mark)))) + (if (or (and transient-mark-mode + mark-active)) (setq on-region t)) (and on-region (set-marker tempo-region-start (min (mark) (point))) @@ -318,9 +310,7 @@ mode, ON-REGION is ignored and assumed true if the region is active." (tempo-insert-mark (point-marker))) (tempo-forward-mark)) (tempo-forget-insertions) - ;; Should I check for zmacs here too??? - (and (boundp 'transient-mark-mode) - transient-mark-mode + (and transient-mark-mode (deactivate-mark)))) ;;; diff --git a/lisp/term.el b/lisp/term.el index 5ace5e341d0..77fbb1d0915 100644 --- a/lisp/term.el +++ b/lisp/term.el @@ -1,4 +1,4 @@ -;;; term.el --- general command interpreter in a window stuff +;;; term.el --- general command interpreter in a window stuff -*- lexical-binding: t -*- ;; Copyright (C) 1988, 1990, 1992, 1994-1995, 2001-2019 Free Software ;; Foundation, Inc. @@ -108,12 +108,9 @@ ;; ;; ---------------------------------------- ;; -;; ANSI colorization should work well, I've decided to limit the interpreter -;; to five outstanding commands (like ESC [ 01;04;32;41;07m. -;; You shouldn't need more, if you do, tell me and I'll increase it. It's -;; so easy you could do it yourself... ;; -;; Blink, is not supported. Currently it's mapped as bold. +;; ANSI colorization should work well. Blink, is not supported. +;; Currently it's mapped as bold. ;; ;; ---------------------------------------- ;; @@ -357,28 +354,31 @@ contains saved term-home-marker from original sub-buffer.") "Current vertical row (relative to home-marker) or nil if unknown.") (defvar term-insert-mode nil) (defvar term-vertical-motion) -(defvar term-terminal-state 0 - "State of the terminal emulator: -state 0: Normal state -state 1: Last character was a graphic in the last column. +(defvar term-do-line-wrapping nil + "Last character was a graphic in the last column. If next char is graphic, first move one column right \(and line warp) before displaying it. -This emulates (more or less) the behavior of xterm. -state 2: seen ESC -state 3: seen ESC [ (or ESC [ ?) -state 4: term-terminal-parameter contains pending output.") +This emulates (more or less) the behavior of xterm.") (defvar term-kill-echo-list nil "A queue of strings whose echo we want suppressed.") -(defvar term-terminal-parameter) (defvar term-terminal-undecoded-bytes nil) -(defvar term-terminal-previous-parameter) (defvar term-current-face 'term) -(defvar term-scroll-start 0 "Top-most line (inclusive) of scrolling region.") -(defvar term-scroll-end) ; Number of line (zero-based) after scrolling region. +(defvar-local term-scroll-start 0 + "Top-most line (inclusive) of the scrolling region. +`term-scroll-start' must be in the range [0,term-height). In addition, its +value has to be smaller than `term-scroll-end', i.e. one line scroll regions are +not allowed.") +(defvar-local term-scroll-end nil + "Bottom-most line (inclusive) of the scrolling region. +`term-scroll-end' must be in the range [0,term-height). In addition, its +value has to be greater than `term-scroll-start', i.e. one line scroll regions are +not allowed.") (defvar term-pager-count nil "Number of lines before we need to page; if nil, paging is disabled.") (defvar term-saved-cursor nil) -(defvar term-command-hook) +(define-obsolete-variable-alias 'term-command-hook + 'term-command-function "27.1") +(defvar term-command-function #'term-command-hook) (defvar term-log-buffer nil) (defvar term-scroll-with-delete nil "If t, forward scrolling should be implemented by delete to @@ -517,6 +517,8 @@ This means text can automatically reflow if the window is resized." :version "24.4" :type 'boolean :group 'term) +(make-obsolete-variable 'term-suppress-hard-newline nil + "27.1") ;; Where gud-display-frame should put the debugging arrow. This is ;; set by the marker-filter, which scans the debugger's output for @@ -551,16 +553,13 @@ These functions get one argument, a string containing the text to send. This variable is buffer-local.") -(defvar term-input-sender (function term-simple-send) +(defvar term-input-sender #'term-simple-send "Function to actually send to PROCESS the STRING submitted by user. Usually this is just `term-simple-send', but if your mode needs to massage the input string, this is your hook. This is called from the user command `term-send-input'. `term-simple-send' just sends the string plus a newline.") -(defvar term-partial-ansi-terminal-message nil - "Keep partial ansi terminal messages for future processing.") - (defcustom term-eol-on-send t "Non-nil means go to the end of the line before sending input. See `term-send-input'." @@ -718,12 +717,6 @@ Buffer local variable.") (defvar term-ansi-current-reverse nil) (defvar term-ansi-current-invisible nil) -;; Four should be enough, if you want more, just add. -mm -(defvar term-terminal-more-parameters 0) -(defvar term-terminal-previous-parameter-2 -1) -(defvar term-terminal-previous-parameter-3 -1) -(defvar term-terminal-previous-parameter-4 -1) - ;;; Faces (defvar ansi-term-color-vector [term @@ -1012,13 +1005,11 @@ Entry to this mode runs the hooks on `term-mode-hook'." (setq indent-tabs-mode nil) (setq buffer-display-table term-display-table) (set (make-local-variable 'term-home-marker) (copy-marker 0)) - (set (make-local-variable 'term-height) (window-text-height)) + (set (make-local-variable 'term-height) (floor (window-screen-lines))) (set (make-local-variable 'term-width) (window-max-chars-per-line)) (set (make-local-variable 'term-last-input-start) (make-marker)) (set (make-local-variable 'term-last-input-end) (make-marker)) (set (make-local-variable 'term-last-input-match) "") - (set (make-local-variable 'term-command-hook) - (symbol-function 'term-command-hook)) ;; These local variables are set to their local values: (make-local-variable 'term-saved-home-marker) @@ -1045,8 +1036,6 @@ Entry to this mode runs the hooks on `term-mode-hook'." (make-local-variable 'ange-ftp-default-password) (make-local-variable 'ange-ftp-generate-anonymous-password) - (make-local-variable 'term-partial-ansi-terminal-message) - ;; You may want to have different scroll-back sizes -mm (make-local-variable 'term-buffer-maximum-size) @@ -1059,42 +1048,30 @@ Entry to this mode runs the hooks on `term-mode-hook'." (make-local-variable 'term-ansi-current-reverse) (make-local-variable 'term-ansi-current-invisible) - (make-local-variable 'term-terminal-parameter) (make-local-variable 'term-terminal-undecoded-bytes) - (make-local-variable 'term-terminal-previous-parameter) - (make-local-variable 'term-terminal-previous-parameter-2) - (make-local-variable 'term-terminal-previous-parameter-3) - (make-local-variable 'term-terminal-previous-parameter-4) - (make-local-variable 'term-terminal-more-parameters) - (make-local-variable 'term-terminal-state) + (make-local-variable 'term-do-line-wrapping) (make-local-variable 'term-kill-echo-list) (make-local-variable 'term-start-line-column) (make-local-variable 'term-current-column) (make-local-variable 'term-current-row) (make-local-variable 'term-log-buffer) - (make-local-variable 'term-scroll-start) - (set (make-local-variable 'term-scroll-end) term-height) - (make-local-variable 'term-scroll-with-delete) (make-local-variable 'term-pager-count) (make-local-variable 'term-pager-old-local-map) (make-local-variable 'term-old-mode-map) (make-local-variable 'term-insert-mode) - (make-local-variable 'term-dynamic-complete-functions) (make-local-variable 'term-completion-fignore) (make-local-variable 'term-get-old-input) (make-local-variable 'term-matching-input-from-input-string) (make-local-variable 'term-input-autoexpand) (make-local-variable 'term-input-ignoredups) (make-local-variable 'term-delimiter-argument-list) - (make-local-variable 'term-input-filter-functions) (make-local-variable 'term-input-filter) (make-local-variable 'term-input-sender) (make-local-variable 'term-eol-on-send) (make-local-variable 'term-scroll-to-bottom-on-output) (make-local-variable 'term-scroll-show-maximum-output) (make-local-variable 'term-ptyp) - (make-local-variable 'term-exec-hook) (set (make-local-variable 'term-vertical-motion) 'vertical-motion) (set (make-local-variable 'term-pending-delete-marker) (make-marker)) (make-local-variable 'term-current-face) @@ -1106,6 +1083,9 @@ Entry to this mode runs the hooks on `term-mode-hook'." (set (make-local-variable 'font-lock-defaults) '(nil t)) (add-function :filter-return + (local 'filter-buffer-substring-function) + #'term--filter-buffer-substring) + (add-function :filter-return (local 'window-adjust-process-window-size-function) (lambda (size) (when size @@ -1115,28 +1095,76 @@ Entry to this mode runs the hooks on `term-mode-hook'." (add-hook 'read-only-mode-hook #'term-line-mode-buffer-read-only-update nil t) + (term--reset-scroll-region) + (easy-menu-add term-terminal-menu) (easy-menu-add term-signals-menu) (or term-input-ring (setq term-input-ring (make-ring term-input-ring-size))) (term-update-mode-line)) +(defun term--remove-fake-newlines () + (goto-char (point-min)) + (let (fake-newline) + (while (setq fake-newline (next-single-property-change (point) + 'term-line-wrap)) + (goto-char fake-newline) + (cl-assert (eq ?\n (char-after))) + (let ((inhibit-read-only t)) + (delete-char 1))))) + +(defun term--last-line () + (1- term-height)) + +(defun term--filter-buffer-substring (content) + (with-temp-buffer + (insert content) + (term--remove-fake-newlines) + (buffer-string))) + +(defun term--unwrap-visible-long-lines (width) + ;; Unwrap lines longer than width using fake newlines. Only do it + ;; for lines that are currently visible (i.e. following the home + ;; marker). Invisible lines don't have to be unwrapped since they + ;; are unreachable using the cursor movement anyway. Not having to + ;; unwrap the entire buffer means the runtime of this function is + ;; bounded by the size of the screen instead of the buffer size. + + (save-excursion + ;; We will just assume that our accounting for the home marker is + ;; correct, i.e. programs will not try to reach any position + ;; earlier than this marker. + (goto-char term-home-marker) + + (move-to-column width) + (while (not (eobp)) + (if (eolp) + (forward-char) + (let ((inhibit-read-only t)) + (term-unwrap-line))) + (move-to-column width)))) + (defun term-reset-size (height width) (when (or (/= height term-height) (/= width term-width)) + ;; Delete all newlines used for wrapping + (when (/= width term-width) + (save-excursion + (term--remove-fake-newlines))) (let ((point (point))) (setq term-height height) (setq term-width width) (setq term-start-line-column nil) (setq term-current-row nil) (setq term-current-column nil) - (term-set-scroll-region 0 height) + (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). (setq term-start-line-column nil) (setq term-current-row nil) (setq term-current-column nil) - (goto-char point)))) + (goto-char point)) + (term--unwrap-visible-long-lines width))) ;; Recursive routine used to check if any string in term-kill-echo-list ;; matches part of the buffer before point. @@ -1269,16 +1297,14 @@ intervention from Emacs, except for the escape character (usually C-c)." (add-hook 'post-command-hook #'term-goto-process-mark-maybe nil t) ;; Send existing partial line to inferior (without newline). - (let ((pmark (process-mark (get-buffer-process (current-buffer)))) - (save-input-sender term-input-sender)) + (let ((pmark (process-mark (get-buffer-process (current-buffer))))) (when (> (point) pmark) (unwind-protect (progn - (setq term-input-sender - (symbol-function 'term-send-string)) + (add-function :override term-input-sender #'term-send-string) (end-of-line) (term-send-input)) - (setq term-input-sender save-input-sender)))) + (remove-function term-input-sender #'term-send-string)))) (term-update-mode-line))) (defun term-line-mode () @@ -1408,8 +1434,8 @@ buffer. The hook `term-exec-hook' is run after each exec." ;; Jump to the end, and set the process mark. (goto-char (point-max)) (set-marker (process-mark proc) (point)) - (set-process-filter proc 'term-emulate-terminal) - (set-process-sentinel proc 'term-sentinel) + (set-process-filter proc #'term-emulate-terminal) + (set-process-sentinel proc #'term-sentinel) ;; Feed it the startfile. (when startfile ;;This is guaranteed to wait long enough @@ -1538,7 +1564,7 @@ Nil if unknown.") (when (term--bash-needs-EMACSp) (push (format "EMACS=%s (term:%s)" emacs-version term-protocol-version) process-environment)) - (apply 'start-process name buffer + (apply #'start-process name buffer "/bin/sh" "-c" (format "stty -nl echo rows %d columns %d sane 2>/dev/null;\ if [ $1 = .. ]; then shift; fi; exec \"$@\"" @@ -1941,8 +1967,8 @@ A useful command to bind to SPC. See `term-replace-by-expanded-history'." (defun term-within-quotes (beg end) "Return t if the number of quotes between BEG and END is odd. Quotes are single and double." - (let ((countsq (term-how-many-region "\\(^\\|[^\\\\]\\)'" beg end)) - (countdq (term-how-many-region "\\(^\\|[^\\\\]\\)\"" beg end))) + (let ((countsq (term-how-many-region "\\(^\\|[^\\]\\)'" beg end)) + (countdq (term-how-many-region "\\(^\\|[^\\]\\)\"" beg end))) (or (= (mod countsq 2) 1) (= (mod countdq 2) 1)))) (defun term-how-many-region (regexp beg end) @@ -2032,7 +2058,7 @@ Argument 0 is the command name." (let ((n (or nth (1- count))) (m (if mth (1- (- count mth)) 0))) (mapconcat - (function (lambda (a) a)) (nthcdr n (nreverse (nthcdr m args))) " ")))) + #'identity (nthcdr n (nreverse (nthcdr m args))) " ")))) ;;; ;;; Input processing stuff [line mode] @@ -2112,10 +2138,7 @@ Similarly for Soar, Scheme, etc." (not (string-equal (ring-ref term-input-ring 0) history)))) (ring-insert term-input-ring history)) - (let ((functions term-input-filter-functions)) - (while functions - (funcall (car functions) (concat input "\n")) - (setq functions (cdr functions)))) + (run-hook-with-args 'term-input-filter-functions (concat input "\n")) (setq term-input-ring-index nil) ;; Update the markers before we send the input @@ -2205,6 +2228,7 @@ filter and C-g is pressed, this function returns nil rather than a string). Note that the keystrokes comprising the text can still be recovered \(temporarily) with \\[view-lossage]. This may be a security bug for some applications." + (declare (obsolete read-passwd "27.1")) (let ((ans "") (c 0) (echo-keystrokes 0) @@ -2664,10 +2688,8 @@ See `term-prompt-regexp'." (cond (term-current-column) ((setq term-current-column (current-column))))) -;; Move DELTA column right (or left if delta < 0 limiting at column 0). - -(defun term-move-columns (delta) - (setq term-current-column (max 0 (+ (term-current-column) delta))) +(defun term-move-to-column (column) + (setq term-current-column column) (let ((point-at-eol (line-end-position))) (move-to-column term-current-column t) ;; If move-to-column extends the current line it will use the face @@ -2676,6 +2698,11 @@ See `term-prompt-regexp'." (when (> (point) point-at-eol) (put-text-property point-at-eol (point) 'font-lock-face 'default)))) +;; Move DELTA column right (or left if delta < 0 limiting at column 0). +(defun term-move-columns (delta) + (term-move-to-column + (max 0 (+ (term-current-column) delta)))) + ;; Insert COUNT copies of CHAR in the default face. (defun term-insert-char (char count) (let ((old-point (point))) @@ -2708,11 +2735,6 @@ See `term-prompt-regexp'." ;;difference ;-) -mm (defun term-handle-ansi-terminal-messages (message) - ;; Handle stored partial message - (when term-partial-ansi-terminal-message - (setq message (concat term-partial-ansi-terminal-message message)) - (setq term-partial-ansi-terminal-message nil)) - ;; Is there a command here? (while (string-match "\eAnSiT.+\n" message) ;; Extract the command code and the argument. @@ -2763,11 +2785,6 @@ See `term-prompt-regexp'." (setq ange-ftp-default-user nil) (setq ange-ftp-default-password nil) (setq ange-ftp-generate-anonymous-password nil))))) - ;; If there is a partial message at the end of the string, store it - ;; for future use. - (when (string-match "\eAnSiT.+$" message) - (setq term-partial-ansi-terminal-message (match-string 0 message)) - (setq message (replace-match "" t t message))) message) @@ -2775,27 +2792,42 @@ See `term-prompt-regexp'." ;; This is the standard process filter for term buffers. ;; It emulates (most of the features of) a VT100/ANSI-style terminal. +;; References: +;; [ctlseqs]: http://invisible-island.net/xterm/ctlseqs/ctlseqs.html +;; [ECMA-48]: http://www.ecma-international.org/publications/standards/Ecma-048.htm +;; [vt100]: https://vt100.net/docs/vt100-ug/chapter3.html + +(defconst term-control-seq-regexp + (concat + ;; A control character, + "\\(?:[\r\n\000\007\t\b\016\017]\\|" + ;; some Emacs specific control sequences, implemented by + ;; `term-command-hook', + "\032[^\n]+\r?\n\\|" + ;; a C1 escape coded character (see [ECMA-48] section 5.3 "Elements + ;; of the C1 set"), + "\e\\(?:[DM78c]\\|" + ;; another Emacs specific control sequence, + "AnSiT[^\n]+\r?\n\\|" + ;; or an escape sequence (section 5.4 "Control Sequences"), + "\\[\\([\x30-\x3F]*\\)[\x20-\x2F]*[\x40-\x7E]\\)\\)") + "Regexp matching control sequences handled by term.el.") + +(defconst term-control-seq-prefix-regexp + "[\032\e]") + (defun term-emulate-terminal (proc str) (with-current-buffer (process-buffer proc) - (let* ((i 0) char funny - count ; number of decoded chars in substring - count-bytes ; number of bytes + (let* ((i 0) funny decoded-substring - save-point save-marker old-point temp win + save-point save-marker win (inhibit-read-only t) (buffer-undo-list t) (selected (selected-window)) last-win - handled-ansi-message (str-length (length str))) (save-selected-window - (let ((newstr (term-handle-ansi-terminal-messages str))) - (unless (eq str newstr) - (setq handled-ansi-message t - str newstr))) - (setq str-length (length str)) - (when (marker-buffer term-pending-delete-marker) ;; Delete text following term-pending-delete-marker. (delete-region term-pending-delete-marker (process-mark proc)) @@ -2825,299 +2857,225 @@ See `term-prompt-regexp'." (setq str (concat term-terminal-undecoded-bytes str)) (setq str-length (length str)) (setq term-terminal-undecoded-bytes nil)) - (cond ((eq term-terminal-state 4) ;; Have saved pending output. - (setq str (concat term-terminal-parameter str)) - (setq term-terminal-parameter nil) - (setq str-length (length str)) - (setq term-terminal-state 0))) - - (while (< i str-length) - (setq char (aref str i)) - (cond ((< term-terminal-state 2) - ;; Look for prefix of regular chars - (setq funny - (string-match "[\r\n\000\007\033\t\b\032\016\017]" - str i)) - (when (not funny) (setq funny str-length)) - (cond ((> funny i) - (cond ((eq term-terminal-state 1) - ;; We are in state 1, we need to wrap - ;; around. Go to the beginning of - ;; the next line and switch to state - ;; 0. - (term-down 1 t) - (term-move-columns (- (term-current-column))) - (setq term-terminal-state 0))) - ;; Decode the string before counting - ;; characters, to avoid garbling of certain - ;; multibyte characters (bug#1006). - (setq decoded-substring - (decode-coding-string - (substring str i funny) - locale-coding-system)) - (setq count (length decoded-substring)) - ;; Check for multibyte characters that ends - ;; before end of string, and save it for - ;; next time. - (when (= funny str-length) - (let ((partial 0)) - (while (and (< partial count) - (eq (char-charset (aref decoded-substring - (- count 1 partial))) - 'eight-bit)) - (cl-incf partial)) - (when (> count partial 0) - (setq term-terminal-undecoded-bytes - (substring decoded-substring (- partial))) - (setq decoded-substring - (substring decoded-substring 0 (- partial))) - (cl-decf str-length partial) - (cl-decf count partial) - (cl-decf funny partial)))) - (setq temp (- (+ (term-horizontal-column) count) - term-width)) - (cond ((or term-suppress-hard-newline (<= temp 0))) - ;; All count chars fit in line. - ((> count temp) ;; Some chars fit. - ;; This iteration, handle only what fits. - (setq count (- count temp)) - (setq count-bytes - (length - (encode-coding-string - (substring decoded-substring 0 count) - 'binary))) - (setq temp 0) - (setq funny (+ count-bytes i))) - ((or (not (or term-pager-count - term-scroll-with-delete)) - (> (term-handle-scroll 1) 0)) - (term-adjust-current-row-cache 1) - (setq count (min count term-width)) - (setq count-bytes - (length - (encode-coding-string - (substring decoded-substring 0 count) - 'binary))) - (setq funny (+ count-bytes i)) - (setq term-start-line-column - term-current-column)) - (t ;; Doing PAGER processing. - (setq count 0 funny i) - (setq term-current-column nil) - (setq term-start-line-column nil))) - (setq old-point (point)) - - ;; Insert a string, check how many columns - ;; we moved, then delete that many columns - ;; following point if not eob nor insert-mode. - (let ((old-column (current-column)) - columns pos) - (insert (decode-coding-string (substring str i funny) locale-coding-system)) - (setq term-current-column (current-column) - columns (- term-current-column old-column)) - (when (not (or (eobp) term-insert-mode)) - (setq pos (point)) - (term-move-columns columns) - (delete-region pos (point))) - ;; In insert mode if the current line - ;; has become too long it needs to be - ;; chopped off. - (when term-insert-mode - (setq pos (point)) - (end-of-line) - (when (> (current-column) term-width) - (delete-region (- (point) (- (current-column) term-width)) - (point))) - (goto-char pos))) - (setq term-current-column nil) - - (put-text-property old-point (point) - 'font-lock-face term-current-face) - ;; If the last char was written in last column, - ;; back up one column, but remember we did so. - ;; Thus we emulate xterm/vt100-style line-wrapping. - (cond ((eq temp 0) - (term-move-columns -1) - (setq term-terminal-state 1))) - (setq i (1- funny))) - ((and (setq term-terminal-state 0) - (eq char ?\^I)) ; TAB (terminfo: ht) - (setq count (term-current-column)) - ;; The line cannot exceed term-width. TAB at - ;; the end of a line should not cause wrapping. - (setq count (min term-width - (+ count 8 (- (mod count 8))))) - (if (> term-width count) - (progn - (term-move-columns - (- count (term-current-column))) - (setq term-current-column count)) - (when (> term-width (term-current-column)) - (term-move-columns - (1- (- term-width (term-current-column))))) - (when (= term-width (term-current-column)) - (term-move-columns -1)))) - ((eq char ?\r) ;; (terminfo: cr) - (term-vertical-motion 0) - (setq term-current-column term-start-line-column)) - ((eq char ?\n) ;; (terminfo: cud1, ind) - (unless (and term-kill-echo-list - (term-check-kill-echo-list)) - (term-down 1 t))) - ((eq char ?\b) ;; (terminfo: cub1) - (term-move-columns -1)) - ((eq char ?\033) ; Escape - (setq term-terminal-state 2)) - ((eq char 0)) ; NUL: Do nothing - ((eq char ?\016)) ; Shift Out - ignored - ((eq char ?\017)) ; Shift In - ignored - ((eq char ?\^G) ;; (terminfo: bel) - (beep t)) - ((eq char ?\032) - (let ((end (string-match "\r?\n" str i))) - (if end - (progn - (unless handled-ansi-message - (funcall term-command-hook - (decode-coding-string - (substring str (1+ i) end) - locale-coding-system))) - (setq i (1- (match-end 0)))) - (setq term-terminal-parameter (substring str i)) - (setq term-terminal-state 4) - (setq i str-length)))) - (t ; insert char FIXME: Should never happen - (term-move-columns 1) - (backward-delete-char 1) - (insert char)))) - ((eq term-terminal-state 2) ; Seen Esc - (cond ((eq char ?\133) ;; ?\133 = ?[ - - ;; Some modifications to cope with multiple - ;; settings like ^[[01;32;43m -mm - ;; Note that now the init value of - ;; term-terminal-previous-parameter has been - ;; changed to -1 - - (setq term-terminal-parameter 0) - (setq term-terminal-previous-parameter -1) - (setq term-terminal-previous-parameter-2 -1) - (setq term-terminal-previous-parameter-3 -1) - (setq term-terminal-previous-parameter-4 -1) - (setq term-terminal-more-parameters 0) - (setq term-terminal-state 3)) - ((eq char ?D) ;; scroll forward - (term-handle-deferred-scroll) - (term-down 1 t) - (setq term-terminal-state 0)) - ;; ((eq char ?E) ;; (terminfo: nw), not used for - ;; ;; now, but this is a working - ;; ;; implementation - ;; (term-down 1) - ;; (term-goto term-current-row 0) - ;; (setq term-terminal-state 0)) - ((eq char ?M) ;; scroll reversed (terminfo: ri) - (if (or (< (term-current-row) term-scroll-start) - (>= (1- (term-current-row)) - term-scroll-start)) - ;; Scrolling up will not move outside - ;; the scroll region. - (term-down -1) - ;; Scrolling the scroll region is needed. - (term-down -1 t)) - (setq term-terminal-state 0)) - ((eq char ?7) ;; Save cursor (terminfo: sc) - (term-handle-deferred-scroll) - (setq term-saved-cursor - (list (term-current-row) - (term-horizontal-column) - term-ansi-current-bg-color - term-ansi-current-bold - term-ansi-current-color - term-ansi-current-invisible - term-ansi-current-reverse - term-ansi-current-underline - term-current-face) - ) - (setq term-terminal-state 0)) - ((eq char ?8) ;; Restore cursor (terminfo: rc) - (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))) - (setq term-terminal-state 0)) - ((eq char ?c) ;; \Ec - Reset (terminfo: rs1) - ;; This is used by the "clear" program. - (setq term-terminal-state 0) - (term-reset-terminal)) - ;; The \E#8 reset sequence for xterm. We - ;; probably don't need to handle it, but this - ;; is the code to parse it. - ;; ((eq char ?#) - ;; (when (eq (aref str (1+ i)) ?8) - ;; (setq i (1+ i)) - ;; (setq term-scroll-start 0) - ;; (setq term-scroll-end term-height) - ;; (setq term-terminal-state 0))) - ((setq term-terminal-state 0)))) - ((eq term-terminal-state 3) ; Seen Esc [ - (cond ((and (>= char ?0) (<= char ?9)) - (setq term-terminal-parameter - (+ (* 10 term-terminal-parameter) (- char ?0)))) - ((eq char ?\;) - ;; Some modifications to cope with multiple - ;; settings like ^[[01;32;43m -mm - (setq term-terminal-more-parameters 1) - (setq term-terminal-previous-parameter-4 - term-terminal-previous-parameter-3) - (setq term-terminal-previous-parameter-3 - term-terminal-previous-parameter-2) - (setq term-terminal-previous-parameter-2 - term-terminal-previous-parameter) - (setq term-terminal-previous-parameter - term-terminal-parameter) - (setq term-terminal-parameter 0)) - ((eq char ??)) ; Ignore ? - (t - (term-handle-ansi-escape proc char) - (setq term-terminal-more-parameters 0) - (setq term-terminal-previous-parameter-4 -1) - (setq term-terminal-previous-parameter-3 -1) - (setq term-terminal-previous-parameter-2 -1) - (setq term-terminal-previous-parameter -1) - (setq term-terminal-state 0))))) - (when (term-handling-pager) - ;; Finish stuff to get ready to handle PAGER. - (if (> (% (current-column) term-width) 0) - (setq term-terminal-parameter - (substring str i)) - ;; We're at column 0. Goto end of buffer; to compensate, - ;; prepend a ?\r for later. This looks more consistent. - (if (zerop i) - (setq term-terminal-parameter - (concat "\r" (substring str i))) - (setq term-terminal-parameter (substring str (1- i))) - (aset term-terminal-parameter 0 ?\r)) - (goto-char (point-max))) - (setq term-terminal-state 4) - (make-local-variable 'term-pager-old-filter) - (setq term-pager-old-filter (process-filter proc)) - (set-process-filter proc term-pager-filter) - (setq i str-length)) - (setq i (1+ i)))) + + (while (< i str-length) + (setq funny (string-match term-control-seq-regexp str i)) + (let ((ctl-params (and funny (match-string 1 str))) + (ctl-params-end (and funny (match-end 1))) + (ctl-end (if funny (match-end 0) + (setq funny (string-match term-control-seq-prefix-regexp str i)) + (if funny + (setq term-terminal-undecoded-bytes + (substring str funny)) + (setq funny str-length)) + ;; The control sequence ends somewhere + ;; past the end of this string. + (1+ str-length)))) + (when (> funny i) + (when term-do-line-wrapping + (term-down 1 t) + (term-move-to-column 0) + (setq term-do-line-wrapping nil)) + ;; Handle non-control data. Decode the string before + ;; counting characters, to avoid garbling of certain + ;; multibyte characters (bug#1006). + (setq decoded-substring + (decode-coding-string + (substring str i funny) + locale-coding-system t)) + ;; Check for multibyte characters that ends + ;; before end of string, and save it for + ;; next time. + (when (= funny str-length) + (let ((partial 0) + (count (length decoded-substring))) + (while (and (< partial count) + (eq (char-charset (aref decoded-substring + (- count 1 partial))) + 'eight-bit)) + (cl-incf partial)) + (when (> count partial 0) + (setq term-terminal-undecoded-bytes + (substring decoded-substring (- partial))) + (setq decoded-substring + (substring decoded-substring 0 (- partial))) + (cl-decf str-length partial) + (cl-decf funny partial)))) + + ;; Insert a string, check how many columns + ;; we moved, then delete that many columns + ;; following point if not eob nor insert-mode. + (let ((old-column (term-horizontal-column)) + (old-point (point)) + columns) + (unless term-suppress-hard-newline + (while (> (+ (length decoded-substring) old-column) + term-width) + (insert (substring decoded-substring 0 + (- term-width old-column))) + ;; Since we've enough text to fill the whole line, + ;; delete previous text regardless of + ;; `term-insert-mode's value. + (delete-region (point) (line-end-position)) + (term-down 1 t) + (term-move-columns (- (term-current-column))) + (add-text-properties (1- (point)) (point) + '(term-line-wrap t rear-nonsticky t)) + (setq decoded-substring + (substring decoded-substring (- term-width old-column))) + (setq old-column 0))) + (insert decoded-substring) + (setq term-current-column (current-column) + columns (- term-current-column old-column)) + (when (not (or (eobp) term-insert-mode)) + (let ((pos (point))) + (term-move-columns columns) + (delete-region pos (point)) + (setq term-current-column nil))) + ;; In insert mode if the current line + ;; has become too long it needs to be + ;; chopped off. + (when term-insert-mode + (let ((pos (point))) + (end-of-line) + (when (> (current-column) term-width) + (delete-region (- (point) (- (current-column) term-width)) + (point))) + (goto-char pos))) + + (put-text-property old-point (point) + 'font-lock-face term-current-face)) + ;; If the last char was written in last column, + ;; back up one column, but remember we did so. + ;; Thus we emulate xterm/vt100-style line-wrapping. + (when (eq (term-current-column) term-width) + (term-move-columns -1) + ;; We check after ctrl sequence handling if point + ;; was moved (and leave line-wrapping state if so). + (setq term-do-line-wrapping (point))) + (setq term-current-column nil) + (setq i funny)) + (pcase-exhaustive (and (<= ctl-end str-length) (aref str i)) + (?\t ;; TAB (terminfo: ht) + ;; The line cannot exceed term-width. TAB at + ;; the end of a line should not cause wrapping. + (let ((col (term-current-column))) + (term-move-to-column + (min (1- term-width) + (+ col 8 (- (mod col 8))))))) + (?\r ;; (terminfo: cr) + (term-vertical-motion 0) + (setq term-current-column term-start-line-column)) + (?\n ;; (terminfo: cud1, ind) + (unless (and term-kill-echo-list + (term-check-kill-echo-list)) + (term-down 1 t))) + (?\b ;; (terminfo: cub1) + (term-move-columns -1)) + (?\C-g ;; (terminfo: bel) + (beep t)) + (?\032 ; Emacs specific control sequence. + (funcall term-command-function + (decode-coding-string + (substring str (1+ i) + (- ctl-end + (if (eq (aref str (- ctl-end 2)) ?\r) + 2 1))) + locale-coding-system t))) + (?\e + (pcase (aref str (1+ i)) + (?\[ + ;; We only handle control sequences with a single + ;; "Final" byte (see [ECMA-48] section 5.4). + (when (eq ctl-params-end (1- ctl-end)) + (term-handle-ansi-escape + proc + (mapcar ;; We don't distinguish empty params + ;; from 0 (according to [ECMA-48] we + ;; should, but all commands we support + ;; default to 0 values anyway). + #'string-to-number + (split-string ctl-params ";")) + (aref str (1- ctl-end))))) + (?D ;; Scroll forward (apparently not documented in + ;; [ECMA-48], [ctlseqs] mentions it as C1 + ;; character "Index" though). + (term-handle-deferred-scroll) + (term-down 1 t)) + (?M ;; Scroll reversed (terminfo: ri, ECMA-48 + ;; "Reverse Linefeed"). + (if (or (< (term-current-row) term-scroll-start) + (>= (1- (term-current-row)) + term-scroll-start)) + ;; Scrolling up will not move outside + ;; the scroll region. + (term-down -1) + ;; Scrolling the scroll region is needed. + (term-down -1 t))) + (?7 ;; Save cursor (terminfo: sc, not in [ECMA-48], + ;; [ctlseqs] has it as "DECSC"). + (term-handle-deferred-scroll) + (setq term-saved-cursor + (list (term-current-row) + (term-horizontal-column) + term-ansi-current-bg-color + term-ansi-current-bold + 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)))) + (?c ;; \Ec - Reset (terminfo: rs1, [ctlseqs] "RIS"). + ;; This is used by the "clear" program. + (term-reset-terminal)) + (?A ;; An \eAnSiT sequence (Emacs specific). + (term-handle-ansi-terminal-messages + (substring str i ctl-end))))) + ;; Ignore NUL, Shift Out, Shift In. + ((or ?\0 #xE #xF 'nil) nil)) + ;; Leave line-wrapping state if point was moved. + (unless (eq term-do-line-wrapping (point)) + (setq term-do-line-wrapping nil)) + (if (term-handling-pager) + (progn + ;; Finish stuff to get ready to handle PAGER. + (if (> (% (current-column) term-width) 0) + (setq term-terminal-undecoded-bytes + (substring str i)) + ;; We're at column 0. Goto end of buffer; to compensate, + ;; prepend a ?\r for later. This looks more consistent. + (if (zerop i) + (setq term-terminal-undecoded-bytes + (concat "\r" (substring str i))) + (setq term-terminal-undecoded-bytes (substring str (1- i))) + (aset term-terminal-undecoded-bytes 0 ?\r)) + (goto-char (point-max))) + ;; FIXME: Use (add-function :override (process-filter proc) + (make-local-variable 'term-pager-old-filter) + (setq term-pager-old-filter (process-filter proc)) + ;; FIXME: Where is `term-pager-filter' set to a function?! + (set-process-filter proc term-pager-filter) + (setq i str-length)) + (setq i ctl-end))))) (when (>= (term-current-row) term-height) (term-handle-deferred-scroll)) @@ -3231,7 +3189,7 @@ option is enabled. See `term-set-goto-process-mark'." (goto-char term-home-marker) (term-vertical-motion (1+ count)) (set-marker term-home-marker (point)) - (setq term-current-row (1- term-height)))))) + (setq term-current-row (term--last-line)))))) (defun term-reset-terminal () "Reset the terminal, delete all the content and set the face to the default one." @@ -3239,8 +3197,7 @@ option is enabled. See `term-set-goto-process-mark'." (term-ansi-reset) (setq term-current-row 0) (setq term-current-column 1) - (setq term-scroll-start 0) - (setq term-scroll-end term-height) + (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)) @@ -3350,86 +3307,81 @@ option is enabled. See `term-set-goto-process-mark'." ;; Handle a character assuming (eq terminal-state 2) - ;; i.e. we have previously seen Escape followed by ?[. -(defun term-handle-ansi-escape (proc char) +(defun term-handle-ansi-escape (proc params char) (cond ((or (eq char ?H) ;; cursor motion (terminfo: cup,home) ;; (eq char ?f) ;; xterm seems to handle this sequence too, not ;; needed for now ) - (when (<= term-terminal-parameter 0) - (setq term-terminal-parameter 1)) - (when (<= term-terminal-previous-parameter 0) - (setq term-terminal-previous-parameter 1)) - (when (> term-terminal-previous-parameter term-height) - (setq term-terminal-previous-parameter term-height)) - (when (> term-terminal-parameter term-width) - (setq term-terminal-parameter term-width)) (term-goto - (1- term-terminal-previous-parameter) - (1- term-terminal-parameter))) + (1- (max 1 (min (or (nth 0 params) 0) term-height))) + (1- (max 1 (min (or (nth 1 params) 0) term-width))))) ;; \E[A - cursor up (terminfo: cuu, cuu1) ((eq char ?A) (term-handle-deferred-scroll) - (let ((tcr (term-current-row))) + (let ((tcr (term-current-row)) + (scroll-amount (car params))) (term-down - (if (< (- tcr term-terminal-parameter) term-scroll-start) + (if (< (- tcr scroll-amount) term-scroll-start) ;; If the amount to move is before scroll start, move ;; to scroll start. (- term-scroll-start tcr) - (if (>= term-terminal-parameter tcr) + (if (>= scroll-amount tcr) (- tcr) - (- (max 1 term-terminal-parameter)))) t))) + (- (max 1 scroll-amount)))) + t))) ;; \E[B - cursor down (terminfo: cud) ((eq char ?B) - (let ((tcr (term-current-row))) + (let ((tcr (term-current-row)) + (scroll-amount (car params))) (unless (>= tcr term-scroll-end) (term-down - (min (- term-scroll-end tcr) (max 1 term-terminal-parameter)) + (min (- term-scroll-end tcr) (max 1 scroll-amount)) t)))) ;; \E[C - cursor right (terminfo: cuf, cuf1) ((eq char ?C) (term-move-columns (max 1 - (if (>= (+ term-terminal-parameter (term-current-column)) term-width) + (if (>= (+ (car params) (term-current-column)) term-width) (- term-width (term-current-column) 1) - term-terminal-parameter)))) + (car params))))) ;; \E[D - cursor left (terminfo: cub) ((eq char ?D) - (term-move-columns (- (max 1 term-terminal-parameter)))) + (term-move-columns (- (max 1 (car params))))) ;; \E[G - cursor motion to absolute column (terminfo: hpa) ((eq char ?G) - (term-move-columns (- (max 0 (min term-width term-terminal-parameter)) + (term-move-columns (- (max 0 (min term-width (car params))) (term-current-column)))) ;; \E[J - clear to end of screen (terminfo: ed, clear) ((eq char ?J) - (term-erase-in-display term-terminal-parameter)) + (term-erase-in-display (car params))) ;; \E[K - clear to end of line (terminfo: el, el1) ((eq char ?K) - (term-erase-in-line term-terminal-parameter)) + (term-erase-in-line (car params))) ;; \E[L - insert lines (terminfo: il, il1) ((eq char ?L) - (term-insert-lines (max 1 term-terminal-parameter))) + (term-insert-lines (max 1 (car params)))) ;; \E[M - delete lines (terminfo: dl, dl1) ((eq char ?M) - (term-delete-lines (max 1 term-terminal-parameter))) + (term-delete-lines (max 1 (car params)))) ;; \E[P - delete chars (terminfo: dch, dch1) ((eq char ?P) - (term-delete-chars (max 1 term-terminal-parameter))) + (term-delete-chars (max 1 (car params)))) ;; \E[@ - insert spaces (terminfo: ich) ((eq char ?@) - (term-insert-spaces (max 1 term-terminal-parameter))) + (term-insert-spaces (max 1 (car params)))) ;; \E[?h - DEC Private Mode Set ((eq char ?h) - (cond ((eq term-terminal-parameter 4) ;; (terminfo: smir) + (cond ((eq (car params) 4) ;; (terminfo: smir) (setq term-insert-mode t)) - ;; ((eq term-terminal-parameter 47) ;; (terminfo: smcup) + ;; ((eq (car params) 47) ;; (terminfo: smcup) ;; (term-switch-to-alternate-sub-buffer t)) )) ;; \E[?l - DEC Private Mode Reset ((eq char ?l) - (cond ((eq term-terminal-parameter 4) ;; (terminfo: rmir) + (cond ((eq (car params) 4) ;; (terminfo: rmir) (setq term-insert-mode nil)) - ;; ((eq term-terminal-parameter 47) ;; (terminfo: rmcup) + ;; ((eq (car params) 47) ;; (terminfo: rmcup) ;; (term-switch-to-alternate-sub-buffer nil)) )) @@ -3437,15 +3389,7 @@ option is enabled. See `term-set-goto-process-mark'." ;; \E[m - Set/reset modes, set bg/fg ;;(terminfo: smso,rmso,smul,rmul,rev,bold,sgr0,invis,op,setab,setaf) ((eq char ?m) - (when (= term-terminal-more-parameters 1) - (when (>= term-terminal-previous-parameter-4 0) - (term-handle-colors-array term-terminal-previous-parameter-4)) - (when (>= term-terminal-previous-parameter-3 0) - (term-handle-colors-array term-terminal-previous-parameter-3)) - (when (>= term-terminal-previous-parameter-2 0) - (term-handle-colors-array term-terminal-previous-parameter-2)) - (term-handle-colors-array term-terminal-previous-parameter)) - (term-handle-colors-array term-terminal-parameter)) + (mapc #'term-handle-colors-array params)) ;; \E[6n - Report cursor position (terminfo: u7) ((eq char ?n) @@ -3458,10 +3402,14 @@ option is enabled. See `term-set-goto-process-mark'." ;; \E[r - Set scrolling region (terminfo: csr) ((eq char ?r) (term-set-scroll-region - (1- term-terminal-previous-parameter) - (1- term-terminal-parameter))) + (1- (or (nth 0 params) 0)) + (1- (or (nth 1 params) 0)))) (t))) +(defun term--reset-scroll-region () + "Sets the scroll region to the full height of the terminal." + (term-set-scroll-region 0 (term--last-line))) + (defun term-set-scroll-region (top bottom) "Set scrolling region. TOP is the top-most line (inclusive) of the new scrolling region, @@ -3472,13 +3420,13 @@ The top-most line is line 0." 0 top)) (setq term-scroll-end - (if (or (<= bottom term-scroll-start) (> bottom term-height)) - term-height + (if (or (<= bottom term-scroll-start) (> bottom (term--last-line))) + (term--last-line) bottom)) (setq term-scroll-with-delete (or (term-using-alternate-sub-buffer) (not (and (= term-scroll-start 0) - (= term-scroll-end term-height))))) + (= term-scroll-end (term--last-line)))))) (term-move-columns (- (term-current-column))) (term-goto 0 0)) @@ -3509,7 +3457,7 @@ The top-most line is line 0." ;; (setq term-current-row 0) ;; (term-goto row col)))) -;; Default value for the symbol term-command-hook. +;; Default value for the symbol term-command-function. (defun term-command-hook (string) (cond ((equal string "") @@ -3607,7 +3555,7 @@ The top-most line is line 0." (when (> moved lines) (backward-char)) (cond ((<= deficit 0) ;; OK, had enough in the buffer for request. - (recenter (1- term-height))) + (recenter (term--last-line))) ((term-pager-continue deficit))))) (defun term-pager-page (arg) @@ -3621,7 +3569,7 @@ The top-most line is line 0." (goto-char (point-min)) (when (= (vertical-motion term-height) term-height) (backward-char)) - (recenter (1- term-height))) + (recenter (term--last-line))) ;; Pager mode command to go to end of buffer. (defun term-pager-eob () @@ -3639,7 +3587,7 @@ The top-most line is line 0." ;; Move cursor to end of window. (vertical-motion term-height) (backward-char)) - (recenter (1- term-height))) + (recenter (term--last-line))) (defun term-pager-back-page (arg) (interactive "p") @@ -3647,7 +3595,7 @@ The top-most line is line 0." (defun term-pager-discard () (interactive) - (setq term-terminal-parameter "") + (setq term-terminal-undecoded-bytes "") (interrupt-process nil t) (term-pager-continue term-height)) @@ -3791,7 +3739,11 @@ all pending output has been dealt with.")) ;; if the line above point wraps around, add a ?\n to undo the wrapping. ;; FIXME: Probably should be called more than it is. (defun term-unwrap-line () - (when (not (bolp)) (insert-before-markers ?\n))) + (when (not (bolp)) + (let ((old-point (point))) + (insert-before-markers ?\n) + (add-text-properties old-point (point) + '(term-line-wrap t rear-nonsticky t))))) (defun term-erase-in-line (kind) (when (= kind 1) ;; erase left of point @@ -3825,7 +3777,7 @@ all pending output has been dealt with.")) If KIND is 0, erase from (point) to (point-max); if KIND is 1, erase from home to point; else erase from home to point-max." (term-handle-deferred-scroll) - (cond ((eq term-terminal-parameter 0) + (cond ((eq kind 0) (let ((need-unwrap (bolp))) (delete-region (point) (point-max)) (when need-unwrap (term-unwrap-line)))) @@ -4060,9 +4012,7 @@ Calls the functions in `term-dynamic-complete-functions' to perform completion until a function returns non-nil, at which point completion is assumed to have occurred." (interactive) - (let ((functions term-dynamic-complete-functions)) - (while (and functions (null (funcall (car functions)))) - (setq functions (cdr functions))))) + (run-hook-with-args-until-success 'term-dynamic-complete-functions)) (defun term-dynamic-complete-filename () @@ -4162,7 +4112,6 @@ Returns `listed' if a completion listing was shown. See also `term-dynamic-complete-filename'." (declare (obsolete completion-in-region "23.2")) (let* ((completion-ignore-case nil) - (candidates (mapcar (function (lambda (x) (list x))) candidates)) (completions (all-completions stub candidates))) (cond ((null completions) (message "No completions of %s" stub) @@ -4387,9 +4336,9 @@ well as the newer ports COM10 and higher." (setq serial-name-history file-name-history)) (when (or (null x) (and (stringp x) (zerop (length x)))) (error "No serial port selected")) - (when (and (not (serial-port-is-file-p)) - (not (string-match "\\\\" x))) - (set 'x (concat "\\\\.\\" x))) + (when (not (or (serial-port-is-file-p) + (string-match "\\\\" x))) + (setq x (concat "\\\\.\\" x))) x)) (defun serial-read-speed () @@ -4419,18 +4368,26 @@ Try to be nice by providing useful defaults and history." x)) ;;;###autoload -(defun serial-term (port speed) +(defun serial-term (port speed &optional line-mode) "Start a terminal-emulator for a serial port in a new buffer. PORT is the path or name of the serial port. For example, this could be \"/dev/ttyS0\" on Unix. On Windows, this could be \"COM1\" or \"\\\\.\\COM10\". + SPEED is the speed of the serial port in bits per second. 9600 is a common value. SPEED can be nil, see `serial-process-configure' for details. + +Usually `term-char-mode' is used, but if LINE-MODE (the prefix +when used interactively) is non-nil, `term-line-mode' is used +instead. + The buffer is in Term mode; see `term-mode' for the commands to use in that buffer. + \\<term-raw-map>Type \\[switch-to-buffer] to switch to another buffer." - (interactive (list (serial-read-name) (serial-read-speed))) + (interactive (list (serial-read-name) (serial-read-speed) + current-prefix-arg)) (serial-supported-or-barf) (let* ((process (make-serial-process :port port @@ -4440,11 +4397,12 @@ use in that buffer. (buffer (process-buffer process))) (with-current-buffer buffer (term-mode) - (term-char-mode) + (unless line-mode + (term-char-mode)) (goto-char (point-max)) (set-marker (process-mark process) (point)) - (set-process-filter process 'term-emulate-terminal) - (set-process-sentinel process 'term-sentinel)) + (set-process-filter process #'term-emulate-terminal) + (set-process-sentinel process #'term-sentinel)) (switch-to-buffer buffer) buffer)) @@ -4581,27 +4539,19 @@ The return value may be nil for a special serial port." ;; term-mode will take care of it. The following example, from shell.el, ;; is typical: ;; -;; (defvar shell-mode-map '()) -;; (cond ((not shell-mode-map) -;; (setq shell-mode-map (copy-keymap term-mode-map)) -;; (define-key shell-mode-map "\C-c\C-f" 'shell-forward-command) -;; (define-key shell-mode-map "\C-c\C-b" 'shell-backward-command) -;; (define-key shell-mode-map "\t" 'term-dynamic-complete) -;; (define-key shell-mode-map "\M-?" -;; 'term-dynamic-list-filename-completions))) -;; -;; (defun shell-mode () -;; (interactive) -;; (term-mode) -;; (setq term-prompt-regexp shell-prompt-pattern) -;; (setq major-mode 'shell-mode) -;; (setq mode-name "Shell") -;; (use-local-map shell-mode-map) -;; (make-local-variable 'shell-directory-stack) -;; (setq shell-directory-stack nil) -;; (add-hook 'term-input-filter-functions 'shell-directory-tracker) -;; (run-mode-hooks 'shell-mode-hook)) +;; (defvar shell-mode-map +;; (let ((map (make-sparse-keymap))) +;; (define-key map "\C-c\C-f" 'shell-forward-command) +;; (define-key map "\C-c\C-b" 'shell-backward-command) +;; (define-key map "\t" 'term-dynamic-complete) +;; (define-key map "\M-?" +;; 'term-dynamic-list-filename-completions))) ;; +;; (define-derived-mode shell-mode term-mode "Shell" +;; "A shell mode." +;; (setq-local term-prompt-regexp shell-prompt-pattern) +;; (setq-local shell-directory-stack nil) +;; (add-hook 'term-input-filter-functions #'shell-directory-tracker nil t)) ;; ;; Completion for term-mode users ;; diff --git a/lisp/term/common-win.el b/lisp/term/common-win.el index 4399eaed186..b7a778fc004 100644 --- a/lisp/term/common-win.el +++ b/lisp/term/common-win.el @@ -59,20 +59,20 @@ (setq system-key-alist (list ;; These are special "keys" used to pass events from C to lisp. - (cons (logior (lsh 0 16) 1) 'ns-power-off) - (cons (logior (lsh 0 16) 2) 'ns-open-file) - (cons (logior (lsh 0 16) 3) 'ns-open-temp-file) - (cons (logior (lsh 0 16) 4) 'ns-drag-file) - (cons (logior (lsh 0 16) 5) 'ns-drag-color) - (cons (logior (lsh 0 16) 6) 'ns-drag-text) - (cons (logior (lsh 0 16) 7) 'ns-change-font) - (cons (logior (lsh 0 16) 8) 'ns-open-file-line) -;;; (cons (logior (lsh 0 16) 9) 'ns-insert-working-text) -;;; (cons (logior (lsh 0 16) 10) 'ns-delete-working-text) - (cons (logior (lsh 0 16) 11) 'ns-spi-service-call) - (cons (logior (lsh 0 16) 12) 'ns-new-frame) - (cons (logior (lsh 0 16) 13) 'ns-toggle-toolbar) - (cons (logior (lsh 0 16) 14) 'ns-show-prefs) + (cons 1 'ns-power-off) + (cons 2 'ns-open-file) + (cons 3 'ns-open-temp-file) + (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) + (cons 11 'ns-spi-service-call) + (cons 12 'ns-new-frame) + (cons 13 'ns-toggle-toolbar) + (cons 14 'ns-show-prefs) )))) (set-terminal-parameter frame 'x-setup-function-keys t))) @@ -112,7 +112,7 @@ ;; Handle the -xrm option. (defun x-handle-xrm-switch (switch) (unless (consp x-invocation-args) - (error "%s: missing argument to `%s' option" (invocation-name) switch)) + (error "%s: missing argument to `%s' option" invocation-name switch)) (setq x-command-line-resources (if (null x-command-line-resources) (pop x-invocation-args) @@ -152,7 +152,7 @@ ;; the initial frame, too. (defun x-handle-name-switch (switch) (or (consp x-invocation-args) - (error "%s: missing argument to `%s' option" (invocation-name) switch)) + (error "%s: missing argument to `%s' option" invocation-name switch)) (setq x-resource-name (pop x-invocation-args) initial-frame-alist (cons (cons 'name x-resource-name) initial-frame-alist))) diff --git a/lisp/term/internal.el b/lisp/term/internal.el index 1e9cbf477df..396521d676d 100644 --- a/lisp/term/internal.el +++ b/lisp/term/internal.el @@ -595,8 +595,7 @@ list. You can (and should) also run it if and when the value of (set-selection-coding-system coding-dos) (IT-setup-unicode-display coding-unix) (prefer-coding-system coding-dos) - (and (default-value 'enable-multibyte-characters) - (setq unibyte-display-via-language-environment t)) + (setq unibyte-display-via-language-environment t) ;; Some codepages have sporadic support for Latin-1, Greek, and ;; symbol glyphs, which don't belong to their native character ;; set. It's a nuisance to have all those glyphs here, for all diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el index 40397fcfedd..83b845b1a5a 100644 --- a/lisp/term/ns-win.el +++ b/lisp/term/ns-win.el @@ -42,7 +42,7 @@ (eval-when-compile (require 'cl-lib)) (or (featurep 'ns) (error "%s: Loading ns-win.el but not compiled for GNUstep/macOS" - (invocation-name))) + invocation-name)) ;; Documentation-purposes only: actually loaded in loadup.el. (require 'frame) @@ -125,7 +125,6 @@ The properties returned may include `top', `left', `height', and `width'." (define-key global-map [?\s-h] 'ns-do-hide-emacs) (define-key global-map [?\s-H] 'ns-do-hide-others) (define-key global-map [?\M-\s-h] 'ns-do-hide-others) -(define-key key-translation-map [?\M-\s-\u02D9] [?\M-\s-h]) (define-key global-map [?\s-j] 'exchange-point-and-mark) (define-key global-map [?\s-k] 'kill-current-buffer) (define-key global-map [?\s-l] 'goto-line) @@ -142,8 +141,13 @@ The properties returned may include `top', `left', `height', and `width'." (define-key global-map [?\s-x] 'kill-region) (define-key global-map [?\s-y] 'ns-paste-secondary) (define-key global-map [?\s-z] 'undo) +(define-key global-map [?\s-+] 'text-scale-adjust) +(define-key global-map [?\s-=] 'text-scale-adjust) +(define-key global-map [?\s--] 'text-scale-adjust) +(define-key global-map [?\s-0] 'text-scale-adjust) (define-key global-map [?\s-|] 'shell-command-on-region) (define-key global-map [s-kp-bar] 'shell-command-on-region) +(define-key global-map [?\C-\s- ] 'ns-do-show-character-palette) ;; (as in Terminal.app) (define-key global-map [s-right] 'ns-next-frame) (define-key global-map [s-left] 'ns-prev-frame) @@ -307,8 +311,8 @@ is currently being used." "Insert contents of `ns-working-text' as UTF-8 string and mark with `ns-working-overlay'. Any previously existing working text is cleared first. The overlay is assigned the face `ns-working-text-face'." - ;; FIXME: if buffer is read-only, don't try to insert anything - ;; and if text is bound to a command, execute that instead (Bug#1453) + ;; FIXME: if buffer is read-only, don't try to insert anything, and + ;; if text is bound to a command, execute that instead (Bug#1453). (interactive) (ns-delete-working-text) (let ((start (point))) @@ -354,7 +358,7 @@ See `ns-insert-working-text'." ;; Used prior to Emacs 25. (define-coding-system-alias 'utf-8-nfd 'utf-8-hfs) - (set-file-name-coding-system 'utf-8-hfs)) + (set-file-name-coding-system 'utf-8-hfs-unix)) ;;;; Inter-app communications support. @@ -437,14 +441,7 @@ Lines are highlighted according to `ns-input-line'." ;;;; File handling. (defun x-file-dialog (prompt dir default_filename mustmatch only_dir_p) -"Read file name, prompting with PROMPT in directory DIR. -Use a file selection dialog. Select DEFAULT-FILENAME in the dialog's file -selection box, if specified. If MUSTMATCH is non-nil, the returned file -or directory must exist. - -This function is only defined on NS, MS Windows, and X Windows with the -Motif or Gtk toolkits. With the Motif toolkit, ONLY-DIR-P is ignored. -Otherwise, if ONLY-DIR-P is non-nil, the user can only select directories." + "SKIP: real doc in xfns.c." (ns-read-file-name prompt dir mustmatch default_filename only_dir_p)) (defun ns-open-file-using-panel () @@ -504,48 +501,38 @@ unless the current buffer is a scratch buffer." (find-file f))))) -(defun ns-drag-n-drop (event &optional new-frame force-text) +(defun ns-drag-n-drop (event) "Edit the files listed in the drag-n-drop EVENT. -Switch to a buffer editing the last file dropped." +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)) - (data (car (cdr arg))) - (url-or-string (cond ((eq type 'file) - (concat "file:" data)) - (t data)))) + (operations (car (cdr arg))) + (objects (cdr (cdr arg))) + (string (mapconcat 'identity objects "\n"))) (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 ns-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") - (ns-drag-n-drop event t)) - -(defun ns-drag-n-drop-as-text (event) - "Drop the data in EVENT as text." - (interactive "e") - (ns-drag-n-drop event nil t)) - -(defun ns-drag-n-drop-as-text-other-frame (event) - "Drop the data in EVENT as text in a new frame." - (interactive "e") - (ns-drag-n-drop event t t)) + (cond ((memq 'ns-drag-operation-generic operations) + ;; Perform the default action for the type. + (if (eq type 'file) + (dolist (data objects) + (dnd-handle-one-url window 'private (concat "file:" data))) + (dnd-insert-text window 'private string))) + ((memq 'ns-drag-operation-copy operations) + ;; Try to open the file/URL. If type is nil, try to open + ;; it as a URL anyway. + (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) -(global-set-key [C-drag-n-drop] 'ns-drag-n-drop-other-frame) -(global-set-key [M-drag-n-drop] 'ns-drag-n-drop-as-text) -(global-set-key [C-M-drag-n-drop] 'ns-drag-n-drop-as-text-other-frame) ;;;; Frame-related functions. @@ -556,8 +543,9 @@ the last file dropped is selected." (defvar ns-right-control-modifier) ;; You say tomAYto, I say tomAHto.. -(defvaralias 'ns-option-modifier 'ns-alternate-modifier) -(defvaralias 'ns-right-option-modifier 'ns-right-alternate-modifier) +(with-no-warnings + (defvaralias 'ns-option-modifier 'ns-alternate-modifier) + (defvaralias 'ns-right-option-modifier 'ns-right-alternate-modifier)) (defun ns-do-hide-emacs () (interactive) @@ -575,6 +563,12 @@ the last file dropped is selected." (interactive) (ns-emacs-info-panel)) +(declare-function ns-show-character-palette "nsfns.m" ()) + +(defun ns-do-show-character-palette () + (interactive) + (ns-show-character-palette)) + (defun ns-next-frame () "Switch to next visible frame." (interactive) @@ -619,7 +613,7 @@ the last file dropped is selected." (let ((last-nonmenu-event (if (listp last-nonmenu-event) last-nonmenu-event ;; Fake it: - `(mouse-1 POSITION 1)))) + '(mouse-1 POSITION 1)))) (if (y-or-n-p (format "Print buffer %s? " (buffer-name))) (print-buffer) (error "Canceled"))) @@ -739,6 +733,10 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") ;;;; macOS-like defaults for trackpad and mouse wheel scrolling on ;;;; macOS 10.7+. +(defvar ns-version-string) +(defvar mouse-wheel-scroll-amount) +(defvar mouse-wheel-progressive-speed) + ;; FIXME: This doesn't look right. Is there a better way to do this ;; that keeps customize happy? (when (featurep 'cocoa) @@ -747,10 +745,6 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") (string-to-number (match-string 1 ns-version-string))))) ;; Appkit 1138 ~= macOS 10.7. (when (>= appkit-version 1138) - (setq mouse-wheel-scroll-amount '(1 ((shift) . 5) ((control)))) - (put 'mouse-wheel-scroll-amount 'customized-value - (list (custom-quote (symbol-value 'mouse-wheel-scroll-amount)))) - (setq mouse-wheel-progressive-speed nil) (put 'mouse-wheel-progressive-speed 'customized-value (list (custom-quote @@ -801,8 +795,8 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") ;; Set some options to be as Nextstep-like as possible. -(setq frame-title-format t - icon-title-format t) +(setq frame-title-format "%b" + icon-title-format "%b") (defvar ns-initialized nil diff --git a/lisp/term/pc-win.el b/lisp/term/pc-win.el index 214c5a37f55..09275991cf5 100644 --- a/lisp/term/pc-win.el +++ b/lisp/term/pc-win.el @@ -38,7 +38,7 @@ (if (not (fboundp 'msdos-remember-default-colors)) (error "%s: Loading pc-win.el but not compiled for MS-DOS" - (invocation-name))) + invocation-name)) (declare-function msdos-remember-default-colors "msdos.c") (declare-function w16-set-clipboard-data "w16select.c") @@ -158,159 +158,59 @@ created." ;; a useful function for returning 'nil regardless of argument. ;; Note: Any re-definition in this file of a function that is defined -;; in C on other platforms, should either have no doc-string, or one -;; that is identical to the C version, but with the arglist signature -;; at the end. Otherwise help-split-fundoc gets confused on other -;; platforms. (Bug#10783) +;; in C on other platforms, should either have a doc-string that +;; starts with "SKIP", or one that is identical to the C version, +;; but with the arglist signature at the end. Otherwise +;; help-split-fundoc gets confused on other platforms. (Bug#10783) -;; From src/xfns.c (defun x-list-fonts (_pattern &optional _face _frame _maximum width) - "Return a list of the names of available fonts matching PATTERN. -If optional arguments FACE and FRAME are specified, return only fonts -the same size as FACE on FRAME. - -PATTERN should be a string containing a font name in the XLFD, -Fontconfig, or GTK format. A font name given in the XLFD format may -contain wildcard characters: - the * character matches any substring, and - the ? character matches any single character. - PATTERN is case-insensitive. - -The return value is a list of strings, suitable as arguments to -`set-face-font'. - -Fonts Emacs can't use may or may not be excluded -even if they match PATTERN and FACE. -The optional fourth argument MAXIMUM sets a limit on how many -fonts to match. The first MAXIMUM fonts are reported. -The optional fifth argument WIDTH, if specified, is a number of columns -occupied by a character of a font. In that case, return only fonts -the WIDTH times as wide as FACE on FRAME." + "SKIP: real doc in xfaces.c." (if (or (null width) (and (numberp width) (= width 1))) (list "ms-dos") (list "no-such-font"))) (defun x-display-pixel-width (&optional frame) - "Return the width in pixels of DISPLAY. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. - -On \"multi-monitor\" setups this refers to the pixel width for all -physical monitors associated with DISPLAY. To get information for -each physical monitor, use `display-monitor-attributes-list'." + "SKIP: real doc in xfns.c." (frame-width frame)) (defun x-display-pixel-height (&optional frame) - "Return the height in pixels of DISPLAY. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. - -On \"multi-monitor\" setups this refers to the pixel height for all -physical monitors associated with DISPLAY. To get information for -each physical monitor, use `display-monitor-attributes-list'." + "SKIP: real doc in xfns.c." (frame-height frame)) (defun x-display-planes (&optional _frame) - "Return the number of bitplanes of DISPLAY. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display." + "SKIP: real doc in xfns.c." 4) ;bg switched to 16 colors as well (defun x-display-color-cells (&optional _frame) - "Return the number of color cells of DISPLAY. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display." + "SKIP: real doc in xfns.c." 16) (defun x-server-max-request-size (&optional _frame) - "Return the maximum request size of the server of DISPLAY. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display." + "SKIP: real doc in xfns.c." 1000000) ; ??? (defun x-server-vendor (&optional _frame) - "Return the \"vendor ID\" string of the GUI software on TERMINAL. - -\(Labeling every distributor as a \"vendor\" embodies the false assumption -that operating systems cannot be developed and distributed noncommercially.) - -For GNU and Unix systems, this queries the X server software; for -MS-Windows, this queries the OS. - -The optional argument TERMINAL specifies which display to ask about. -TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display." + "SKIP: real doc in xfns.c." "GNU") (defun x-server-version (&optional _frame) - "Return the version numbers of the GUI software on TERMINAL. -The value is a list of three integers specifying the version of the GUI -software in use. - -For GNU and Unix system, the first 2 numbers are the version of the X -Protocol used on TERMINAL and the 3rd number is the distributor-specific -release number. For MS-Windows, the 3 numbers report the version and -the build number of the OS. - -See also the function `x-server-vendor'. - -The optional argument TERMINAL specifies which display to ask about. -TERMINAL should be a terminal object, a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display." + "SKIP: real doc in xfns.c." '(1 0 0)) (defun x-display-screens (&optional _frame) - "Return the number of screens on the server of DISPLAY. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display." + "SKIP: real doc in xfns.c." 1) (defun x-display-mm-height (&optional _frame) - "Return the height in millimeters of DISPLAY. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. - -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'." + "SKIP: real doc in xfns.c." 245) ; Guess the size of my... (defun x-display-mm-width (&optional _frame) - "Return the width in millimeters of DISPLAY. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display. - -On \"multi-monitor\" setups this refers to the width in millimeters for -all physical monitors associated with TERMINAL. To get information -for each physical monitor, use `display-monitor-attributes-list'." + "SKIP: real doc in xfns.c." 322) ; ...monitor, EZ... (defun x-display-backing-store (&optional _frame) - "Return an indication of whether DISPLAY does backing store. -The value may be `always', `when-mapped', or `not-useful'. -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display." + "SKIP: real doc in xfns.c." 'not-useful) (defun x-display-visual-class (&optional _frame) - "Return the visual class of DISPLAY. -The value is one of the symbols `static-gray', `gray-scale', -`static-color', `pseudo-color', `true-color', or `direct-color'. - -The optional argument DISPLAY specifies which display to ask about. -DISPLAY should be either a frame or a display name (a string). -If omitted or nil, that stands for the selected frame's display." + "SKIP: real doc in xfns.c." 'static-color) (fset 'x-display-save-under 'ignore) (fset 'x-get-resource 'ignore) -;; From lisp/term/x-win.el (defvar x-display-name "pc" - "The name of the window display on which Emacs was started. -On X, the display name of individual X frames is recorded in the -`display' frame parameter.") + "SKIP: real doc in common-win.el.") (defvar x-colors (mapcar 'car msdos-color-values) - "List of basic colors available on color displays. -For X, the list comes from the `rgb.txt' file,v 10.41 94/02/20. -For Nextstep, this is a list of non-PANTONE colors returned by -the operating system.") + "SKIP: real doc in common-win.el.") ;; From lisp/term/w32-win.el ; diff --git a/lisp/term/sun.el b/lisp/term/sun.el index a1c018483d5..c9f531e3520 100644 --- a/lisp/term/sun.el +++ b/lisp/term/sun.el @@ -118,14 +118,6 @@ (define-key map "D" [left]) ; R10 map)) -;; Since .emacs gets loaded before this file, a hook is supplied -;; for you to put your own bindings in. - -(defvar sun-raw-prefix-hooks nil - "List of forms to evaluate after setting `sun-raw-prefix'.") -;; Obsolete since 21.1, but tty-setup-hook only exists since 24.4. -(make-obsolete-variable 'sun-raw-prefix-hooks 'tty-setup-hook "21.1") - (defun terminal-init-sun () @@ -147,16 +139,7 @@ (global-set-key [f3] 'scroll-down-in-place) (global-set-key [f4] 'scroll-up-in-place) (global-set-key [f6] 'shrink-window) - (global-set-key [f7] 'enlarge-window) - - (when sun-raw-prefix-hooks - (message "sun-raw-prefix-hooks is obsolete! Use %s instead!" - (or (car-safe (get 'sun-raw-prefix-hooks 'byte-obsolete-variable)) - "emacs-startup-hook")) - (let ((hooks sun-raw-prefix-hooks)) - (while hooks - (eval (car hooks)) - (setq hooks (cdr hooks)))))) + (global-set-key [f7] 'enlarge-window)) (provide 'term/sun) diff --git a/lisp/term/tty-colors.el b/lisp/term/tty-colors.el index 04b433e178c..43c1071ceb7 100644 --- a/lisp/term/tty-colors.el +++ b/lisp/term/tty-colors.el @@ -820,7 +820,7 @@ Value is the modified color alist for FRAME." "Return COLOR in canonical form. A canonicalized color name is all-lower case, with any blanks removed." (let ((case-fold-search nil)) - (if (string-match "[A-Z ]" color) + (if (string-match-p "[A-Z ]" color) (replace-regexp-in-string " +" "" (downcase color)) color))) @@ -830,10 +830,10 @@ DISPLAY can be a display name or a frame, and defaults to the selected frame's display. If DISPLAY is not on a 24-but TTY terminal, return nil." (when (and rgb (= (display-color-cells display) 16777216)) - (let ((r (lsh (car rgb) -8)) - (g (lsh (cadr rgb) -8)) - (b (lsh (nth 2 rgb) -8))) - (logior (lsh r 16) (lsh g 8) b)))) + (let ((r (ash (car rgb) -8)) + (g (ash (cadr rgb) -8)) + (b (ash (nth 2 rgb) -8))) + (logior (ash r 16) (ash g 8) b)))) (defun tty-color-define (name index &optional rgb frame) "Specify a tty color by its NAME, terminal INDEX and RGB values. @@ -895,9 +895,9 @@ FRAME defaults to the selected frame." ;; never consider it for approximating another color. (if try-rgb (progn - (setq try-r (lsh (car try-rgb) -8) - try-g (lsh (cadr try-rgb) -8) - try-b (lsh (nth 2 try-rgb) -8)) + (setq try-r (ash (car try-rgb) -8) + try-g (ash (cadr try-rgb) -8) + try-b (ash (nth 2 try-rgb) -8)) (setq dif-r (- r try-r) dif-g (- g try-g) dif-b (- b try-b)) @@ -919,57 +919,63 @@ FRAME defaults to the selected frame." The result is a list of integer RGB values--(RED GREEN BLUE). These values range from 0 to 65535; white is (65535 65535 65535). -The returned value reflects the standard X definition of COLOR, -regardless of whether the terminal can display it, so the return value -should be the same regardless of what display is being used." +The returned value reflects the standard Emacs definition of +COLOR (see the info node `(emacs) Colors'), regardless of whether +the terminal can display it, so the return value should be the +same regardless of what display is being used." (let ((len (length color))) - (cond ((and (>= len 4) ;; X-style "#XXYYZZ" color spec + (cond ((and (>= len 4) ;; HTML/CSS/SVG-style "#XXYYZZ" color spec (eq (aref color 0) ?#) (member (aref color 1) '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 - ?a ?b ?c ?d ?e ?f))) - ;; Translate the string "#XXYYZZ" into a list - ;; of numbers (XX YY ZZ). If the primary colors - ;; are specified with less than 4 hex digits, - ;; the used digits represent the most significant - ;; bits of the value (e.g. #XYZ = #X000Y000Z000). + ?a ?b ?c ?d ?e ?f + ?A ?B ?C ?D ?E ?F))) + ;; Translate the string "#XXYYZZ" into a list of numbers + ;; (XX YY ZZ), scaling each to the {0..65535} range. This + ;; follows the HTML color convention, where both "#fff" and + ;; "#ffffff" represent the same color, white. (let* ((ndig (/ (- len 1) 3)) + (maxval (1- (ash 1 (* 4 ndig)))) (i1 1) (i2 (+ i1 ndig)) - (i3 (+ i2 ndig))) + (i3 (+ i2 ndig)) + (i4 (+ i3 ndig))) (list - (lsh - (string-to-number (substring color i1 i2) 16) - (* 4 (- 4 ndig))) - (lsh - (string-to-number (substring color i2 i3) 16) - (* 4 (- 4 ndig))) - (lsh - (string-to-number (substring color i3) 16) - (* 4 (- 4 ndig)))))) - ((and (>= len 9) ;; X-style RGB:xx/yy/zz color spec + (/ (* (string-to-number + (substring color i1 i2) 16) + 65535) + maxval) + (/ (* (string-to-number + (substring color i2 i3) 16) + 65535) + maxval) + (/ (* (string-to-number + (substring color i3 i4) 16) + 65535) + maxval)))) + ((and (>= len 9) ;; X-style rgb:xx/yy/zz color spec (string= (substring color 0 4) "rgb:")) - ;; Translate the string "RGB:XX/YY/ZZ" into a list - ;; of numbers (XX YY ZZ). If fewer than 4 hex - ;; digits are used, they represent the fraction - ;; of the maximum value (RGB:X/Y/Z = #XXXXYYYYZZZZ). + ;; Translate the string "rgb:XX/YY/ZZ" into a list of + ;; numbers (XX YY ZZ), scaling each to the {0..65535} + ;; range. "rgb:F/F/F" is white. (let* ((ndig (/ (- len 3) 3)) (maxval (1- (ash 1 (* 4 (- ndig 1))))) (i1 4) (i2 (+ i1 ndig)) - (i3 (+ i2 ndig))) + (i3 (+ i2 ndig)) + (i4 (+ i3 ndig))) (list (/ (* (string-to-number (substring color i1 (- i2 1)) 16) - 255) + 65535) maxval) (/ (* (string-to-number (substring color i2 (- i3 1)) 16) - 255) + 65535) maxval) (/ (* (string-to-number - (substring color i3) 16) - 255) + (substring color i3 (1- i4)) 16) + 65535) maxval)))) (t (cdr (assoc color color-name-rgb-alist)))))) @@ -977,9 +983,9 @@ should be the same regardless of what display is being used." (defun tty-color-translate (color &optional frame) "Given a color COLOR, return the index of the corresponding TTY color. -COLOR must be a string that is either the color's name, or its X-style -specification like \"#RRGGBB\" or \"RGB:rr/gg/bb\", where each primary. -color can be given with 1 to 4 hex digits. +COLOR must be a string that is either the color's name, or its +color triplet specification like \"#RRGGBB\" or \"rgb:RR/GG/BB\", +where each primary color can be given with 1 to 4 hex digits. If COLOR is a color name that is found among supported colors in `tty-color-alist', the associated index is returned. Otherwise, the @@ -987,7 +993,7 @@ RGB values of the color, either as given by the argument or from looking up the name in `color-name-rgb-alist', are used to find the supported color that is the best approximation for COLOR in the RGB space. -If COLOR is neither a valid X RGB specification of the color, nor a +If COLOR is neither a valid RGB specification of the color, nor a name of a color in `color-name-rgb-alist', the returned value is nil. If FRAME is unspecified or nil, it defaults to the selected frame." diff --git a/lisp/term/tvi970.el b/lisp/term/tvi970.el index 20c5a53fc2d..3b748483eef 100644 --- a/lisp/term/tvi970.el +++ b/lisp/term/tvi970.el @@ -101,9 +101,6 @@ ;; Should keypad numbers send ordinary digits or distinct escape sequences? (define-minor-mode tvi970-set-keypad-mode "Toggle alternate keypad mode on TVI 970 keypad. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. In alternate keypad mode, the keys send distinct escape sequences, meaning that they can have their own bindings, diff --git a/lisp/term/vt100.el b/lisp/term/vt100.el index a296f7e5293..81843ceb975 100644 --- a/lisp/term/vt100.el +++ b/lisp/term/vt100.el @@ -39,10 +39,7 @@ ;;; Controlling the screen width. (define-minor-mode vt100-wide-mode - "Toggle 132/80 column mode for vt100s. -With a prefix argument ARG, switch to 132-column mode if ARG is -positive, and 80-column mode otherwise. If called from Lisp, -switch to 132-column mode if ARG is omitted or nil." + "Toggle 132/80 column mode for vt100s." :global t :init-value (= (frame-width) 132) :group 'terminals (send-string-to-terminal (if vt100-wide-mode "\e[?3h" "\e[?3l")) diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 12c3e97e411..198182fca72 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -66,7 +66,7 @@ ;; ../startup.el. ;; (if (not (eq window-system 'w32)) -;; (error "%s: Loading w32-win.el but not compiled for w32" (invocation-name))) +;; (error "%s: Loading w32-win.el but not compiled for w32" invocation-name)) (eval-when-compile (require 'cl-lib)) (require 'frame) @@ -279,13 +279,15 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") '(svg "librsvg-2-2.dll") '(gdk-pixbuf "libgdk_pixbuf-2.0-0.dll") '(glib "libglib-2.0-0.dll") + '(gio "libgio-2.0-0.dll") '(gobject "libgobject-2.0-0.dll") (if (>= libgnutls-version 30400) '(gnutls "libgnutls-30.dll") '(gnutls "libgnutls-28.dll" "libgnutls-26.dll")) '(libxml2 "libxml2-2.dll" "libxml2.dll") '(zlib "zlib1.dll" "libz-1.dll") - '(lcms2 "liblcms2-2.dll"))) + '(lcms2 "liblcms2-2.dll") + '(json "libjansson-4.dll"))) ;;; multi-tty support (defvar w32-initialized nil @@ -318,7 +320,7 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") (setq x-resource-name ;; Change any . or * characters in x-resource-name to hyphens, ;; so as not to choke when we use it in X resource queries. - (replace-regexp-in-string "[.*]" "-" (invocation-name)))) + (replace-regexp-in-string "[.*]" "-" invocation-name))) (x-open-connection "w32" x-command-line-resources ;; Exit with a fatal error if this fails and we @@ -400,8 +402,12 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") (declare-function w32-set-clipboard-data "w32select.c" (string &optional ignored)) -(declare-function w32-get-clipboard-data "w32select.c") -(declare-function w32-selection-exists-p "w32select.c") +(declare-function w32-get-clipboard-data "w32select.c" + (&optional ignored)) +(declare-function w32-selection-exists-p "w32select.c" + (&optional selection terminal)) +(declare-function w32-selection-targets "w32select.c" + (&optional selection terminal)) ;;; Fix interface to (X-specific) mouse.el (defun w32--set-selection (type value) diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el index f159a71d988..56061371fe1 100644 --- a/lisp/term/x-win.el +++ b/lisp/term/x-win.el @@ -69,7 +69,7 @@ (eval-when-compile (require 'cl-lib)) (if (not (fboundp 'x-create-frame)) - (error "%s: Loading x-win.el but not compiled for X" (invocation-name))) + (error "%s: Loading x-win.el but not compiled for X" invocation-name)) (require 'term/common-win) (require 'frame) @@ -93,7 +93,7 @@ ;; Handle the --parent-id option. (defun x-handle-parent-id (switch) (or (consp x-invocation-args) - (error "%s: missing argument to `%s' option" (invocation-name) switch)) + (error "%s: missing argument to `%s' option" invocation-name switch)) (setq initial-frame-alist (cons (cons 'parent-id (string-to-number (car x-invocation-args))) @@ -104,7 +104,7 @@ ;; to give us back our session id we had on the previous run. (defun x-handle-smid (switch) (or (consp x-invocation-args) - (error "%s: missing argument to `%s' option" (invocation-name) switch)) + (error "%s: missing argument to `%s' option" invocation-name switch)) (setq x-session-previous-id (car x-invocation-args) x-invocation-args (cdr x-invocation-args))) @@ -1205,7 +1205,7 @@ This returns an error if any Emacs frames are X frames." ;; Make sure we have a valid resource name. (or (stringp x-resource-name) (let (i) - (setq x-resource-name (invocation-name)) + (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. diff --git a/lisp/term/xterm.el b/lisp/term/xterm.el index 8cbf5dace0f..c4b0a8fb6e6 100644 --- a/lisp/term/xterm.el +++ b/lisp/term/xterm.el @@ -68,8 +68,13 @@ string bytes that can be copied is 3/4 of this value." :version "25.1" :type 'integer) +(defcustom xterm-set-window-title nil + "Whether Emacs should set window titles to an Emacs frame in an XTerm." + :version "27.1" + :type 'boolean) + (defconst xterm-paste-ending-sequence "\e[201~" - "Characters send by the terminal to end a bracketed paste.") + "Characters sent by the terminal to end a bracketed paste.") (defun xterm--pasted-text () "Handle the rest of a terminal paste operation. @@ -90,15 +95,49 @@ Return the pasted text as a string." (decode-coding-region (point-min) (point) (keyboard-coding-system) t))))) -(defun xterm-paste () +(defun xterm-paste (event) "Handle the start of a terminal paste operation." - (interactive) - (let* ((pasted-text (xterm--pasted-text)) + (interactive "e") + (unless (eq (car-safe event) 'xterm-paste) + (error "xterm-paste must be found to xterm-paste event")) + (let* ((pasted-text (nth 1 event)) (interprogram-paste-function (lambda () pasted-text))) (yank))) +;; Put xterm-paste itself in global-map because, after translation, +;; it's just a normal input event. (define-key global-map [xterm-paste] #'xterm-paste) +;; By returning an empty key sequence, these two functions perform the +;; moral equivalent of the kind of transparent event processing done +;; by read-event's handling of special-event-map, but inside +;; read-key-sequence (which can recognize multi-character terminal +;; notifications) instead of read-event (which can't). + +(defun xterm-translate-focus-in (_prompt) + (setf (terminal-parameter nil 'tty-focus-state) 'focused) + (funcall after-focus-change-function) + []) + +(defun xterm-translate-focus-out (_prompt) + (setf (terminal-parameter nil 'tty-focus-state) 'defocused) + (funcall after-focus-change-function) + []) + +(defun xterm--suspend-tty-function (_tty) + ;; We can't know what happens to the tty after we're suspended + (setf (terminal-parameter nil 'tty-focus-state) nil) + (funcall after-focus-change-function)) + +;; Similarly, we want to transparently slurp the entirety of a +;; bracketed paste and encapsulate it into a single event. We used to +;; just slurp up the bracketed paste content in the event handler, but +;; this strategy can produce unexpected results in a caller manually +;; looping on read-key and buffering input for later processing. + +(defun xterm-translate-bracketed-paste (_prompt) + (vector (list 'xterm-paste (xterm--pasted-text)))) + (defvar xterm-rxvt-function-map (let ((map (make-sparse-keymap))) (define-key map "\e[2~" [insert]) @@ -127,9 +166,15 @@ Return the pasted text as a string." (define-key map "\e[13~" [f3]) (define-key map "\e[14~" [f4]) - ;; Recognize the start of a bracketed paste sequence. The handler - ;; internally recognizes the end. - (define-key map "\e[200~" [xterm-paste]) + ;; Recognize the start of a bracketed paste sequence. + ;; The translation function internally recognizes the end. + (define-key map "\e[200~" #'xterm-translate-bracketed-paste) + + ;; These translation functions actually call the focus handlers + ;; internally and return an empty sequence, causing us to go on to + ;; read the next event. + (define-key map "\e[I" #'xterm-translate-focus-in) + (define-key map "\e[O" #'xterm-translate-focus-out) map) "Keymap of escape sequences, shared between xterm and rxvt support.") @@ -634,7 +679,7 @@ Return the pasted text as a string." (let ((str "") chr) ;; The reply should be: \e ] 11 ; rgb: NUMBER1 / NUMBER2 / NUMBER3 \e \\ - (while (and (setq chr (read-event nil nil 2)) (not (equal chr ?\\))) + (while (and (setq chr (xterm--read-event-for-query)) (not (equal chr ?\\))) (setq str (concat str (string chr)))) (when (string-match "rgb:\\([a-f0-9]+\\)/\\([a-f0-9]+\\)/\\([a-f0-9]+\\)" str) @@ -662,7 +707,7 @@ Return the pasted text as a string." ;; respond to this escape sequence. RMS' opinion was to remove ;; it completely. That might be right, but let's first try to ;; see if by using a longer timeout we get rid of most issues. - (while (and (setq chr (read-event nil nil 2)) (not (equal chr ?c))) + (while (and (setq chr (xterm--read-event-for-query)) (not (equal chr ?c))) (setq str (concat str (string chr)))) ;; Since xterm-280, the terminal type (NUMBER1) is now 41 instead of 0. (when (string-match "\\([0-9]+\\);\\([0-9]+\\);0" str) @@ -712,6 +757,26 @@ Return the pasted text as a string." "Seconds to wait for an answer from the terminal. Can be nil to mean \"no timeout\".") +(defvar xterm-query-redisplay-timeout 0.2 + "Seconds to wait before allowing redisplay during terminal + query." ) + +(defun xterm--read-event-for-query () + "Like read-event, but inhibit redisplay. + +By not redisplaying right away for xterm queries, we can avoid +unsightly flashing during initialization. Give up and redisplay +anyway if we've been waiting a little while." + (let ((start-time (current-time))) + (or (let ((inhibit-redisplay t)) + (read-event nil nil xterm-query-redisplay-timeout)) + (read-event nil nil + (and xterm-query-timeout + (max 0 (float-time + (time-subtract + xterm-query-timeout + (time-since start-time))))))))) + (defun xterm--query (query handlers &optional no-async) "Send QUERY string to the terminal and watch for a response. HANDLERS is an alist with elements of the form (STRING . FUNCTION). @@ -744,7 +809,7 @@ We run the first FUNCTION whose STRING matches the input events." (let ((handler (pop handlers)) (i 0)) (while (and (< i (length (car handler))) - (let ((evt (read-event nil nil xterm-query-timeout))) + (let ((evt (xterm--read-event-for-query))) (if (and (null evt) (= i 0) (not no-async)) ;; Timeout on the first event: fallback on async. (progn @@ -807,9 +872,13 @@ We run the first FUNCTION whose STRING matches the input events." (when (memq 'setSelection xterm-extra-capabilities) (xterm--init-activate-set-selection))) + (when xterm-set-window-title + (xterm--init-frame-title)) ;; Unconditionally enable bracketed paste mode: terminals that don't ;; support it just ignore the sequence. (xterm--init-bracketed-paste-mode) + ;; We likewise unconditionally enable support for focus tracking. + (xterm--init-focus-tracking) (run-hooks 'terminal-init-xterm-hook)) @@ -825,6 +894,12 @@ We run the first FUNCTION whose STRING matches the input events." (push "\e[?2004l" (terminal-parameter nil 'tty-mode-reset-strings)) (push "\e[?2004h" (terminal-parameter nil 'tty-mode-set-strings))) +(defun xterm--init-focus-tracking () + "Terminal initialization for focus tracking mode." + (send-string-to-terminal "\e[?1004h") + (push "\e[?1004l" (terminal-parameter nil 'tty-mode-reset-strings)) + (push "\e[?1004h" (terminal-parameter nil 'tty-mode-set-strings))) + (defun xterm--init-activate-get-selection () "Terminal initialization for `gui-get-selection'." (set-terminal-parameter nil 'xterm--get-selection t)) @@ -833,6 +908,34 @@ We run the first FUNCTION whose STRING matches the input events." "Terminal initialization for `gui-set-selection'." (set-terminal-parameter nil 'xterm--set-selection t)) +(defun xterm--init-frame-title () + "Terminal initialization for XTerm frame titles." + (xterm-set-window-title) + (add-hook 'after-make-frame-functions 'xterm-set-window-title-flag) + (add-hook 'window-configuration-change-hook 'xterm-unset-window-title-flag) + (add-hook 'post-command-hook 'xterm-set-window-title) + (add-hook 'minibuffer-exit-hook 'xterm-set-window-title)) + +(defvar xterm-window-title-flag nil + "Whether a new frame has been created, calling for a title update.") + +(defun xterm-set-window-title-flag (_frame) + "Set `xterm-window-title-flag'. +See `xterm--init-frame-title'" + (setq xterm-window-title-flag t)) + +(defun xterm-unset-window-title-flag () + (when xterm-window-title-flag + (setq xterm-window-title-flag nil) + (xterm-set-window-title))) + +(defun xterm-set-window-title (&optional terminal) + "Set the window title of the Xterm TERMINAL. +The title is constructed from `frame-title-format'." + (send-string-to-terminal + (format "\e]2;%s\a" (format-mode-line frame-title-format)) + terminal)) + (defun xterm--selection-char (type) (pcase type ('PRIMARY "p") @@ -908,7 +1011,7 @@ hitting screen's max DCS length." (defun xterm-rgb-convert-to-16bit (prim) "Convert an 8-bit primary color value PRIM to a corresponding 16-bit value." - (logior prim (lsh prim 8))) + (logior prim (ash prim 8))) (defun xterm-register-default-colors (colors) "Register the default set of colors for xterm or compatible emulator. diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el index 885a4ee67ec..19d1df6d51c 100644 --- a/lisp/textmodes/artist.el +++ b/lisp/textmodes/artist.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2000-2019 Free Software Foundation, Inc. ;; Author: Tomas Abrahamsson <tab@lysator.liu.se> -;; Maintainer: Tomas Abrahamsson <tab@lysator.liu.se> ;; Keywords: mouse ;; Version: 1.2.6 ;; Release-date: 6-Aug-2004 @@ -351,13 +350,12 @@ 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) (defcustom artist-text-renderer-function 'artist-figlet "Function for doing text rendering." :group 'artist-text :type 'symbol) -(defvaralias 'artist-text-renderer 'artist-text-renderer-function) - (defcustom artist-figlet-program "figlet" "Program to run for `figlet'." @@ -1199,7 +1197,7 @@ PREV-OP-ARG are used when invoked recursively during the build-up." ;;;###autoload (define-minor-mode artist-mode "Toggle Artist mode. -With argument ARG, turn Artist mode on if ARG is positive. + Artist lets you draw lines, squares, rectangles and poly-lines, ellipses and circles with your mouse and/or keyboard. @@ -1401,7 +1399,10 @@ Keymap summary (artist-mode-exit)) (t ;; Turn mode on - (artist-mode-init)))) + (artist-mode-init) + (let ((font (face-attribute 'default :font))) + (when (and (fontp font) (not (font-get font :spacing))) + (message "The default font isn't monospaced, so the drawings in this buffer may look odd")))))) ;; Init and exit (defun artist-mode-init () @@ -2893,7 +2894,7 @@ Returns a list of strings." dir-list) (mapcar (lambda (file) - (replace-regexp-in-string "\.flf\\'" "" file)) + (replace-regexp-in-string "\\.flf\\'" "" file)) result)))) (defun artist-figlet-choose-font () diff --git a/lisp/textmodes/bib-mode.el b/lisp/textmodes/bib-mode.el index 81dfb6c99c0..7a5d3ef7758 100644 --- a/lisp/textmodes/bib-mode.el +++ b/lisp/textmodes/bib-mode.el @@ -198,7 +198,7 @@ named by variable `unread-bib-file'." (defvar bib-capitalize-title-stop-words (concat - "the\\|and\\|of\\|is\\|a\\|an\\|of\\|for\\|in\\|to\\|in\\|on\\|at\\|" + "the\\|and\\|of\\|is\\|a\\|an\\|for\\|in\\|to\\|on\\|at\\|" "by\\|with\\|that\\|its") "Words not to be capitalized in a title (unless the first word).") diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index b9ff7a57988..a560c2b097f 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -1038,6 +1038,9 @@ 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) + (defcustom bibtex-autokey-name-case-convert-function 'downcase "Function called for each name to perform case conversion. See `bibtex-generate-autokey' for details." @@ -1049,8 +1052,6 @@ See `bibtex-generate-autokey' for details." (function :tag "Conversion function"))) (put 'bibtex-autokey-name-case-convert-function 'safe-local-variable (lambda (x) (memq x '(upcase downcase capitalize identity)))) -(defvaralias 'bibtex-autokey-name-case-convert - 'bibtex-autokey-name-case-convert-function) (defcustom bibtex-autokey-name-length 'infty "Number of characters from name to incorporate into key. @@ -1113,6 +1114,9 @@ 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) + (defcustom bibtex-autokey-titleword-case-convert-function 'downcase "Function called for each titleword to perform case conversion. See `bibtex-generate-autokey' for details." @@ -1122,8 +1126,6 @@ See `bibtex-generate-autokey' for details." (const :tag "Capitalize" capitalize) (const :tag "Upcase" upcase) (function :tag "Conversion function"))) -(defvaralias 'bibtex-autokey-titleword-case-convert - 'bibtex-autokey-titleword-case-convert-function) (defcustom bibtex-autokey-titleword-abbrevs nil "Determines exceptions to the usual abbreviation mechanism. @@ -1354,6 +1356,8 @@ Set this variable before loading BibTeX mode." ;; The Key `C-c&' is reserved for reftex.el (define-key km "\t" 'bibtex-find-text) (define-key km "\n" 'bibtex-next-field) + (define-key km [remap forward-paragraph] 'bibtex-next-entry) + (define-key km [remap backward-paragraph] 'bibtex-previous-entry) (define-key km "\M-\t" 'completion-at-point) (define-key km "\C-c\"" 'bibtex-remove-delimiters) (define-key km "\C-c{" 'bibtex-remove-delimiters) @@ -1413,6 +1417,8 @@ Set this variable before loading BibTeX mode." ("Moving inside an Entry" ["End of Field" bibtex-find-text t] ["Next Field" bibtex-next-field t] + ["Next entry" bibtex-next-entry t] + ["Previous entry" bibtex-previous-entry t] ["Beginning of Entry" bibtex-beginning-of-entry t] ["End of Entry" bibtex-end-of-entry t] "--" @@ -2343,7 +2349,8 @@ Formats current entry according to variable `bibtex-entry-format'." (when (memq 'sort-fields format) (goto-char (point-min)) (let ((beg-fields (save-excursion (bibtex-beginning-first-field))) - (fields-alist (bibtex-parse-entry)) + (fields-alist (bibtex-parse-entry + nil (not (memq 'opts-or-alts format)))) bibtex-help-message elt) (delete-region beg-fields (point)) (dolist (field default-field-list) @@ -2365,7 +2372,8 @@ Formats current entry according to variable `bibtex-entry-format'." (end-text (copy-marker (bibtex-end-of-text-in-field bounds) t)) (empty-field (equal "" (bibtex-text-in-field-bounds bounds t))) (field-name (buffer-substring-no-properties beg-name end-name)) - (opt-alt (and (string-match "\\`\\(OPT\\|ALT\\)" field-name) + (opt-alt (and (memq 'opts-or-alts format) + (string-match "\\`\\(OPT\\|ALT\\)" field-name) (not (and bibtex-no-opt-remove-re (string-match bibtex-no-opt-remove-re field-name))))) @@ -2932,7 +2940,7 @@ for parsing BibTeX keys. If parsing fails, try to set this variable to nil." (if verbose (bibtex-progress-message 'done)) ;; successful operation --> return `bibtex-reference-keys' - (setq bibtex-reference-keys ref-keys))))))) + (setq bibtex-reference-keys (nreverse ref-keys)))))))) (defun bibtex-parse-strings (&optional add abortable) "Set `bibtex-strings' to the string definitions in the whole buffer. @@ -3639,20 +3647,20 @@ When called interactively with a prefix arg, query for a value of ENTRY-TYPE." (mapc 'bibtex-make-field required) (mapc 'bibtex-make-optional-field optional))))) -(defun bibtex-parse-entry (&optional content) +(defun bibtex-parse-entry (&optional content keep-opt-alt) "Parse entry at point, return an alist. The alist elements have the form (FIELD . TEXT), where FIELD can also be the special strings \"=type=\" and \"=key=\". For the FIELD \"=key=\" -TEXT may be nil. Remove \"OPT\" and \"ALT\" from FIELD. -Move point to the end of the last field. -If optional arg CONTENT is non-nil extract content of text fields." +TEXT may be nil. Move point to the end of the last field. +If optional arg CONTENT is non-nil extract content of text fields. +Remove \"OPT\" and \"ALT\" from FIELD unless KEEP-OPT-ALT is non-nil." (let (alist bounds) (when (looking-at bibtex-entry-maybe-empty-head) (push (cons "=type=" (bibtex-type-in-head)) alist) (push (cons "=key=" (bibtex-key-in-head)) alist) (goto-char (match-end 0)) (while (setq bounds (bibtex-parse-field)) - (push (cons (bibtex-name-in-field bounds t) + (push (cons (bibtex-name-in-field bounds (not keep-opt-alt)) (bibtex-text-in-field-bounds bounds content)) alist) (goto-char (bibtex-end-of-field bounds)))) @@ -3846,11 +3854,13 @@ Return the new location of point." (re-search-forward "[\n\C-m]" nil 'end (1- arg)) (forward-line (1- arg)))) -(defun bibtex-reposition-window () +(defun bibtex-reposition-window (&optional pos) "Make the current BibTeX entry visible. If entry is smaller than `window-body-height', entry is centered in window. -Otherwise display the beginning of entry." +Otherwise display the beginning of entry. +Optional arg POS is the position of the BibTeX entry to use." (interactive) + (if pos (goto-char pos)) (let ((pnt (point)) (beg (line-number-at-pos (bibtex-beginning-of-entry))) (end (line-number-at-pos (bibtex-end-of-entry)))) @@ -3869,9 +3879,10 @@ Otherwise display the beginning of entry." (goto-char pnt))))) (defun bibtex-mark-entry () - "Put mark at beginning, point at end of current BibTeX entry." + "Put mark at beginning, point at end of current BibTeX entry. +Activate mark in Transient Mark mode." (interactive) - (push-mark (bibtex-beginning-of-entry) :activate t) + (push-mark (bibtex-beginning-of-entry) t t) (bibtex-end-of-entry)) (defun bibtex-count-entries (&optional count-string-entries) @@ -4058,8 +4069,7 @@ for a crossref key, t otherwise." (message "Key `%s' is current entry" crossref-key) (if eqb (select-window (split-window)) (pop-to-buffer buffer)) - (goto-char pos) - (bibtex-reposition-window) + (bibtex-reposition-window pos) (beginning-of-line) (if (and eqb (> pnt pos) (not noerror)) (error "The referencing entry must precede the crossrefed entry!")))) @@ -4107,9 +4117,14 @@ A prefix arg negates the value of `bibtex-search-entry-globally'." (if (cdr (assoc-string key bibtex-reference-keys)) (setq found (bibtex-search-entry key))))) (cond ((and found display) - (switch-to-buffer buffer) - (goto-char found) - (bibtex-reposition-window)) + ;; If possible, reuse the window displaying BUFFER. + (let ((window (get-buffer-window buffer t))) + (if window + (progn + (select-frame-set-input-focus (window-frame window)) + (select-window window)) + (switch-to-buffer buffer))) + (bibtex-reposition-window found)) (found (set-buffer buffer)) (display (message "Key `%s' not found" key))) found) @@ -4441,6 +4456,24 @@ is as in `bibtex-enclosing-field'. It is t for interactive calls." (goto-char (match-beginning 0))) (bibtex-find-text begin nil bibtex-help-message))) +(defun bibtex-next-entry (&optional arg) + "Move point ARG entries forward. +ARG defaults to one. Called interactively, ARG is the prefix +argument." + (interactive "p") + (bibtex-end-of-entry) + (when (re-search-forward bibtex-entry-maybe-empty-head nil t (or arg 1)) + (goto-char (match-beginning 0)))) + +(defun bibtex-previous-entry (&optional arg) + "Move point ARG entries backward. +ARG defaults to one. Called interactively, ARG is the prefix +argument." + (interactive "p") + (bibtex-beginning-of-entry) + (when (re-search-backward bibtex-entry-maybe-empty-head nil t (or arg 1)) + (goto-char (match-beginning 0)))) + (defun bibtex-find-text (&optional begin noerror help comma) "Move point to end of text of current BibTeX field or entry head. With optional prefix BEGIN non-nil, move point to its beginning. @@ -4925,23 +4958,26 @@ If mark is active reformat entries in region, if not in whole buffer." (cond (read-options (if use-previous-options bibtex-reformat-previous-options - (setq bibtex-reformat-previous-options - (delq nil - (mapcar (lambda (option) - (if (y-or-n-p (car option)) (cdr option))) - `(("Realign entries (recommended)? " . realign) - ("Remove empty optional and alternative fields? " . opts-or-alts) - ("Remove delimiters around pure numerical fields? " . numerical-fields) - (,(concat (if bibtex-comma-after-last-field "Insert" "Remove") - " comma at end of entry? ") . last-comma) - ("Replace double page dashes by single ones? " . page-dashes) - ("Delete whitespace at the beginning and end of fields? " . whitespace) - ("Inherit booktitle? " . inherit-booktitle) - ("Force delimiters? " . delimiters) - ("Unify case of entry types and field names? " . unify-case) - ("Enclose parts of field entries by braces? " . braces) - ("Replace parts of field entries by string constants? " . strings) - ("Sort fields? " . sort-fields))))))) + (let (answers) + (map-y-or-n-p + #'car + (lambda (option) + (push (cdr option) answers)) + `(("Realign entries (recommended)? " . realign) + ("Remove empty optional and alternative fields? " . opts-or-alts) + ("Remove delimiters around pure numerical fields? " . numerical-fields) + (,(concat (if bibtex-comma-after-last-field "Insert" "Remove") + " comma at end of entry? ") . last-comma) + ("Replace double page dashes by single ones? " . page-dashes) + ("Delete whitespace at the beginning and end of fields? " . whitespace) + ("Inherit booktitle? " . inherit-booktitle) + ("Force delimiters? " . delimiters) + ("Unify case of entry types and field names? " . unify-case) + ("Enclose parts of field entries by braces? " . braces) + ("Replace parts of field entries by string constants? " . strings) + ("Sort fields? " . sort-fields)) + '("formatting action" "formatting actions" "perform")) + (setq bibtex-reformat-previous-options (nreverse answers))))) ;; Do not include required-fields because `bibtex-reformat' ;; cannot handle the error messages of `bibtex-format-entry'. ;; Use `bibtex-validate' to check for required fields. @@ -5059,7 +5095,7 @@ entries from minibuffer." (list beg end (lambda (s p a) (cond - ((eq a 'metadata) `(metadata (category . bibtex-key))) + ((eq a 'metadata) '(metadata (category . bibtex-key))) (t (let ((completion-ignore-case nil)) (complete-with-action a (bibtex-global-key-alist) s p))))) @@ -5077,7 +5113,7 @@ entries from minibuffer." (list beg end (lambda (s p a) (cond - ((eq a 'metadata) `(metadata (category . bibtex-string))) + ((eq a 'metadata) '(metadata (category . bibtex-string))) (t (let ((completion-ignore-case t)) (complete-with-action a compl s p))))) :exit-function (bibtex-complete-string-cleanup compl)))))) diff --git a/lisp/textmodes/conf-mode.el b/lisp/textmodes/conf-mode.el index ff0f56ebbb8..3b3d5d4ff20 100644 --- a/lisp/textmodes/conf-mode.el +++ b/lisp/textmodes/conf-mode.el @@ -1,4 +1,4 @@ -;;; conf-mode.el --- Simple major mode for editing conf/ini/properties files +;;; conf-mode.el --- Simple major mode for editing conf/ini/properties files -*- lexical-binding: t; -*- ;; Copyright (C) 2004-2019 Free Software Foundation, Inc. @@ -135,7 +135,7 @@ not align (only setting space according to `conf-assignment-space')." (modify-syntax-entry ?_ "_" table) (modify-syntax-entry ?- "_" table) (modify-syntax-entry ?. "_" table) - (modify-syntax-entry ?\' "\"" table) + (modify-syntax-entry ?' "\"" table) (modify-syntax-entry ?\; "<" table) (modify-syntax-entry ?\n ">" table) (modify-syntax-entry ?\r ">" table) @@ -194,7 +194,7 @@ not align (only setting space according to `conf-assignment-space')." (1 'font-lock-variable-name-face) (2 'font-lock-constant-face nil t)) ;; section { ... } (do this last because some assign ...{...) - ("^[ \t]*\\([^=:\n]+?\\)[ \t\n]*{[^{}]*?$" 1 'font-lock-type-face prepend)) + ("^[ \t]*\\([^#=:\n]+?\\)[ \t\n]*{[^{}]*?$" 1 'font-lock-type-face prepend)) "Keywords to highlight in Conf mode.") (defvar conf-javaprop-font-lock-keywords @@ -230,7 +230,7 @@ This variable is best set in the file local variables, or through (put 'conf-space-keywords 'safe-local-variable 'stringp) (defvar conf-space-font-lock-keywords - `(;; [section] (do this first because it may look like a parameter) + '(;; [section] (do this first because it may look like a parameter) ("^[ \t]*\\[\\(.+\\)\\]" 1 'font-lock-type-face) ;; section { ... } (do this first because it looks like a parameter) ("^[ \t]*\\(.+?\\)[ \t\n]*{[^{}]*?$" 1 'font-lock-type-face) @@ -243,7 +243,7 @@ This variable is best set in the file local variables, or through "Keywords to highlight in Conf Space mode.") (defvar conf-colon-font-lock-keywords - `(;; [section] (do this first because it may look like a parameter) + '(;; [section] (do this first because it may look like a parameter) ("^[ \t]*\\[\\(.+\\)\\]" 1 'font-lock-type-face) ;; var: val ("^[ \t]*\\(.+?\\)[ \t]*:" @@ -281,10 +281,10 @@ whitespace.") ;; If anybody can figure out how to get the same effect by configuring ;; `align', I'd be glad to hear. (defun conf-align-assignments (&optional arg) - (interactive "P") "Align the assignments in the buffer or active region. In Transient Mark mode, if the mark is active, operate on the contents of the region. Otherwise, operate on the whole buffer." + (interactive "P") (setq arg (if arg (prefix-numeric-value arg) conf-assignment-column)) @@ -323,7 +323,7 @@ contents of the region. Otherwise, operate on the whole buffer." (defun conf-quote-normal (arg) "Set the syntax of \\=' and \" to punctuation. -With prefix arg, only do it for \\=' if 1, or only for \" if 2. +With prefix ARG, only do it for \\=' if 1, or only for \" if 2. This only affects the current buffer. Some conf files use quotes to delimit strings, while others allow quotes as simple parts of the assigned value. In those files font locking will be wrong, @@ -442,7 +442,7 @@ See also `conf-space-mode', `conf-colon-mode', `conf-javaprop-mode', (run-mode-hooks 'conf-mode-hook))) (defun conf-mode-initialize (comment &optional font-lock) - "Initializations for sub-modes of conf-mode. + "Initializations for sub-modes of `conf-mode'. COMMENT initializes `comment-start' and `comment-start-skip'. The optional arg FONT-LOCK is the value for FONT-LOCK-KEYWORDS." (set (make-local-variable 'comment-start) comment) diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index 67a0c9f7a57..b0653bce81c 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -34,9 +34,12 @@ (require 'cl-lib) (require 'color) +(require 'eww) +(require 'imenu) (require 'seq) (require 'sgml-mode) (require 'smie) +(require 'thingatpt) (eval-when-compile (require 'subr-x)) (defgroup css nil @@ -109,7 +112,6 @@ ("bottom" length percentage "auto") ("caption-side" "top" "bottom") ("clear" "none" "left" "right" "both") - ("clip" shape "auto") ("content" "normal" "none" string uri counter "attr()" "open-quote" "close-quote" "no-open-quote" "no-close-quote") ("counter-increment" identifier integer "none") @@ -372,6 +374,31 @@ ("orphans" integer) ("widows" integer) + ;; CSS Masking Module Level 1 + ;; (https://www.w3.org/TR/css-masking-1/#property-index) + ("clip-path" clip-source basic-shape geometry-box "none") + ("clip-rule" "nonzero" "evenodd") + ("mask-image" mask-reference) + ("mask-mode" masking-mode) + ("mask-repeat" repeat-style) + ("mask-position" position) + ("mask-clip" geometry-box "no-clip") + ("mask-origin" geometry-box) + ("mask-size" bg-size) + ("mask-composite" compositing-operator) + ("mask" mask-layer) + ("mask-border-source" "none" image) + ("mask-border-mode" "luminance" "alpha") + ("mask-border-slice" number percentage "fill") + ("mask-border-width" length percentage number "auto") + ("mask-border-outset" length number) + ("mask-border-repeat" "stretch" "repeat" "round" "space") + ("mask-border" mask-border-source mask-border-slice + mask-border-width mask-border-outset mask-border-repeat + mask-border-mode) + ("mask-type" "luminance" "alpha") + ("clip" "rect()" "auto") + ;; CSS Multi-column Layout Module ;; (https://www.w3.org/TR/css3-multicol/#property-index) ;; "break-after", "break-before", and "break-inside" are left out @@ -649,14 +676,17 @@ further value candidates, since that list would be infinite.") (attachment "scroll" "fixed" "local") (auto-repeat "repeat()") (auto-track-list line-names fixed-size fixed-repeat auto-repeat) + (basic-shape "inset()" "circle()" "ellipse()" "polygon()") (bg-image image "none") (bg-layer bg-image position repeat-style attachment box) (bg-size length percentage "auto" "cover" "contain") (box "border-box" "padding-box" "content-box") + (clip-source uri) (color "rgb()" "rgba()" "hsl()" "hsla()" named-color "transparent" "currentColor") (common-lig-values "common-ligatures" "no-common-ligatures") + (compositing-operator "add" "subtract" "intersect" "exclude") (contextual-alt-values "contextual" "no-contextual") (counter "counter()" "counters()") (discretionary-lig-values @@ -682,6 +712,7 @@ further value candidates, since that list would be infinite.") (generic-family "serif" "sans-serif" "cursive" "fantasy" "monospace") (generic-voice "male" "female" "child") + (geometry-box shape-box "fill-box" "stroke-box" "view-box") (gradient linear-gradient radial-gradient repeating-linear-gradient repeating-radial-gradient) @@ -702,6 +733,12 @@ further value candidates, since that list would be infinite.") (line-width length "thin" "medium" "thick") (linear-gradient "linear-gradient()") (margin-width "auto" length percentage) + (mask-layer + mask-reference masking-mode position bg-size repeat-style + geometry-box "no-clip" compositing-operator) + (mask-reference "none" image mask-source) + (mask-source uri) + (masking-mode "alpha" "luminance" "auto") (named-color . ,(mapcar #'car css--color-map)) (number "calc()") (numeric-figure-values "lining-nums" "oldstyle-nums") @@ -717,7 +754,7 @@ further value candidates, since that list would be infinite.") (repeating-linear-gradient "repeating-linear-gradient()") (repeating-radial-gradient "repeating-radial-gradient()") (shadow "inset" length color) - (shape "rect()") + (shape-box box "margin-box") (single-animation-direction "normal" "reverse" "alternate" "alternate-reverse") (single-animation-fill-mode "none" "forwards" "backwards" "both") @@ -807,6 +844,21 @@ cannot be completed sensibly: `custom-ident', (defvar css-mode-map (let ((map (make-sparse-keymap))) (define-key map [remap info-lookup-symbol] 'css-lookup-symbol) + ;; `info-complete-symbol' is not used. + (define-key map [remap complete-symbol] 'completion-at-point) + (define-key map "\C-c\C-f" 'css-cycle-color-format) + (easy-menu-define css-menu map "CSS mode menu" + '("CSS" + :help "CSS-specific features" + ["Reformat block" fill-paragraph + :help "Reformat declaration block or fill comment at point"] + ["Cycle color format" css-cycle-color-format + :help "Cycle color at point between different formats"] + "-" + ["Describe symbol" css-lookup-symbol + :help "Display documentation for a CSS symbol"] + ["Complete symbol" completion-at-point + :help "Complete symbol before point"])) map) "Keymap used in `css-mode'.") @@ -821,7 +873,7 @@ cannot be completed sensibly: `custom-ident', (css--uri-re (1 "|") (2 "|")))) (defconst css-escapes-re - "\\\\\\(?:[^\000-\037\177]\\|[0-9a-fA-F]+[ \n\t\r\f]?\\)") + "\\\\\\(?:[^\000-\037\177]\\|[[:xdigit:]]+[ \n\t\r\f]?\\)") (defconst css-nmchar-re (concat "\\(?:[-[:alnum:]]\\|" css-escapes-re "\\)")) (defconst css-nmstart-re (concat "\\(?:[[:alpha:]]\\|" css-escapes-re "\\)")) (defconst css-ident-re ;; (concat css-nmstart-re css-nmchar-re "*") @@ -854,7 +906,7 @@ cannot be completed sensibly: `custom-ident', (,(concat "@" css-ident-re) (0 font-lock-builtin-face)) ;; Selectors. ;; Allow plain ":root" as a selector. - ("^[ \t]*\\(:root\\)\\(?:[\n \t]*\\)*{" (1 'css-selector keep)) + ("^[ \t]*\\(:root\\)[\n \t]*{" (1 'css-selector keep)) ;; FIXME: attribute selectors don't work well because they may contain ;; strings which have already been highlighted as f-l-string-face and ;; thus prevent this highlighting from being applied (actually now that @@ -877,7 +929,7 @@ cannot be completed sensibly: `custom-ident', "\\(?:\\(:" (regexp-opt (append css-pseudo-class-ids css-pseudo-element-ids) t) - "\\|\\::" (regexp-opt css-pseudo-element-ids t) "\\)" + "\\|::" (regexp-opt css-pseudo-element-ids t) "\\)" "\\(?:([^)]+)\\)?" (if (not sassy) "[^:{}()\n]*" @@ -897,7 +949,7 @@ cannot be completed sensibly: `custom-ident', ;; No face. nil))) ;; Variables. - (,(concat "--" css-ident-re) (0 font-lock-variable-name-face)) + (,(concat (rx symbol-start) "--" css-ident-re) (0 font-lock-variable-name-face)) ;; Properties. Again, we don't limit ourselves to css-property-ids. (,(concat "\\(?:[{;]\\|^\\)[ \t]*\\(" "\\(?:\\(" css-proprietary-nmstart-re "\\)\\|" @@ -937,11 +989,13 @@ cannot be completed sensibly: `custom-ident', "Skip blanks and comments." (while (forward-comment 1))) -(cl-defun css--rgb-color () +(cl-defun css--rgb-color (&optional include-alpha) "Parse a CSS rgb() or rgba() color. Point should be just after the open paren. Returns a hex RGB color, or nil if the color could not be recognized. -This recognizes CSS-color-4 extensions." +This recognizes CSS-color-4 extensions. +When INCLUDE-ALPHA is non-nil, the alpha component is included in +the returned hex string." (let ((result '()) (iter 0)) (while (< iter 4) @@ -951,11 +1005,11 @@ This recognizes CSS-color-4 extensions." (let* ((is-percent (match-beginning 1)) (str (match-string (if is-percent 1 2))) (number (string-to-number str))) - (when is-percent - (setq number (* 255 (/ number 100.0)))) - ;; Don't push the alpha. - (when (< iter 3) - (push (min (max 0 (truncate number)) 255) result)) + (if is-percent + (setq number (* 255 (/ number 100.0))) + (when (and include-alpha (= iter 3)) + (setq number (* number 255)))) + (push (min (max 0 (round number)) 255) result) (goto-char (match-end 0)) (css--color-skip-blanks) (cl-incf iter) @@ -967,7 +1021,11 @@ This recognizes CSS-color-4 extensions." (css--color-skip-blanks))) (when (looking-at ")") (forward-char) - (apply #'format "#%02x%02x%02x" (nreverse result))))) + (apply #'format + (if (and include-alpha (= (length result) 4)) + "#%02x%02x%02x%02x" + "#%02x%02x%02x") + (nreverse result))))) (cl-defun css--hsl-color () "Parse a CSS hsl() or hsla() color. @@ -1021,10 +1079,10 @@ This recognizes CSS-color-4 extensions." (regexp-opt (mapcar #'car css--color-map) 'symbols) "\\|" ;; Short hex. css-color-4 adds alpha. - "\\(#[0-9a-fA-F]\\{3,4\\}\\b\\)" + "\\(#[[:xdigit:]]\\{3,4\\}\\b\\)" "\\|" ;; Long hex. css-color-4 adds alpha. - "\\(#\\(?:[0-9a-fA-F][0-9a-fA-F]\\)\\{3,4\\}\\b\\)" + "\\(#\\(?:[[:xdigit:]][[:xdigit:]]\\)\\{3,4\\}\\b\\)" "\\|" ;; RGB. "\\(\\_<rgba?(\\)" @@ -1038,9 +1096,15 @@ This recognizes CSS-color-4 extensions." STR is the incoming CSS hex color. This function simply drops any transparency." ;; Either #RGB or #RRGGBB, drop the "A" or "AA". - (if (> (length str) 5) - (substring str 0 7) - (substring str 0 4))) + (substring str 0 (if (> (length str) 5) 7 4))) + +(defun css--hex-alpha (hex) + "Return the alpha component of CSS color HEX. +HEX can either be in the #RGBA or #RRGGBBAA format. Return nil +if the color doesn't have an alpha component." + (cl-case (length hex) + (5 (string (elt hex 4))) + (9 (substring hex 7 9)))) (defun css--named-color (start-point str) "Check whether STR, seen at point, is CSS named color. @@ -1200,19 +1264,20 @@ for determining whether point is within a selector." (defun css-smie-rules (kind token) (pcase (cons kind token) - (`(:elem . basic) css-indent-offset) - (`(:elem . arg) 0) - (`(:list-intro . ,(or `";" `"")) t) ;"" stands for BOB (bug#15467). - (`(:before . "{") + ('(:elem . basic) css-indent-offset) + ('(:elem . arg) 0) + ;; "" stands for BOB (bug#15467). + (`(:list-intro . ,(or ";" "" ":-property")) t) + ('(:before . "{") (when (or (smie-rule-hanging-p) (smie-rule-bolp)) (smie-backward-sexp ";") (unless (eq (char-after) ?\{) (smie-indent-virtual)))) - (`(:before . "(") + ('(:before . "(") (cond ((smie-rule-hanging-p) (smie-rule-parent 0)) ((not (smie-rule-bolp)) 0))) - (`(:after . ":-property") + ('(:after . ":-property") (when (smie-rule-hanging-p) css-indent-offset)))) @@ -1384,6 +1449,171 @@ tags, classes and IDs." (progn (insert ": ;") (forward-char -1)))))))))) +(defun css--color-to-4-dpc (hex) + "Convert the CSS color HEX to four digits per component. +CSS colors use one or two digits per component for RGB hex +values. Convert the given color to four digits per component. + +Note that this function handles CSS colors specifically, and +should not be mixed with those in color.el." + (let ((six-digits (= (length hex) 7))) + (apply + #'concat + `("#" + ,@(seq-mapcat + (apply-partially #'make-list (if six-digits 2 4)) + (seq-partition (seq-drop hex 1) (if six-digits 2 1))))))) + +(defun css--format-hex (hex) + "Format a CSS hex color by shortening it if possible." + (let ((parts (seq-partition (seq-drop hex 1) 2))) + (if (and (>= (length hex) 6) + (seq-every-p (lambda (p) (eq (elt p 0) (elt p 1))) parts)) + (apply #'string + (cons ?# (mapcar (lambda (p) (elt p 0)) parts))) + hex))) + +(defun css--named-color-to-hex () + "Convert named CSS color at point to hex format. +Return non-nil if a conversion was made. + +Note that this function handles CSS colors specifically, and +should not be mixed with those in color.el." + (save-excursion + (unless (or (looking-at css--colors-regexp) + (eq (char-before) ?#)) + (backward-word)) + (when (member (word-at-point) (mapcar #'car css--color-map)) + (looking-at css--colors-regexp) + (let ((color (css--compute-color (point) (match-string 0)))) + (replace-match (css--format-hex color))) + t))) + +(defun css--format-rgba-alpha (alpha) + "Return ALPHA component formatted for use in rgba()." + (let ((a (string-to-number (format "%.2f" alpha)))) + (if (or (= a 0) + (= a 1)) + (format "%d" a) + (string-remove-suffix "0" (number-to-string a))))) + +(defun css--hex-to-rgb () + "Convert CSS hex color at point to RGB format. +Return non-nil if a conversion was made. + +Note that this function handles CSS colors specifically, and +should not be mixed with those in color.el." + (save-excursion + (unless (or (eq (char-after) ?#) + (eq (char-before) ?\()) + (backward-sexp)) + (when-let* ((hex (when (looking-at css--colors-regexp) + (and (eq (elt (match-string 0) 0) ?#) + (match-string 0)))) + (rgb (css--hex-color hex))) + (seq-let (r g b) + (mapcar (lambda (x) (round (* x 255))) + (color-name-to-rgb (css--color-to-4-dpc rgb))) + (replace-match + (if-let* ((alpha (css--hex-alpha hex)) + (a (css--format-rgba-alpha + (/ (string-to-number alpha 16) + (float (- (expt 16 (length alpha)) 1)))))) + (format "rgba(%d, %d, %d, %s)" r g b a) + (format "rgb(%d, %d, %d)" r g b)) + t)) + t))) + +(defun css--rgb-to-named-color-or-hex () + "Convert CSS RGB color at point to a named color or hex format. +Convert to a named color if the color at point has a name, else +convert to hex format. Return non-nil if a conversion was made. + +Note that this function handles CSS colors specifically, and +should not be mixed with those in color.el." + (save-excursion + (when-let* ((open-paren-pos (nth 1 (syntax-ppss)))) + (when (save-excursion + (goto-char open-paren-pos) + (looking-back "rgba?" (- (point) 4))) + (goto-char (nth 1 (syntax-ppss))))) + (when (eq (char-before) ?\)) + (backward-sexp)) + (skip-chars-backward "rgba") + (when (looking-at css--colors-regexp) + (let* ((start (match-end 0)) + (color (save-excursion + (goto-char start) + (css--rgb-color t)))) + (when color + (kill-sexp) + (kill-sexp) + (let ((named-color (seq-find (lambda (x) (equal (cdr x) color)) + css--color-map))) + (insert (if named-color + (car named-color) + (css--format-hex color)))) + t))))) + +(defun css-cycle-color-format () + "Cycle the color at point between different CSS color formats. +Supported formats are by name (if possible), hexadecimal, and +rgb()/rgba()." + (interactive) + (or (css--named-color-to-hex) + (css--hex-to-rgb) + (css--rgb-to-named-color-or-hex) + (message "It doesn't look like a color at point"))) + +(defun css--join-nested-selectors (selectors) + "Join a list of nested CSS selectors." + (let ((processed '()) + (prev nil)) + (dolist (sel selectors) + (cond + ((seq-contains-p sel ?&) + (setq sel (replace-regexp-in-string "&" prev sel)) + (pop processed)) + ;; Unless this is the first selector, separate this one and the + ;; previous one by a space. + (processed + (push " " processed))) + (push sel processed) + (setq prev sel)) + (apply #'concat (nreverse processed)))) + +(defun css--prev-index-position () + (when (nth 7 (syntax-ppss)) + (goto-char (comment-beginning))) + (forward-comment (- (point))) + (when (search-backward "{" (point-min) t) + (if (re-search-backward "}\\|;\\|{" (point-min) t) + (forward-char) + (goto-char (point-min))) + (forward-comment (point-max)) + (save-excursion (re-search-forward "[^{;]*")))) + +(defun css--extract-index-name () + (save-excursion + (let ((res (list (match-string-no-properties 0)))) + (condition-case nil + (while t + (goto-char (nth 1 (syntax-ppss))) + (if (re-search-backward "}\\|;\\|{" (point-min) t) + (forward-char) + (goto-char (point-min))) + (forward-comment (point-max)) + (when (save-excursion + (re-search-forward "[^{;]*")) + (push (match-string-no-properties 0) res))) + (error + (css--join-nested-selectors + (mapcar + (lambda (s) + (string-trim + (replace-regexp-in-string "[\n ]+" " " s))) + res))))))) + ;;;###autoload (define-derived-mode css-mode prog-mode "CSS" "Major mode to edit Cascading Style Sheets (CSS). @@ -1391,7 +1621,7 @@ tags, classes and IDs." This mode provides syntax highlighting, indentation, completion, and documentation lookup for CSS. -Use `\\[complete-symbol]' to complete CSS properties, property values, +Use `\\[completion-at-point]' to complete CSS properties, property values, pseudo-elements, pseudo-classes, at-rules, bang-rules, and HTML tags, classes and IDs. Completion candidates for HTML class names and IDs are found by looking through open HTML mode @@ -1422,7 +1652,13 @@ be used to fill comments. (append css-electric-keys electric-indent-chars)) (setq-local font-lock-fontify-region-function #'css--fontify-region) (add-hook 'completion-at-point-functions - #'css-completion-at-point nil 'local)) + #'css-completion-at-point nil 'local) + ;; The default "." creates ambiguity with class selectors. + (setq-local imenu-space-replacement " ") + (setq-local imenu-prev-index-position-function + #'css--prev-index-position) + (setq-local imenu-extract-index-name-function + #'css--extract-index-name)) (defvar comment-continue) @@ -1519,12 +1755,8 @@ be used to fill comments. (defun css-current-defun-name () "Return the name of the CSS section at point, or nil." (save-excursion - (let ((max (max (point-min) (- (point) 1600)))) ; approx 20 lines back - (when (search-backward "{" max t) - (skip-chars-backward " \t\r\n") - (beginning-of-line) - (if (looking-at "^[ \t]*\\([^{\r\n]*[^ {\t\r\n]\\)") - (match-string-no-properties 1)))))) + (when (css--prev-index-position) + (css--extract-index-name)))) ;;; SCSS mode diff --git a/lisp/textmodes/dns-mode.el b/lisp/textmodes/dns-mode.el index 5344d6127fe..06e944815a7 100644 --- a/lisp/textmodes/dns-mode.el +++ b/lisp/textmodes/dns-mode.el @@ -45,6 +45,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defgroup dns-mode nil "DNS master file mode configuration." :group 'data) @@ -112,9 +114,9 @@ "26.1" 'set) (defcustom dns-mode-font-lock-keywords - `((,(concat "^$" (regexp-opt dns-mode-control-entities)) + `((,(concat "^\\$" (regexp-opt dns-mode-control-entities)) 0 ,dns-mode-control-entity-face) - ("^$[a-z0-9A-Z]+" 0 ,dns-mode-bad-control-entity-face) + ("^\\$[a-z0-9A-Z]+" 0 ,dns-mode-bad-control-entity-face) (,(regexp-opt dns-mode-classes) 0 ,dns-mode-class-face) (,(regexp-opt dns-mode-types) 0 ,dns-mode-type-face)) "Font lock keywords used to highlight text in DNS master file mode." @@ -178,9 +180,8 @@ Turning on DNS mode runs `dns-mode-hook'." (set (make-local-variable 'comment-start) ";") (set (make-local-variable 'comment-end) "") (set (make-local-variable 'comment-start-skip) ";+ *") - (unless (featurep 'xemacs) - (set (make-local-variable 'font-lock-defaults) - '(dns-mode-font-lock-keywords nil nil ((?_ . "w"))))) + (set (make-local-variable 'font-lock-defaults) + '(dns-mode-font-lock-keywords nil nil ((?_ . "w")))) (add-hook 'before-save-hook 'dns-mode-soa-maybe-increment-serial nil t) (easy-menu-add dns-mode-menu dns-mode-map)) @@ -290,9 +291,9 @@ Examples: (skip-syntax-backward " ") (skip-syntax-backward "w_.") (re-search-forward "\\([[:xdigit:]:]+\\)\\(/-?[0-9]\\{2,3\\}\\)?") - (kill-new (match-string 0)) (let ((address (match-string 1)) (prefix-length (match-string 2))) + (kill-new (match-string 0)) (when prefix-length (setq prefix-length (string-to-number (substring prefix-length 1))) (if negate-prefix diff --git a/lisp/textmodes/enriched.el b/lisp/textmodes/enriched.el index d4e2f788ee3..e89ffead9e8 100644 --- a/lisp/textmodes/enriched.el +++ b/lisp/textmodes/enriched.el @@ -120,9 +120,11 @@ expression, which is evaluated to get the string to insert.") ;; The following are not part of the standard: (FUNCTION (enriched-decode-foreground "x-color") (enriched-decode-background "x-bg-color") - (enriched-decode-display-prop "x-display")) + (enriched-decode-display-prop "x-display") + (enriched-decode-charset "x-charset")) (read-only (t "x-read-only")) (display (nil enriched-handle-display-prop)) + (charset (nil enriched-handle-charset-prop)) (unknown (nil format-annotate-value)) ; (font-size (2 "bigger") ; unimplemented ; (-2 "smaller")) @@ -208,10 +210,6 @@ The value is a list of \(VAR VALUE VAR VALUE...).") These are files with embedded formatting information in the MIME standard text/enriched format. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. - Turning the mode on or off runs `enriched-mode-hook'. More information about Enriched mode is available in the file @@ -492,6 +490,21 @@ Return value is \(begin end name positive-p), or nil if none was found." (list from to 'face (list ':background color)) (message "Warning: no color specified for <x-bg-color>") nil)) + +(defun enriched-decode-charset (from to &optional cset) + (let ((cs (when (stringp cset) + (condition-case () + (car (read-from-string cset)) + (error nil))))) + (unless cs + (message "Warning: invalid <x-charset> parameter %s" cset)) + (list from to 'charset cs))) + +(defun enriched-handle-charset-prop (old new) + "Return a list of annotations for a change in the `charset' property." + (cons (and old (list (list "x-charset" (symbol-name old)))) + (and new (list (list "x-charset" (symbol-name new)))))) + ;;; Handling the `display' property. diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el index c5975bb721b..c285491a305 100644 --- a/lisp/textmodes/fill.el +++ b/lisp/textmodes/fill.el @@ -129,10 +129,11 @@ if it would act as a paragraph-starter on the second line." :type 'regexp :group 'fill) -(defcustom adaptive-fill-function nil - "Function to call to choose a fill prefix for a paragraph, or nil. -A nil value means the function has not determined the fill prefix." - :type '(choice (const nil) function) +(defcustom adaptive-fill-function #'ignore + "Function to call to choose a fill prefix for a paragraph. +A nil return value means the function has not determined the fill prefix." + :version "27.1" + :type 'function :group 'fill) (defvar fill-indent-according-to-mode nil ;Screws up CC-mode's filling tricks. @@ -339,6 +340,18 @@ places." (and (memq (preceding-char) '(?\t ?\s)) (eq (char-syntax (following-char)) ?w))))))) +(defun fill-polish-nobreak-p () + "Return nil if Polish style allows breaking the line at point. +This function may be used in the `fill-nobreak-predicate' hook. +It is almost the same as `fill-single-char-nobreak-p', with the +exception that it does not require the one-letter word to be +preceded by a space. This blocks line-breaking in cases like +\"(a jednak)\"." + (save-excursion + (skip-chars-backward " \t") + (backward-char 2) + (looking-at "[^[:alpha:]]\\cl"))) + (defun fill-single-char-nobreak-p () "Return non-nil if a one-letter word is before point. This function is suitable for adding to the hook `fill-nobreak-predicate', diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index 042f432d635..bfe912308e9 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -68,6 +68,12 @@ Detection of repeated words is not implemented in :group 'flyspell :type 'boolean) +(defcustom flyspell-case-fold-duplications t + "Non-nil means Flyspell matches duplicate words case-insensitively." + :group 'flyspell + :type 'boolean + :version "27.1") + (defcustom flyspell-mark-duplications-exceptions '((nil . ("that" "had")) ; Common defaults for English. ("\\`francais" . ("nous" "vous"))) @@ -324,14 +330,16 @@ If this variable is nil, all regions are treated as small." ;;* (lambda () (setq flyspell-generic-check-word-predicate */ ;;* 'mail-mode-flyspell-verify))) */ ;;*---------------------------------------------------------------------*/ + +(define-obsolete-variable-alias 'flyspell-generic-check-word-p + 'flyspell-generic-check-word-predicate "25.1") + (defvar flyspell-generic-check-word-predicate nil "Function providing per-mode customization over which words are flyspelled. Returns t to continue checking, nil otherwise. Flyspell mode sets this variable to whatever is the `flyspell-mode-predicate' property of the major mode name.") (make-variable-buffer-local 'flyspell-generic-check-word-predicate) -(define-obsolete-variable-alias 'flyspell-generic-check-word-p - 'flyspell-generic-check-word-predicate "25.1") ;;*--- mail mode -------------------------------------------------------*/ (put 'mail-mode 'flyspell-mode-predicate 'mail-mode-flyspell-verify) @@ -415,9 +423,10 @@ like <img alt=\"Some thing.\">." (defun flyspell-generic-progmode-verify () "Used for `flyspell-generic-check-word-predicate' in programming modes." - ;; (point) is next char after the word. Must check one char before. - (let ((f (get-text-property (- (point) 1) 'face))) - (memq f flyspell-prog-text-faces))) + (unless (eql (point) (point-min)) + ;; (point) is next char after the word. Must check one char before. + (let ((f (get-text-property (1- (point)) 'face))) + (memq f flyspell-prog-text-faces)))) ;; Records the binding of M-TAB in effect before flyspell was activated. (defvar flyspell--prev-meta-tab-binding) @@ -506,9 +515,6 @@ See also `flyspell-duplicate-distance'." ;;;###autoload (define-minor-mode flyspell-mode "Toggle on-the-fly spell checking (Flyspell mode). -With a prefix argument ARG, enable Flyspell mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Flyspell mode is a buffer-local minor mode. When enabled, it spawns a single Ispell process and checks each word. The default @@ -924,7 +930,7 @@ Mostly we check word delimiters." (or (string= "" ispell-otherchars) (not (looking-at ispell-otherchars))) (or flyspell-consider-dash-as-word-delimiter-flag - (not (looking-at "\\-"))) + (not (looking-at "-"))) 2))))) (format " because : %S\n" (cond @@ -942,7 +948,7 @@ Mostly we check word delimiters." (or (string= "" ispell-otherchars) (not (looking-at ispell-otherchars))) (or flyspell-consider-dash-as-word-delimiter-flag - (not (looking-at "\\-"))))))) + (not (looking-at "-"))))))) ;; Yes because we have reached or typed a word delimiter. 'separator) ((not (integerp flyspell-delay)) @@ -985,6 +991,11 @@ Mostly we check word delimiters." (let ((command this-command) ;; Prevent anything we do from affecting the mark. deactivate-mark) + (if (and (eq command 'transpose-chars) + flyspell-pre-point) + (save-excursion + (goto-char (- flyspell-pre-point 1)) + (flyspell-word))) (if (flyspell-check-pre-word-p) (save-excursion '(flyspell-debug-signal-pre-word-checked) @@ -1150,7 +1161,8 @@ spell-check." (- (save-excursion (skip-chars-backward " \t\n\f"))))) (p (when (>= bound (point-min)) - (flyspell-word-search-backward word bound t)))) + (flyspell-word-search-backward + word bound flyspell-case-fold-duplications)))) (and p (/= p start))))) ;; yes, this is a doublon (flyspell-highlight-incorrect-region start end 'doublon) diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el index 237997d41d7..9dfa9f3c448 100644 --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1994-1995, 1997-2019 Free Software Foundation, Inc. -;; Author: Ken Stevens <k.stevens@ieee.org> +;; Author: Ken Stevens <k.stevens@ieee.org> ;; This file is part of GNU Emacs. @@ -320,18 +320,21 @@ The following values are supported: :type 'boolean :group 'ispell) +(defvaralias 'ispell-format-word 'ispell-format-word-function) + (defcustom ispell-format-word-function (function upcase) "Formatting function for displaying word being spell checked. The function must take one string argument and return a string." :type 'function :group 'ispell) -(defvaralias 'ispell-format-word 'ispell-format-word-function) +;; FIXME framepop.el last updated c 2003 (?), +;; probably something else replaces it these days. (defcustom ispell-use-framepop-p nil "When non-nil ispell uses framepop to display choices in a dedicated frame. You can set this variable to dynamically use framepop if you are in a window system by evaluating the following on startup to set this variable: - (and window-system (condition-case () (require \\='framepop) (error nil)))" + (and (display-graphic-p) (require \\='framepop nil t))" :type 'boolean :group 'ispell) @@ -815,16 +818,6 @@ See `ispell-buffer-with-debug' for an example of use." ;; because otherwise this file gets autoloaded every time Emacs starts ;; so that it can set up the menus and determine keyboard equivalents. -;;;###autoload -(defvar ispell-menu-map nil "Key map for ispell menu.") -;; Redo menu when loading ispell to get dictionary modifications -(setq ispell-menu-map nil) - -;;; Set up dictionary -;;;###autoload -(defvar ispell-menu-map-needed - (unless ispell-menu-map 'reload)) - (defvar ispell-library-directory (condition-case () (ispell-check-version) (error nil)) @@ -1193,6 +1186,12 @@ dictionary from that list was found." ;; Parse and set values for default dictionary. (setq hunspell-default-dict (or hunspell-multi-dict (car hunspell-default-dict))) + ;; If hunspell-default-dict is nil, ispell-parse-hunspell-affix-file + ;; will barf with an error message that doesn't help users figure + ;; out what is wrong. Produce an error message that points to the + ;; root cause of the problem. + (or hunspell-default-dict + (error "Can't find Hunspell dictionary with a .aff affix file")) (setq hunspell-default-dict-entry (ispell-parse-hunspell-affix-file hunspell-default-dict)) ;; Create an alist of found dicts with only names, except for default dict. @@ -1215,9 +1214,11 @@ Internal use.") (with-output-to-string (with-current-buffer standard-output - (apply 'ispell-call-process - (replace-regexp-in-string "enchant\\(-[0-9]\\)?$" "enchant-lsmod\\1" - ispell-program-name) nil t nil args)))) + (apply #'ispell-call-process + (replace-regexp-in-string "enchant\\(-[0-9]\\)?\\'" + "enchant-lsmod\\1" + ispell-program-name) + nil t nil args)))) (defun ispell--get-extra-word-characters (&optional lang) "Get the extra word characters for LANG as a character class. @@ -1272,7 +1273,6 @@ aspell is used along with Emacs).") (defun ispell-set-spellchecker-params () "Initialize some spellchecker parameters when changed or first used." (unless (eq ispell-last-program-name ispell-program-name) - (setq ispell-last-program-name ispell-program-name) (ispell-kill-ispell t) (if (and (condition-case () (progn @@ -1387,7 +1387,8 @@ aspell is used along with Emacs).") (nth 7 adict))) adict) tmp-dicts-alist :test #'equal)) - (setq ispell-dictionary-alist tmp-dicts-alist)))) + (setq ispell-dictionary-alist tmp-dicts-alist))) + (setq ispell-last-program-name ispell-program-name)) (defun ispell-valid-dictionary-list () "Return a list of valid dictionaries. @@ -1425,80 +1426,78 @@ The variable `ispell-library-directory' defines their location." (push name dict-list))) dict-list)) -;; Define commands in menu in opposite order you want them to appear. ;;;###autoload -(if ispell-menu-map-needed - (progn - (setq ispell-menu-map (make-sparse-keymap "Spell")) - (define-key ispell-menu-map [ispell-change-dictionary] - `(menu-item ,(purecopy "Change Dictionary...") ispell-change-dictionary - :help ,(purecopy "Supply explicit dictionary file name"))) - (define-key ispell-menu-map [ispell-kill-ispell] - `(menu-item ,(purecopy "Kill Process") - (lambda () (interactive) (ispell-kill-ispell nil 'clear)) - :enable (and (boundp 'ispell-process) ispell-process - (eq (ispell-process-status) 'run)) - :help ,(purecopy "Terminate Ispell subprocess"))) - (define-key ispell-menu-map [ispell-pdict-save] - `(menu-item ,(purecopy "Save Dictionary") - (lambda () (interactive) (ispell-pdict-save t t)) - :help ,(purecopy "Save personal dictionary"))) - (define-key ispell-menu-map [ispell-customize] - `(menu-item ,(purecopy "Customize...") - (lambda () (interactive) (customize-group 'ispell)) - :help ,(purecopy "Customize spell checking options"))) - (define-key ispell-menu-map [ispell-help] - ;; use (x-popup-menu last-nonmenu-event(list "" ispell-help-list)) ? - `(menu-item ,(purecopy "Help") - (lambda () (interactive) (describe-function 'ispell-help)) - :help ,(purecopy "Show standard Ispell keybindings and commands"))) - (define-key ispell-menu-map [flyspell-mode] - `(menu-item ,(purecopy "Automatic spell checking (Flyspell)") - flyspell-mode - :help ,(purecopy "Check spelling while you edit the text") - :button (:toggle . (bound-and-true-p flyspell-mode)))) - (define-key ispell-menu-map [ispell-complete-word] - `(menu-item ,(purecopy "Complete Word") ispell-complete-word - :help ,(purecopy "Complete word at cursor using dictionary"))) - (define-key ispell-menu-map [ispell-complete-word-interior-frag] - `(menu-item ,(purecopy "Complete Word Fragment") - ispell-complete-word-interior-frag - :help ,(purecopy "Complete word fragment at cursor"))))) - -;;;###autoload -(if ispell-menu-map-needed - (progn - (define-key ispell-menu-map [ispell-continue] - `(menu-item ,(purecopy "Continue Spell-Checking") ispell-continue - :enable (and (boundp 'ispell-region-end) - (marker-position ispell-region-end) - (equal (marker-buffer ispell-region-end) - (current-buffer))) - :help ,(purecopy "Continue spell checking last region"))) - (define-key ispell-menu-map [ispell-word] - `(menu-item ,(purecopy "Spell-Check Word") ispell-word - :help ,(purecopy "Spell-check word at cursor"))) - (define-key ispell-menu-map [ispell-comments-and-strings] - `(menu-item ,(purecopy "Spell-Check Comments") - ispell-comments-and-strings - :help ,(purecopy "Spell-check only comments and strings"))))) - +(defconst ispell-menu-map + ;; Use `defconst' so as to redo the menu when loading ispell, like the + ;; previous code did. + + ;; Define commands in menu in opposite order you want them to appear. + (let ((map (make-sparse-keymap "Spell"))) + (define-key map [ispell-change-dictionary] + `(menu-item ,(purecopy "Change Dictionary...") ispell-change-dictionary + :help ,(purecopy "Supply explicit dictionary file name"))) + (define-key map [ispell-kill-ispell] + `(menu-item ,(purecopy "Kill Process") + (lambda () (interactive) (ispell-kill-ispell nil 'clear)) + :enable (and (boundp 'ispell-process) ispell-process + (eq (ispell-process-status) 'run)) + :help ,(purecopy "Terminate Ispell subprocess"))) + (define-key map [ispell-pdict-save] + `(menu-item ,(purecopy "Save Dictionary") + (lambda () (interactive) (ispell-pdict-save t t)) + :help ,(purecopy "Save personal dictionary"))) + (define-key map [ispell-customize] + `(menu-item ,(purecopy "Customize...") + (lambda () (interactive) (customize-group 'ispell)) + :help ,(purecopy "Customize spell checking options"))) + (define-key map [ispell-help] + ;; use (x-popup-menu last-nonmenu-event(list "" ispell-help-list)) ? + `(menu-item ,(purecopy "Help") + (lambda () (interactive) (describe-function 'ispell-help)) + :help ,(purecopy "Show standard Ispell keybindings and commands"))) + (define-key map [flyspell-mode] + `(menu-item ,(purecopy "Automatic spell checking (Flyspell)") + flyspell-mode + :help ,(purecopy "Check spelling while you edit the text") + :button (:toggle . (bound-and-true-p flyspell-mode)))) + (define-key map [ispell-complete-word] + `(menu-item ,(purecopy "Complete Word") ispell-complete-word + :help ,(purecopy "Complete word at cursor using dictionary"))) + (define-key map [ispell-complete-word-interior-frag] + `(menu-item ,(purecopy "Complete Word Fragment") + ispell-complete-word-interior-frag + :help ,(purecopy "Complete word fragment at cursor"))) + + (define-key map [ispell-continue] + `(menu-item ,(purecopy "Continue Spell-Checking") ispell-continue + :enable (and (boundp 'ispell-region-end) + (marker-position ispell-region-end) + (equal (marker-buffer ispell-region-end) + (current-buffer))) + :help ,(purecopy "Continue spell checking last region"))) + (define-key map [ispell-word] + `(menu-item ,(purecopy "Spell-Check Word") ispell-word + :help ,(purecopy "Spell-check word at cursor"))) + (define-key map [ispell-comments-and-strings] + `(menu-item ,(purecopy "Spell-Check Comments") + ispell-comments-and-strings + :help ,(purecopy "Spell-check only comments and strings"))) + + (define-key map [ispell-region] + `(menu-item ,(purecopy "Spell-Check Region") ispell-region + :enable mark-active + :help ,(purecopy "Spell-check text in marked region"))) + (define-key map [ispell-message] + `(menu-item ,(purecopy "Spell-Check Message") ispell-message + :visible (eq major-mode 'mail-mode) + :help ,(purecopy "Skip headers and included message text"))) + (define-key map [ispell-buffer] + `(menu-item ,(purecopy "Spell-Check Buffer") ispell-buffer + :help ,(purecopy "Check spelling of selected buffer"))) + map) + "Key map for ispell menu.") ;;;###autoload -(if ispell-menu-map-needed - (progn - (define-key ispell-menu-map [ispell-region] - `(menu-item ,(purecopy "Spell-Check Region") ispell-region - :enable mark-active - :help ,(purecopy "Spell-check text in marked region"))) - (define-key ispell-menu-map [ispell-message] - `(menu-item ,(purecopy "Spell-Check Message") ispell-message - :visible (eq major-mode 'mail-mode) - :help ,(purecopy "Skip headers and included message text"))) - (define-key ispell-menu-map [ispell-buffer] - `(menu-item ,(purecopy "Spell-Check Buffer") ispell-buffer - :help ,(purecopy "Check spelling of selected buffer"))) - (fset 'ispell-menu-map (symbol-value 'ispell-menu-map)))) - +(fset 'ispell-menu-map (symbol-value 'ispell-menu-map)) ;;; ********************************************************************** @@ -1791,11 +1790,15 @@ You can set this variable in hooks in your init file -- eg: (defun ispell-accept-output (&optional timeout-secs timeout-msecs) - "Wait for output from Ispell process, or TIMEOUT-SECS and TIMEOUT-MSECS. + "Wait for output from Ispell process, or for TIMEOUT-SECS + TIMEOUT-MSECS. +\(The TIMEOUT-MSECS argument is obsolete and should be avoided.) If asynchronous subprocesses are not supported, call function `ispell-filter' and pass it the output of the last Ispell invocation." (if ispell-async-processp - (accept-process-output ispell-process timeout-secs timeout-msecs) + (let ((timeout (if timeout-msecs + (+ (or timeout-secs 0) (/ timeout-msecs 1000.0)) + timeout-secs))) + (accept-process-output ispell-process timeout)) (if (null ispell-process) (error "No Ispell process to read output from!") (let ((buf ispell-output-buffer) @@ -1840,11 +1843,9 @@ Only works for Aspell and Enchant." (setq default-directory defdir) (insert string) (if (not (memq cmd cmds-to-defer)) - (let (coding-system-for-read coding-system-for-write status) - (if (and (boundp 'enable-multibyte-characters) - enable-multibyte-characters) - (setq coding-system-for-read (ispell-get-coding-system) - coding-system-for-write (ispell-get-coding-system))) + (let* ((coding-system-for-read (ispell-get-coding-system)) + (coding-system-for-write coding-system-for-read) + status) (set-buffer output-buf) (erase-buffer) (set-buffer session-buf) @@ -2972,6 +2973,9 @@ With CLEAR, buffer session localwords are cleaned." (message "Ispell process killed") nil)) +(defvar ispell-change-dictionary-hook nil + "Hook run after changing dictionary.") + ;; ispell-change-dictionary is set in some people's hooks. Maybe this should ;; call ispell-init-process rather than wait for a spell checking command? @@ -2997,7 +3001,8 @@ By just answering RET you can find out what the current dictionary is." (ispell-internal-change-dictionary) (message "Using %s dictionary" (or (and (not arg) ispell-local-dictionary) - ispell-dictionary "default"))) + ispell-dictionary "default")) + (run-hooks 'ispell-change-dictionary-hook)) ((equal dict (or (and (not arg) ispell-local-dictionary) ispell-dictionary "default")) ;; Specified dictionary is the default already. Could reload @@ -3019,7 +3024,8 @@ By just answering RET you can find out what the current dictionary is." (setq ispell-buffer-session-localwords nil) (message "%s Ispell dictionary set to %s" (if arg "Global" "Local") - dict)))) + dict) + (run-hooks 'ispell-change-dictionary-hook)))) (defun ispell-internal-change-dictionary () "Update the dictionary and the personal dictionary used by Ispell. @@ -3474,7 +3480,7 @@ Returns the sum SHIFT due to changes in word replacements." ;; Error in tex mode when a potential math mode change exists. (if (and replace (listp replace) (= 2 (length replace))) (if (and (eq ispell-parser 'tex) - (string-match "[\\\\][]()[]\\|\\\\begin\\|\\$" + (string-match "[\\][]()[]\\|\\\\begin\\|\\$" (regexp-quote string))) (error "Don't start query replace on a line with math characters" @@ -3718,9 +3724,6 @@ available on the net." ;;;###autoload (define-minor-mode ispell-minor-mode "Toggle last-word spell checking (Ispell minor mode). -With a prefix argument ARG, enable Ispell minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Ispell minor mode is a buffer-local minor mode. When enabled, typing SPC or RET warns you if the previous word is incorrectly @@ -4018,7 +4021,7 @@ You can bind this to the key C-c i in GNUS or mail by adding to (defun ispell-non-empty-string (string) (if (or (not string) (string-equal string "")) - "\\'\\`" ; An unmatchable string if string is null. + regexp-unmatchable (regexp-quote string))) diff --git a/lisp/textmodes/less-css-mode.el b/lisp/textmodes/less-css-mode.el index b4c7f28985d..4077789eb12 100644 --- a/lisp/textmodes/less-css-mode.el +++ b/lisp/textmodes/less-css-mode.el @@ -194,10 +194,10 @@ directory by default." ;; - custom faces. (defconst less-css-font-lock-keywords '(;; Variables - ("@[a-z_-][a-z-_0-9]*" . font-lock-variable-name-face) + ("@[a-z_-][a-z_0-9-]*" . font-lock-variable-name-face) ("&" . font-lock-preprocessor-face) ;; Mixins - ("\\(?:[ \t{;]\\|^\\)\\(\\.[a-z_-][a-z-_0-9]*\\)[ \t]*;" . + ("\\(?:[ \t{;]\\|^\\)\\(\\.[a-z_-][a-z_0-9-]*\\)[ \t]*;" . (1 font-lock-keyword-face)))) (defvar less-css-mode-syntax-table diff --git a/lisp/textmodes/mhtml-mode.el b/lisp/textmodes/mhtml-mode.el index 17298ccf5f7..7de24c783f0 100644 --- a/lisp/textmodes/mhtml-mode.el +++ b/lisp/textmodes/mhtml-mode.el @@ -21,7 +21,9 @@ ;;; Code: -(eval-and-compile (require 'sgml-mode)) +(eval-and-compile + (require 'cl-lib) + (require 'sgml-mode)) (require 'js) (require 'css-mode) (require 'prog-mode) @@ -363,7 +365,6 @@ Code inside a <script> element is indented using the rules from `js-mode'; and code inside a <style> element is indented using the rules from `css-mode'." (setq-local indent-line-function #'mhtml-indent-line) - (setq-local parse-sexp-lookup-properties t) (setq-local syntax-propertize-function #'mhtml-syntax-propertize) (setq-local font-lock-fontify-region-function #'mhtml--submode-fontify-region) diff --git a/lisp/textmodes/nroff-mode.el b/lisp/textmodes/nroff-mode.el index e5cc39d54f6..f33d4df4d19 100644 --- a/lisp/textmodes/nroff-mode.el +++ b/lisp/textmodes/nroff-mode.el @@ -298,9 +298,6 @@ automatically inserts the matching closing request after point." (define-minor-mode nroff-electric-mode "Toggle automatic nroff request pairing (Nroff Electric mode). -With a prefix argument ARG, enable Nroff Electric mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Nroff Electric mode is a buffer-local minor mode, for use with `nroff-mode'. When enabled, Emacs checks for an nroff request at @@ -328,13 +325,6 @@ otherwise off." (kill-buffer viewbuf)) (Man-getpage-in-background file))) -;; Old names that were not namespace clean. -(define-obsolete-function-alias 'count-text-lines 'nroff-count-text-lines "22.1") -(define-obsolete-function-alias 'forward-text-line 'nroff-forward-text-line "22.1") -(define-obsolete-function-alias 'backward-text-line 'nroff-backward-text-line "22.1") -(define-obsolete-function-alias 'electric-nroff-newline 'nroff-electric-newline "22.1") -(define-obsolete-function-alias 'electric-nroff-mode 'nroff-electric-mode "22.1") - (provide 'nroff-mode) ;;; nroff-mode.el ends here diff --git a/lisp/textmodes/page-ext.el b/lisp/textmodes/page-ext.el index a9199fffe0d..582b2625b3c 100644 --- a/lisp/textmodes/page-ext.el +++ b/lisp/textmodes/page-ext.el @@ -1,4 +1,4 @@ -;;; page-ext.el --- extended page handling commands +;;; page-ext.el --- extended page handling commands -*- lexical-binding:t -*- ;; Copyright (C) 1990-1991, 1993-1994, 2001-2019 Free Software ;; Foundation, Inc. @@ -47,12 +47,12 @@ ;; New page handling commands: -;; next-page C-x C-p C-n -;; previous-page C-x C-p C-p -;; search-pages C-x C-p C-s -;; add-new-page C-x C-p C-a -;; sort-pages-buffer C-x C-p s -;; set-page-delimiter C-x C-p C-l +;; pages-next-page C-x C-p C-n +;; pages-previous-page C-x C-p C-p +;; pages-search C-x C-p C-s +;; pages-add-new-page C-x C-p C-a +;; pages-sort-buffer C-x C-p s +;; pages-set-delimiter C-x C-p C-l ;; pages-directory C-x C-p C-d ;; pages-directory-for-addresses C-x C-p d ;; pages-directory-goto C-c C-c @@ -156,11 +156,11 @@ ;; George Lakoff ;; OBI (On line text collection.) -;; The `C-x C-p s' (sort-pages-buffer) command sorts the entries in the +;; The `C-x C-p s' (pages-sort-buffer) command sorts the entries in the ;; buffer alphabetically. -;; You may use any of the page commands, including the `next-page', -;; `previous-page', `add-new-page', `mark-page', and `search-pages' +;; You may use any of the page commands, including the `pages-next-page', +;; `pages-previous-page', `pages-add-new-page', `mark-page', and `pages-search' ;; commands. ;; You may use either the `C-x C-p d' (pages-directory-for-addresses) @@ -171,7 +171,7 @@ ;; and type `C-c C-c' (pages-directory-goto) to go to the entry to ;; which it refers in the pages buffer. -;; You can type `C-c C-p C-a' (add-new-page) to add a new entry in the +;; You can type `C-c C-p C-a' (pages-add-new-page) to add a new entry in the ;; pages buffer or address file. This is the same command you use to ;; add a new entry when you are in the pages buffer or address file. @@ -243,18 +243,15 @@ (defcustom pages-directory-buffer-narrowing-p t "If non-nil, `pages-directory-goto' narrows pages buffer to entry." - :type 'boolean - :group 'pages) + :type 'boolean) (defcustom pages-directory-for-adding-page-narrowing-p t "If non-nil, `add-new-page' narrows page buffer to new entry." - :type 'boolean - :group 'pages) + :type 'boolean) (defcustom pages-directory-for-adding-new-page-before-current-page-p t "If non-nil, `add-new-page' inserts new page before current page." - :type 'boolean - :group 'pages) + :type 'boolean) ;;; Addresses related variables @@ -262,83 +259,86 @@ (defcustom pages-addresses-file-name "~/addresses" "Standard name for file of addresses. Entries separated by page-delimiter. Used by `pages-directory-for-addresses' function." - :type 'file - :group 'pages) + :type 'file) (defcustom pages-directory-for-addresses-goto-narrowing-p t "If non-nil, `pages-directory-goto' narrows addresses buffer to entry." - :type 'boolean - :group 'pages) + :type 'boolean) (defcustom pages-directory-for-addresses-buffer-keep-windows-p t "If nil, `pages-directory-for-addresses' deletes other windows." - :type 'boolean - :group 'pages) + :type 'boolean) (defcustom pages-directory-for-adding-addresses-narrowing-p t "If non-nil, `add-new-page' narrows addresses buffer to new entry." - :type 'boolean - :group 'pages) + :type 'boolean) ;;; Key bindings for page handling functions -(global-unset-key "\C-x\C-p") - -(defvar ctl-x-ctl-p-map (make-sparse-keymap) +(defvar pages--ctl-x-ctl-p-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-n" #'pages-next-page) + (define-key map "\C-p" #'pages-previous-page) + (define-key map "\C-a" #'pages-add-new-page) + (define-key map "\C-m" #'mark-page) + (define-key map "\C-s" #'pages-search) + (define-key map "s" #'pages-sort-buffer) + (define-key map "\C-l" #'pages-set-delimiter) + (define-key map "\C-d" #'pages-directory) + (define-key map "d" #'pages-directory-for-addresses) + map) "Keymap for subcommands of C-x C-p, which are for page handling.") -(define-key ctl-x-map "\C-p" 'ctl-x-ctl-p-prefix) -(fset 'ctl-x-ctl-p-prefix ctl-x-ctl-p-map) - -(define-key ctl-x-ctl-p-map "\C-n" 'next-page) -(define-key ctl-x-ctl-p-map "\C-p" 'previous-page) -(define-key ctl-x-ctl-p-map "\C-a" 'add-new-page) -(define-key ctl-x-ctl-p-map "\C-m" 'mark-page) -(define-key ctl-x-ctl-p-map "\C-s" 'search-pages) -(define-key ctl-x-ctl-p-map "s" 'sort-pages-buffer) -(define-key ctl-x-ctl-p-map "\C-l" 'set-page-delimiter) -(define-key ctl-x-ctl-p-map "\C-d" 'pages-directory) -(define-key ctl-x-ctl-p-map "d" 'pages-directory-for-addresses) +;; FIXME: Merely loading a package shouldn't have this kind of side-effects! +(global-unset-key "\C-x\C-p") +(define-key ctl-x-map "\C-p" #'pages-ctl-x-ctl-p-prefix) +(define-obsolete-function-alias 'ctl-x-ctl-p-prefix 'pages-ctl-x-ctl-p-prefix "27.1") +(defalias 'pages-ctl-x-ctl-p-prefix pages--ctl-x-ctl-p-map) ;;; Page movement function definitions -(defun next-page (&optional count) +(define-obsolete-function-alias 'next-page #'pages-next-page "27.1") +(defun pages-next-page (&optional count) "Move to the next page bounded by the `page-delimiter' variable. With arg (prefix if interactive), move that many pages." (interactive "p") (or count (setq count 1)) (widen) ;; Cannot use forward-page because of problems at page boundaries. - (while (and (> count 0) (not (eobp))) - (if (re-search-forward page-delimiter nil t) - nil - (goto-char (point-max))) - (setq count (1- count))) - ;; If COUNT is negative, we want to go back -COUNT + 1 page boundaries. - ;; The first page boundary we reach is the top of the current page, - ;; which doesn't count. - (while (and (< count 1) (not (bobp))) - (if (re-search-backward page-delimiter nil t) - (goto-char (match-beginning 0)) - (goto-char (point-min))) - (setq count (1+ count))) + (if (>= count 0) + (while (and (> count 0) (not (eobp))) + (if (re-search-forward page-delimiter nil t) + nil + (goto-char (point-max))) + (setq count (1- count))) + ;; If COUNT is negative, we want to go back -COUNT + 1 page boundaries. + ;; The first page boundary we reach is the top of the current page, + ;; which doesn't count. + (while (and (< count 1) (not (bobp))) + (if (re-search-backward page-delimiter nil t) + (when (= count 0) + (goto-char (match-end 0))) + (goto-char (point-min))) + (setq count (1+ count)))) (narrow-to-page) (goto-char (point-min)) (recenter 0)) -(defun previous-page (&optional count) +(define-obsolete-function-alias 'previous-page #'pages-previous-page "27.1") +(defun pages-previous-page (&optional count) "Move to the previous page bounded by the `page-delimiter' variable. With arg (prefix if interactive), move that many pages." (interactive "p") (or count (setq count 1)) - (next-page (- count))) + (pages-next-page (- count))) ;;; Adding and searching pages -(defun add-new-page (header-line) +(define-obsolete-function-alias 'add-new-page #'pages-add-new-page "27.1") +(defun pages-add-new-page (header-line) "Insert new page. Prompt for header line. If point is in the pages directory buffer, insert the new page in the @@ -391,7 +391,8 @@ Point is left in the body of page." (defvar pages-last-search nil "Value of last regexp searched for. Initially, nil.") -(defun search-pages (regexp) +(define-obsolete-function-alias 'search-pages #'pages-search "27.1") +(defun pages-search (regexp) "Search for REGEXP, starting from point, and narrow to page it is in." (interactive (list (read-string @@ -407,17 +408,16 @@ Point is left in the body of page." ;;; Sorting pages -(autoload 'sort-subr "sort" "Primary function for sorting." t nil) - -(defun sort-pages-in-region (reverse beg end) +(define-obsolete-function-alias 'sort-pages-in-region #'pages-sort-region "27.1") +(defun pages-sort-region (reverse beg end) "Sort pages in region alphabetically. Prefix arg means reverse order. Called from a program, there are three arguments: REVERSE (non-nil means reverse order), BEG and END (region to sort)." -;;; This sort function handles ends of pages differently than -;;; `sort-pages' and works better with lists of addresses and similar -;;; files. + ;; This sort function handles ends of pages differently than + ;; `sort-pages' and works better with lists of addresses and similar + ;; files. (interactive "P\nr") (save-restriction @@ -444,7 +444,8 @@ REVERSE (non-nil means reverse order), BEG and END (region to sort)." (goto-char (match-beginning 0)) (goto-char (point-max)))))))) -(defun sort-pages-buffer (&optional reverse) +(define-obsolete-function-alias 'sort-pages-buffer #'pages-sort-buffer "27.1") +(defun pages-sort-buffer (&optional reverse) "Sort pages alphabetically in buffer. Prefix arg means reverse order. \(Non-nil arg if not interactive.)" @@ -453,7 +454,7 @@ REVERSE (non-nil means reverse order), BEG and END (region to sort)." (widen) (let ((beginning (point-min)) (end (point-max))) - (sort-pages-in-region reverse beginning end))) + (pages-sort-region reverse beginning end))) ;;; Pages directory ancillary definitions @@ -463,30 +464,33 @@ REVERSE (non-nil means reverse order), BEG and END (region to sort)." \(This regular expression may be used to select only those pages that contain matches to the regexp.)") -(defvar pages-buffer nil +(defvar-local pages-buffer nil "The buffer for which the pages-directory function creates the directory.") (defvar pages-directory-prefix "*Directory for:" "Prefix of name of temporary buffer for pages-directory.") -(defvar pages-pos-list nil +(defvar-local pages-pos-list nil "List containing the positions of the pages in the pages-buffer.") (defvar pages-target-buffer) +(define-obsolete-variable-alias 'pages-directory-map + 'pages-directory-mode-map "26.1") (defvar pages-directory-mode-map (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-c" 'pages-directory-goto) - (define-key map "\C-c\C-p\C-a" 'add-new-page) - (define-key map [mouse-2] 'pages-directory-goto-with-mouse) + (define-key map "\C-c\C-c" #'pages-directory-goto) + (define-key map "\C-m" #'pages-directory-goto) + (define-key map "\C-c\C-p\C-a" #'pages-add-new-page) + (define-key map [mouse-2] #'pages-directory-goto) map) "Keymap for the pages-directory-buffer.") -(defvaralias 'pages-directory-map 'pages-directory-mode-map) -(defvar original-page-delimiter "^\f" +(defvar pages-original-delimiter "^\f" "Default page delimiter.") -(defun set-page-delimiter (regexp reset-p) +(define-obsolete-function-alias 'set-page-delimiter #'pages-set-delimiter "27.1") +(defun pages-set-delimiter (regexp reset-p &optional interactively) "Set buffer local value of page-delimiter to REGEXP. Called interactively with a prefix argument, reset `page-delimiter' to its original value. @@ -496,22 +500,22 @@ resets the page-delimiter to the original value." (interactive (if current-prefix-arg - (list original-page-delimiter "^\f") - (list (read-string "Set page-delimiter to regexp: " page-delimiter) - nil))) - (make-local-variable 'original-page-delimiter) - (make-local-variable 'page-delimiter) - (setq original-page-delimiter - (or original-page-delimiter page-delimiter)) - (if (not reset-p) - (setq page-delimiter regexp) - (setq page-delimiter original-page-delimiter)) - (if (called-interactively-p 'interactive) + (list pages-original-delimiter t t) + (list (read-regexp "Set page-delimiter to regexp: " page-delimiter) + nil t))) + (setq-local pages-original-delimiter + (or pages-original-delimiter page-delimiter)) + (setq-local page-delimiter + (if (not reset-p) regexp pages-original-delimiter)) + (if interactively (message "The value of `page-delimiter' is now: %s" page-delimiter))) ;;; Pages directory main definitions +(defvar pages-buffer-original-position) +(defvar pages-buffer-original-page) + (defun pages-directory (pages-list-all-headers-p count-lines-p &optional regexp) "Display a directory of the page headers in a temporary buffer. @@ -573,7 +577,6 @@ directory for only the accessible portion of the buffer." (let ((pages-target-buffer (current-buffer)) (pages-directory-buffer (concat pages-directory-prefix " " (buffer-name))) - (linenum 1) (pages-buffer-original-position (point)) (pages-buffer-original-page 0)) @@ -644,10 +647,6 @@ directory for only the accessible portion of the buffer." 1 pages-buffer-original-page)))) -(defvar pages-buffer-original-position) -(defvar pages-buffer-original-page) -(defvar pages-buffer-original-page) - (defun pages-copy-header-and-position (count-lines-p) "Copy page header and its position to the Pages Directory. Only arg non-nil, count lines in page and insert before header. @@ -701,16 +700,13 @@ Used by `pages-directory' function." Move point to one of the lines in this buffer, then use \\[pages-directory-goto] to go to the same line in the pages buffer." - (make-local-variable 'pages-buffer) - (make-local-variable 'pages-pos-list) - (make-local-variable 'pages-directory-buffer-narrowing-p)) + ) -(defun pages-directory-goto () +(defun pages-directory-goto (&optional event) "Go to the corresponding line in the pages buffer." - -;;; This function is mostly a copy of `occur-mode-goto-occurrence' - - (interactive) + ;; This function is mostly a copy of `occur-mode-goto-occurrence' + (interactive (list last-nonmenu-event)) + (if event (mouse-set-point event)) (if (or (not pages-buffer) (not (buffer-name pages-buffer))) (progn @@ -724,18 +720,13 @@ to the same line in the pages buffer." (narrowing-p pages-directory-buffer-narrowing-p)) (pop-to-buffer pages-buffer) (widen) - (if end-of-directory-p - (goto-char (point-max)) - (goto-char (marker-position pos))) + (goto-char (if end-of-directory-p + (point-max) + (marker-position pos))) (if narrowing-p (narrow-to-page)))) -(defun pages-directory-goto-with-mouse (event) - "Go to the corresponding line under the mouse pointer in the pages buffer." - (interactive "e") - (with-current-buffer (window-buffer (posn-window (event-end event))) - (save-excursion - (goto-char (posn-point (event-end event))) - (pages-directory-goto)))) +(define-obsolete-function-alias 'pages-directory-goto-with-mouse + #'pages-directory-goto "26.1") ;;; The `pages-directory-for-addresses' function and ancillary code @@ -774,8 +765,8 @@ directory." ;; by RJC, 2006 Jun 11: including this causes failure; it results in ;; the message "Buffer in which pages were found is deleted" ;; (pages-directory-address-mode) - (setq pages-directory-buffer-narrowing-p - pages-directory-for-addresses-goto-narrowing-p) + (setq-local pages-directory-buffer-narrowing-p + pages-directory-for-addresses-goto-narrowing-p) (or pages-directory-for-addresses-buffer-keep-windows-p (delete-other-windows)) (save-excursion diff --git a/lisp/textmodes/page.el b/lisp/textmodes/page.el index 220ef2d7fd6..a42fc6e0538 100644 --- a/lisp/textmodes/page.el +++ b/lisp/textmodes/page.el @@ -1,4 +1,4 @@ -;;; page.el --- page motion commands for Emacs +;;; page.el --- page motion commands for Emacs -*- lexical-binding: t; -*- ;; Copyright (C) 1985, 2001-2019 Free Software Foundation, Inc. @@ -38,8 +38,7 @@ A page boundary is any line whose beginning matches the regexp ;; In case the page-delimiter matches the null string, ;; don't find a match without moving. (if (bolp) (forward-char 1)) - (if (re-search-forward page-delimiter nil t) - nil + (unless (re-search-forward page-delimiter nil t) (goto-char (point-max))) (setq count (1- count))) (while (and (< count 0) (not (bobp))) @@ -126,39 +125,50 @@ thus showing a page other than the one point was originally in." (point))))) (put 'narrow-to-page 'disabled t) -(defun count-lines-page () - "Report number of lines on current page, and how many are before or after point." - (interactive) +(defun page--count-lines-page () + "Return a list of line counts on the current page. +The list is on the form (TOTAL BEFORE AFTER), where TOTAL is the +total number of lines on the current page, while BEFORE and AFTER +are the number of lines on the current page before and after +point, respectively." (save-excursion - (let ((opoint (point)) beg end - total before after) + (let ((opoint (point))) (forward-page) (beginning-of-line) - (or (looking-at page-delimiter) - (end-of-line)) - (setq end (point)) - (backward-page) - (setq beg (point)) - (setq total (count-lines beg end) - before (count-lines beg opoint) - after (count-lines opoint end)) - (message "Page has %d lines (%d + %d)" total before after)))) + (unless (looking-at page-delimiter) + (end-of-line)) + (let ((end (point))) + (backward-page) + (list (count-lines (point) end) + (count-lines (point) opoint) + (count-lines opoint end)))))) -(defun what-page () - "Print page and line number of point." +(defun count-lines-page () + "Report number of lines on current page, and how many are before or after point." (interactive) + (pcase-let ((`(,total ,before ,after) (page--count-lines-page))) + (message (ngettext "Page has %d line (%d + %d)" + "Page has %d lines (%d + %d)" total) + total before after))) + +(defun page--what-page () + "Return a list of the page and line number of point." (save-restriction (widen) (save-excursion (let ((count 1) - (opoint (point))) - (goto-char (point-min)) - (while (re-search-forward page-delimiter opoint t) - (if (= (match-beginning 0) (match-end 0)) - (forward-char 1)) - (setq count (1+ count))) - (message "Page %d, line %d" count (line-number-at-pos opoint)))))) + (opoint (point))) + (goto-char (point-min)) + (while (re-search-forward page-delimiter opoint t) + (when (= (match-beginning 0) (match-end 0)) + (forward-char)) + (setq count (1+ count))) + (list count (line-number-at-pos opoint)))))) +(defun what-page () + "Print page and line number of point." + (interactive) + (apply #'message (cons "Page %d, line %d" (page--what-page)))) ;;; Place `provide' at end of file. diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el index 40ad64b846e..3762010985f 100644 --- a/lisp/textmodes/paragraphs.el +++ b/lisp/textmodes/paragraphs.el @@ -1,4 +1,4 @@ -;;; paragraphs.el --- paragraph and sentence parsing +;;; paragraphs.el --- paragraph and sentence parsing -*- lexical-binding: t -*- ;; Copyright (C) 1985-1987, 1991, 1994-1997, 1999-2019 Free Software ;; Foundation, Inc. @@ -36,9 +36,6 @@ (put 'use-hard-newlines 'permanent-local t) (define-minor-mode use-hard-newlines "Toggle distinguishing between hard and soft newlines. -With a prefix argument ARG, enable the feature if ARG is -positive, and disable it otherwise. If called from Lisp, enable -it if ARG is omitted or nil. When enabled, the functions `newline' and `open-line' add the text-property `hard' to newlines that they insert, and a line is @@ -168,7 +165,7 @@ to obtain the value of this variable." :type '(choice regexp (const :tag "Use default value" nil))) (put 'sentence-end 'safe-local-variable 'string-or-null-p) -(defcustom sentence-end-base "[.?!…‽][]\"'”’)}]*" +(defcustom sentence-end-base "[.?!…‽][]\"'”’)}»›]*" "Regexp matching the basic end of a sentence, not including following space." :group 'paragraphs :type 'string @@ -211,6 +208,9 @@ This is desirable in modes where blank lines are the paragraph delimiters." :type 'boolean) (put 'paragraph-ignore-fill-prefix 'safe-local-variable 'booleanp) +;; Silence the compiler. +(defvar multiple-lines) + (defun forward-paragraph (&optional arg) "Move forward to end of paragraph. With argument ARG, do it ARG times; @@ -401,15 +401,15 @@ it marks the next ARG paragraphs after the ones already marked." (defun kill-paragraph (arg) "Kill forward to end of paragraph. -With arg N, kill forward to Nth end of paragraph; -negative arg -N means kill backward to Nth start of paragraph." +With ARG N, kill forward to Nth end of paragraph; +negative ARG -N means kill backward to Nth start of paragraph." (interactive "p") (kill-region (point) (progn (forward-paragraph arg) (point)))) (defun backward-kill-paragraph (arg) "Kill back to start of paragraph. -With arg N, kill back to Nth start of paragraph; -negative arg -N means kill forward to Nth end of paragraph." +With ARG N, kill back to Nth start of paragraph; +negative ARG -N means kill forward to Nth end of paragraph." (interactive "p") (kill-region (point) (progn (backward-paragraph arg) (point)))) @@ -424,6 +424,7 @@ the current paragraph with the one containing the mark." (transpose-subr 'forward-paragraph arg)) (defun start-of-paragraph-text () + "Move to the start of the current paragraph." (let ((opoint (point)) npoint) (forward-paragraph -1) (setq npoint (point)) @@ -439,6 +440,7 @@ the current paragraph with the one containing the mark." (start-of-paragraph-text)))))) (defun end-of-paragraph-text () + "Move to the end of the current paragraph." (let ((opoint (point))) (forward-paragraph 1) (if (eq (preceding-char) ?\n) (forward-char -1)) @@ -450,7 +452,7 @@ the current paragraph with the one containing the mark." (defun forward-sentence (&optional arg) "Move forward to next end of sentence. With argument, repeat. -With negative argument, move backward repeatedly to start of sentence. +When ARG is negative, move backward repeatedly to start of sentence. The variable `sentence-end' is a regular expression that matches ends of sentences. Also, every paragraph boundary terminates sentences as well." @@ -486,37 +488,46 @@ sentences. Also, every paragraph boundary terminates sentences as well." (setq arg (1- arg))) (constrain-to-field nil opoint t))) -(defun repunctuate-sentences () +(defun repunctuate-sentences (&optional no-query) "Put two spaces at the end of sentences from point to the end of buffer. -It works using `query-replace-regexp'." +It works using `query-replace-regexp'. +If optional argument NO-QUERY is non-nil, make changes without +asking for confirmation." (interactive) - (query-replace-regexp "\\([]\"')]?\\)\\([.?!]\\)\\([]\"')]?\\) +" - "\\1\\2\\3 ")) + (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)))) (defun backward-sentence (&optional arg) - "Move backward to start of sentence. With arg, do it arg times. -See `forward-sentence' for more information." + "Move backward to start of sentence. +With ARG, do it ARG times. See `forward-sentence' for more +information." (interactive "^p") (or arg (setq arg 1)) (forward-sentence (- arg))) (defun kill-sentence (&optional arg) "Kill from point to end of sentence. -With arg, repeat; negative arg -N means kill back to Nth start of sentence." +With ARG, repeat; negative ARG -N means kill back to Nth start of +sentence." (interactive "p") (kill-region (point) (progn (forward-sentence arg) (point)))) (defun backward-kill-sentence (&optional arg) "Kill back from point to start of sentence. -With arg, repeat, or kill forward to Nth end of sentence if negative arg -N." +With ARG, repeat, or kill forward to Nth end of sentence if +negative ARG -N." (interactive "p") (kill-region (point) (progn (backward-sentence arg) (point)))) (defun mark-end-of-sentence (arg) - "Put mark at end of sentence. Arg works as in `forward-sentence'. -If this command is repeated, it marks the next ARG sentences after the -ones already marked." + "Put mark at end of sentence. +ARG works as in `forward-sentence'. If this command is repeated, +it marks the next ARG sentences after the ones already marked." (interactive "p") (push-mark (save-excursion diff --git a/lisp/textmodes/picture.el b/lisp/textmodes/picture.el index aed531e7694..bc85372de68 100644 --- a/lisp/textmodes/picture.el +++ b/lisp/textmodes/picture.el @@ -387,7 +387,8 @@ Interactively, ARG is the numeric argument, and defaults to 1." \\[picture-set-tab-stops] and \\[picture-tab-search]. The syntax for this variable is like the syntax used inside of `[...]' in a regular expression--but without the `[' and the `]'. -It is NOT a regular expression, any regexp special characters will be quoted. +It is NOT a regular expression, and should follow the usual +rules for the contents of a character alternative. It defines a set of \"interesting characters\" to look for when setting \(or searching for) tab stops, initially \"!-~\" (all printing characters). For example, suppose that you are editing a table which is formatted thus: @@ -425,7 +426,7 @@ stops computed are displayed in the minibuffer with `:' at each stop." (if arg (setq tabs (or (default-value 'tab-stop-list) (indent-accumulate-tab-stops (window-width)))) - (let ((regexp (concat "[ \t]+[" (regexp-quote picture-tab-chars) "]"))) + (let ((regexp (concat "[ \t]+[" picture-tab-chars "]"))) (beginning-of-line) (let ((bol (point))) (end-of-line) @@ -433,8 +434,8 @@ stops computed are displayed in the minibuffer with `:' at each stop." (skip-chars-forward " \t") (setq tabs (cons (current-column) tabs))) (if (null tabs) - (error "No characters in set %s on this line" - (regexp-quote picture-tab-chars)))))) + (error "No characters in set [%s] on this line" + picture-tab-chars))))) (setq tab-stop-list tabs) (let ((blurb (make-string (1+ (nth (1- (length tabs)) tabs)) ?\ ))) (while tabs @@ -455,12 +456,13 @@ If no such character is found, move to beginning of line." (progn (beginning-of-line) (skip-chars-backward - (concat "^" (regexp-quote picture-tab-chars)) + (concat "^" (replace-regexp-in-string + "\\\\" "\\\\" picture-tab-chars nil t)) (point-min)) (not (bobp)))) (move-to-column target)) (if (re-search-forward - (concat "[ \t]+[" (regexp-quote picture-tab-chars) "]") + (concat "[ \t]+[" picture-tab-chars "]") (line-end-position) 'move) (setq target (1- (current-column))) diff --git a/lisp/textmodes/refbib.el b/lisp/textmodes/refbib.el index f8013c73bb2..3ba52e61ea6 100644 --- a/lisp/textmodes/refbib.el +++ b/lisp/textmodes/refbib.el @@ -137,7 +137,7 @@ This is in addition to the `r2b-capitalize-title-stop-words'.") (defvar r2b-capitalize-title-stop-words (concat - "the\\|and\\|of\\|is\\|a\\|an\\|of\\|for\\|in\\|to\\|in\\|on\\|at\\|" + "the\\|and\\|of\\|is\\|a\\|an\\|for\\|in\\|to\\|on\\|at\\|" "by\\|with\\|that\\|its") "Words not to be capitalized in a title (unless the first word).") diff --git a/lisp/textmodes/refill.el b/lisp/textmodes/refill.el index 5e577e4b279..e597ba866c4 100644 --- a/lisp/textmodes/refill.el +++ b/lisp/textmodes/refill.el @@ -169,7 +169,7 @@ complex processing.") (when refill-doit ; there was a change ;; There's probably scope for more special cases here... (pcase this-command - (`self-insert-command + ('self-insert-command ;; Treat self-insertion commands specially, since they don't ;; always reset `refill-doit' -- for self-insertion commands that ;; *don't* cause a refill, we want to leave it turned on so that @@ -179,9 +179,9 @@ complex processing.") ;; newline, covered below). (refill-fill-paragraph-at refill-doit) (setq refill-doit nil))) - ((or `quoted-insert `fill-paragraph `fill-region) nil) - ((or `newline `newline-and-indent `open-line `indent-new-comment-line - `reindent-then-newline-and-indent) + ((or 'quoted-insert 'fill-paragraph 'fill-region) nil) + ((or 'newline 'newline-and-indent 'open-line 'indent-new-comment-line + 'default-indent-new-line 'reindent-then-newline-and-indent) ;; Don't zap what was just inserted. (save-excursion (beginning-of-line) ; for newline-and-indent @@ -213,9 +213,6 @@ complex processing.") ;;;###autoload (define-minor-mode refill-mode "Toggle automatic refilling (Refill mode). -With a prefix argument ARG, enable Refill mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Refill mode is a buffer-local minor mode. When enabled, the current paragraph is refilled as you edit. Self-inserting diff --git a/lisp/textmodes/reftex-cite.el b/lisp/textmodes/reftex-cite.el index 851e46ca2d5..5b42b25f772 100644 --- a/lisp/textmodes/reftex-cite.el +++ b/lisp/textmodes/reftex-cite.el @@ -172,7 +172,7 @@ If RETURN is non-nil, just return the entry and restore point." (if item (progn (end-of-line) (re-search-forward - "\\\\bibitem\\|\\end{thebibliography}") + "\\\\bibitem\\|\\\\end{thebibliography}") (1- (match-beginning 0))) (progn (forward-list 1) (point))) (error (min (point-max) (+ 300 (point))))))) @@ -447,7 +447,7 @@ If FIELD is empty try \"editor\" field." (setq names (reftex-get-bib-field "editor" entry))) (while (string-match "\\band\\b[ \t]*" names) (setq names (replace-match "\n" nil t names))) - (while (string-match "[\\.a-zA-Z\\-]+\\.[ \t]*\\|,.*\\|[{}]+" names) + (while (string-match "[-.a-zA-Z]+\\.[ \t]*\\|,.*\\|[{}]+" names) (setq names (replace-match "" nil t names))) (while (string-match "^[ \t]+\\|[ \t]+$" names) (setq names (replace-match "" nil t names))) diff --git a/lisp/textmodes/reftex-global.el b/lisp/textmodes/reftex-global.el index cdff2f479fa..6103c6c0206 100644 --- a/lisp/textmodes/reftex-global.el +++ b/lisp/textmodes/reftex-global.el @@ -27,6 +27,8 @@ (eval-when-compile (require 'cl-lib)) (provide 'reftex-global) (require 'reftex) + +(declare-function fileloop-continue "fileloop") ;;; ;;;###autoload @@ -98,8 +100,11 @@ No active TAGS table is required." (unless to (setq to (read-string (format "Replace regexp %s with: " from)))) (reftex-access-scan-info current-prefix-arg) - (tags-query-replace from to (or delimited current-prefix-arg) - (list 'reftex-all-document-files)))) + (fileloop-initialize-replace + from to (reftex-all-document-files) + (if (equal from (downcase from)) nil 'default) + (or delimited current-prefix-arg)) + (fileloop-continue))) (defvar TeX-master) (defvar isearch-next-buffer-function) diff --git a/lisp/textmodes/reftex-parse.el b/lisp/textmodes/reftex-parse.el index 2f9b7268fc8..005816e9659 100644 --- a/lisp/textmodes/reftex-parse.el +++ b/lisp/textmodes/reftex-parse.el @@ -1000,7 +1000,7 @@ OPT-ARGS is a list of argument numbers which are optional." (eq (following-char) ?\{)) (cl-incf cnt))) (if (and (= n cnt) - (> (skip-chars-forward "{\\[") 0)) + (> (skip-chars-forward "{[") 0)) (reftex-context-substring) nil)))) diff --git a/lisp/textmodes/reftex-ref.el b/lisp/textmodes/reftex-ref.el index ca1d2b2df8d..3ec96aa67db 100644 --- a/lisp/textmodes/reftex-ref.el +++ b/lisp/textmodes/reftex-ref.el @@ -308,13 +308,13 @@ also applies `reftex-translate-to-ascii-function' to the string." ;; Replace %escapes in a label prefix (save-match-data (let (letter (num 0) replace) - (while (string-match "\\%\\([a-zA-Z]\\)" prefix num) + (while (string-match "%\\([a-zA-Z]\\)" prefix num) (setq letter (match-string 1 prefix)) (setq replace (save-match-data (cond ((equal letter "f") - (file-name-base)) + (file-name-base (buffer-file-name))) ((equal letter "F") (let ((masterdir (file-name-directory (reftex-TeX-master-file))) (file (file-name-sans-extension (buffer-file-name)))) diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el index 017f5a32126..a9d5819f4b6 100644 --- a/lisp/textmodes/reftex-vars.el +++ b/lisp/textmodes/reftex-vars.el @@ -202,8 +202,8 @@ distribution. Mixed-case symbols are convenience aliases.") (harvard "The Harvard package" ((?\C-m . "\\cite[]{%l}") (?p . "\\cite[]{%l}") - (?t . "\\citeasnoun{%l}") - (?n . "\\citeasnoun{%l}") + (?t . "\\citeasnoun[]{%l}") + (?n . "\\citeasnoun[]{%l}") (?s . "\\possessivecite{%l}") (?e . "\\citeaffixed{%l}{?}") (?y . "\\citeyear{%l}") @@ -891,21 +891,58 @@ DOWNCASE t: Downcase words before using them." ;; so this list mustn't get any more items. (defconst reftex-label-regexps '("\\\\label{\\([^}]*\\)}")) (defcustom reftex-label-regexps - '(;; Normal \\label{foo} labels + `(;; Normal \\label{foo} labels "\\\\label{\\(?1:[^}]*\\)}" ;; keyvals [..., label = {foo}, ...] forms used by ctable, - ;; listings, minted, ... - "\\[[^][]\\{0,2000\\}\\<label[[:space:]]*=[[:space:]]*{?\\(?1:[^],}]+\\)}?") + ;; listings, breqn, ... + ,(concat + ;; Make sure we search only for optional arguments of + ;; environments/macros and don't match any other [. ctable + ;; provides a macro called \ctable, listings/breqn have + ;; environments. Start with a backslash and a group for names + "\\\\\\(?:" + ;; begin, optional spaces and opening brace + "begin[[:space:]]*{" + ;; Build a regexp for env names + (regexp-opt '("lstlisting" "dmath" "dseries" "dgroup" "darray")) + ;; closing brace, optional spaces + "}[[:space:]]*" + ;; Now for macros + "\\|" + ;; Build a regexp for macro names; currently only \ctable + (regexp-opt '("ctable")) + ;; Close the group for names + "\\)" + ;; Match the opening [ and the following chars + "\\[[^][]*" + ;; Allow nested levels of chars enclosed in braces + "\\(?:{[^}{]*" + "\\(?:{[^}{]*" + "\\(?:{[^}{]*}[^}{]*\\)*" + "}[^}{]*\\)*" + "}[^][]*\\)*" + ;; Match the label key + "\\<label[[:space:]]*=[[:space:]]*" + ;; Match the label value; braces around the value are + ;; optional. + "{?\\(?1:[^] ,}\r\n\t%]+\\)}?" + ;; We are done. Just search until the next closing bracket + "[^]]*\\]")) "List of regexps matching \\label definitions. The default value matches usual \\label{...} definitions and -keyval style [..., label = {...}, ...] label definitions. It is -assumed that the regexp group 1 matches the label text, so you -have to define it using \\(?1:...\\) when adding new regexps. +keyval style [..., label = {...}, ...] label definitions. The +regexp for keyval style explicitly looks for environments +provided by the packages \"listings\" (\"lstlisting\"), +\"breqn\" (\"dmath\", \"dseries\", \"dgroup\", \"darray\") and +the macro \"\\ctable\" provided by the package of the same name. + +It is assumed that the regexp group 1 matches the label text, so +you have to define it using \\(?1:...\\) when adding new regexps. When changed from Lisp, make sure to call `reftex-compile-variables' afterwards to make the change effective." - :version "25.1" + :version "27.1" :set (lambda (symbol value) (set symbol value) (when (fboundp 'reftex-compile-variables) @@ -1030,7 +1067,9 @@ This is used to string together whole reference sets, like ("Hyperref" "hyperref" (("\\autoref" ?a) ("\\autopageref" ?u))) ("Cleveref" "cleveref" - (("\\cref" ?c) ("\\Cref" ?C) ("\\cpageref" ?d) ("\\Cpageref" ?D)))) + (("\\cref" ?c) ("\\Cref" ?C) ("\\cpageref" ?d) ("\\Cpageref" ?D))) + ("AMSmath" "amsmath" + (("\\eqref" ?e)))) "Alist of reference styles. Each element is a list of the style name, the name of the LaTeX package associated with the style or t for any package, and an @@ -1040,7 +1079,7 @@ the macro type is being prompted for. (See also `reftex-ref-macro-prompt'.) The keys, represented as characters, have to be unique." :group 'reftex-referencing-labels - :version "24.3" + :version "27.1" :type '(alist :key-type (string :tag "Style name") :value-type (group (choice :tag "Package" (const :tag "Any package" t) diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el index b9c08b8797e..67ecd3ced81 100644 --- a/lisp/textmodes/remember.el +++ b/lisp/textmodes/remember.el @@ -402,11 +402,19 @@ exists) might be changed." :type 'string :group 'remember) +(defcustom remember-time-format "%a %b %d %H:%M:%S %Y" + "The format for time stamp, passed to `format-time-string'. +The default emulates `current-time-string' for backward compatibility." + :type 'string + :group 'remember + :version "27.1") + (defun remember-append-to-file () "Remember, with description DESC, the given TEXT." (let* ((text (buffer-string)) (desc (remember-buffer-desc)) - (remember-text (concat "\n" remember-leader-text (current-time-string) + (remember-text (concat "\n" remember-leader-text + (format-time-string remember-time-format) " (" desc ")\n\n" text (save-excursion (goto-char (point-max)) (if (bolp) nil "\n")))) diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el index 7b9b618e4a4..ba5d7e4f46f 100644 --- a/lisp/textmodes/rst.el +++ b/lisp/textmodes/rst.el @@ -112,27 +112,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Support for `testcover' -(when (and (boundp 'testcover-1value-functions) - (boundp 'testcover-compose-functions)) - ;; Below `lambda' is used in a loop with varying parameters and is thus not - ;; 1valued. - (setq testcover-1value-functions - (delq 'lambda testcover-1value-functions)) - (add-to-list 'testcover-compose-functions 'lambda)) - -(defun rst-testcover-defcustom () - "Remove all customized variables from `testcover-module-constants'. -This seems to be a bug in `testcover': `defcustom' variables are -considered constants. Revert it with this function after each `defcustom'." - (when (boundp 'testcover-module-constants) - (setq testcover-module-constants - (delq nil - (mapcar - #'(lambda (sym) - (if (not (plist-member (symbol-plist sym) 'standard-value)) - sym)) - testcover-module-constants))))) - (defun rst-testcover-add-compose (fun) "Add FUN to `testcover-compose-functions'." (when (boundp 'testcover-compose-functions) @@ -246,7 +225,7 @@ and before TAIL-RE and DELIM-RE in VAR or DEFAULT for no match." "The SVN revision of this file. SVN revision is the upstream (docutils) revision.") (defconst rst-svn-timestamp - (rst-extract-version "\\$" "LastChangedDate: " ".+?+" " " + (rst-extract-version "\\$" "LastChangedDate: " ".+" " " "$LastChangedDate: 2017-01-08 10:54:35 +0100 (Sun, 08 Jan 2017) $") "The SVN time stamp of this file.") @@ -817,6 +796,9 @@ Return ADO if so or signal an error otherwise." ;; Public class methods +(define-obsolete-variable-alias + 'rst-preferred-decorations 'rst-preferred-adornments "rst 1.0.0") + (defvar rst-preferred-adornments) ; Forward declaration. (defun rst-Hdr-preferred-adornments () @@ -1344,7 +1326,6 @@ This inherits from Text mode.") The hook for `text-mode' is run before this one." :group 'rst :type '(hook)) -(rst-testcover-defcustom) ;; Pull in variable definitions silencing byte-compiler. (require 'newcomment) @@ -1430,9 +1411,6 @@ highlighting. ;;;###autoload (define-minor-mode rst-minor-mode "Toggle ReST minor mode. -With a prefix argument ARG, enable ReST minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. When ReST minor mode is enabled, the ReST mode keybindings are installed on top of the major mode bindings. Use this @@ -1503,8 +1481,6 @@ for modes derived from Text mode, like Mail mode." :group 'rst :version "21.1") -(define-obsolete-variable-alias - 'rst-preferred-decorations 'rst-preferred-adornments "rst 1.0.0") ;; FIXME: Default must match suggestion in ;; http://sphinx-doc.org/rest.html#sections for Python documentation. (defcustom rst-preferred-adornments '((?= over-and-under 1) @@ -1541,7 +1517,6 @@ file." (const :tag "Underline only" simple)) (integer :tag "Indentation for overline and underline type" :value 0)))) -(rst-testcover-defcustom) ;; FIXME: Rename this to `rst-over-and-under-default-indent' and set default to ;; 0 because the effect of 1 is probably surprising in the few cases @@ -1558,7 +1533,6 @@ found in the buffer are to be used but the indentation for over-and-under adornments is inconsistent across the buffer." :group 'rst-adjust :type '(integer)) -(rst-testcover-defcustom) (defun rst-new-preferred-hdr (seen prev) ;; testcover: ok. @@ -1997,7 +1971,6 @@ b. a negative numerical argument, which generally inverts the :group 'rst-adjust :type '(hook) :package-version '(rst . "1.1.0")) -(rst-testcover-defcustom) (defcustom rst-new-adornment-down nil "Controls level of new adornment for section headers." @@ -2006,7 +1979,6 @@ b. a negative numerical argument, which generally inverts the (const :tag "Same level as previous one" nil) (const :tag "One level down relative to the previous one" t)) :package-version '(rst . "1.1.0")) -(rst-testcover-defcustom) (defun rst-adjust-adornment (pfxarg) "Call `rst-adjust-section' interactively. @@ -2429,7 +2401,6 @@ also arranged by `rst-insert-list-new-tag'." :tag (char-to-string char) char)) rst-bullets))) :package-version '(rst . "1.1.0")) -(rst-testcover-defcustom) (defun rst-insert-list-continue (ind tag tab prefer-roman) ;; testcover: ok. @@ -2666,7 +2637,6 @@ section headers at all." Also used for formatting insertion, when numbering is disabled." :type 'integer :group 'rst-toc) -(rst-testcover-defcustom) (defcustom rst-toc-insert-style 'fixed "Insertion style for table-of-contents. @@ -2681,19 +2651,16 @@ indentation style: (const aligned) (const listed)) :group 'rst-toc) -(rst-testcover-defcustom) (defcustom rst-toc-insert-number-separator " " "Separator that goes between the TOC number and the title." :type 'string :group 'rst-toc) -(rst-testcover-defcustom) (defcustom rst-toc-insert-max-level nil "If non-nil, maximum depth of the inserted TOC." :type '(choice (const nil) integer) :group 'rst-toc) -(rst-testcover-defcustom) (defconst rst-toc-link-keymap (let ((map (make-sparse-keymap))) @@ -3158,35 +3125,30 @@ These indentation widths can be customized here." "Indentation when there is no more indentation point given." :group 'rst-indent :type '(integer)) -(rst-testcover-defcustom) (defcustom rst-indent-field 3 "Indentation for first line after a field or 0 to always indent for content." :group 'rst-indent :package-version '(rst . "1.1.0") :type '(integer)) -(rst-testcover-defcustom) (defcustom rst-indent-literal-normal 3 "Default indentation for literal block after a markup on an own line." :group 'rst-indent :package-version '(rst . "1.1.0") :type '(integer)) -(rst-testcover-defcustom) (defcustom rst-indent-literal-minimized 2 "Default indentation for literal block after a minimized markup." :group 'rst-indent :package-version '(rst . "1.1.0") :type '(integer)) -(rst-testcover-defcustom) (defcustom rst-indent-comment 3 "Default indentation for first line of a comment." :group 'rst-indent :package-version '(rst . "1.1.0") :type '(integer)) -(rst-testcover-defcustom) ;; FIXME: Must consider other tabs: ;; * Line blocks @@ -3636,7 +3598,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." :version "24.1" :group 'rst-faces :type '(face)) -(rst-testcover-defcustom) (make-obsolete-variable 'rst-block-face "customize the face `rst-block' instead." "24.1") @@ -3651,7 +3612,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." :version "24.1" :group 'rst-faces :type '(face)) -(rst-testcover-defcustom) (make-obsolete-variable 'rst-external-face "customize the face `rst-external' instead." "24.1") @@ -3666,7 +3626,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." :version "24.1" :group 'rst-faces :type '(face)) -(rst-testcover-defcustom) (make-obsolete-variable 'rst-definition-face "customize the face `rst-definition' instead." "24.1") @@ -3683,7 +3642,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." "Directives and roles." :group 'rst-faces :type '(face)) -(rst-testcover-defcustom) (make-obsolete-variable 'rst-directive-face "customize the face `rst-directive' instead." "24.1") @@ -3698,7 +3656,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." :version "24.1" :group 'rst-faces :type '(face)) -(rst-testcover-defcustom) (make-obsolete-variable 'rst-comment-face "customize the face `rst-comment' instead." "24.1") @@ -3713,7 +3670,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." :version "24.1" :group 'rst-faces :type '(face)) -(rst-testcover-defcustom) (make-obsolete-variable 'rst-emphasis1-face "customize the face `rst-emphasis1' instead." "24.1") @@ -3727,7 +3683,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." "Double emphasis." :group 'rst-faces :type '(face)) -(rst-testcover-defcustom) (make-obsolete-variable 'rst-emphasis2-face "customize the face `rst-emphasis2' instead." "24.1") @@ -3742,7 +3697,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." :version "24.1" :group 'rst-faces :type '(face)) -(rst-testcover-defcustom) (make-obsolete-variable 'rst-literal-face "customize the face `rst-literal' instead." "24.1") @@ -3757,7 +3711,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." :version "24.1" :group 'rst-faces :type '(face)) -(rst-testcover-defcustom) (make-obsolete-variable 'rst-reference-face "customize the face `rst-reference' instead." "24.1") @@ -3840,7 +3793,6 @@ of your own." (const :tag "transitions" t) (const :tag "section title adornment" nil)) :value-type (face))) -(rst-testcover-defcustom) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -4337,7 +4289,6 @@ string)) to be used for converting the document." (string :tag "Options")))) :group 'rst-compile :package-version "1.2.0") -(rst-testcover-defcustom) ;; FIXME: Must be defcustom. (defvar rst-compile-primary-toolset 'html diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el index c9724e0e3f7..d8210037c6d 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -46,8 +46,7 @@ (defcustom sgml-basic-offset 2 "Specifies the basic indentation level for `sgml-indent-line'." - :type 'integer - :group 'sgml) + :type 'integer) (defcustom sgml-attribute-offset 0 "Specifies a delta for attribute indentation in `sgml-indent-line'. @@ -65,16 +64,16 @@ When 2, attribute indentation looks like this: </element>" :version "25.1" :type 'integer - :safe 'integerp - :group 'sgml) + :safe 'integerp) (defcustom sgml-xml-mode nil "When non-nil, tag insertion functions will be XML-compliant. It is set to be buffer-local when the file has a DOCTYPE or an XML declaration." :type 'boolean - :version "22.1" - :group 'sgml) + :version "22.1") + +(defvaralias 'sgml-transformation 'sgml-transformation-function) (defcustom sgml-transformation-function 'identity "Default value for `skeleton-transformation-function' in SGML mode." @@ -87,17 +86,14 @@ a DOCTYPE or an XML declaration." (and (derived-mode-p 'sgml-mode) (not sgml-xml-mode) (setq skeleton-transformation-function val)))) - (buffer-list))) - :group 'sgml) + (buffer-list)))) (put 'sgml-transformation-function 'variable-interactive "aTransformation function: ") -(defvaralias 'sgml-transformation 'sgml-transformation-function) (defcustom sgml-mode-hook nil "Hook run by command `sgml-mode'. `text-mode-hook' is run first." - :group 'sgml :type 'hook) ;; The official handling of "--" is complicated in SGML, and @@ -206,8 +202,7 @@ This takes effect when first loading the `sgml-mode' library.") (defcustom sgml-name-8bit-mode nil "When non-nil, insert non-ASCII characters as named entities." - :type 'boolean - :group 'sgml) + :type 'boolean) (defvar sgml-char-names [nil nil nil nil nil nil nil nil @@ -277,8 +272,7 @@ Currently, only Latin-1 characters are supported.") The file name of current buffer file name will be appended to this, separated by a space." :type 'string - :version "21.1" - :group 'sgml) + :version "21.1") (defvar sgml-saved-validate-command nil "The command last used to validate in this buffer.") @@ -287,8 +281,7 @@ separated by a space." ;; so use a small distance here. (defcustom sgml-slash-distance 1000 "If non-nil, is the maximum distance to search for matching `/'." - :type '(choice (const nil) integer) - :group 'sgml) + :type '(choice (const nil) integer)) (defconst sgml-namespace-re "[_[:alpha:]][-_.[:alnum:]]*") (defconst sgml-name-re "[_:[:alpha:]][-_.:[:alnum:]]*") @@ -300,8 +293,7 @@ Any terminating `>' or `/' is not matched.") (defface sgml-namespace '((t (:inherit font-lock-builtin-face))) - "`sgml-mode' face used to highlight the namespace part of identifiers." - :group 'sgml) + "`sgml-mode' face used to highlight the namespace part of identifiers.") (defvar sgml-namespace-face 'sgml-namespace) ;; internal @@ -337,6 +329,30 @@ Any terminating `>' or `/' is not matched.") (defvar sgml-font-lock-keywords sgml-font-lock-keywords-1 "Rules for highlighting SGML code. See also `sgml-tag-face-alist'.") +(defun sgml-font-lock-syntactic-face (state) + "`font-lock-syntactic-face-function' for `sgml-mode'." + ;; Don't use string face outside of tags. + (cond ((and (nth 9 state) (nth 3 state)) font-lock-string-face) + ((nth 4 state) font-lock-comment-face))) + +(defvar-local sgml--syntax-propertize-ppss nil) + +(defun sgml--syntax-propertize-ppss (pos) + "Return PPSS at POS, fixing the syntax of any lone `>' along the way." + (cl-assert (>= pos (car sgml--syntax-propertize-ppss))) + (let ((ppss (parse-partial-sexp (car sgml--syntax-propertize-ppss) pos -1 + nil (cdr sgml--syntax-propertize-ppss)))) + (while (eq -1 (car ppss)) + (put-text-property (1- (point)) (point) + 'syntax-table (string-to-syntax ".")) + ;; Hack attack: rather than recompute the ppss from + ;; (car sgml--syntax-propertize-ppss), we manually "fix it". + (setcar ppss 0) + (setq ppss (parse-partial-sexp (point) pos -1 nil ppss))) + (setcdr sgml--syntax-propertize-ppss ppss) + (setcar sgml--syntax-propertize-ppss pos) + ppss)) + (eval-and-compile (defconst sgml-syntax-propertize-rules (syntax-propertize-precompile-rules @@ -347,21 +363,50 @@ Any terminating `>' or `/' is not matched.") ("--[ \t\n]*\\(>\\)" (1 "> b")) ("\\(<\\)[?!]" (1 (prog1 "|>" (sgml-syntax-propertize-inside end)))) - ;; Quotes outside of tags should not introduce strings. - ;; Be careful to call `syntax-ppss' on a position before the one we're - ;; going to change, so as not to need to flush the data we just computed. - ("[\"']" (0 (if (prog1 (zerop (car (syntax-ppss (match-beginning 0)))) - (goto-char (match-end 0))) - (string-to-syntax "."))))))) + ;; Quotes outside of tags should not introduce strings which end up + ;; hiding tags. We used to test every quote and mark it as "." + ;; if it's outside of tags, but there are too many quotes and + ;; the resulting number of calls to syntax-ppss made it too slow + ;; (bug#33887), so we're now careful to leave alone any pair + ;; of quotes that doesn't hold a < or > char, which is the vast majority: + ;; either they're both within a tag (or a comment), in which case it's + ;; indeed correct to leave them as is, or they're both outside of tags, in + ;; which case they arguably should have punctuation syntax, but it is + ;; harmless to let them have string syntax because they won't "hide" any + ;; tag or comment from us (and we use the + ;; font-lock-syntactic-face-function to make sure those spurious "strings + ;; within text" aren't highlighted as strings). + ("\\([\"']\\)[^\"'<>]*" + (1 (if (eq (char-after) (char-after (match-beginning 0))) + ;; Fast-track case. + (forward-char 1) + ;; Point has moved to the end of the text we matched after the + ;; quote, but this risks overlooking a match to one of the other + ;; regexp in the rules. We could just (goto-char (match-end 1)) + ;; to solve this, but that would be too easy, so instead we + ;; only move back enough to avoid skipping comment ender, which + ;; happens to be the only one that we could have overlooked. + (when (eq (char-after) ?>) + (skip-chars-backward "-")) + ;; Be careful to call `syntax-ppss' on a position before the one + ;; we're going to change, so as not to need to flush the data we + ;; just computed. + (if (zerop (save-excursion + (car (sgml--syntax-propertize-ppss + (match-beginning 0))))) + (string-to-syntax "."))))) + ))) (defun sgml-syntax-propertize (start end) "Syntactic keywords for `sgml-mode'." - (goto-char start) - (with-syntax-table (or syntax-ppss-table (syntax-table)) - (sgml-syntax-propertize-inside end) - (funcall - (syntax-propertize-rules sgml-syntax-propertize-rules) - start end))) + (setq sgml--syntax-propertize-ppss (cons start (syntax-ppss start))) + (cl-assert (>= (cadr sgml--syntax-propertize-ppss) 0)) + (sgml-syntax-propertize-inside end) + (funcall + (syntax-propertize-rules sgml-syntax-propertize-rules) + start end) + ;; Catch any '>' after the last quote. + (sgml--syntax-propertize-ppss end)) (defun sgml-syntax-propertize-inside (end) (let ((ppss (syntax-ppss))) @@ -417,8 +462,7 @@ The attribute alist is made up as ATTRIBUTERULE is a list of optionally t (no value when no input) followed by an optional alist of possible values." :type '(repeat (cons (string :tag "Tag Name") - (repeat :tag "Tag Rule" sexp))) - :group 'sgml) + (repeat :tag "Tag Rule" sexp)))) (put 'sgml-tag-alist 'risky-local-variable t) (defcustom sgml-tag-help @@ -430,8 +474,7 @@ an optional alist of possible values." ("!entity" . "Entity (macro) declaration")) "Alist of tag name and short description." :type '(repeat (cons (string :tag "Tag Name") - (string :tag "Description"))) - :group 'sgml) + (string :tag "Description")))) (defvar sgml-empty-tags nil "List of tags whose !ELEMENT definition says EMPTY.") @@ -457,7 +500,7 @@ an optional alist of possible values." nil t) (string-match "X\\(HT\\)?ML" (match-string 3)))))) -(defvar v2) ; free for skeleton +(with-no-warnings (defvar v2)) ; free for skeleton (defun sgml-comment-indent-new-line (&optional soft) (let ((comment-start "-- ") @@ -549,7 +592,7 @@ Do \\[describe-key] on the following bindings to discover what they do. ;; This is desirable because SGML discards a newline that appears ;; immediately after a start tag or immediately before an end tag. (setq-local paragraph-start (concat "[ \t]*$\\|\ -[ \t]*</?\\(" sgml-name-re sgml-attrs-re "\\)?>")) +\[ \t]*</?\\(" sgml-name-re sgml-attrs-re "\\)?>")) (setq-local paragraph-separate (concat paragraph-start "$")) (setq-local adaptive-fill-regexp "[ \t]*") (add-hook 'fill-nobreak-predicate 'sgml-fill-nobreak nil t) @@ -567,7 +610,9 @@ Do \\[describe-key] on the following bindings to discover what they do. (setq font-lock-defaults '((sgml-font-lock-keywords sgml-font-lock-keywords-1 sgml-font-lock-keywords-2) - nil t)) + nil t nil + (font-lock-syntactic-face-function + . sgml-font-lock-syntactic-face))) (setq-local syntax-propertize-function #'sgml-syntax-propertize) (setq-local syntax-ppss-table sgml-tag-syntax-table) (setq-local facemenu-add-face-function 'sgml-mode-facemenu-add-face-function) @@ -616,7 +661,7 @@ Behaves electrically if `sgml-quick-keys' is non-nil." (delete-char -1) (sgml-close-tag)) (t - (sgml-slash-matching arg)))) + (insert-char ?/ arg)))) (defun sgml-slash-matching (arg) "Insert `/' and display any previous matching `/'. @@ -772,8 +817,16 @@ If QUIET, do not print a message when there are no attributes for TAG." (symbolp (car (car alist)))) (setq car (car alist) alist (cdr alist))) - (or quiet - (message "No attributes configured.")) + (unless (or alist quiet) + (message "No attributes configured.")) + (when alist + ;; Add class and id attributes if a) the element has any + ;; other attributes configured, and b) they're not already + ;; present. + (unless (assoc-string "class" alist) + (setq alist (cons '("class") alist))) + (unless (assoc-string "id" alist) + (setq alist (cons '("id") alist)))) (if (stringp (car alist)) (progn (insert (if (eq (preceding-char) ?\s) "" ?\s) @@ -893,7 +946,7 @@ Return non-nil if we skipped over matched tags." (condition-case err (save-excursion (goto-char end) - (skip-chars-backward "[:alnum:]-_.:") + (skip-chars-backward "-[:alnum:]_.:") (if (and ;; (<= (point) beg) ; This poses problems for downcase-word. (or (eq (char-before) ?<) (and (eq (char-before) ?/) @@ -901,7 +954,7 @@ Return non-nil if we skipped over matched tags." (null (get-char-property (point) 'text-clones))) (let* ((endp (eq (char-before) ?/)) (cl-start (point)) - (cl-end (progn (skip-chars-forward "[:alnum:]-_.:") (point))) + (cl-end (progn (skip-chars-forward "-[:alnum:]_.:") (point))) (match (if endp (when (sgml-skip-tag-backward 1) (forward-char 1) t) @@ -918,7 +971,8 @@ Return non-nil if we skipped over matched tags." (equal (buffer-substring cl-start cl-end) (buffer-substring (point) (save-excursion - (skip-chars-forward "[:alnum:]-_.:") + (skip-chars-forward + "-[:alnum:]_.:") (point)))) (or (not endp) (eq (char-after cl-end) ?>))) (when clones @@ -938,9 +992,6 @@ Return non-nil if we skipped over matched tags." (define-minor-mode sgml-electric-tag-pair-mode "Toggle SGML Electric Tag Pair mode. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. SGML Electric Tag Pair mode is a buffer-local minor mode for use with `sgml-mode' and related major modes. When enabled, editing @@ -1239,8 +1290,11 @@ See `sgml-tag-alist' for info about attribute rules." (defun sgml-quote (start end &optional unquotep) "Quote SGML text in region START ... END. -Only &, < and > are quoted, the rest is left untouched. -With prefix argument UNQUOTEP, unquote the region." +Only &, <, >, ' and \" characters are quoted, the rest is left +untouched. This is sufficient to use quoted text as SGML argument. + +With prefix argument UNQUOTEP, unquote the region. All numeric entities, +\"amp\", \"lt\", \"gt\" and \"quot\" named entities are unquoted." (interactive "r\nP") (save-restriction (narrow-to-region start end) @@ -1248,14 +1302,23 @@ With prefix argument UNQUOTEP, unquote the region." (if unquotep ;; FIXME: We should unquote other named character references as well. (while (re-search-forward - "\\(&\\(amp\\|\\(l\\|\\(g\\)\\)t\\)\\)[][<>&;\n\t \"%!'(),/=?]" + "\\(&\\(amp\\|quot\\|lt\\|gt\\|#\\([0-9]+\\|[xX][[:xdigit:]]+\\)\\)\\)\\([][<>&;\n\t \"%!'(),/=?]\\|$\\)" nil t) - (replace-match (if (match-end 4) ">" (if (match-end 3) "<" "&")) t t - nil (if (eq (char-before (match-end 0)) ?\;) 0 1))) - (while (re-search-forward "[&<>]" nil t) + (replace-match + (string + (or (cdr (assq (char-after (match-beginning 2)) + '((?a . ?&) (?q . ?\") (?l . ?<) (?g . ?>)))) + (let ((num (match-string 3))) + (if (or (eq ?x (aref num 0)) (eq ?X (aref num 0))) + (string-to-number (substring num 1) 16) + (string-to-number num 10))))) + t t nil (if (eq (char-before (match-end 0)) ?\;) 0 1))) + (while (re-search-forward "[&<>\"']" nil t) (replace-match (cdr (assq (char-before) '((?& . "&") (?< . "<") - (?> . ">")))) + (?> . ">") + (?\" . """) + (?' . "'")))) t t))))) (defun sgml-pretty-print (beg end) @@ -1512,12 +1575,12 @@ Depending on context, inserts a matching close-tag, or closes the current start-tag or the current comment or the current cdata, ..." (interactive) (pcase (car (sgml-lexical-context)) - (`comment (insert " -->")) - (`cdata (insert "]]>")) - (`pi (insert " ?>")) - (`jsp (insert " %>")) - (`tag (insert " />")) - (`text + ('comment (insert " -->")) + ('cdata (insert "]]>")) + ('pi (insert " ?>")) + ('jsp (insert " %>")) + ('tag (insert " />")) + ('text (let ((context (save-excursion (sgml-get-context)))) (if context (progn @@ -1550,7 +1613,7 @@ LCON is the lexical context, if any." (pcase (car lcon) - (`string + ('string ;; Go back to previous non-empty line. (while (and (> (point) (cdr lcon)) (zerop (forward-line -1)) @@ -1561,7 +1624,7 @@ LCON is the lexical context, if any." (goto-char (cdr lcon)) (1+ (current-column)))) - (`comment + ('comment (let ((mark (looking-at "--"))) ;; Go back to previous non-empty line. (while (and (> (point) (cdr lcon)) @@ -1580,11 +1643,11 @@ LCON is the lexical context, if any." (current-column))) ;; We don't know how to indent it. Let's be honest about it. - (`cdata nil) + ('cdata nil) ;; We don't know how to indent it. Let's be honest about it. - (`pi nil) + ('pi nil) - (`tag + ('tag (goto-char (+ (cdr lcon) sgml-attribute-offset)) (skip-chars-forward "^ \t\n") ;Skip tag name. (skip-chars-forward " \t") @@ -1594,7 +1657,7 @@ LCON is the lexical context, if any." (goto-char (+ (cdr lcon) sgml-attribute-offset)) (+ (current-column) sgml-basic-offset))) - (`text + ('text (while (looking-at "</") (sgml-forward-sexp 1) (skip-chars-forward " \t")) @@ -1710,7 +1773,6 @@ Currently just returns (EMPTY-TAGS UNCLOSED-TAGS)." (defcustom html-mode-hook nil "Hook run by command `html-mode'. `text-mode-hook' and `sgml-mode-hook' are run first." - :group 'sgml :type 'hook :options '(html-autoview-mode)) @@ -1742,6 +1804,7 @@ This takes effect when first loading the library.") (define-key map "\C-c\C-ci" 'html-image) (when html-quick-keys (define-key map "\C-c-" 'html-horizontal-rule) + (define-key map "\C-cd" 'html-div) (define-key map "\C-co" 'html-ordered-list) (define-key map "\C-cu" 'html-unordered-list) (define-key map "\C-cr" 'html-radio-buttons) @@ -1749,7 +1812,8 @@ This takes effect when first loading the library.") (define-key map "\C-cl" 'html-list-item) (define-key map "\C-ch" 'html-href-anchor) (define-key map "\C-cn" 'html-name-anchor) - (define-key map "\C-ci" 'html-image)) + (define-key map "\C-ci" 'html-image) + (define-key map "\C-cs" 'html-span)) (define-key map "\C-c\C-s" 'html-autoview-mode) (define-key map "\C-c\C-v" 'browse-url-of-buffer) (define-key map [menu-bar html] (cons "HTML" menu-map)) @@ -1950,7 +2014,7 @@ This takes effect when first loading the library.") ("dd" ,(not sgml-xml-mode)) ("del" nil ("cite") ("datetime")) ("dfn") - ("div") + ("div" \n ("id") ("class")) ("dl" (nil \n ( "Term: " "<dt>" str (if sgml-xml-mode "</dt>") @@ -2230,6 +2294,9 @@ buffer's tick counter (as produced by `buffer-modified-tick'), and the CDR is the list of class names found in the buffer.") (make-variable-buffer-local 'html--buffer-ids-cache) +(declare-function libxml-parse-html-region "xml.c" + (start end &optional base-url discard-comments)) + (defun html-current-buffer-classes () "Return a list of class names used in the current buffer. The result is cached in `html--buffer-classes-cache'." @@ -2361,18 +2428,14 @@ The third `match-string' will be the used in the menu.") (define-minor-mode html-autoview-mode "Toggle viewing of HTML files on save (HTML Autoview mode). -With a prefix argument ARG, enable HTML Autoview mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. HTML Autoview mode is a buffer-local minor mode for use with `html-mode'. If enabled, saving the file automatically runs `browse-url-of-buffer' to view it." nil nil nil - :group 'sgml (if html-autoview-mode - (add-hook 'after-save-hook 'browse-url-of-buffer nil t) - (remove-hook 'after-save-hook 'browse-url-of-buffer t))) + (add-hook 'after-save-hook #'browse-url-of-buffer nil t) + (remove-hook 'after-save-hook #'browse-url-of-buffer t))) (define-skeleton html-href-anchor @@ -2437,16 +2500,16 @@ HTML Autoview mode is a buffer-local minor mode for use with (define-skeleton html-ordered-list "HTML ordered list tags." nil - "<ol>" \n + \n "<ol>" \n "<li>" _ (if sgml-xml-mode "</li>") \n - "</ol>") + "</ol>" > \n) (define-skeleton html-unordered-list "HTML unordered list tags." nil - "<ul>" \n + \n "<ul>" \n "<li>" _ (if sgml-xml-mode "</li>") \n - "</ul>") + "</ul>" > \n) (define-skeleton html-list-item "HTML list item tag." @@ -2457,8 +2520,17 @@ HTML Autoview mode is a buffer-local minor mode for use with (define-skeleton html-paragraph "HTML paragraph tag." nil - (if (bolp) nil ?\n) - "<p>" _ (if sgml-xml-mode "</p>")) + \n "<p>" _ (if sgml-xml-mode "</p>")) + +(define-skeleton html-div + "HTML div tag." + nil + "<div>" > \n _ \n "</div>" >) + +(define-skeleton html-span + "HTML span tag." + nil + "<span>" > _ "</span>") (define-skeleton html-checkboxes "Group of connected checkbox inputs." diff --git a/lisp/textmodes/table.el b/lisp/textmodes/table.el index bed8b2fef27..1f185e0f216 100644 --- a/lisp/textmodes/table.el +++ b/lisp/textmodes/table.el @@ -590,7 +590,7 @@ ;; attempt of implementing the table feature to Emacs. This greatly ;; motivated me to follow through to its completion. ;; -;; Kenichi Handa <handa@etl.go.jp> kindly guided me through to +;; Kenichi Handa <handa@gnu.org> kindly guided me through to ;; overcome many technical issues while I was struggling with quail ;; related internationalization problems. ;; @@ -882,7 +882,7 @@ This is always set to nil at the entry to `table-with-cache-buffer' before execu (push '(table-mode-indicator (table-fixed-width-mode " Fixed-Table" " Table")) minor-mode-alist)) -(defconst table-source-languages '(html latex cals) +(defconst table-source-languages '(html latex cals wiki mediawiki) "Supported source languages.") (defvar table-source-info-plist nil "General storage for temporary information used while generating source.") @@ -930,16 +930,16 @@ This is always set to nil at the entry to `table-with-cache-buffer' before execu ;; refill the table cache. If the command were not listed fast ;; typing can cause unwanted cache refill. (defconst table-cell-bindings - '(([(control i)] . table-forward-cell) - ([(control I)] . table-backward-cell) + '(([(control ?i)] . table-forward-cell) + ([(control ?I)] . table-backward-cell) ([tab] . table-forward-cell) ([(shift backtab)] . table-backward-cell) ; for HPUX console keyboard ([(shift iso-lefttab)] . table-backward-cell) ; shift-tab on a microsoft natural keyboard and redhat linux ([(shift tab)] . table-backward-cell) ([backtab] . table-backward-cell) ; for terminals (e.g., xterm) ([return] . *table--cell-newline) - ([(control m)] . *table--cell-newline) - ([(control j)] . *table--cell-newline-and-indent) + ([(control ?m)] . *table--cell-newline) + ([(control ?j)] . *table--cell-newline-and-indent) ([mouse-3] . *table--present-cell-popup-menu) ([(control ?>)] . table-widen-cell) ([(control ?<)] . table-narrow-cell) @@ -1202,35 +1202,13 @@ This is always set to nil at the entry to `table-with-cache-buffer' before execu :help "Move point backward by cell(s)"]) )) -;; XEmacs causes an error when encountering unknown keywords in the -;; menu definition. Specifically the :help keyword is new in Emacs 21 -;; and causes error for the XEmacs function `check-menu-syntax'. IMHO -;; it is unwise to generate an error for unknown keywords because it -;; kills the nice backward compatible extensibility of keyword use. -;; Unknown keywords should be quietly ignore so that future extension -;; does not cause a problem in the old implementation. Sigh... -(when (featurep 'xemacs) - (defun table--tweak-menu-for-xemacs (menu) - (cond - ((listp menu) - (mapcar #'table--tweak-menu-for-xemacs menu)) - ((vectorp menu) - (let ((len (length menu))) - (dotimes (i len) - ;; replace :help with something harmless. - (if (eq (aref menu i) :help) (aset menu i :included))))))) - (mapcar #'table--tweak-menu-for-xemacs - (list table-global-menu table-cell-menu)) - (defvar mark-active t)) - ;; register table menu under global tools menu (unless table-disable-menu - (easy-menu-define table-global-menu-map nil "Table global menu" table-global-menu) - (if (featurep 'xemacs) - (progn - (easy-menu-add-item nil '("Tools") table-global-menu-map)) - (easy-menu-add-item (current-global-map) '("menu-bar" "tools") "--") - (easy-menu-add-item (current-global-map) '("menu-bar" "tools") table-global-menu-map))) + (easy-menu-define table-global-menu-map nil + "Table global menu" table-global-menu) + (easy-menu-add-item (current-global-map) '("menu-bar" "tools") "--") + (easy-menu-add-item (current-global-map) + '("menu-bar" "tools") table-global-menu-map)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -1310,8 +1288,8 @@ the last cache point coordinate." ;; set up the update timer unless it is explicitly inhibited. (unless table-inhibit-update (table--update-cell))))) -(if (or (featurep 'xemacs) - (null (fboundp 'font-lock-add-keywords))) nil +(if (null (fboundp 'font-lock-add-keywords)) + nil ;; Color it as a keyword. (font-lock-add-keywords 'emacs-lisp-mode @@ -2046,8 +2024,6 @@ plain text and loses all the table specific features." (erase-buffer) (table--insert-rectangle rectangle))))) (restore-buffer-modified-p modified-flag)) - (if (featurep 'xemacs) - (table--warn-incompatibility)) cell))) ;;;###autoload @@ -3077,7 +3053,11 @@ CALS (DocBook DTD): (table-put-source-info 'row-type (if (zerop table-cals-thead-rows) "tbody" "thead")) (set-marker-insertion-type (table-get-source-info 'colspec-marker) nil) ;; insert after (insert (format " <%s valign=\"top\">\n" (table-get-source-info 'row-type)))) - ))) + ((eq language 'mediawiki) + (insert (format + "<!-- This HTML table template is generated by Emacs %s -->\n" + emacs-version)) + (insert "{|\n"))))) (defun table--generate-source-epilogue (dest-buffer language _col-list _row-list) "Generate and insert source epilogue into DEST-BUFFER." @@ -3094,7 +3074,8 @@ CALS (DocBook DTD): (dolist (col (sort (table-get-source-info 'colnum-list) '<)) (insert (format " <colspec colnum=\"%d\" colname=\"c%d\"/>\n" col col)))) (insert (format " </%s>\n </tgroup>\n</table>\n" (table-get-source-info 'row-type)))) - ))) + ((eq language 'mediawiki) + (insert "|}\n"))))) (defun table--generate-source-scan-rows (dest-buffer language _origin-cell col-list row-list) "Generate and insert source rows into DEST-BUFFER." @@ -3106,7 +3087,11 @@ CALS (DocBook DTD): (insert " <tr>\n")) ((eq language 'cals) (insert " <row>\n")) - )) + ((eq language 'wiki) + (insert "|")) + ((and (eq language 'mediawiki) + (> (table-get-source-info 'current-row) 1)) + (insert "|-\n")))) (table--generate-source-cells-in-a-row dest-buffer language col-list row-list) (with-current-buffer dest-buffer (cond @@ -3116,7 +3101,9 @@ CALS (DocBook DTD): (insert " </row>\n") (unless (/= (table-get-source-info 'current-row) table-cals-thead-rows) (insert (format " </%s>\n" (table-get-source-info 'row-type))) - (insert (format " <%s valign=\"top\">\n" (table-put-source-info 'row-type "tbody"))))))) + (insert (format " <%s valign=\"top\">\n" (table-put-source-info 'row-type "tbody"))))) + ((eq language 'wiki) + (insert "|\n")))) (table-put-source-info 'current-row (1+ (table-get-source-info 'current-row))) (setq row-list (cdr row-list)))) @@ -3185,7 +3172,8 @@ CALS (DocBook DTD): (not (memq valign '(top none)))) (insert " valign=\"" (symbol-name valign) "\"")) (insert ">\n")) - )) + ((memq language '(wiki mediawiki)) + (insert "|")))) (table--generate-source-cell-contents dest-buffer language cell) (with-current-buffer dest-buffer (cond @@ -3193,7 +3181,10 @@ CALS (DocBook DTD): (insert (format" </%s>\n" (table-get-source-info 'cell-type)))) ((eq language 'cals) (insert " </entry>\n")) - )) + ((eq language 'wiki) + (insert "|")) + ((eq language 'mediawiki) + (insert ?\n)))) (table-forward-cell 1 t) (table-put-source-info 'current-column (table-get-source-info 'next-column)) )))) @@ -3232,11 +3223,12 @@ CALS (DocBook DTD): (with-current-buffer dest-buffer (let ((beg (point))) (insert cell-contents) - (indent-rigidly beg (point) - (cond - ((eq language 'html) 6) - ((eq language 'cals) 10))) - (insert ?\n))))) + (when (memq language '(html cals)) + (indent-rigidly beg (point) + (cond + ((eq language 'html) 6) + ((eq language 'cals) 10))) + (insert ?\n)))))) (defun table--cell-horizontal-char-p (c) "Test if character C is one of the horizontal characters" @@ -3878,9 +3870,7 @@ converts a table into plain text without frames. It is a companion to ;; Add menu for table cells. (unless table-disable-menu (easy-menu-define table-cell-menu-map table-cell-map - "Table cell menu" table-cell-menu) - (if (featurep 'xemacs) - (easy-menu-add table-cell-menu))) + "Table cell menu" table-cell-menu)) (run-hooks 'table-cell-map-hook)) ;; Create the keymap after running the user init file so that the user @@ -4093,7 +4083,7 @@ When the optional parameter NOW is nil it only sets up the update timer. If it is non-nil the function copies the contents of the cell cache buffer into the designated cell in the table buffer." (if (null table-update-timer) nil - (table--cancel-timer table-update-timer) + (cancel-timer table-update-timer) (setq table-update-timer nil)) (if (or (not now) (and (boundp 'quail-converting) @@ -4136,7 +4126,7 @@ cache buffer into the designated cell in the table buffer." (defun table--update-cell-widened (&optional now) "Update the contents of the cells that are affected by widening operation." (if (null table-widen-timer) nil - (table--cancel-timer table-widen-timer) + (cancel-timer table-widen-timer) (setq table-widen-timer nil)) (if (not now) (setq table-widen-timer @@ -4175,7 +4165,7 @@ cache buffer into the designated cell in the table buffer." (defun table--update-cell-heightened (&optional now) "Update the contents of the cells that are affected by heightening operation." (if (null table-heighten-timer) nil - (table--cancel-timer table-heighten-timer) + (cancel-timer table-heighten-timer) (setq table-heighten-timer nil)) (if (not now) (setq table-heighten-timer @@ -4270,10 +4260,6 @@ cdr is the history symbol." (read-from-minibuffer (format "%s (default %s): " (car prompt-history) default) "" nil nil (cdr prompt-history) default)) - (and (featurep 'xemacs) - (equal (car (symbol-value (cdr prompt-history))) "") - (set (cdr prompt-history) - (cdr (symbol-value (cdr prompt-history))))) (car (symbol-value (cdr prompt-history)))) (defun table--buffer-substring-and-trim (beg end) @@ -4584,10 +4570,7 @@ of line." (defun table--untabify (beg end) "Wrapper to raw untabify." - (untabify beg end) - (if (featurep 'xemacs) - ;; Cancel strange behavior of xemacs - (message ""))) + (untabify beg end)) (defun table--multiply-string (string multiplier) "Multiply string and return it." @@ -5208,9 +5191,7 @@ instead of the current buffer and returns the OBJECT." (defun table--update-cell-face () "Update cell face according to the current mode." - (if (featurep 'xemacs) - (set-face-property 'table-cell 'underline table-fixed-width-mode) - (set-face-inverse-video 'table-cell table-fixed-width-mode))) + (set-face-inverse-video 'table-cell table-fixed-width-mode)) (table--update-cell-face) @@ -5263,27 +5244,12 @@ This feature is disabled when `table-disable-incompatibility-warning' is non-nil. The warning is done only once per session for each item." (unless (and table-disable-incompatibility-warning (not (called-interactively-p 'interactive))) - (cond ((and (featurep 'xemacs) - (not (get 'table-disable-incompatibility-warning 'xemacs))) - (put 'table-disable-incompatibility-warning 'xemacs t) - (display-warning 'table - " -*** Warning *** - -Table package mostly works fine under XEmacs, however, due to the -peculiar implementation of text property under XEmacs, cell splitting -and any undo operation of table exhibit some known strange problems, -such that a border characters dissolve into adjacent cells. Please be -aware of this. - -" - :warning)) - ((and (boundp 'flyspell-mode) - flyspell-mode - (not (get 'table-disable-incompatibility-warning 'flyspell))) - (put 'table-disable-incompatibility-warning 'flyspell t) - (display-warning 'table - " + (when (and (boundp 'flyspell-mode) + flyspell-mode + (not (get 'table-disable-incompatibility-warning 'flyspell))) + (put 'table-disable-incompatibility-warning 'flyspell t) + (display-warning 'table + " *** Warning *** Flyspell minor mode is known to be incompatible with this table @@ -5291,8 +5257,7 @@ package. The flyspell version 1.5d at URL `http://kaolin.unice.fr/~serrano' works better than the previous versions however not fully compatible. " - :warning)) - ))) + :warning)))) (defun table--cell-blank-str (&optional n) "Return blank table cell string of length N." @@ -5338,7 +5303,6 @@ Current buffer must already be set to the cache buffer." (setq justify (or justify table-cell-info-justify)) (and justify (not (eq justify 'left)) - (not (featurep 'xemacs)) (set-marker-insertion-type marker-point t)) (table--remove-eol-spaces (point-min) (point-max)) (if table-fixed-width-mode @@ -5486,19 +5450,7 @@ It returns COLUMN unless STR contains some wide characters." (defun table--set-timer (seconds func args) "Generic wrapper for setting up a timer." - (if (featurep 'xemacs) - ;; the picky xemacs refuses to accept zero - (add-timeout (if (zerop seconds) 0.01 seconds) func args nil) - ;;(run-at-time seconds nil func args))) - ;; somehow run-at-time causes strange problem under Emacs 20.7 - ;; this problem does not show up under Emacs 21.0.90 - (run-with-idle-timer seconds nil func args))) - -(defun table--cancel-timer (timer) - "Generic wrapper for canceling a timer." - (if (featurep 'xemacs) - (disable-timeout timer) - (cancel-timer timer))) + (run-with-idle-timer seconds nil func args)) (defun table--get-last-command () "Generic wrapper for getting the real last command." diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index 479bcbe975a..91c580adec4 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -251,7 +251,7 @@ Normally set to either `plain-tex-mode' or `latex-mode'." :type 'boolean :group 'tex :version "23.1") -(put 'tex-fontify-script 'safe-local-variable 'booleanp) +(put 'tex-fontify-script 'safe-local-variable #'booleanp) (defcustom tex-font-script-display '(-0.2 0.2) "How much to lower and raise subscript and superscript content. @@ -601,9 +601,9 @@ An alternative value is \" . \", if you use a font with a narrow period." (list (concat slash citations opt arg) 3 'font-lock-constant-face) ;; ;; Text between `` quotes ''. - (cons (concat (regexp-opt `("``" "\"<" "\"`" "<<" "«") t) + (cons (concat (regexp-opt '("``" "\"<" "\"`" "<<" "«") t) "[^'\">{]+" ;a bit pessimistic - (regexp-opt `("''" "\">" "\"'" ">>" "»") t)) + (regexp-opt '("''" "\">" "\"'" ">>" "»") t)) 'font-lock-string-face) ;; ;; Command names, special and general. @@ -670,7 +670,7 @@ An alternative value is \" . \", if you use a font with a narrow period." (defvar tex-verbatim-environments '("verbatim" "verbatim*")) (put 'tex-verbatim-environments 'safe-local-variable - (lambda (x) (null (delq t (mapcar #'stringp x))))) + (lambda (x) (not (memq nil (mapcar #'stringp x))))) (eval-when-compile (defconst tex-syntax-propertize-rules @@ -713,9 +713,6 @@ An alternative value is \" . \", if you use a font with a narrow period." (define-minor-mode latex-electric-env-pair-mode "Toggle Latex Electric Env Pair mode. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable it if ARG -is omitted or nil. Latex Electric Env Pair mode is a buffer-local minor mode for use with `latex-mode'. When enabled, typing a \\begin or \\end tag @@ -1173,7 +1170,7 @@ subshell is initiated, `tex-shell-hook' is run." (setq-local fill-indent-according-to-mode t) (add-hook 'completion-at-point-functions #'latex-complete-data nil 'local) - (add-hook 'flymake-diagnostic-functions 'tex-chktex nil t) + (add-hook 'flymake-diagnostic-functions #'tex-chktex nil t) (setq-local outline-regexp latex-outline-regexp) (setq-local outline-level #'latex-outline-level) (setq-local forward-sexp-function #'latex-forward-sexp) @@ -1264,8 +1261,8 @@ Entering SliTeX mode runs the hook `text-mode-hook', then the hook (setq-local comment-start-skip "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\)\\(%+ *\\)") (setq-local parse-sexp-ignore-comments t) - (setq-local compare-windows-whitespace 'tex-categorize-whitespace) - (setq-local facemenu-add-face-function 'tex-facemenu-add-face-function) + (setq-local compare-windows-whitespace #'tex-categorize-whitespace) + (setq-local facemenu-add-face-function #'tex-facemenu-add-face-function) (setq-local facemenu-end-add-face "}") (setq-local facemenu-remove-face-function t) (setq-local font-lock-defaults @@ -1594,7 +1591,7 @@ Puts point on a blank line between them." (defvar latex-complete-bibtex-cache nil) (define-obsolete-function-alias 'latex-string-prefix-p - 'string-prefix-p "24.3") + #'string-prefix-p "24.3") (defvar bibtex-reference-key) (declare-function reftex-get-bibfile-list "reftex-cite.el" ()) @@ -1659,7 +1656,7 @@ Puts point on a blank line between them." (let ((pt (point))) (skip-chars-backward "^ {}\n\t\\\\") (pcase (char-before) - ((or `nil ?\s ?\n ?\t ?\}) nil) + ((or 'nil ?\s ?\n ?\t ?\}) nil) (?\\ ;; TODO: Complete commands. nil) @@ -2112,7 +2109,7 @@ If NOT-ALL is non-nil, save the `.dvi' file." (delete-file (concat dir (car list)))) (setq list (cdr list)))))) -(add-hook 'kill-emacs-hook 'tex-delete-last-temp-files) +(add-hook 'kill-emacs-hook #'tex-delete-last-temp-files) ;; ;; Machinery to guess the command that the user wants to execute. @@ -2171,7 +2168,7 @@ IN can be either a string (with the same % escapes in it) indicating OUT describes the output file and is either a %-escaped string or nil to indicate that there is no output file.") -(define-obsolete-function-alias 'tex-string-prefix-p 'string-prefix-p "24.3") +(define-obsolete-function-alias 'tex-string-prefix-p #'string-prefix-p "24.3") (defun tex-guess-main-file (&optional all) "Find a likely `tex-main-file'. @@ -2266,9 +2263,11 @@ FILE is typically the output DVI or PDF file." (> (save-excursion ;; Usually page numbers are output as [N], but ;; I've already seen things like - ;; [1{/var/lib/texmf/fonts/map/pdftex/updmap/pdftex.map}] - (or (re-search-backward "\\[[0-9]+\\({[^}]*}\\)?\\]" - nil t) + ;; [N{/var/lib/texmf/fonts/map/pdftex/updmap/pdftex.map}] + ;; as well as [N.N] (e.g. with 'acmart' style). + (or (re-search-backward + "\\[[0-9]+\\({[^}]*}\\|\\.[0-9]+\\)?\\]" + nil t) (point-min))) (save-excursion (or (re-search-backward "Rerun" nil t) @@ -2804,9 +2803,19 @@ Runs the shell command defined by `tex-show-queue-command'." (defvar tex-indent-basic 2) (defvar tex-indent-item tex-indent-basic) (defvar tex-indent-item-re "\\\\\\(bib\\)?item\\>") -(defvar latex-noindent-environments '("document")) -(put 'latex-noindent-environments 'safe-local-variable - (lambda (x) (null (delq t (mapcar #'stringp x))))) +(defcustom latex-noindent-environments '("document") + "Environments whose content is not indented by `tex-indent-basic'." + :type '(repeat string) + :safe (lambda (x) (not (memq nil (mapcar #'stringp x)))) + :group 'tex-file + :version "27.1") + +(defcustom latex-noindent-commands '("emph" "footnote") + "Commands for which `tex-indent-basic' should not be used." + :type '(repeat string) + :safe (lambda (x) (not (memq nil (mapcar #'stringp x)))) + :group 'tex-file + :version "27.1") (defvar tex-latex-indent-syntax-table (let ((st (make-syntax-table tex-mode-syntax-table))) @@ -2913,9 +2922,17 @@ There might be text before point." (current-column) ;; We're the first element after a hanging brace. (goto-char up-list-pos) - (+ (if (and (looking-at "\\\\begin *{\\([^\n}]+\\)") + (+ (if (if (eq (char-after) ?\{) + (save-excursion + (skip-chars-backward " \t") + (let ((end (point))) + (skip-chars-backward "a-zA-Z") + (and (eq (char-before) ?\\) + (member (buffer-substring (point) end) + latex-noindent-commands)))) + (and (looking-at "\\\\begin *{\\([^\n}]+\\)") (member (match-string 1) - latex-noindent-environments)) + latex-noindent-environments))) 0 tex-indent-basic) indent (latex-find-indent 'virtual)))) ;; We're now at the "beginning" of a line. @@ -2995,8 +3012,8 @@ There might be text before point." (mapcar (lambda (x) (pcase (car-safe x) - (`font-lock-syntactic-face-function - (cons (car x) 'doctex-font-lock-syntactic-face-function)) + ('font-lock-syntactic-face-function + (cons (car x) #'doctex-font-lock-syntactic-face-function)) (_ x))) (cdr font-lock-defaults)))) (setq-local syntax-propertize-function diff --git a/lisp/textmodes/texinfmt.el b/lisp/textmodes/texinfmt.el index 0e65b1c4e20..3c32037c3ef 100644 --- a/lisp/textmodes/texinfmt.el +++ b/lisp/textmodes/texinfmt.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1985-1986, 1988, 1990-1998, 2000-2019 Free Software ;; Foundation, Inc. -;; Maintainer: Robert J. Chassell <bug-texinfo@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: maint, tex, docs ;; This file is part of GNU Emacs. @@ -552,13 +552,7 @@ if large. You can use `Info-split' to do this manually." (defvar texinfo-accent-commands (concat - "@^\\|" - "@`\\|" - "@'\\|" - "@\"\\|" - "@,\\|" - "@=\\|" - "@~\\|" + "@[\"',=^`~]\\|" "@OE{\\|" "@oe{\\|" "@AA{\\|" @@ -1292,8 +1286,7 @@ otherwise, insert URL-TITLE followed by URL in parentheses." ;; if url-title (if (nth 1 args) (insert (nth 1 args) " (" (nth 0 args) ")") - (insert "`" (nth 0 args) "'")) - (goto-char texinfo-command-start))) + (insert "`" (nth 0 args) "'")))) ;;; Section headings @@ -2447,7 +2440,7 @@ Use only the FILENAME arg; for Info, ignore the other arguments to @image." (defun texinfo-format-option () "Insert \\=` ... \\=' around arg unless inside a table; in that case, no quotes." ;; `looking-at-backward' not available in v. 18.57, 20.2 - (if (not (search-backward "" ; searched-for character is a control-H + (if (not (search-backward "\^H" (line-beginning-position) t)) (insert "`" (texinfo-parse-arg-discard) "'") diff --git a/lisp/textmodes/texinfo.el b/lisp/textmodes/texinfo.el index f6aa8727410..71cdcab57ef 100644 --- a/lisp/textmodes/texinfo.el +++ b/lisp/textmodes/texinfo.el @@ -470,6 +470,7 @@ Subexpression 1 is what goes into the corresponding `@end' statement.") (define-key map "\C-c\C-cu" 'texinfo-insert-@uref) (define-key map "\C-c\C-ct" 'texinfo-insert-@table) (define-key map "\C-c\C-cs" 'texinfo-insert-@samp) + (define-key map "\C-c\C-cr" 'texinfo-insert-dwim-@ref) (define-key map "\C-c\C-cq" 'texinfo-insert-@quotation) (define-key map "\C-c\C-co" 'texinfo-insert-@noindent) (define-key map "\C-c\C-cn" 'texinfo-insert-@node) @@ -596,9 +597,9 @@ 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 "\b\\|@[a-zA-Z]*[ \n]\\|" + (concat "@[a-zA-Z]*[ \n]\\|" paragraph-separate)) - (setq-local paragraph-start (concat "\b\\|@[a-zA-Z]*[ \n]\\|" + (setq-local paragraph-start (concat "@[a-zA-Z]*[ \n]\\|" paragraph-start)) (setq-local sentence-end-base "\\(@\\(end\\)?dots{}\\|[.?!]\\)[]\"'”)}]*") (setq-local fill-column 70) @@ -610,7 +611,6 @@ value of `texinfo-mode-hook'." (setq font-lock-defaults '(texinfo-font-lock-keywords nil nil nil backward-paragraph)) (setq-local syntax-propertize-function texinfo-syntax-propertize-function) - (setq-local parse-sexp-lookup-properties t) (setq-local add-log-current-defun-function #'texinfo-current-defun-name) ;; Outline settings. @@ -826,6 +826,38 @@ Leave point after `@node'." "Insert the string `@quotation' in a Texinfo buffer." \n "@quotation" \n _ \n) +(define-skeleton texinfo-insert-dwim-@ref + "Insert appropriate `@pxref{...}', `@xref{}', or `@ref{}' command. + +Looks at text around point to decide what to insert; an unclosed +preceding open parenthesis results in '@pxref{}', point at the +beginning of a sentence or at (point-min) yields '@xref{}', any +other location (including inside a word), will result in '@ref{}' +at the nearest previous whitespace or beginning-of-line. A +numeric argument says how many words the braces should surround. +The default is not to surround any existing words with the +braces." + nil + (cond + ;; parenthesis + ((looking-back "([^)]*" (point-at-bol 0)) + "@pxref{") + ;; beginning of sentence or buffer + ((or (looking-back (sentence-end) (point-at-bol 0)) + (= (point) (point-min))) + "@xref{") + ;; bol or eol + ((looking-at "^\\|$") + "@ref{") + ;; inside word + ((not (eq (char-syntax (char-after)) ? )) + (skip-syntax-backward "^ " (point-at-bol)) + "@ref{") + ;; everything else + (t + "@ref{")) + _ "}") + (define-skeleton texinfo-insert-@samp "Insert a `@samp{...}' command in a Texinfo buffer. A numeric argument says how many words the braces should surround. diff --git a/lisp/textmodes/texnfo-upd.el b/lisp/textmodes/texnfo-upd.el index 8c6e23eae4a..134f82b14e0 100644 --- a/lisp/textmodes/texnfo-upd.el +++ b/lisp/textmodes/texnfo-upd.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1989-1992, 2001-2019 Free Software Foundation, Inc. ;; Author: Robert J. Chassell -;; Maintainer: bug-texinfo@gnu.org +;; Maintainer: emacs-devel@gnu.org ;; Keywords: maint, tex, docs ;; This file is part of GNU Emacs. @@ -642,7 +642,7 @@ appears in the texinfo file." "Return description field of old menu line as string. Point must be located just after the node name. Point left before description. Single argument, END-OF-MENU, is position limiting search." - (skip-chars-forward "[:.,\t\n ]+") + (skip-chars-forward ":.,\t\n ") ;; don't copy a carriage return at line beginning with asterisk! ;; don't copy @detailmenu or @end menu or @ignore as descriptions! ;; do copy a description that begins with an `@'! diff --git a/lisp/textmodes/text-mode.el b/lisp/textmodes/text-mode.el index 931faadb5bb..e676a5dae20 100644 --- a/lisp/textmodes/text-mode.el +++ b/lisp/textmodes/text-mode.el @@ -1,4 +1,4 @@ -;;; text-mode.el --- text mode, and its idiosyncratic commands +;;; text-mode.el --- text mode, and its idiosyncratic commands -*- lexical-binding: t -*- ;; Copyright (C) 1985, 1992, 1994, 2001-2019 Free Software Foundation, ;; Inc. @@ -38,8 +38,8 @@ :group 'text) (defvar text-mode-variant nil - "Non-nil if this buffer's major mode is a variant of Text mode. -Use (derived-mode-p \\='text-mode) instead.") + "Non-nil if this buffer's major mode is a variant of Text mode.") +(make-obsolete-variable 'text-mode-variant 'derived-mode-p "27.1") (defvar text-mode-syntax-table (let ((st (make-syntax-table))) @@ -104,10 +104,8 @@ You can thus get the full benefit of adaptive filling (see the variable `adaptive-fill-mode'). \\{text-mode-map} Turning on Text mode runs the normal hook `text-mode-hook'." - (set (make-local-variable 'text-mode-variant) t) - (set (make-local-variable 'require-final-newline) - mode-require-final-newline) - (set (make-local-variable 'indent-line-function) 'indent-relative)) + (setq-local text-mode-variant t) + (setq-local require-final-newline mode-require-final-newline)) (define-derived-mode paragraph-indent-text-mode text-mode "Parindent" "Major mode for editing text, with leading spaces starting a paragraph. @@ -131,14 +129,12 @@ Turning on Paragraph-Indent minor mode runs the normal hook :initial-value nil ;; Change the definition of a paragraph start. (let ((ps-re "[ \t\n\f]\\|")) - (if (eq t (compare-strings ps-re nil nil - paragraph-start nil (length ps-re))) + (if (string-prefix-p ps-re paragraph-start) (if (not paragraph-indent-minor-mode) - (set (make-local-variable 'paragraph-start) - (substring paragraph-start (length ps-re)))) + (setq-local paragraph-start + (substring paragraph-start (length ps-re)))) (if paragraph-indent-minor-mode - (set (make-local-variable 'paragraph-start) - (concat ps-re paragraph-start))))) + (setq-local paragraph-start (concat ps-re paragraph-start))))) ;; Change the indentation function. (if paragraph-indent-minor-mode (add-function :override (local 'indent-line-function) @@ -154,7 +150,7 @@ Turning on Paragraph-Indent minor mode runs the normal hook (defun text-mode-hook-identify () "Mark that this mode has run `text-mode-hook'. This is how `toggle-text-mode-auto-fill' knows which buffers to operate on." - (set (make-local-variable 'text-mode-variant) t)) + (setq-local text-mode-variant t)) (defun toggle-text-mode-auto-fill () "Toggle whether to use Auto Fill in Text mode and related modes. @@ -163,8 +159,8 @@ both existing buffers and buffers that you subsequently create." (interactive) (let ((enable-mode (not (memq 'turn-on-auto-fill text-mode-hook)))) (if enable-mode - (add-hook 'text-mode-hook 'turn-on-auto-fill) - (remove-hook 'text-mode-hook 'turn-on-auto-fill)) + (add-hook 'text-mode-hook #'turn-on-auto-fill) + (remove-hook 'text-mode-hook #'turn-on-auto-fill)) (dolist (buffer (buffer-list)) (with-current-buffer buffer (if (or (derived-mode-p 'text-mode) text-mode-variant) @@ -214,15 +210,14 @@ The argument NLINES says how many lines to center." (while (not (eq nlines 0)) (save-excursion (let ((lm (current-left-margin)) - line-length) + space) (beginning-of-line) (delete-horizontal-space) (end-of-line) (delete-horizontal-space) - (setq line-length (current-column)) - (if (> (- fill-column lm line-length) 0) - (indent-line-to - (+ lm (/ (- fill-column lm line-length) 2)))))) + (setq space (- fill-column lm (current-column))) + (if (> space 0) + (indent-line-to (+ lm (/ space 2)))))) (cond ((null nlines) (setq nlines 0)) ((> nlines 0) diff --git a/lisp/textmodes/tildify.el b/lisp/textmodes/tildify.el index cf33d44ed3c..ccbc2b086c6 100644 --- a/lisp/textmodes/tildify.el +++ b/lisp/textmodes/tildify.el @@ -261,7 +261,9 @@ Call CALLBACK on each region outside of environment to ignore. Stop scanning the region as soon as CALLBACK returns nil. Environments to ignore are defined by deprecated `tildify-ignored-environments-alist'. CALLBACK may be called on portions of the buffer outside of [BEG END)." - (let ((pairs (tildify--pick-alist-entry tildify-ignored-environments-alist))) + (let ((pairs (with-suppressed-warnings ((obsolete tildify--pick-alist-entry)) + (tildify--pick-alist-entry + tildify-ignored-environments-alist)))) (if pairs (tildify-foreach-ignore-environments pairs callback beg end) (funcall callback beg end)))) @@ -355,7 +357,9 @@ replacements done and response is one of symbols: t (all right), nil (goto-char beg) (let ((regexp tildify-pattern) (match-number 1) - (tilde (or (tildify--pick-alist-entry tildify-string-alist) + (tilde (or (with-suppressed-warnings ((obsolete + tildify--pick-alist-entry)) + (tildify--pick-alist-entry tildify-string-alist)) tildify-space-string)) (end-marker (copy-marker end)) answer @@ -365,7 +369,9 @@ replacements done and response is one of symbols: t (all right), nil (message-log-max nil) (count 0)) ;; For the time being, tildify-pattern-alist overwrites tildify-pattern - (let ((alist (tildify--pick-alist-entry tildify-pattern-alist))) + (let ((alist (with-suppressed-warnings ((obsolete + tildify--pick-alist-entry)) + (tildify--pick-alist-entry tildify-pattern-alist)))) (when alist (setq regexp (car alist) match-number (cadr alist)))) (while (and (not quit) @@ -491,7 +497,9 @@ representation for current major mode, the `tildify-space-string' buffer-local variable will be set to the representation." nil " ~" nil (when tildify-mode - (let ((space (tildify--pick-alist-entry tildify-string-alist))) + (let ((space (with-suppressed-warnings ((obsolete + tildify--pick-alist-entry)) + (tildify--pick-alist-entry tildify-string-alist)))) (if (not (string-equal " " (or space tildify-space-string))) (when space (setq tildify-space-string space)) diff --git a/lisp/textmodes/underline.el b/lisp/textmodes/underline.el index e0bfd24557b..6d359f1d69b 100644 --- a/lisp/textmodes/underline.el +++ b/lisp/textmodes/underline.el @@ -1,4 +1,4 @@ -;;; underline.el --- insert/remove underlining (done by overstriking) in Emacs +;;; underline.el --- insert/remove underlining (done by overstriking) in Emacs -*- lexical-binding: t -*- ;; Copyright (C) 1985, 2001-2019 Free Software Foundation, Inc. diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index d75898fcc4f..319f4b2cf8a 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -42,6 +42,9 @@ ;; beginning-op Function to call to skip to the beginning of a "thing". ;; end-op Function to call to skip to the end of a "thing". ;; +;; For simple things, defined as sequences of specific kinds of characters, +;; use macro define-thing-chars. +;; ;; Reliance on existing operators means that many `things' can be accessed ;; without further code: eg. ;; (thing-at-point 'line) @@ -58,7 +61,7 @@ "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', -`filename', `url', `email', `word', `sentence', `whitespace', +`filename', `url', `email', `uuid', `word', `sentence', `whitespace', `line', and `page'." (let ((forward-op (or (get thing 'forward-op) (intern-soft (format "forward-%s" thing))))) @@ -73,7 +76,7 @@ Possibilities include `symbol', `list', `sexp', `defun', "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', -`filename', `url', `email', `word', `sentence', `whitespace', +`filename', `url', `email', `uuid', `word', `sentence', `whitespace', `line', and `page'. See the file `thingatpt.el' for documentation on how to define a @@ -131,7 +134,7 @@ positions of the thing found." "Return the THING at point. THING should be a symbol specifying a type of syntactic entity. Possibilities include `symbol', `list', `sexp', `defun', -`filename', `url', `email', `word', `sentence', `whitespace', +`filename', `url', `email', `uuid', `word', `sentence', `whitespace', `line', `number', and `page'. When the optional argument NO-PROPERTIES is non-nil, @@ -191,7 +194,9 @@ The bounds of THING are determined by `bounds-of-thing-at-point'." (if (or (eq char-syntax ?\)) (and (eq char-syntax ?\") (nth 3 (syntax-ppss)))) (forward-char 1) - (forward-sexp 1)))) + (condition-case _ + (forward-sexp 1) + (scan-error nil))))) (define-obsolete-function-alias 'end-of-sexp 'thing-at-point--end-of-sexp "25.1" @@ -235,21 +240,28 @@ Prefer the enclosing list with fallback on sexp at point. (put 'defun 'end-op 'end-of-defun) (put 'defun 'forward-op 'end-of-defun) +;; Things defined by sets of characters + +(defmacro define-thing-chars (thing chars) + "Define THING as a sequence of CHARS. +E.g.: +\(define-thing-chars twitter-screen-name \"[:alnum:]_\")" + `(progn + (put ',thing 'end-op + (lambda () + (re-search-forward (concat "\\=[" ,chars "]*") nil t))) + (put ',thing 'beginning-op + (lambda () + (if (re-search-backward (concat "[^" ,chars "]") nil t) + (forward-char) + (goto-char (point-min))))))) + ;; Filenames (defvar thing-at-point-file-name-chars "-~/[:alnum:]_.${}#%,:" "Characters allowable in filenames.") -(put 'filename 'end-op - (lambda () - (re-search-forward (concat "\\=[" thing-at-point-file-name-chars "]*") - nil t))) -(put 'filename 'beginning-op - (lambda () - (if (re-search-backward (concat "[^" thing-at-point-file-name-chars "]") - nil t) - (forward-char) - (goto-char (point-min))))) +(define-thing-chars filename thing-at-point-file-name-chars) ;; URIs @@ -456,11 +468,14 @@ looks like an email address, \"ftp://\" if it starts with (while htbs (setq htb (car htbs) htbs (cdr htbs)) (ignore-errors - ;; errs: htb symbol may be unbound, or not a hash-table. - ;; gnus-gethash is just a macro for intern-soft. - (and (symbol-value htb) - (intern-soft string (symbol-value htb)) - (setq ret string htbs nil)) + (setq htb (symbol-value htb)) + (when (cond ((obarrayp htb) + (intern-soft string htb)) + ((listp htb) + (member string htb)) + ((hash-table-p htb) + (gethash string htb))) + (setq ret string htbs nil)) ;; If we made it this far, gnus is running, so ignore "heads": (setq heads nil))) (or ret (not heads) @@ -552,15 +567,33 @@ with angle brackets.") (put 'buffer 'end-op (lambda () (goto-char (point-max)))) (put 'buffer 'beginning-op (lambda () (goto-char (point-min)))) +;; UUID + +(defconst thing-at-point-uuid-regexp + (rx bow + (repeat 8 hex-digit) "-" + (repeat 4 hex-digit) "-" + (repeat 4 hex-digit) "-" + (repeat 4 hex-digit) "-" + (repeat 12 hex-digit) + eow) + "A regular expression matching a UUID. +See RFC 4122 for the description of the format.") + +(put 'uuid 'bounds-of-thing-at-point + (lambda () + (when (thing-at-point-looking-at thing-at-point-uuid-regexp 36) + (cons (match-beginning 0) (match-end 0))))) + ;; Aliases -(defun word-at-point () +(defun word-at-point (&optional no-properties) "Return the word at point. See `thing-at-point'." - (thing-at-point 'word)) + (thing-at-point 'word no-properties)) -(defun sentence-at-point () +(defun sentence-at-point (&optional no-properties) "Return the sentence at point. See `thing-at-point'." - (thing-at-point 'sentence)) + (thing-at-point 'sentence no-properties)) (defun thing-at-point--read-from-whole-string (str) "Read a Lisp expression from STR. diff --git a/lisp/thread.el b/lisp/thread.el new file mode 100644 index 00000000000..e8f3cc7da6a --- /dev/null +++ b/lisp/thread.el @@ -0,0 +1,200 @@ +;;; thread.el --- Thread support in Emacs Lisp -*- lexical-binding: t -*- + +;; Copyright (C) 2018-2019 Free Software Foundation, Inc. + +;; Author: Gemini Lasswell <gazally@runbox.com> +;; Maintainer: emacs-devel@gnu.org +;; Keywords: thread, 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 'backtrace) +(eval-when-compile (require 'pcase)) +(eval-when-compile (require 'subr-x)) + +;;;###autoload +(defun thread-handle-event (event) + "Handle thread events, propagated by `thread-signal'. +An EVENT has the format + (thread-event THREAD ERROR-SYMBOL DATA)" + (interactive "e") + (if (and (consp event) + (eq (car event) 'thread-event) + (= (length event) 4)) + (let ((thread (cadr event)) + (err (cddr event))) + (message "Error %s: %S" thread err)))) + +(make-obsolete 'thread-alive-p 'thread-live-p "27.1") + +;;; The thread list buffer and list-threads command + +(defcustom thread-list-refresh-seconds 0.5 + "Seconds between automatic refreshes of the *Threads* buffer." + :group 'thread-list + :type 'number + :version "27.1") + +(defvar thread-list-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map tabulated-list-mode-map) + (define-key map "b" #'thread-list-pop-to-backtrace) + (define-key map "s" nil) + (define-key map "sq" #'thread-list-send-quit-signal) + (define-key map "se" #'thread-list-send-error-signal) + (easy-menu-define nil map "" + '("Threads" + ["Show backtrace" thread-list-pop-to-backtrace t] + ["Send Quit Signal" thread-list-send-quit-signal t] + ["Send Error Signal" thread-list-send-error-signal t])) + map) + "Local keymap for `thread-list-mode' buffers.") + +(define-derived-mode thread-list-mode tabulated-list-mode "Thread-List" + "Major mode for monitoring Lisp threads." + (setq tabulated-list-format + [("Thread Name" 20 t) + ("Status" 10 t) + ("Blocked On" 30 t)]) + (setq tabulated-list-sort-key (cons (car (aref tabulated-list-format 0)) nil)) + (setq tabulated-list-entries #'thread-list--get-entries) + (tabulated-list-init-header)) + +;;;###autoload +(defun list-threads () + "Display a list of threads." + (interactive) + ;; Threads may not exist, if Emacs was configured --without-threads. + (unless (bound-and-true-p main-thread) + (error "Threads are not supported in this configuration")) + ;; Generate the Threads list buffer, and switch to it. + (let ((buf (get-buffer-create "*Threads*"))) + (with-current-buffer buf + (unless (derived-mode-p 'thread-list-mode) + (thread-list-mode) + (run-at-time thread-list-refresh-seconds nil + #'thread-list--timer-func buf)) + (revert-buffer)) + (switch-to-buffer buf))) +;; This command can be destructive if they don't know what they are +;; doing. Kids, don't try this at home! +;;;###autoload (put 'list-threads 'disabled "Beware: manually canceling threads can ruin your Emacs session.") + +(defun thread-list--timer-func (buffer) + "Revert BUFFER and set a timer to do it again." + (when (buffer-live-p buffer) + (with-current-buffer buffer + (revert-buffer)) + (run-at-time thread-list-refresh-seconds nil + #'thread-list--timer-func buffer))) + +(defun thread-list--get-entries () + "Return tabulated list entries for the currently live threads." + (let (entries) + (dolist (thread (all-threads)) + (pcase-let ((`(,status ,blocker) (thread-list--get-status thread))) + (push `(,thread [,(thread-list--name thread) + ,status ,blocker]) + entries))) + entries)) + +(defun thread-list--get-status (thread) + "Describe the status of THREAD. +Return a list of two strings, one describing THREAD's status, the +other describing THREAD's blocker, if any." + (cond + ((not (thread-live-p thread)) '("Finished" "")) + ((eq thread (current-thread)) '("Running" "")) + (t (if-let ((blocker (thread--blocker thread))) + `("Blocked" ,(prin1-to-string blocker)) + '("Yielded" ""))))) + +(defun thread-list-send-quit-signal () + "Send a quit signal to the thread at point." + (interactive) + (thread-list--send-signal 'quit)) + +(defun thread-list-send-error-signal () + "Send an error signal to the thread at point." + (interactive) + (thread-list--send-signal 'error)) + +(defun thread-list--send-signal (signal) + "Send the specified SIGNAL to the thread at point. +Ask for user confirmation before signaling the thread." + (let ((thread (tabulated-list-get-id))) + (if (thread-live-p thread) + (when (y-or-n-p (format "Send %s signal to %s? " signal thread)) + (if (thread-live-p thread) + (thread-signal thread signal nil) + (message "This thread is no longer alive"))) + (message "This thread is no longer alive")))) + +(defvar-local thread-list-backtrace--thread nil + "Thread whose backtrace is displayed in the current buffer.") + +(defun thread-list-pop-to-backtrace () + "Display the backtrace for the thread at point." + (interactive) + (let ((thread (tabulated-list-get-id))) + (if (thread-live-p thread) + (let ((buffer (get-buffer-create "*Thread Backtrace*"))) + (pop-to-buffer buffer) + (unless (derived-mode-p 'backtrace-mode) + (backtrace-mode) + (add-hook 'backtrace-revert-hook + #'thread-list-backtrace--revert-hook-function) + (setq backtrace-insert-header-function + #'thread-list-backtrace--insert-header)) + (setq thread-list-backtrace--thread thread) + (thread-list-backtrace--revert-hook-function) + (backtrace-print) + (goto-char (point-min))) + (message "This thread is no longer alive")))) + +(defun thread-list-backtrace--revert-hook-function () + (setq backtrace-frames + (when (thread-live-p thread-list-backtrace--thread) + (mapcar #'thread-list--make-backtrace-frame + (backtrace--frames-from-thread + thread-list-backtrace--thread))))) + +(cl-defun thread-list--make-backtrace-frame ((evald fun &rest args)) + (backtrace-make-frame :evald evald :fun fun :args args)) + +(defun thread-list-backtrace--insert-header () + (let ((name (thread-list--name thread-list-backtrace--thread))) + (if (thread-live-p thread-list-backtrace--thread) + (progn + (insert (substitute-command-keys "Backtrace for thread `")) + (insert name) + (insert (substitute-command-keys "':\n"))) + (insert (substitute-command-keys "Thread `")) + (insert name) + (insert (substitute-command-keys "' is no longer running\n"))))) + +(defun thread-list--name (thread) + (or (thread-name thread) + (and (eq thread main-thread) "Main") + (prin1-to-string thread))) + +(provide 'thread) +;;; thread.el ends here diff --git a/lisp/thumbs.el b/lisp/thumbs.el index 3309ed23317..6a17a756548 100644 --- a/lisp/thumbs.el +++ b/lisp/thumbs.el @@ -210,7 +210,9 @@ reached." (mapcar (lambda (f) (let ((fattribs-list (file-attributes f))) - `(,(nth 4 fattribs-list) ,(nth 7 fattribs-list) ,f))) + `(,(file-attribute-access-time fattribs-list) + ,(file-attribute-size fattribs-list) + ,f))) (directory-files (thumbs-thumbsdir) t (image-file-name-regexp))) (lambda (l1 l2) (time-less-p (car l1) (car l2))))) (dirsize (apply '+ (mapcar (lambda (x) (cadr x)) files-list)))) diff --git a/lisp/time-stamp.el b/lisp/time-stamp.el index 91e02bef513..ec6a45cd58b 100644 --- a/lisp/time-stamp.el +++ b/lisp/time-stamp.el @@ -5,7 +5,7 @@ ;; This file is part of GNU Emacs. -;; Maintainer: Stephen Gildea <gildea@stop.mail-abuse.org> +;; Maintainer: Stephen Gildea <stepheng+emacs@gildea.com> ;; Keywords: tools ;; GNU Emacs is free software: you can redistribute it and/or modify @@ -223,10 +223,17 @@ The fourth part is a regexp identifying the pattern following the time stamp. This part may be omitted to use the normal pattern. Examples: -\"-10/\" -\"-9/^Last modified: %%$\" -\"@set Time-stamp: %:b %:d, %:y$\" -\"newcommand{\\\\\\\\timestamp}{%%}\" + +\"-10/\" (sets only `time-stamp-line-limit') + +\"-9/^Last modified: %%$\" (sets `time-stamp-line-limit', +`time-stamp-start', `time-stamp-end' and `time-stamp-format') + +\"@set Time-stamp: %:b %:d, %:y$\" (sets `time-stamp-start', +`time-stamp-end' and `time-stamp-format') + +\"newcommand{\\\\\\\\timestamp}{%%}\" (sets `time-stamp-start', +`time-stamp-end' and `time-stamp-format') Do not change `time-stamp-pattern' `time-stamp-line-limit', `time-stamp-start', or `time-stamp-end' for yourself or you will be diff --git a/lisp/time.el b/lisp/time.el index 953e6084e29..35157c5e807 100644 --- a/lisp/time.el +++ b/lisp/time.el @@ -336,15 +336,10 @@ would give mode line times like `94/12/30 21:07:48 (UTC)'." (next-time (timer-relative-time (list (aref timer 1) (aref timer 2) (aref timer 3)) (* 5 (aref timer 4)) 0))) - ;; If the activation time is far in the past, + ;; If the activation time is not in the future, ;; skip executions until we reach a time in the future. ;; This avoids a long pause if Emacs has been suspended for hours. - (or (> (nth 0 next-time) (nth 0 current)) - (and (= (nth 0 next-time) (nth 0 current)) - (> (nth 1 next-time) (nth 1 current))) - (and (= (nth 0 next-time) (nth 0 current)) - (= (nth 1 next-time) (nth 1 current)) - (> (nth 2 next-time) (nth 2 current))) + (or (time-less-p current next-time) (progn (timer-set-time timer (timer-next-integral-multiple-of-time current display-time-interval) @@ -365,7 +360,8 @@ Switches from the 1 to 5 to 15 minute load average, and then back to 1." (while (and mail-files (= size 0)) ;; Count size of regular files only. (setq size (+ size (or (and (file-regular-p (car mail-files)) - (nth 7 (file-attributes (car mail-files)))) + (file-attribute-size + (file-attributes (car mail-files)))) 0))) (setq mail-files (cdr mail-files))) (if (> size 0) @@ -438,23 +434,17 @@ update which can wait for the next redisplay." ((and (stringp mail-spool-file) (or (null display-time-server-down-time) ;; If have been down for 20 min, try again. - (> (- (nth 1 now) display-time-server-down-time) - 1200) - (and (< (nth 1 now) display-time-server-down-time) - (> (- (nth 1 now) - display-time-server-down-time) - -64336)))) + (time-less-p 1200 (time-since + display-time-server-down-time)))) (let ((start-time (current-time))) (prog1 (display-time-file-nonempty-p mail-spool-file) - (if (> (- (nth 1 (current-time)) - (nth 1 start-time)) - 20) - ;; Record that mail file is not accessible. - (setq display-time-server-down-time - (nth 1 (current-time))) - ;; Record that mail file is accessible. - (setq display-time-server-down-time nil))))))) + ;; Record whether mail file is accessible. + (setq display-time-server-down-time + (let ((end-time (current-time))) + (and (time-less-p 20 (time-subtract + end-time start-time)) + (float-time end-time))))))))) (24-hours (substring time 11 13)) (hour (string-to-number 24-hours)) (12-hours (int-to-string (1+ (% (+ hour 11) 12)))) @@ -483,14 +473,12 @@ update which can wait for the next redisplay." (defun display-time-file-nonempty-p (file) (let ((remote-file-name-inhibit-cache (- display-time-interval 5))) (and (file-exists-p file) - (< 0 (nth 7 (file-attributes (file-chase-links file))))))) + (< 0 (file-attribute-size + (file-attributes (file-chase-links file))))))) ;;;###autoload (define-minor-mode display-time-mode "Toggle display of time, load level, and mail flag in mode lines. -With a prefix argument ARG, enable Display Time mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -it if ARG is omitted or nil. When Display Time mode is enabled, it updates every minute (you can control the number of seconds between updates by customizing @@ -584,8 +572,9 @@ For example, the Unix uptime command format is \"%D, %z%2h:%.2m\"." (interactive) (let ((str (format-seconds (or format "%Y, %D, %H, %M, %z%S") - (float-time - (time-subtract (current-time) before-init-time))))) + (encode-time + (time-since before-init-time) + 'integer)))) (if (called-interactively-p 'interactive) (message "%s" str) str))) @@ -595,7 +584,7 @@ For example, the Unix uptime command format is \"%D, %z%2h:%.2m\"." "Return a string giving the duration of the Emacs initialization." (interactive) (let ((str - (format "%.1f seconds" + (format "%s seconds" (float-time (time-subtract after-init-time before-init-time))))) (if (called-interactively-p 'interactive) diff --git a/lisp/timezone.el b/lisp/timezone.el index 621f02479f7..ff0b266245f 100644 --- a/lisp/timezone.el +++ b/lisp/timezone.el @@ -1,10 +1,9 @@ -;;; timezone.el --- time zone package for GNU Emacs +;;; timezone.el --- time zone package for GNU Emacs -- lexical-binding: t -*- ;; Copyright (C) 1990-1993, 1996, 1999, 2001-2019 Free Software ;; Foundation, Inc. -;; Author: Masanobu Umeda -;; Maintainer: umerin@mse.kyutech.ac.jp +;; Author: Masanobu Umeda <umerin@mse.kyutech.ac.jp> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -73,8 +72,7 @@ if nil, the local time zone is assumed." (timezone-make-arpa-date (aref new 0) (aref new 1) (aref new 2) (timezone-make-time-string (aref new 3) (aref new 4) (aref new 5)) - (aref new 6)) - )) + (aref new 6)))) (defun timezone-make-date-sortable (date &optional local timezone) "Convert DATE to a sortable date string. @@ -85,8 +83,7 @@ if nil, the local time zone is assumed." (let ((new (timezone-fix-time date local timezone))) (timezone-make-sortable-date (aref new 0) (aref new 1) (aref new 2) (timezone-make-time-string - (aref new 3) (aref new 4) (aref new 5))) - )) + (aref new 3) (aref new 4) (aref new 5))))) ;; diff --git a/lisp/tmm.el b/lisp/tmm.el index e8122339c8e..44f04eab87b 100644 --- a/lisp/tmm.el +++ b/lisp/tmm.el @@ -42,6 +42,23 @@ (defvar tmm-next-shortcut-digit) (defvar tmm-table-undef) +(defun tmm-menubar-keymap () + "Return the current menu-bar keymap. + +The ordering of the return value respects `menu-bar-final-items'." + (let ((menu-bar '()) + (menu-end '())) + (map-keymap + (lambda (key binding) + (push (cons key binding) + ;; If KEY is the name of an item that we want to put last, + ;; move it to the end. + (if (memq key menu-bar-final-items) + menu-end + menu-bar))) + (tmm-get-keybind [menu-bar])) + `(keymap ,@(nreverse menu-bar) ,@(nreverse menu-end)))) + ;;;###autoload (define-key global-map "\M-`" 'tmm-menubar) ;;;###autoload (define-key global-map [menu-bar mouse-1] 'tmm-menubar-mouse) @@ -58,19 +75,8 @@ to invoke `tmm-menubar' instead, customize the variable (interactive) (run-hooks 'menu-bar-update-hook) ;; Obey menu-bar-final-items; put those items last. - (let ((menu-bar '()) - (menu-end '()) + (let ((menu-bar (tmm-menubar-keymap)) menu-bar-item) - (map-keymap - (lambda (key binding) - (push (cons key binding) - ;; If KEY is the name of an item that we want to put last, - ;; move it to the end. - (if (memq key menu-bar-final-items) - menu-end - menu-bar))) - (tmm-get-keybind [menu-bar])) - (setq menu-bar `(keymap ,@(nreverse menu-bar) ,@(nreverse menu-end))) (if x-position (let ((column 0) prev-key) @@ -154,7 +160,7 @@ specify nil for this variable." (defvar tmm--history nil) ;;;###autoload -(defun tmm-prompt (menu &optional in-popup default-item) +(defun tmm-prompt (menu &optional in-popup default-item no-execute) "Text-mode emulation of calling the bindings in keymap. Creates a text-mode menu of possible choices. You can access the elements in the menu in two ways: @@ -165,7 +171,9 @@ The last alternative is currently a hack, you cannot use mouse reliably. MENU is like the MENU argument to `x-popup-menu': either a keymap or an alist of alists. DEFAULT-ITEM, if non-nil, specifies an initial default choice. -Its value should be an event that has a binding in MENU." +Its value should be an event that has a binding in MENU. +NO-EXECUTE, if non-nil, means to return the command the user selects +instead of executing it." ;; If the optional argument IN-POPUP is t, ;; then MENU is an alist of elements of the form (STRING . VALUE). ;; That is used for recursive calls only. @@ -268,7 +276,7 @@ Its value should be an event that has a binding in MENU." ;; We just did the inner level of a -popup menu. choice) ;; We just did the outer level. Do the inner level now. - (not-menu (tmm-prompt choice t)) + (not-menu (tmm-prompt choice t nil no-execute)) ;; We just handled a menu keymap and found another keymap. ((keymapp choice) (if (symbolp choice) @@ -276,11 +284,11 @@ Its value should be an event that has a binding in MENU." (condition-case nil (require 'mouse) (error nil)) - (tmm-prompt choice)) + (tmm-prompt choice nil nil no-execute)) ;; We just handled a menu keymap and found a command. (choice (if chosen-string - (progn + (if no-execute choice (setq last-command-event chosen-string) (call-interactively choice)) choice))))) diff --git a/lisp/tool-bar.el b/lisp/tool-bar.el index 06f5bff6c9a..4be16b21fb8 100644 --- a/lisp/tool-bar.el +++ b/lisp/tool-bar.el @@ -44,9 +44,6 @@ ;; when you are on a tty. I hope that won't cause too much trouble -- rms. (define-minor-mode tool-bar-mode "Toggle the tool bar in all graphical frames (Tool Bar mode). -With a prefix argument ARG, enable Tool Bar mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -Tool Bar mode if ARG is omitted or nil. See `tool-bar-add-item' and `tool-bar-add-item-from-menu' for conveniently adding tool bar items." diff --git a/lisp/tooltip.el b/lisp/tooltip.el index 8b029b5f07a..b1c69ae7368 100644 --- a/lisp/tooltip.el +++ b/lisp/tooltip.el @@ -42,9 +42,6 @@ (define-minor-mode tooltip-mode "Toggle Tooltip mode. -With a prefix argument ARG, enable Tooltip mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. When this global minor mode is enabled, Emacs displays help text (e.g. for buttons and menu items that you put the mouse on) @@ -155,6 +152,18 @@ This variable is obsolete; instead of setting it to t, disable (make-obsolete-variable 'tooltip-use-echo-area "disable Tooltip mode instead" "24.1" 'set) +(defcustom tooltip-resize-echo-area nil + "If non-nil, using the echo area for tooltips will resize the echo area. +By default, when the echo area is used for displaying tooltips, +the tooltip text is truncated if it exceeds a single screen line. +When this variable is non-nil, the text is not truncated; instead, +the echo area is resized as needed to accommodate the full text +of the tooltip. +This variable has effect only on GUI frames." + :type 'boolean + :group 'tooltip + :version "27.1") + ;;; Variables that are not customizable. @@ -192,7 +201,8 @@ This might return nil if the event did not occur over a buffer." (defun tooltip-delay () "Return the delay in seconds for the next tooltip." (if (and tooltip-hide-time - (< (- (float-time) tooltip-hide-time) tooltip-recent-seconds)) + (time-less-p (time-since tooltip-hide-time) + tooltip-recent-seconds)) tooltip-short-delay tooltip-delay)) @@ -347,7 +357,8 @@ It is also called if Tooltip mode is on, for text-only displays." (current-message)))) (setq tooltip-previous-message (current-message))) (setq tooltip-help-message help) - (let ((message-truncate-lines t) + (let ((message-truncate-lines + (or (not (display-graphic-p)) (not tooltip-resize-echo-area))) (message-log-max nil)) (message "%s" help))) ((stringp tooltip-previous-message) diff --git a/lisp/tree-widget.el b/lisp/tree-widget.el index 61bfacd56a1..b28448654c1 100644 --- a/lisp/tree-widget.el +++ b/lisp/tree-widget.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2004-2019 Free Software Foundation, Inc. ;; Author: David Ponce <david@dponce.com> -;; Maintainer: David Ponce <david@dponce.com> ;; Created: 16 Feb 2001 ;; Keywords: extensions @@ -124,11 +123,11 @@ :version "22.1" :group 'widgets) -(defcustom tree-widget-image-enable (if (fboundp 'display-images-p) - (display-images-p)) +(defcustom tree-widget-image-enable t "Non-nil means that tree-widget will try to use images." :type 'boolean - :group 'tree-widget) + :group 'tree-widget + :version "27.1") (defvar tree-widget-themes-load-path '(load-path diff --git a/lisp/tutorial.el b/lisp/tutorial.el index 3a64e290cd4..37ebb5cbe7c 100644 --- a/lisp/tutorial.el +++ b/lisp/tutorial.el @@ -476,8 +476,8 @@ where ((and cua-mode (or (and (eq def-fun 'ESC-prefix) (equal key-fun - `(keymap - (118 . cua-repeat-replace-region))) + '(keymap + (118 . cua-repeat-replace-region))) (setq def-fun-txt "\"ESC prefix\"")) (and (eq def-fun 'mode-specific-command-prefix) (equal key-fun diff --git a/lisp/type-break.el b/lisp/type-break.el index 60aec3cf1fa..52029604afc 100644 --- a/lisp/type-break.el +++ b/lisp/type-break.el @@ -3,8 +3,7 @@ ;; Copyright (C) 1994-1995, 1997, 2000-2019 Free Software Foundation, ;; Inc. -;; Author: Noah Friedman -;; Maintainer: Noah Friedman <friedman@splode.com> +;; Author: Noah Friedman <friedman@splode.com> ;; Keywords: extensions, timers ;; Created: 1994-07-13 @@ -287,9 +286,6 @@ again in a short period of time. The idea is to give the user enough time to find a good breaking point in his or her work, but be sufficiently annoying to discourage putting typing breaks off indefinitely. -A negative prefix argument disables this mode. -No argument or any non-negative argument enables it. - The user may enable or disable this mode by setting the variable of the same name, though setting it in that way doesn't reschedule a break or reset the keystroke counter. @@ -376,7 +372,7 @@ problems." (if (and type-break-time-last-break (< (setq diff (type-break-time-difference type-break-time-last-break - (current-time))) + nil)) type-break-interval)) ;; Use the file's value. (progn @@ -406,9 +402,6 @@ problems." (define-minor-mode type-break-mode-line-message-mode "Toggle warnings about typing breaks in the mode line. -With a prefix argument ARG, enable these warnings if ARG is -positive, and disable them otherwise. If called from Lisp, -enable them if ARG is omitted or nil. The user may also enable or disable this mode simply by setting the variable of the same name. @@ -423,9 +416,6 @@ Variables controlling the display of messages in the mode line include: (define-minor-mode type-break-query-mode "Toggle typing break queries. -With a prefix argument ARG, enable these queries if ARG is -positive, and disable them otherwise. If called from Lisp, -enable them if ARG is omitted or nil. The user may also enable or disable this mode simply by setting the variable of the same name." @@ -469,8 +459,7 @@ the variable of the same name." )))))) (defun timep (time) - "If TIME is in the format returned by `current-time' then -return TIME, else return nil." + "If TIME is a Lisp time value then return TIME, else return nil." (condition-case nil (and (float-time time) time) (error nil))) @@ -490,8 +479,7 @@ return TIME, else return nil." (defun type-break-get-previous-time () "Get previous break time from `type-break-file-name'. -Returns nil if the file is missing or if the time breaks with the -`current-time' format." +Return nil if the file is missing or if the time is not a Lisp time value." (let ((file (type-break-choose-file))) (if file (timep ;; returns expected format, else nil @@ -563,7 +551,7 @@ as per the function `type-break-schedule'." (cond (good-interval (let ((break-secs (type-break-time-difference - start-time (current-time)))) + start-time nil))) (cond ((>= break-secs good-interval) (setq continue nil)) @@ -624,7 +612,7 @@ INTERVAL is the full length of an interval (defaults to TIME)." type-break-time-warning-intervals)) (or time - (setq time (type-break-time-difference (current-time) + (setq time (type-break-time-difference nil type-break-time-next-break))) (while (and type-break-current-time-warning-interval @@ -685,7 +673,7 @@ keystroke threshold has been exceeded." (and type-break-good-rest-interval (progn (and (> (type-break-time-difference - type-break-time-last-command (current-time)) + type-break-time-last-command nil) type-break-good-rest-interval) (progn (type-break-keystroke-reset) @@ -817,7 +805,7 @@ this or ask the user to start one right now." ((and (car type-break-keystroke-threshold) (< type-break-keystroke-count (car type-break-keystroke-threshold)))) ((> type-break-time-warning-count 0) - (let ((timeleft (type-break-time-difference (current-time) + (let ((timeleft (type-break-time-difference nil type-break-time-next-break))) (setq type-break-warning-countdown-string (number-to-string timeleft)) (cond @@ -914,8 +902,8 @@ Current keystroke count : %s" (current-time-string type-break-time-next-break) (type-break-format-time (type-break-time-difference - (current-time) - type-break-time-next-break))) + nil + type-break-time-next-break))) "none scheduled") (or (car type-break-keystroke-threshold) "none") (or (cdr type-break-keystroke-threshold) "none") @@ -1099,7 +1087,7 @@ With optional non-nil ALL, force redisplay of all mode-lines." (erase-buffer) (setq elapsed (type-break-time-difference type-break-time-last-break - (current-time))) + nil)) (let ((good-interval (or type-break-good-rest-interval type-break-good-break-interval))) (cond diff --git a/lisp/uniquify.el b/lisp/uniquify.el index 3dd9e341351..7a86eef2e28 100644 --- a/lisp/uniquify.el +++ b/lisp/uniquify.el @@ -40,13 +40,10 @@ ;; For other options, see "User-visible variables", below. -;; A version of uniquify.el that works under Emacs 18, Emacs 19, XEmacs, -;; and InfoDock is available from the maintainer. - ;;; Change Log: ;; Originally by Dick King <king@reasoning.com> 15 May 86 -;; Converted for Emacs 18 by Stephen Gildea <gildea@stop.mail-abuse.org> +;; Converted for Emacs 18 by Stephen Gildea <stepheng+emacs@gildea.com> ;; Make uniquify-min-dir-content 0 truly non-invasive. gildea 23 May 89 ;; Some cleanup. uniquify-min-dir-content default 0. gildea 01 Jun 89 ;; Don't rename to "". Michael Ernst <mernst@theory.lcs.mit.edu> 15 Jun 94 diff --git a/lisp/url/url-auth.el b/lisp/url/url-auth.el index c3714f26562..b78544e3f37 100644 --- a/lisp/url/url-auth.el +++ b/lisp/url/url-auth.el @@ -82,11 +82,11 @@ instead of the filename inheritance method." (cond ((and user pass) ;; Explicit http://user:pass@foo/ URL. Just return the credentials. - (setq retval (base64-encode-string (format "%s:%s" user pass)))) + (setq retval (base64-encode-string (format "%s:%s" user pass) t))) ((and prompt (not byserv)) (setq user (or (url-do-auth-source-search server type :user) - (read-string (url-auth-user-prompt url realm) + (read-string (url-auth-user-prompt href realm) (or user (user-real-login-name)))) pass (or (url-do-auth-source-search server type :secret) @@ -97,7 +97,8 @@ instead of the filename inheritance method." (setq retval (base64-encode-string (format "%s:%s" user - (encode-coding-string pass 'utf-8)))))) + (encode-coding-string pass 'utf-8)) + t)))) (symbol-value url-basic-auth-storage)))) (byserv (setq retval (cdr-safe (assoc file byserv))) @@ -115,12 +116,12 @@ instead of the filename inheritance method." (progn (setq user (or (url-do-auth-source-search server type :user) - (read-string (url-auth-user-prompt url realm) + (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: ")) - retval (base64-encode-string (format "%s:%s" user pass)) + retval (base64-encode-string (format "%s:%s" user pass) t) byserv (assoc server (symbol-value url-basic-auth-storage))) (setcdr byserv (cons (cons file retval) (cdr byserv)))))) @@ -192,9 +193,10 @@ key cache `url-digest-auth-storage'." (defun url-digest-auth-make-cnonce () "Compute a new unique client nonce value." (base64-encode-string - (apply 'format "%016x%04x%04x%05x%05x" (random) (current-time)) t)) + (format "%016x%016x" (random) (car (encode-time nil t))) + t)) -(defun url-digest-auth-nonce-count (nonce) +(defun url-digest-auth-nonce-count (_nonce) "The number requests sent to server with the given NONCE. This count includes the request we're preparing here. @@ -477,6 +479,8 @@ PROMPT is boolean - specifies whether to ask the user for a username/password if one cannot be found in the cache" (if (not realm) (setq realm (cdr-safe (assoc "realm" args)))) + (if (equal realm "") + (setq realm nil)) (if (stringp url) (setq url (url-generic-parse-url url))) (if (or (null type) (eq type 'any)) diff --git a/lisp/url/url-cache.el b/lisp/url/url-cache.el index 01e57799cc6..b306082c3ba 100644 --- a/lisp/url/url-cache.el +++ b/lisp/url/url-cache.el @@ -86,10 +86,10 @@ FILE can be created or overwritten." The actual return value is the last modification time of the cache file." (let* ((fname (url-cache-create-filename url)) (attribs (file-attributes fname))) - (and fname ; got a filename - (file-exists-p fname) ; file exists - (not (eq (nth 0 attribs) t)) ; Its not a directory - (nth 5 attribs)))) ; Can get last mod-time + (and fname + (file-exists-p fname) + (not (eq (file-attribute-type attribs) t)) + (file-attribute-modification-time attribs)))) (defun url-cache-create-filename-human-readable (url) "Return a filename in the local cache for URL." @@ -205,8 +205,8 @@ If `url-standalone-mode' is non-nil, cached items never expire." (time-less-p (time-add cache-time - (seconds-to-time (or expire-time url-cache-expire-time))) - (current-time)))))) + (or expire-time url-cache-expire-time)) + nil))))) (defun url-cache-prune-cache (&optional directory) "Remove all expired files from the cache. @@ -226,8 +226,8 @@ considered \"expired\"." (setq deleted-files (1+ deleted-files)))) ((time-less-p (time-add - (nth 5 (file-attributes file)) - (seconds-to-time url-cache-expire-time)) + (file-attribute-modification-time (file-attributes file)) + url-cache-expire-time) now) (delete-file file) (setq deleted-files (1+ deleted-files)))))) diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el index 61fd85bbf1e..31fc3e72664 100644 --- a/lisp/url/url-cookie.el +++ b/lisp/url/url-cookie.el @@ -74,6 +74,54 @@ telling Microsoft that." ;; It's completely normal for the cookies file not to exist yet. (load (or fname url-cookie-file) t t)) +(defun url-cookie-parse-file-netscape (filename &optional long-session) + "Load cookies from FILENAME in Netscape/Mozilla format. +When LONG-SESSION is non-nil, session cookies (expiring at t=0 +i.e. 1970-1-1) are loaded as expiring one year from now instead." + (interactive "fLoad Netscape/Mozilla cookie file: ") + (let ((n 0)) + (with-temp-buffer + (insert-file-contents-literally filename) + (goto-char (point-min)) + (when (not (looking-at-p "# Netscape HTTP Cookie File\n")) + (error (format "File %s doesn't look like a netscape cookie file" filename))) + (while (not (eobp)) + (when (not (looking-at-p (rx bol (* space) "#"))) + (let* ((line (buffer-substring (point) (save-excursion (end-of-line) (point)))) + (fields (split-string line "\t"))) + (cond + ;;((>= 1 (length line) 0) + ;; (message "skipping empty line")) + ((= (length fields) 7) + (let ((dom (nth 0 fields)) + ;; (match (nth 1 fields)) + (path (nth 2 fields)) + (secure (string= (nth 3 fields) "TRUE")) + ;; session cookies (expire time = 0) are supposed + ;; to be removed when the browser is closed, but + ;; the main point of loading external cookie is to + ;; reuse a browser session, so to prevent the + ;; cookie from being detected as expired straight + ;; away, make it expire a year from now + (expires (format-time-string + "%d %b %Y %T [GMT]" + (let ((s (string-to-number (nth 4 fields)))) + (if (and (zerop s) long-session) + (time-add nil (* 365 24 60 60)) + s)))) + (key (nth 5 fields)) + (val (nth 6 fields))) + (cl-incf n) + ;;(message "adding <%s>=<%s> exp=<%s> dom=<%s> path=<%s> sec=%S" key val expires dom path secure) + (url-cookie-store key val expires dom path secure) + )) + (t + (message "ignoring malformed cookie line <%s>" line))))) + (forward-line)) + (when (< 0 n) + (setq url-cookies-changed-since-last-save t)) + (message "added %d cookies from file %s" n filename)))) + (defun url-cookie-clean-up (&optional secure) (let ((var (if secure 'url-cookie-secure-storage 'url-cookie-storage)) new new-cookies) @@ -90,7 +138,8 @@ telling Microsoft that." (set var new))) (defun url-cookie-write-file (&optional fname) - (when url-cookies-changed-since-last-save + (when (and url-cookies-changed-since-last-save + url-cookie-file) (or fname (setq fname (expand-file-name url-cookie-file))) (if (condition-case nil (progn @@ -345,6 +394,8 @@ instead delete all cookies that do not match REGEXP." ;;; Mode for listing and editing cookies. +(defvar url-cookie--deleted-cookies nil) + (defun url-cookie-list () "Display a buffer listing the current URL cookies, if there are any. Use \\<url-cookie-mode-map>\\[url-cookie-delete] to remove cookies." @@ -354,6 +405,11 @@ Use \\<url-cookie-mode-map>\\[url-cookie-delete] to remove cookies." (error "No cookies are defined")) (pop-to-buffer "*url cookies*") + (url-cookie-mode) + (url-cookie--generate-buffer) + (goto-char (point-min))) + +(defun url-cookie--generate-buffer () (let ((inhibit-read-only t) (domains (sort (copy-sequence @@ -364,7 +420,6 @@ Use \\<url-cookie-mode-map>\\[url-cookie-delete] to remove cookies." (domain-length 0) start name format domain) (erase-buffer) - (url-cookie-mode) (dolist (elem domains) (setq domain-length (max domain-length (length (car elem))))) (setq format (format "%%-%ds %%-20s %%s" domain-length) @@ -376,16 +431,15 @@ Use \\<url-cookie-mode-map>\\[url-cookie-delete] to remove cookies." (lambda (c1 c2) (string< (url-cookie-name c1) (url-cookie-name c2))))) - (setq start (point) + (setq start (point) name (url-cookie-name cookie)) - (when (> (length name) 20) + (when (> (length name) 20) (setq name (substring name 0 20))) - (insert (format format domain name - (url-cookie-value cookie)) - "\n") - (setq domain "") - (put-text-property start (1+ start) 'url-cookie cookie))) - (goto-char (point-min)))) + (insert (format format domain name + (url-cookie-value cookie)) + "\n") + (setq domain "") + (put-text-property start (1+ start) 'url-cookie cookie))))) (defun url-cookie-delete () "Delete the cookie on the current line." @@ -409,12 +463,41 @@ Use \\<url-cookie-mode-map>\\[url-cookie-delete] to remove cookies." (delete-region (line-beginning-position) (progn (forward-line 1) - (point))))) + (point))) + (let ((point (point))) + (erase-buffer) + (url-cookie--generate-buffer) + (goto-char point)) + (push cookie url-cookie--deleted-cookies))) + +(defun url-cookie-undo () + "Undo deletion of a cookie." + (interactive) + (unless url-cookie--deleted-cookies + (error "No cookie deletions to undo")) + (let* ((cookie (pop url-cookie--deleted-cookies)) + (variable (if (url-cookie-secure cookie) + 'url-cookie-secure-storage + 'url-cookie-storage)) + (list (symbol-value variable)) + (elem (assoc (url-cookie-domain cookie) list))) + (if elem + (nconc elem (list cookie)) + (setq elem (list (url-cookie-domain cookie) cookie)) + (set variable (cons elem list))) + (setq url-cookies-changed-since-last-save t) + (url-cookie-write-file) + (let ((point (point)) + (inhibit-read-only t)) + (erase-buffer) + (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)) (define-derived-mode url-cookie-mode special-mode "URL Cookie" diff --git a/lisp/url/url-dav.el b/lisp/url/url-dav.el index f2182e39e65..a4cf0f0ec01 100644 --- a/lisp/url/url-dav.el +++ b/lisp/url/url-dav.el @@ -146,7 +146,7 @@ Returns nil if WebDAV is not supported." (setq time (parse-time-string date-string))) (if time - (setq time (apply 'encode-time time)) + (setq time (encode-time time)) (url-debug 'dav "Unable to decode date (%S) (%s)" (xml-node-name node) date-string)) time)) @@ -204,22 +204,22 @@ Returns nil if WebDAV is not supported." value nil) (pcase node-type - ((or `dateTime.iso8601tz - `dateTime.iso8601 - `dateTime.tz - `dateTime.rfc1123 - `dateTime - `date) ; date is our 'special' one... + ((or 'dateTime.iso8601tz + 'dateTime.iso8601 + 'dateTime.tz + 'dateTime.rfc1123 + 'dateTime + 'date) ; date is our 'special' one... ;; Some type of date/time string. (setq value (url-dav-process-date-property node))) - (`int + ('int ;; Integer type... (setq value (url-dav-process-integer-property node))) - ((or `number `float) + ((or 'number 'float) (setq value (url-dav-process-number-property node))) - (`boolean + ('boolean (setq value (url-dav-process-boolean-property node))) - (`uri + ('uri (setq value (url-dav-process-uri-property node))) (_ (if (not (eq node-type 'unknown)) @@ -611,11 +611,11 @@ Returns t if the lock was successfully released." (setq lock (car supported-locks) supported-locks (cdr supported-locks)) (pcase (car lock) - (`DAV:write + ('DAV:write (pcase (cdr lock) - (`DAV:shared ; group permissions (possibly world) + ('DAV:shared ; group permissions (possibly world) (aset modes 5 ?w)) - (`DAV:exclusive + ('DAV:exclusive (aset modes 2 ?w)) ; owner permissions? (_ (url-debug 'dav "Unrecognized DAV:lockscope (%S)" (cdr lock))))) diff --git a/lisp/url/url-dired.el b/lisp/url/url-dired.el index 0d7f22b61c5..a665db86fef 100644 --- a/lisp/url/url-dired.el +++ b/lisp/url/url-dired.el @@ -43,10 +43,7 @@ (url-dired-find-file)) (define-minor-mode url-dired-minor-mode - "Minor mode for directory browsing. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "Minor mode for directory browsing." :lighter " URL" :keymap url-dired-minor-mode-map) (defun url-find-file-dired (dir) diff --git a/lisp/url/url-file.el b/lisp/url/url-file.el index 23fc97828ff..b953ce76940 100644 --- a/lisp/url/url-file.el +++ b/lisp/url/url-file.el @@ -1,4 +1,4 @@ -;;; url-file.el --- File retrieval code +;;; url-file.el --- File retrieval code -*- lexical-binding:t -*- ;; Copyright (C) 1996-1999, 2004-2019 Free Software Foundation, Inc. @@ -33,7 +33,7 @@ (defconst url-file-asynchronous-p t "FTP transfers are asynchronous.") (defalias 'url-file-expand-file-name 'url-default-expander) -(defun url-file-find-possibly-compressed-file (fname &rest args) +(defun url-file-find-possibly-compressed-file (fname &rest _) "Find the exact file referenced by `fname'. This tries the common compression extensions, because things like ange-ftp and efs are not quite smart enough to realize when a server @@ -63,14 +63,14 @@ to them." (match-beginning 0)) (system-name))))))) -(defun url-file-asynch-callback (x y name buff func args &optional efs) +(defun url-file-asynch-callback (_x _y name buff func args &optional efs) (if (not (featurep 'ange-ftp)) ;; EFS passes us an extra argument (setq name buff buff func func args args efs)) - (let ((size (nth 7 (file-attributes name)))) + (let ((size (file-attribute-size (file-attributes name)))) (with-current-buffer buff (goto-char (point-max)) (if (/= -1 size) @@ -114,8 +114,7 @@ to them." ((string-match "\\`/[^/]+:/" file) (concat "/:" file)) (t - file))) - pos-index) + file)))) (and user pass (cond @@ -142,17 +141,6 @@ to them." (not (string-match "/\\'" filename))) (setf (url-filename url) (format "%s/" filename))) - - ;; If it is a directory, look for an index file first. - (if (and (file-directory-p filename) - url-directory-index-file - (setq pos-index (expand-file-name url-directory-index-file filename)) - (file-exists-p pos-index) - (file-readable-p pos-index)) - (setq filename pos-index)) - - ;; Find the (possibly compressed) file - (setq filename (url-file-find-possibly-compressed-file filename)) filename)) ;;;###autoload @@ -211,7 +199,7 @@ to them." (if (featurep 'ange-ftp) (ange-ftp-copy-file-internal filename (expand-file-name new) t nil t - (list 'url-file-asynch-callback + (list #'url-file-asynch-callback new (current-buffer) callback cbargs) t) @@ -220,7 +208,7 @@ to them." (efs-copy-file-internal filename (efs-ftp-path filename) new (efs-ftp-path new) t nil 0 - (list 'url-file-asynch-callback + (list #'url-file-asynch-callback new (current-buffer) callback cbargs) 0 nil))))))) diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el index c62e813b663..54360840784 100644 --- a/lisp/url/url-gw.el +++ b/lisp/url/url-gw.el @@ -239,7 +239,7 @@ overriding the value of `url-gateway-method'." (let ((coding-system-for-read 'binary) (coding-system-for-write 'binary)) (setq conn (pcase gw-method - ((or `tls `ssl `native) + ((or 'tls 'ssl 'native) (if (eq gw-method 'native) (setq gw-method 'plain)) (open-network-stream @@ -249,11 +249,11 @@ overriding the value of `url-gateway-method'." :nowait (and (featurep 'make-network-process) (url-asynchronous url-current-object) '(:nowait t)))) - (`socks + ('socks (socks-open-network-stream name buffer host service)) - (`telnet + ('telnet (url-open-telnet name buffer host service)) - (`rlogin + ('rlogin (url-open-rlogin name buffer host service)) (_ (error "Bad setting of url-gateway-method: %s" diff --git a/lisp/url/url-handlers.el b/lisp/url/url-handlers.el index 91f9b7f5208..9d7837d8a7e 100644 --- a/lisp/url/url-handlers.el +++ b/lisp/url/url-handlers.el @@ -23,16 +23,17 @@ ;;; Code: -;; (require 'url) (require 'url-parse) -;; (require 'url-util) (eval-when-compile (require 'mm-decode)) -;; (require 'mailcap) +(eval-when-compile (require 'subr-x)) ;; The following are autoloaded instead of `require'd to avoid eagerly ;; loading all of URL when turning on url-handler-mode in the .emacs. -(autoload 'url-expand-file-name "url-expand" "Convert url to a fully specified url, and canonicalize it.") -(autoload 'mm-dissect-buffer "mm-decode" "Dissect the current buffer and return a list of MIME handles.") -(autoload 'url-scheme-get-property "url-methods" "Get property of a URL SCHEME.") +(autoload 'url-expand-file-name "url-expand" + "Convert URL to a fully specified URL, and canonicalize it.") +(autoload 'mm-dissect-buffer "mm-decode" + "Dissect the current buffer and return a list of MIME handles.") +(autoload 'url-scheme-get-property "url-methods" + "Get PROPERTY of a URL SCHEME.") ;; Always used after mm-dissect-buffer and defined in the same file. (declare-function mm-save-part-to-file "mm-decode" (handle file)) @@ -41,7 +42,7 @@ (declare-function mm-decode-string "mm-bodies" (string charset)) ;; mm-decode loads mail-parse. (declare-function mail-content-type-get "mail-parse" (ct attribute)) -;; mm-bodies loads mm-util. +;; mm-decode loads mm-bodies, which loads mm-util. (declare-function mm-charset-to-coding-system "mm-util" (charset &optional lbt allow-override silent)) @@ -101,10 +102,7 @@ ;;;###autoload (define-minor-mode url-handler-mode - "Toggle using `url' library for URL filenames (URL Handler mode). -With a prefix argument ARG, enable URL Handler mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil." + "Toggle using `url' library for URL filenames (URL Handler mode)." :global t :group 'url ;; Remove old entry, if any. (setq file-name-handler-alist @@ -114,15 +112,16 @@ the mode if ARG is omitted or nil." (push (cons url-handler-regexp 'url-file-handler) file-name-handler-alist))) -(defcustom url-handler-regexp "\\`\\(https?\\|ftp\\|file\\|nfs\\|ssh\\|scp\\|rsync\\|telnet\\)://" +(defcustom url-handler-regexp + "\\`\\(?:https?\\|ftp\\|file\\|nfs\\|ssh\\|scp\\|rsync\\|telnet\\)://" "Regular expression for URLs handled by `url-handler-mode'. When URL Handler mode is enabled, this regular expression is added to `file-name-handler-alist'. Some valid URL protocols just do not make sense to visit -interactively \(about, data, info, irc, mailto, etc.). This +interactively (about, data, info, irc, mailto, etc.). This regular expression avoids conflicts with local files that look -like URLs \(Gnus is particularly bad at this)." +like URLs (Gnus is particularly bad at this)." :group 'url :type 'regexp :version "25.1" @@ -146,8 +145,8 @@ like URLs \(Gnus is particularly bad at this)." ;;;###autoload (defun url-file-handler (operation &rest args) "Function called from the `file-name-handler-alist' routines. -OPERATION is what needs to be done (`file-exists-p', etc). ARGS are -the arguments that would have been passed to OPERATION." +OPERATION is what needs to be done (`file-exists-p', etc.). +ARGS are the arguments that would have been passed to OPERATION." ;; Avoid recursive load. (if (and load-in-progress url-file-handler-load-in-progress) (url-run-real-handler operation args) @@ -155,47 +154,46 @@ the arguments that would have been passed to OPERATION." ;; Check, whether there are arguments we want pass to Tramp. (if (catch :do (dolist (url (cons default-directory args)) - (and (member - (url-type (url-generic-parse-url (and (stringp url) url))) - url-tramp-protocols) + (and (stringp url) + (member (url-type (url-generic-parse-url url)) + url-tramp-protocols) (throw :do t)))) - (apply 'url-tramp-file-handler operation args) + (apply #'url-tramp-file-handler operation args) ;; Otherwise, let's do the job. (let ((fn (get operation 'url-file-handlers)) - (val nil) - (hooked nil)) - (if (and (not fn) (intern-soft (format "url-%s" operation)) + val) + (if (and (not fn) (fboundp (intern-soft (format "url-%s" operation)))) (error "Missing URL handler mapping for %s" operation)) - (if fn - (setq hooked t - val (save-match-data (apply fn args))) - (setq hooked nil - val (url-run-real-handler operation args))) - (url-debug 'handlers "%s %S%S => %S" (if hooked "Hooked" "Real") + (setq val (if fn (save-match-data (apply fn args)) + (url-run-real-handler operation args))) + (url-debug 'handlers "%s %S%S => %S" (if fn "Hooked" "Real") operation args val) val))))) -(defun url-file-handler-identity (&rest args) - ;; Identity function - (car args)) - -;; These are operations that we can fully support -(put 'file-readable-p 'url-file-handlers 'url-file-exists-p) -(put 'substitute-in-file-name 'url-file-handlers 'url-file-handler-identity) -(put 'file-name-absolute-p 'url-file-handlers (lambda (&rest ignored) t)) -(put 'expand-file-name 'url-file-handlers 'url-handler-expand-file-name) -(put 'directory-file-name 'url-file-handlers 'url-handler-directory-file-name) -(put 'unhandled-file-name-directory 'url-file-handlers 'url-handler-unhandled-file-name-directory) -(put 'file-remote-p 'url-file-handlers 'url-handler-file-remote-p) -;; (put 'file-name-as-directory 'url-file-handlers 'url-handler-file-name-as-directory) +(defun url-file-handler-identity (arg &rest _ignored) + ;; Identity function. + arg) + +;; These are operations that we can fully support. +(put 'file-readable-p 'url-file-handlers #'url-file-exists-p) +(put 'substitute-in-file-name 'url-file-handlers #'url-file-handler-identity) +(put 'file-name-absolute-p 'url-file-handlers (lambda (&rest _ignored) t)) +(put 'expand-file-name 'url-file-handlers #'url-handler-expand-file-name) +(put 'directory-file-name 'url-file-handlers #'url-handler-directory-file-name) +(put 'file-name-directory 'url-file-handlers #'url-handler-file-name-directory) +(put 'unhandled-file-name-directory 'url-file-handlers + #'url-handler-unhandled-file-name-directory) +(put 'file-remote-p 'url-file-handlers #'url-handler-file-remote-p) +;; (put 'file-name-as-directory 'url-file-handlers +;; #'url-handler-file-name-as-directory) ;; These are operations that we do not support yet (DAV!!!) -(put 'file-writable-p 'url-file-handlers 'ignore) -(put 'file-symlink-p 'url-file-handlers 'ignore) +(put 'file-writable-p 'url-file-handlers #'ignore) +(put 'file-symlink-p 'url-file-handlers #'ignore) ;; Just like for ange-ftp: let's not waste time trying to look for RCS/foo,v ;; files and such since we can't do anything clever with them anyway. -(put 'vc-registered 'url-file-handlers 'ignore) +(put 'vc-registered 'url-file-handlers #'ignore) (defun url-handler-expand-file-name (file &optional base) ;; When we see "/foo/bar" in a file whose working dir is "http://bla/bla", @@ -216,7 +214,7 @@ the arguments that would have been passed to OPERATION." ;; reversible: (f-n-a-d (d-f-n (f-n-a-d X))) == (f-n-a-d X) (defun url-handler-directory-file-name (dir) ;; When there's more than a single /, just don't touch the slashes at all. - (if (string-match "//\\'" dir) dir + (if (string-suffix-p "//" dir) dir (url-run-real-handler 'directory-file-name (list dir)))) (defun url-handler-unhandled-file-name-directory (filename) @@ -231,6 +229,14 @@ the arguments that would have been passed to OPERATION." ;; a local process. nil))) +(defun url-handler-file-name-directory (dir) + (let ((url (url-generic-parse-url dir))) + ;; Do not attempt to handle `file' URLs which are local. + (if (and (not (equal (url-type url) "file")) + (string-empty-p (url-filename url))) + (url-handler-file-name-directory (concat dir "/")) + (url-run-real-handler 'file-name-directory (list dir))))) + (defun url-handler-file-remote-p (filename &optional identification _connected) (let ((url (url-generic-parse-url filename))) (if (and (url-type url) (not (equal (url-type url) "file"))) @@ -250,49 +256,48 @@ the arguments that would have been passed to OPERATION." ;; `url-handler-unhandled-file-name-directory'. nil))) -;; The actual implementation +;; The actual implementation. ;;;###autoload -(defun url-copy-file (url newname &optional ok-if-already-exists - _keep-time _preserve-uid-gid _preserve-permissions) - "Copy URL to NEWNAME. Both args must be strings. -Signal a `file-already-exists' error if file NEWNAME already exists, -unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil. -A number as third arg means request confirmation if NEWNAME already exists. -This is what happens in interactive use with M-x. -Fourth arg KEEP-TIME non-nil means give the new file the same -last-modified time as the old one. (This works on only some systems.) -Args PRESERVE-UID-GID and PRESERVE-PERMISSIONS are ignored. -A prefix arg makes KEEP-TIME non-nil." - (if (and (file-exists-p newname) - (not ok-if-already-exists)) - (signal 'file-already-exists (list "File exists" newname))) - (let ((buffer (url-retrieve-synchronously url)) - (handle nil)) - (if (not buffer) - (signal 'file-missing (list "Opening URL" "No such file or directory" - url))) - (with-current-buffer buffer - (setq handle (mm-dissect-buffer t))) +(defun url-copy-file (url newname &optional ok-if-already-exists &rest _ignored) + "Copy URL to NEWNAME. Both arguments must be strings. +Signal a `file-already-exists' error if file NEWNAME already +exists, unless a third argument OK-IF-ALREADY-EXISTS is supplied +and non-nil. An integer as third argument means request +confirmation if NEWNAME already exists." + (and (file-exists-p newname) + (or (not ok-if-already-exists) + (and (integerp ok-if-already-exists) + (not (yes-or-no-p + (format "File %s already exists; copy to it anyway? " + newname))))) + (signal 'file-already-exists (list "File already exists" newname))) + (let* ((buffer (or (url-retrieve-synchronously url) + (signal 'file-missing + (list "Opening URL" + "No such file or directory" url)))) + (handle (with-current-buffer buffer + (mm-dissect-buffer t)))) (let ((mm-attachment-file-modes (default-file-modes))) (mm-save-part-to-file handle newname)) (kill-buffer buffer) (mm-destroy-parts handle))) -(put 'copy-file 'url-file-handlers 'url-copy-file) +(put 'copy-file 'url-file-handlers #'url-copy-file) ;;;###autoload -(defun url-file-local-copy (url &rest ignored) +(defun url-file-local-copy (url &rest _ignored) "Copy URL into a temporary file on this machine. Returns the name of the local copy, or nil, if FILE is directly accessible." (let ((filename (make-temp-file "url"))) (url-copy-file url filename 'ok-if-already-exists) filename)) -(put 'file-local-copy 'url-file-handlers 'url-file-local-copy) +(put 'file-local-copy 'url-file-handlers #'url-file-local-copy) (defun url-insert (buffer &optional beg end) "Insert the body of a URL object. BUFFER should be a complete URL buffer as returned by `url-retrieve'. -If the headers specify a coding-system, it is applied to the body before it is inserted. +If the headers specify a coding-system (and current buffer is multibyte), +it is applied to the body before it is inserted. Returns a list of the form (SIZE CHARSET), where SIZE is the size in bytes of the inserted text and CHARSET is the charset that was specified in the header, or nil if none was found. @@ -304,12 +309,13 @@ They count bytes from the beginning of the body." (buffer-substring (+ (point-min) beg) (if end (+ (point-min) end) (point-max))) (buffer-string)))) - (charset (mail-content-type-get (mm-handle-type handle) - 'charset))) + (charset (if enable-multibyte-characters + (mail-content-type-get (mm-handle-type handle) + 'charset)))) (mm-destroy-parts handle) - (if charset - (insert (mm-decode-string data (mm-charset-to-coding-system charset))) - (insert data)) + (insert (if charset + (mm-decode-string data (mm-charset-to-coding-system charset)) + data)) (list (length data) charset))) (defvar url-http-codes) @@ -321,8 +327,8 @@ This is like `url-insert', but also decodes the current buffer as if it had been inserted from a file named URL." (if visit (setq buffer-file-name url)) (save-excursion - (let* ((start (point)) - (size-and-charset (url-insert buffer beg end))) + (let ((start (point)) + (size-and-charset (url-insert buffer beg end))) (kill-buffer buffer) (when replace (delete-region (point-min) start) @@ -333,42 +339,27 @@ if it had been inserted from a file named URL." (decode-coding-inserted-region (point-min) (point) url visit beg end replace)) (let ((inserted (car size-and-charset))) - (when (fboundp 'after-insert-file-set-coding) - (let ((insval (after-insert-file-set-coding inserted visit))) - (if insval (setq inserted insval)))) - (list url inserted))))) + (list url (or (and (fboundp 'after-insert-file-set-coding) + (after-insert-file-set-coding inserted visit)) + inserted)))))) ;;;###autoload (defun url-insert-file-contents (url &optional visit beg end replace) (let ((buffer (url-retrieve-synchronously url))) (unless buffer (signal 'file-error (list url "No Data"))) - (with-current-buffer buffer + (when (fboundp 'url-http--insert-file-helper) ;; XXX: This is HTTP/S specific and should be moved to url-http ;; instead. See bug#17549. - (when (bound-and-true-p url-http-response-status) - ;; Don't signal an error if VISIT is non-nil, because - ;; 'insert-file-contents' doesn't. This is required to - ;; support, e.g., 'browse-url-emacs', which is a fancy way of - ;; visiting the HTML source of a URL: in that case, we want to - ;; display a file buffer even if the URL does not exist and - ;; 'url-retrieve-synchronously' returns 404 or whatever. - (unless (or visit - (and (>= url-http-response-status 200) - (< url-http-response-status 300))) - (let ((desc (nth 2 (assq url-http-response-status url-http-codes)))) - (kill-buffer buffer) - ;; Signal file-error per bug#16733. - (signal 'file-error (list url desc)))))) + (url-http--insert-file-helper buffer url visit)) (url-insert-buffer-contents buffer url visit beg end replace))) - -(put 'insert-file-contents 'url-file-handlers 'url-insert-file-contents) +(put 'insert-file-contents 'url-file-handlers #'url-insert-file-contents) (defun url-file-name-completion (url _directory &optional _predicate) ;; Even if it's not implemented, it's not an error to ask for completion, ;; in case it's available (bug#14806). ;; (error "Unimplemented") url) -(put 'file-name-completion 'url-file-handlers 'url-file-name-completion) +(put 'file-name-completion 'url-file-handlers #'url-file-name-completion) (defun url-file-name-all-completions (_file _directory) ;; Even if it's not implemented, it's not an error to ask for completion, @@ -376,7 +367,7 @@ if it had been inserted from a file named URL." ;; (error "Unimplemented") nil) (put 'file-name-all-completions - 'url-file-handlers 'url-file-name-all-completions) + 'url-file-handlers #'url-file-name-all-completions) ;; All other handlers map onto their respective backends. (defmacro url-handlers-create-wrapper (method args) @@ -386,10 +377,10 @@ if it had been inserted from a file named URL." (or (documentation method t) "No original documentation.")) (setq url (url-generic-parse-url url)) (when (url-type url) - (funcall (url-scheme-get-property (url-type url) (quote ,method)) - ,@(remove '&rest (remove '&optional args))))) + (funcall (url-scheme-get-property (url-type url) ',method) + ,@(remq '&rest (remq '&optional args))))) (unless (get ',method 'url-file-handlers) - (put ',method 'url-file-handlers ',(intern (format "url-%s" method)))))) + (put ',method 'url-file-handlers #',(intern (format "url-%s" method)))))) (url-handlers-create-wrapper file-exists-p (url)) (url-handlers-create-wrapper file-attributes (url &optional id-format)) @@ -400,12 +391,12 @@ if it had been inserted from a file named URL." (url-handlers-create-wrapper directory-files (url &optional full match nosort)) (url-handlers-create-wrapper file-truename (url &optional counter prev-dirs)) -(add-hook 'find-file-hook 'url-handlers-set-buffer-mode) +(add-hook 'find-file-hook #'url-handlers-set-buffer-mode) (defun url-handlers-set-buffer-mode () "Set correct modes for the current buffer if visiting a remote file." - (and (stringp buffer-file-name) - (string-match url-handler-regexp buffer-file-name) + (and buffer-file-name + (string-match-p url-handler-regexp buffer-file-name) (auto-save-mode 0))) (provide 'url-handlers) diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 1bcfc10645d..838f0a30c1f 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -54,6 +54,7 @@ (defvar url-http-target-url) (defvar url-http-transfer-encoding) (defvar url-show-status) +(defvar url-http-referer) (require 'url-gw) (require 'url-parse) @@ -149,15 +150,6 @@ request.") ;; These routines will allow us to implement persistent HTTP ;; connections. (defsubst url-http-debug (&rest args) - (if quit-flag - (let ((proc (get-buffer-process (current-buffer)))) - ;; The user hit C-g, honor it! Some things can get in an - ;; incredibly tight loop (chunked encoding) - (if proc - (progn - (set-process-sentinel proc nil) - (set-process-filter proc nil))) - (error "Transfer interrupted!"))) (apply 'url-debug 'http args)) (defun url-http-mark-connection-as-busy (host port proc) @@ -238,6 +230,35 @@ request.") emacs-info os-info)) " "))) +(defun url-http--get-referer (url) + (url-http-debug "getting referer from buffer: buffer:%S target-url:%S lastloc:%S" (current-buffer) url url-current-lastloc) + (when url-current-lastloc + (if (not (url-p url-current-lastloc)) + (setq url-current-lastloc (url-generic-parse-url url-current-lastloc))) + (let ((referer (copy-sequence url-current-lastloc))) + (setf (url-host referer) (puny-encode-domain (url-host referer))) + (let ((referer-string (url-recreate-url referer))) + (when (and (not (memq url-privacy-level '(low high paranoid))) + (not (and (listp url-privacy-level) + (memq 'lastloc url-privacy-level)))) + ;; url-privacy-level allows referer. But url-lastloc-privacy-level + ;; may restrict who we send it to. + (cl-case url-lastloc-privacy-level + (host-match + (let ((referer-host (url-host referer)) + (url-host (url-host url))) + (when (string= referer-host url-host) + referer-string))) + (domain-match + (let ((referer-domain (url-domain referer)) + (url-domain (url-domain url))) + (when (and referer-domain + url-domain + (string= referer-domain url-domain)) + referer-string))) + (otherwise + referer-string))))))) + ;; Building an HTTP request (defun url-http-user-agent-string () "Compute a User-Agent string. @@ -254,8 +275,9 @@ The string is based on `url-privacy-level' and `url-user-agent'." ((eq url-user-agent 'default) (url-http--user-agent-default-string)))))) (if ua-string (format "User-Agent: %s\r\n" (string-trim ua-string)) ""))) -(defun url-http-create-request (&optional ref-url) - "Create an HTTP request for `url-http-target-url', referred to by REF-URL." +(defun url-http-create-request () + "Create an HTTP request for `url-http-target-url'. +Use `url-http-referer' as the Referer-header (subject to `url-privacy-level')." (let* ((extra-headers) (request nil) (no-cache (cdr-safe (assoc "Pragma" url-http-extra-headers))) @@ -268,13 +290,14 @@ The string is based on `url-privacy-level' and `url-user-agent'." 'url-http-proxy-basic-auth-storage)) (url-get-authentication url-http-proxy nil 'any nil)))) (real-fname (url-filename url-http-target-url)) - (host (url-http--encode-string (url-host url-http-target-url))) + (host (url-host url-http-target-url)) (auth (if (cdr-safe (assoc "Authorization" url-http-extra-headers)) nil (url-get-authentication (or (and (boundp 'proxy-info) proxy-info) - url-http-target-url) nil 'any nil)))) + url-http-target-url) nil 'any nil))) + (ref-url (url-http--encode-string url-http-referer))) (if (equal "" real-fname) (setq real-fname "/")) (setq no-cache (and no-cache (string-match "no-cache" no-cache))) @@ -288,12 +311,6 @@ The string is based on `url-privacy-level' and `url-user-agent'." (string= ref-url ""))) (setq ref-url nil)) - ;; We do not want to expose the referrer if the user is paranoid. - (if (or (memq url-privacy-level '(low high paranoid)) - (and (listp url-privacy-level) - (memq 'lastloc url-privacy-level))) - (setq ref-url nil)) - ;; url-http-extra-headers contains an assoc-list of ;; header/value pairs that we need to put into the request. (setq extra-headers (mapconcat @@ -329,9 +346,11 @@ The string is based on `url-privacy-level' and `url-user-agent'." (url-scheme-get-property (url-type url-http-target-url) 'default-port)) (format - "Host: %s:%d\r\n" (puny-encode-domain host) + "Host: %s:%d\r\n" (url-http--encode-string + (puny-encode-domain host)) (url-port url-http-target-url)) - (format "Host: %s\r\n" (puny-encode-domain host))) + (format "Host: %s\r\n" + (url-http--encode-string (puny-encode-domain host)))) ;; Who its from (if url-personal-mail-address (concat @@ -434,6 +453,14 @@ Return the number of characters removed." auth (strength 0)) + ;; If we're here, then we got a 40x Unauthorized response from the + ;; server. If we already have "Authorization" in the extra + ;; headers, then this means that we've already tried sending + ;; credentials to the server, and they were wrong, so just give + ;; up. + (when (assoc "Authorization" url-http-extra-headers) + (error "Wrong authorization used for %s" url)) + ;; find strongest supported auth (dolist (this-auth auths) (setq this-auth (url-eat-trailing-space @@ -485,11 +512,11 @@ Return the number of characters removed." (url-http-debug "url-http-parse-response called in (%s)" (buffer-name)) (goto-char (point-min)) (skip-chars-forward " \t\n") ; Skip any blank crap - (skip-chars-forward "HTTP/") ; Skip HTTP Version + (skip-chars-forward "/HPT") ; Skip HTTP Version "HTTP/". (setq url-http-response-version (buffer-substring (point) (progn - (skip-chars-forward "[0-9].") + (skip-chars-forward "0-9.") (point)))) (setq url-http-response-status (read (current-buffer)))) @@ -511,6 +538,23 @@ work correctly." (declare-function gnutls-peer-status "gnutls.c" (proc)) (declare-function gnutls-negotiate "gnutls.el" t t) +(defun url-http--insert-file-helper (buffer url &optional visit) + (with-current-buffer buffer + (when (bound-and-true-p url-http-response-status) + ;; Don't signal an error if VISIT is non-nil, because + ;; 'insert-file-contents' doesn't. This is required to + ;; support, e.g., 'browse-url-emacs', which is a fancy way of + ;; visiting the HTML source of a URL: in that case, we want to + ;; display a file buffer even if the URL does not exist and + ;; 'url-retrieve-synchronously' returns 404 or whatever. + (unless (or visit + (and (>= url-http-response-status 200) + (< url-http-response-status 300))) + (let ((desc (nth 2 (assq url-http-response-status url-http-codes)))) + (kill-buffer buffer) + ;; Signal file-error per bug#16733. + (signal 'file-error (list url desc))))))) + (defun url-http-parse-headers () "Parse and handle HTTP specific headers. Return t if and only if the current buffer is still active and @@ -585,7 +629,7 @@ should be shown to the user." ;; 206 Partial content ;; 207 Multi-status (Added by DAV) (pcase status-symbol - ((or `no-content `reset-content) + ((or 'no-content 'reset-content) ;; No new data, just stay at the same document (url-mark-buffer-as-dead buffer)) (_ @@ -606,7 +650,7 @@ should be shown to the user." (let ((redirect-uri (or (mail-fetch-field "Location") (mail-fetch-field "URI")))) (pcase status-symbol - (`multiple-choices ; 300 + ('multiple-choices ; 300 ;; Quoth the spec (section 10.3.1) ;; ------------------------------- ;; The requested resource corresponds to any one of a set of @@ -623,20 +667,26 @@ should be shown to the user." ;; We do not support agent-driven negotiation, so we just ;; redirect to the preferred URI if one is provided. nil) - (`see-other ; 303 + ('found ; 302 + ;; 302 Found was ambiguously defined in the standards, but + ;; it's now recommended that it's treated like 303 instead + ;; of 307, since that's what most servers expect. + (setq url-http-method "GET" + url-http-data nil)) + ('see-other ; 303 ;; The response to the request can be found under a different ;; URI and SHOULD be retrieved using a GET method on that ;; resource. (setq url-http-method "GET" url-http-data nil)) - (`not-modified ; 304 + ('not-modified ; 304 ;; The 304 response MUST NOT contain a message-body. (url-http-debug "Extracting document from cache... (%s)" (url-cache-create-filename (url-view-url t))) (url-cache-extract (url-cache-create-filename (url-view-url t))) (setq redirect-uri nil success t)) - (`use-proxy ; 305 + ('use-proxy ; 305 ;; The requested resource MUST be accessed through the ;; proxy given by the Location field. The Location field ;; gives the URI of the proxy. The recipient is expected @@ -734,50 +784,50 @@ should be shown to the user." ;; 424 Failed Dependency (setq success (pcase status-symbol - (`unauthorized ; 401 + ('unauthorized ; 401 ;; The request requires user authentication. The response ;; MUST include a WWW-Authenticate header field containing a ;; challenge applicable to the requested resource. The ;; client MAY repeat the request with a suitable ;; Authorization header field. (url-http-handle-authentication nil)) - (`payment-required ; 402 + ('payment-required ; 402 ;; This code is reserved for future use (url-mark-buffer-as-dead buffer) (error "Somebody wants you to give them money")) - (`forbidden ; 403 + ('forbidden ; 403 ;; The server understood the request, but is refusing to ;; fulfill it. Authorization will not help and the request ;; SHOULD NOT be repeated. t) - (`not-found ; 404 + ('not-found ; 404 ;; Not found t) - (`method-not-allowed ; 405 + ('method-not-allowed ; 405 ;; The method specified in the Request-Line is not allowed ;; for the resource identified by the Request-URI. The ;; response MUST include an Allow header containing a list of ;; valid methods for the requested resource. t) - (`not-acceptable ; 406 + ('not-acceptable ; 406 ;; The resource identified by the request is only capable of ;; generating response entities which have content ;; characteristics not acceptable according to the accept ;; headers sent in the request. t) - (`proxy-authentication-required ; 407 + ('proxy-authentication-required ; 407 ;; This code is similar to 401 (Unauthorized), but indicates ;; that the client must first authenticate itself with the ;; proxy. The proxy MUST return a Proxy-Authenticate header ;; field containing a challenge applicable to the proxy for ;; the requested resource. (url-http-handle-authentication t)) - (`request-timeout ; 408 + ('request-timeout ; 408 ;; The client did not produce a request within the time that ;; the server was prepared to wait. The client MAY repeat ;; the request without modifications at any later time. t) - (`conflict ; 409 + ('conflict ; 409 ;; The request could not be completed due to a conflict with ;; the current state of the resource. This code is only ;; allowed in situations where it is expected that the user @@ -786,11 +836,11 @@ should be shown to the user." ;; information for the user to recognize the source of the ;; conflict. t) - (`gone ; 410 + ('gone ; 410 ;; The requested resource is no longer available at the ;; server and no forwarding address is known. t) - (`length-required ; 411 + ('length-required ; 411 ;; The server refuses to accept the request without a defined ;; Content-Length. The client MAY repeat the request if it ;; adds a valid Content-Length header field containing the @@ -800,29 +850,29 @@ should be shown to the user." ;; `url-http-create-request' automatically calculates the ;; content-length. t) - (`precondition-failed ; 412 + ('precondition-failed ; 412 ;; The precondition given in one or more of the ;; request-header fields evaluated to false when it was ;; tested on the server. t) - ((or `request-entity-too-large `request-uri-too-large) ; 413 414 + ((or 'request-entity-too-large 'request-uri-too-large) ; 413 414 ;; The server is refusing to process a request because the ;; request entity|URI is larger than the server is willing or ;; able to process. t) - (`unsupported-media-type ; 415 + ('unsupported-media-type ; 415 ;; The server is refusing to service the request because the ;; entity of the request is in a format not supported by the ;; requested resource for the requested method. t) - (`requested-range-not-satisfiable ; 416 + ('requested-range-not-satisfiable ; 416 ;; A server SHOULD return a response with this status code if ;; a request included a Range request-header field, and none ;; of the range-specifier values in this field overlap the ;; current extent of the selected resource, and the request ;; did not include an If-Range request-header field. t) - (`expectation-failed ; 417 + ('expectation-failed ; 417 ;; The expectation given in an Expect request-header field ;; could not be met by this server, or, if the server is a ;; proxy, the server has unambiguous evidence that the @@ -849,16 +899,16 @@ should be shown to the user." ;; 507 Insufficient storage (setq success t) (pcase url-http-response-status - (`not-implemented ; 501 + ('not-implemented ; 501 ;; The server does not support the functionality required to ;; fulfill the request. nil) - (`bad-gateway ; 502 + ('bad-gateway ; 502 ;; The server, while acting as a gateway or proxy, received ;; an invalid response from the upstream server it accessed ;; in attempting to fulfill the request. nil) - (`service-unavailable ; 503 + ('service-unavailable ; 503 ;; The server is currently unable to handle the request due ;; to a temporary overloading or maintenance of the server. ;; The implication is that this is a temporary condition @@ -867,19 +917,19 @@ should be shown to the user." ;; header. If no Retry-After is given, the client SHOULD ;; handle the response as it would for a 500 response. nil) - (`gateway-timeout ; 504 + ('gateway-timeout ; 504 ;; The server, while acting as a gateway or proxy, did not ;; receive a timely response from the upstream server ;; specified by the URI (e.g. HTTP, FTP, LDAP) or some other ;; auxiliary server (e.g. DNS) it needed to access in ;; attempting to complete the request. nil) - (`http-version-not-supported ; 505 + ('http-version-not-supported ; 505 ;; The server does not support, or refuses to support, the ;; HTTP protocol version that was used in the request ;; message. nil) - (`insufficient-storage ; 507 (DAV) + ('insufficient-storage ; 507 (DAV) ;; The method could not be performed on the resource ;; because the server is unable to store the representation ;; needed to successfully complete the request. This @@ -905,10 +955,11 @@ should be shown to the user." (goto-char (point-min)) success)) -(declare-function zlib-decompress-region "decompress.c" (start end)) +(declare-function zlib-decompress-region "decompress.c" + (start end &optional allow-partial)) (defun url-handle-content-transfer-encoding () - (let ((encoding (mail-fetch-field "content-encoding"))) + (let ((encoding (mail-fetch-field "content-encoding" nil nil nil t))) (when (and encoding (fboundp 'zlib-available-p) (zlib-available-p) @@ -917,7 +968,7 @@ should be shown to the user." (widen) (goto-char (point-min)) (when (search-forward "\n\n") - (zlib-decompress-region (point) (point-max))))))) + (zlib-decompress-region (point) (point-max) t)))))) ;; Miscellaneous (defun url-http-activate-callback () @@ -973,7 +1024,8 @@ should be shown to the user." (defun url-http-simple-after-change-function (_st _nd _length) ;; Function used when we do NOT know how long the document is going to be ;; Just _very_ simple 'downloaded %d' type of info. - (url-lazy-message "Reading %s..." (file-size-human-readable (buffer-size)))) + (url-lazy-message "Reading %s..." + (file-size-human-readable (buffer-size) 'iec " "))) (defun url-http-content-length-after-change-function (_st nd _length) "Function used when we DO know how long the document is going to be. @@ -986,16 +1038,16 @@ the callback to be triggered." (url-percentage (- nd url-http-end-of-headers) url-http-content-length) url-http-content-type - (file-size-human-readable (- nd url-http-end-of-headers)) - (file-size-human-readable url-http-content-length) + (file-size-human-readable (- nd url-http-end-of-headers) 'iec " ") + (file-size-human-readable url-http-content-length 'iec " ") (url-percentage (- nd url-http-end-of-headers) url-http-content-length)) (url-display-percentage "Reading... %s of %s (%d%%)" (url-percentage (- nd url-http-end-of-headers) url-http-content-length) - (file-size-human-readable (- nd url-http-end-of-headers)) - (file-size-human-readable url-http-content-length) + (file-size-human-readable (- nd url-http-end-of-headers) 'iec " ") + (file-size-human-readable url-http-content-length 'iec " ") (url-percentage (- nd url-http-end-of-headers) url-http-content-length))) @@ -1054,10 +1106,16 @@ the end of the document." (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, + ;; 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 'start-open t 'end-open t @@ -1073,8 +1131,7 @@ the end of the document." (or url-http-chunked-start (make-marker)) (match-end 0))) -; (if (not url-http-debug) - (delete-region (match-beginning 0) (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)) @@ -1258,7 +1315,8 @@ The return value of this function is the retrieval buffer." (mime-accept-string url-mime-accept-string) (buffer (or retry-buffer (generate-new-buffer - (format " *http %s:%d*" (url-host url) (url-port url)))))) + (format " *http %s:%d*" (url-host url) (url-port url))))) + (referer (url-http--encode-string (url-http--get-referer url)))) (if (not connection) ;; Failed to open the connection for some reason (progn @@ -1293,7 +1351,8 @@ The return value of this function is the retrieval buffer." url-http-no-retry url-http-connection-opened url-mime-accept-string - url-http-proxy)) + url-http-proxy + url-http-referer)) (set (make-local-variable var) nil)) (setq url-http-method (or url-request-method "GET") @@ -1311,15 +1370,16 @@ The return value of this function is the retrieval buffer." url-http-no-retry retry-buffer url-http-connection-opened nil url-mime-accept-string mime-accept-string - url-http-proxy url-using-proxy) + url-http-proxy url-using-proxy + url-http-referer referer) (set-process-buffer connection buffer) (set-process-filter connection 'url-http-generic-filter) (pcase (process-status connection) - (`connect + ('connect ;; Asynchronous connection (set-process-sentinel connection 'url-http-async-sentinel)) - (`failed + ('failed ;; Asynchronous connection failed (error "Could not create connection to %s:%d" (url-host url) (url-port url))) @@ -1375,7 +1435,9 @@ The return value of this function is the retrieval buffer." 'url-http-wait-for-headers-change-function) (set-process-filter tls-connection 'url-http-generic-filter) (process-send-string tls-connection - (url-http-create-request))) + ;; Use the non-proxy form of the request + (let (url-http-proxy) + (url-http-create-request)))) (gnutls-error (url-http-activate-callback) (error "gnutls-error: %s" e)) @@ -1563,7 +1625,6 @@ p3p ;; HTTPS. This used to be in url-https.el, but that file collides ;; with url-http.el on systems with 8-character file names. -(require 'tls) (defconst url-https-asynchronous-p t "HTTPS retrievals are asynchronous.") diff --git a/lisp/url/url-methods.el b/lisp/url/url-methods.el index 456be7ed4f7..1c0c5af86ac 100644 --- a/lisp/url/url-methods.el +++ b/lisp/url/url-methods.el @@ -134,11 +134,11 @@ it has not already been loaded." (type (cdr cell))) (if symbol (pcase type - (`function + ('function ;; Store the symbol name of a function (if (fboundp symbol) (setq desc (plist-put desc (car cell) symbol)))) - (`variable + ('variable ;; Store the VALUE of a variable (if (boundp symbol) (setq desc (plist-put desc (car cell) diff --git a/lisp/url/url-misc.el b/lisp/url/url-misc.el index 4969cba6688..aa44ea78a22 100644 --- a/lisp/url/url-misc.el +++ b/lisp/url/url-misc.el @@ -88,7 +88,7 @@ (encoding "8bit") (data nil)) (save-excursion - (if (not (string-match "\\([^,]*\\)?," desc)) + (if (not (string-match "\\([^,]*\\)," desc)) (error "Malformed data URL: %s" desc) (setq mediatype (match-string 1 desc) data (url-unhex-string (substring desc (match-end 0)))) diff --git a/lisp/url/url-parse.el b/lisp/url/url-parse.el index a15ec953f62..1f72f51d769 100644 --- a/lisp/url/url-parse.el +++ b/lisp/url/url-parse.el @@ -209,7 +209,7 @@ parses to ;; 3.3. Path (skip-chars-forward "^?#") ;; 3.4. Query - (when (looking-at "?") + (when (looking-at "\\?") (skip-chars-forward "^#")) (setq file (buffer-substring save-pos (point))) ;; 3.5 Fragment diff --git a/lisp/url/url-privacy.el b/lisp/url/url-privacy.el index 994ae6ac5da..ef9ff84d56e 100644 --- a/lisp/url/url-privacy.el +++ b/lisp/url/url-privacy.el @@ -45,9 +45,9 @@ ((memq (url-device-type) '(win32 w32)) "Windows; 32bit") (t (pcase (url-device-type) - (`x "X11") - (`ns "OpenStep") - (`tty "TTY") + ('x "X11") + ('ns "OpenStep") + ('tty "TTY") (_ nil))))) (setq url-personal-mail-address (or url-personal-mail-address diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el index 38137b85e40..9bf1bca238d 100644 --- a/lisp/url/url-queue.el +++ b/lisp/url/url-queue.el @@ -52,7 +52,7 @@ (cl-defstruct url-queue url callback cbargs silentp buffer start-time pre-triggered - inhibit-cookiesp) + inhibit-cookiesp context-buffer) ;;;###autoload (defun url-queue-retrieve (url callback &optional cbargs silent inhibit-cookies) @@ -67,7 +67,8 @@ The variable `url-queue-timeout' sets a timeout." :callback callback :cbargs cbargs :silentp silent - :inhibit-cookiesp inhibit-cookies)))) + :inhibit-cookiesp inhibit-cookies + :context-buffer (current-buffer))))) (url-queue-setup-runners)) ;; To ensure asynch behavior, we start the required number of queue @@ -147,19 +148,22 @@ The variable `url-queue-timeout' sets a timeout." (defun url-queue-start-retrieve (job) (setf (url-queue-buffer job) (ignore-errors - (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)))))) + (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))))))) (defun url-queue-prune-old-entries () (let (dead-jobs) (dolist (job url-queue) ;; Kill jobs that have lasted longer than the timeout. (when (and (url-queue-start-time job) - (> (- (float-time) (url-queue-start-time job)) - url-queue-timeout)) + (time-less-p url-queue-timeout + (time-since (url-queue-start-time job)))) (push job dead-jobs))) (dolist (job dead-jobs) (url-queue-kill-job job) diff --git a/lisp/url/url-tramp.el b/lisp/url/url-tramp.el index 305635c8d38..f4ec8226511 100644 --- a/lisp/url/url-tramp.el +++ b/lisp/url/url-tramp.el @@ -42,9 +42,9 @@ If URL contains a password, it will be added to the `password-data' cache. In case URL is not convertible, nil is returned." (let* ((obj (url-generic-parse-url (and (stringp url) url))) (port - (and (natnump (url-portspec obj)) + (and obj (natnump (url-portspec obj)) (number-to-string (url-portspec obj))))) - (when (member (url-type obj) url-tramp-protocols) + (when (and obj (member (url-type obj) url-tramp-protocols)) (when (url-password obj) (password-cache-add (tramp-make-tramp-file-name @@ -60,9 +60,9 @@ In case URL is not convertible, nil is returned." In case FILE is not convertible, nil is returned." (let* ((obj (ignore-errors (tramp-dissect-file-name file))) (port - (and (stringp (tramp-file-name-port obj)) + (and obj (stringp (tramp-file-name-port obj)) (string-to-number (tramp-file-name-port obj))))) - (when (member (tramp-file-name-method obj) url-tramp-protocols) + (when (and obj (member (tramp-file-name-method obj) url-tramp-protocols)) (url-recreate-url (url-parse-make-urlobj (tramp-file-name-method obj) diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el index 95e808f764d..a46e7bb3855 100644 --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el @@ -61,8 +61,6 @@ If a list, it is a list of the types of messages to be logged." ;;;###autoload (defun url-debug (tag &rest args) - (if quit-flag - (error "Interrupted!")) (if (or (eq url-debug t) (numberp url-debug) (and (listp url-debug) (memq tag url-debug))) @@ -183,7 +181,7 @@ Will not do anything if `url-show-status' is nil." (null url-show-status) (active-minibuffer-window) (= url-lazy-message-time - (setq url-lazy-message-time (nth 1 (current-time))))) + (setq url-lazy-message-time (encode-time nil 'integer)))) nil (apply 'message args))) @@ -503,7 +501,7 @@ WIDTH defaults to the current frame width." (urlobj nil)) ;; The first thing that can go are the search strings (if (and (>= str-width fr-width) - (string-match "?" url)) + (string-match "\\?" url)) (setq url (concat (substring url 0 (match-beginning 0)) "?...") str-width (length url))) (if (< str-width fr-width) @@ -545,6 +543,7 @@ This uses `url-current-object', set locally to the buffer." (defun url-get-url-at-point (&optional pt) "Get the URL closest to point, but don't change position. Has a preference for looking backward when not directly on a symbol." + (declare (obsolete thing-at-point-url-at-point "27.1")) ;; Not at all perfect - point must be right in the name. (save-excursion (if pt (goto-char pt)) @@ -628,6 +627,34 @@ Creates FILE and its parent directories if they do not exist." (error "Danger: `%s' is a symbolic link" file)) (set-file-modes file #o0600)))) +(autoload 'puny-encode-domain "puny") +(autoload 'url-domsuf-cookie-allowed-p "url-domsuf") + +;;;###autoload +(defun url-domain (url) + "Return the domain of the host of the URL. +Return nil if this can't be determined. + +For instance, this function will return \"fsf.co.uk\" if the host in URL +is \"www.fsf.co.uk\"." + (let* ((host (puny-encode-domain (url-host url))) + (parts (nreverse (split-string host "\\."))) + (candidate (pop parts)) + found) + ;; IP addresses aren't domains. + (when (string-match "\\`[0-9.]+\\'" host) + (setq parts nil)) + ;; We assume that the top-level domain is never an appropriate + ;; thing as "the domain", so we start at the next one (eg. + ;; "fsf.org"). + (while (and parts + (not (setq found + (url-domsuf-cookie-allowed-p + (setq candidate (concat (pop parts) "." + candidate)))))) + ) + (and found candidate))) + (provide 'url-util) ;;; url-util.el ends here diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el index a5d80ff1518..134404c9984 100644 --- a/lisp/url/url-vars.el +++ b/lisp/url/url-vars.el @@ -60,10 +60,18 @@ (defvar url-current-mime-headers nil "A parsed representation of the MIME headers for the current URL.") +(defvar url-current-lastloc nil + "A parsed representation of the URL to be considered as the last location. +Use of this value on outbound connections is subject to +`url-privacy-level' and `url-lastloc-privacy-level'. This is never set +by the url library, applications are expected to set this +variable in buffers representing a displayed location.") + (mapc 'make-variable-buffer-local '( url-current-object url-current-mime-headers + url-current-lastloc )) (defcustom url-honor-refresh-requests t @@ -117,7 +125,7 @@ Valid symbols are: email -- the email address os -- the operating system info emacs -- the version of Emacs -lastloc -- the last location +lastloc -- the last location (see also `url-lastloc-privacy-level') agent -- do not send the User-Agent string cookies -- never accept HTTP cookies @@ -150,6 +158,24 @@ variable." (const :tag "No cookies" :value cookie))) :group 'url) +(defcustom url-lastloc-privacy-level 'domain-match + "Further restrictions on sending the last location. +This value is only consulted if `url-privacy-level' permits +sending last location in the first place. + +Valid values are: +none -- Always send last location. +domain-match -- Send last location if the new location is within the + same domain +host-match -- Send last location if the new location is on the + same host +" + :version "27.1" + :type '(radio (const :tag "Always send" none) + (const :tag "Domains match" domain-match) + (const :tag "Hosts match" host-match)) + :group 'url) + (defvar url-inhibit-uncompression nil "Do not do decompression if non-nil.") (defcustom url-uncompressor-alist '((".z" . "x-gzip") @@ -223,26 +249,22 @@ Should be an assoc list of headers/contents.") "String to send in the Accept-encoding: field in HTTP requests.") (defvar mm-mime-mule-charset-alist) -(declare-function mm-coding-system-p "mm-util" (cs)) ;; Perhaps the first few should actually be given decreasing `q's and ;; the list should be trimmed significantly. -;; Fixme: do something sane if we don't have `sort-coding-systems' -;; (Emacs 20, XEmacs). (defun url-mime-charset-string () "Generate a list of preferred MIME charsets for HTTP requests. Generated according to current coding system priorities." (require 'mm-util) - (if (fboundp 'sort-coding-systems) - (let ((ordered (sort-coding-systems - (let (accum) - (dolist (elt mm-mime-mule-charset-alist) - (if (mm-coding-system-p (car elt)) - (push (car elt) accum))) - (nreverse accum))))) - (concat (format "%s;q=1, " (pop ordered)) - (mapconcat 'symbol-name ordered ";q=0.5, ") - ";q=0.5")))) + (let ((ordered (sort-coding-systems + (let (accum) + (dolist (elt mm-mime-mule-charset-alist) + (if (coding-system-p (car elt)) + (push (car elt) accum))) + (nreverse accum))))) + (concat (format "%s;q=1, " (pop ordered)) + (mapconcat 'symbol-name ordered ";q=0.5, ") + ";q=0.5"))) (defvar url-mime-charset-string nil "String to send in the Accept-charset: field in HTTP requests. @@ -250,9 +272,8 @@ The MIME charset corresponding to the most preferred coding system is given priority 1 and the rest are given priority 0.5.") (defun url-set-mime-charset-string () + (declare (obsolete nil "27.1")) (setq url-mime-charset-string (url-mime-charset-string))) -;; Regenerate if the language environment changes. -(add-hook 'set-language-environment-hook 'url-set-mime-charset-string) ;; Fixme: set from the locale. (defcustom url-mime-language-string nil diff --git a/lisp/url/url.el b/lisp/url/url.el index fbf31d420cb..5242d42f04c 100644 --- a/lisp/url/url.el +++ b/lisp/url/url.el @@ -136,9 +136,11 @@ STATUS is a plist representing what happened during the request, with most recent events first, or an empty list if no events have occurred. Each pair is one of: -\(:redirect REDIRECTED-TO) - the request was redirected to this URL -\(:error (ERROR-SYMBOL . DATA)) - an error occurred. The error can be -signaled with (signal ERROR-SYMBOL DATA). +\(:redirect REDIRECTED-TO) - the request was redirected to this URL. + +\(:error (error type . DATA)) - an error occurred. TYPE is a +symbol that says something about where the error occurred, and +DATA is a list (possibly nil) that describes the error further. Return the buffer URL will load into, or nil if the process has already completed (i.e. URL was a mailto URL or similar; in this case @@ -259,9 +261,7 @@ how long to wait for a response before giving up." ;; process output. (while (and (not retrieval-done) (or (not timeout) - (< (float-time (time-subtract - (current-time) start-time)) - timeout))) + (time-less-p (time-since start-time) timeout))) (url-debug 'retrieval "Spinning in url-retrieve-synchronously: %S (%S)" retrieval-done asynch-buffer) diff --git a/lisp/userlock.el b/lisp/userlock.el index ec5215badb5..f077bc9ad62 100644 --- a/lisp/userlock.el +++ b/lisp/userlock.el @@ -32,6 +32,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (define-error 'file-locked "File is locked" 'file-error) ;;;###autoload @@ -172,7 +174,9 @@ really edit the buffer? (y, n, r or C-h) " (defun ask-user-about-supersession-help () (with-output-to-temp-buffer "*Help*" - (princ "You want to modify a buffer whose disk file has changed + (princ + (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 `y' to go ahead and modify this buffer, @@ -182,7 +186,7 @@ from the file on disk. If you say `n', the change you started to make will be aborted. Usually, you should type `n' and then `\\[revert-buffer]', -to get the latest version of the file, then make the change again.") +to get the latest version of the file, then make the change again.")) (with-current-buffer standard-output (help-mode)))) diff --git a/lisp/vc/add-log.el b/lisp/vc/add-log.el index 5350176e00e..f9efd44c5c7 100644 --- a/lisp/vc/add-log.el +++ b/lisp/vc/add-log.el @@ -239,7 +239,7 @@ a case simply use the directory containing the changed file." ;; wrongly with a non-date line existing as a random note. In ;; addition, using any kind of fixed setting like this doesn't ;; work if a user customizes add-log-time-format. - ("^[0-9-]+ +\\|^ \\{11,\\}\\|^\t \\{3,\\}\\|^\\(Sun\\|Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\) [A-z][a-z][a-z] [0-9:+ ]+" + ("^[0-9-]+ +\\|^ \\{11,\\}\\|^\t \\{3,\\}\\|^\\(Sun\\|Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\) [A-Z][a-z][a-z] [0-9:+ ]+" (0 'change-log-date) ;; Name and e-mail; some people put e-mail in parens, not angles. ("\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]" nil nil @@ -471,6 +471,11 @@ A change log tag is a symbol within a parenthesized, comma-separated list. If no suitable tag can be found nearby, try to visit the file for the change under `point' instead." (interactive) + (let ((buffer (current-buffer))) + (change-log-goto-source-internal) + (next-error-found buffer (current-buffer)))) + +(defun change-log-goto-source-internal () (if (and (eq last-command 'change-log-goto-source) change-log-find-tail) (setq change-log-find-tail @@ -539,7 +544,7 @@ Compatibility function for \\[next-error] invocations." ;; if we found a place to visit... (when (looking-at change-log-file-names-re) (let (change-log-find-window) - (change-log-goto-source) + (change-log-goto-source-internal) (when change-log-find-window ;; Select window displaying source file. (select-window change-log-find-window))))) @@ -739,6 +744,7 @@ Optional arg BUFFER-FILE overrides `buffer-file-name'." file-name) (defun add-log-file-name (buffer-file log-file) + "Compute file-name of BUFFER-FILE to be used in entries in LOG-FILE." ;; Never want to add a change log entry for the ChangeLog file itself. (unless (or (null buffer-file) (string= buffer-file log-file)) (if add-log-file-name-function @@ -762,15 +768,57 @@ Optional arg BUFFER-FILE overrides `buffer-file-name'." (file-name-sans-versions buffer-file) buffer-file)))) +(defcustom add-log-dont-create-changelog-file t + "If non-nil, don't create ChangeLog files for log entries. +If a ChangeLog file does not already exist, a non-nil value +means to put log entries in a suitably named buffer." + :type :boolean + :version "27.1") + +(put 'add-log-dont-create-changelog-file 'safe-local-variable 'booleanp) + +(defun add-log--pseudo-changelog-buffer-name (changelog-file-name) + "Compute a suitable name for a non-file visiting ChangeLog buffer. +CHANGELOG-FILE-NAME is the file name of the actual ChangeLog file +if it were to exist." + (format "*changes to %s*" + (abbreviate-file-name + (file-name-directory changelog-file-name)))) + +(defun add-log--changelog-buffer-p (changelog-file-name buffer) + "Return non-nil if BUFFER holds a change log for CHANGELOG-FILE-NAME." + (with-current-buffer buffer + (if buffer-file-name + (equal buffer-file-name changelog-file-name) + (equal (add-log--pseudo-changelog-buffer-name changelog-file-name) + (buffer-name))))) + +(defun add-log-find-changelog-buffer (changelog-file-name) + "Find a ChangeLog buffer for CHANGELOG-FILE-NAME. +Respect `add-log-use-pseudo-changelog', which see." + (if (or (file-exists-p changelog-file-name) + (not add-log-dont-create-changelog-file)) + (find-file-noselect changelog-file-name) + (get-buffer-create + (add-log--pseudo-changelog-buffer-name changelog-file-name)))) + ;;;###autoload -(defun add-change-log-entry (&optional whoami file-name other-window new-entry +(defun add-change-log-entry (&optional whoami + changelog-file-name + other-window new-entry put-new-entry-on-new-line) - "Find change log file, and add an entry for today and an item for this file. -Optional arg WHOAMI (interactive prefix) non-nil means prompt for user -name and email (stored in `add-log-full-name' and `add-log-mailing-address'). - -Second arg FILE-NAME is file name of the change log. -If nil, use the value of `change-log-default-name'. + "Find ChangeLog buffer, add an entry for today and an item for this file. +Optional arg WHOAMI (interactive prefix) non-nil means prompt for +user name and email (stored in `add-log-full-name' +and `add-log-mailing-address'). + +Second arg CHANGELOG-FILE-NAME is the file name of the change log. +If nil, use the value of `change-log-default-name'. If the file +thus named exists, it is used for the new entry. If it doesn't +exist, it is created, unless `add-log-dont-create-changelog-file' is t, +in which case a suitably named buffer that doesn't visit any file +is used for keeping entries pertaining to CHANGELOG-FILE-NAME's +directory. Third arg OTHER-WINDOW non-nil means visit in other window. @@ -799,20 +847,28 @@ non-nil, otherwise in local time." (change-log-version-number-search))) (buf-file-name (funcall add-log-buffer-file-name-function)) (buffer-file (if buf-file-name (expand-file-name buf-file-name))) - (file-name (expand-file-name (find-change-log file-name buffer-file))) + (changelog-file-name (expand-file-name (find-change-log + changelog-file-name + buffer-file))) ;; Set ITEM to the file name to use in the new item. - (item (add-log-file-name buffer-file file-name))) + (item (add-log-file-name buffer-file changelog-file-name))) - (unless (equal file-name buffer-file-name) + ;; don't add entries from the ChangeLog file/buffer to itself. + (unless (equal changelog-file-name buffer-file-name) (cond - ((equal file-name (buffer-file-name (window-buffer))) + ((add-log--changelog-buffer-p + changelog-file-name + (window-buffer)) ;; If the selected window already shows the desired buffer don't show ;; it again (particularly important if other-window is true). ;; This is important for diff-add-change-log-entries-other-window. (set-buffer (window-buffer))) ((or other-window (window-dedicated-p)) - (find-file-other-window file-name)) - (t (find-file file-name)))) + (switch-to-buffer-other-window + (add-log-find-changelog-buffer changelog-file-name))) + (t + (switch-to-buffer + (add-log-find-changelog-buffer changelog-file-name))))) (or (derived-mode-p 'change-log-mode) (change-log-mode)) (undo-boundary) @@ -1019,6 +1075,13 @@ the change log file in another window." (defvar smerge-resolve-function) (defvar copyright-at-end-flag) +(defvar change-log-mode-syntax-table + (let ((table (make-syntax-table))) + (modify-syntax-entry ?` "' " table) + (modify-syntax-entry ?' "' " table) + table) + "Syntax table used while in `change-log-mode'.") + ;;;###autoload (define-derived-mode change-log-mode text-mode "Change Log" "Major mode for editing change logs; like Indented Text mode. @@ -1067,8 +1130,7 @@ Runs `change-log-mode-hook'. (set (make-local-variable 'end-of-defun-function) 'change-log-end-of-defun) ;; next-error function glue - (setq next-error-function 'change-log-next-error) - (setq next-error-last-buffer (current-buffer))) + (setq next-error-function 'change-log-next-error)) (defun change-log-next-buffer (&optional buffer wrap) "Return the next buffer in the series of ChangeLog file buffers. @@ -1095,9 +1157,17 @@ file were isearch was started." ;; If there are no files that match the default pattern ChangeLog.[0-9], ;; return the current buffer to force isearch wrapping to its beginning. ;; If file is nil, multi-isearch-search-fun will signal "end of multi". - (if (file-exists-p file) - (find-file-noselect file) - (current-buffer)))) + (cond + ;; Wrapping doesn't catch errors from the nil arg of file-exists-p, + ;; so handle it explicitly. + ((and wrap (null file)) + (current-buffer)) + ;; When there is no next file, file-exists-p raises the error to be + ;; catched by the search function that displays the error message. + ((file-exists-p file) + (find-file-noselect file)) + (t + (current-buffer))))) (defun change-log-fill-forward-paragraph (n) "Cut paragraphs so filling preserves open parentheses at beginning of lines." diff --git a/lisp/vc/cvs-status.el b/lisp/vc/cvs-status.el index 7fdff51607e..ccc8e5f4720 100644 --- a/lisp/vc/cvs-status.el +++ b/lisp/vc/cvs-status.el @@ -269,9 +269,9 @@ BEWARE: because of stability issues, this is not a symmetric operation." (cond ((= l1 l2) (pcase (cvs-tag-compare tag1 tag2) - (`more1 (cons rev2 (cvs-tree-merge tree1 (cdr tree2)))) - (`more2 (cons rev1 (cvs-tree-merge (cdr tree1) tree2))) - (`equal + ('more1 (cons rev2 (cvs-tree-merge tree1 (cdr tree2)))) + ('more2 (cons rev1 (cvs-tree-merge (cdr tree1) tree2))) + ('equal (cons (cons (cvs-tag-merge tag1 tag2) (cvs-tree-merge (cvs-cdr rev1) (cvs-cdr rev2))) (cvs-tree-merge (cdr tree1) (cdr tree2)))))) @@ -395,33 +395,33 @@ Otherwise, default to ASCII chars like +, - and |.") (defconst cvs-tree-char-space (pcase cvs-tree-use-charset - (`jisx0208 (make-char 'japanese-jisx0208 33 33)) - (`unicode " ") + ('jisx0208 (make-char 'japanese-jisx0208 33 33)) + ('unicode " ") (_ " "))) (defconst cvs-tree-char-hbar (pcase cvs-tree-use-charset - (`jisx0208 (make-char 'japanese-jisx0208 40 44)) - (`unicode "━") + ('jisx0208 (make-char 'japanese-jisx0208 40 44)) + ('unicode "━") (_ "--"))) (defconst cvs-tree-char-vbar (pcase cvs-tree-use-charset - (`jisx0208 (make-char 'japanese-jisx0208 40 45)) - (`unicode "┃") + ('jisx0208 (make-char 'japanese-jisx0208 40 45)) + ('unicode "┃") (_ "| "))) (defconst cvs-tree-char-branch (pcase cvs-tree-use-charset - (`jisx0208 (make-char 'japanese-jisx0208 40 50)) - (`unicode "┣") + ('jisx0208 (make-char 'japanese-jisx0208 40 50)) + ('unicode "┣") (_ "+-"))) (defconst cvs-tree-char-eob ;end of branch (pcase cvs-tree-use-charset - (`jisx0208 (make-char 'japanese-jisx0208 40 49)) - (`unicode "┗") + ('jisx0208 (make-char 'japanese-jisx0208 40 49)) + ('unicode "┗") (_ "`-"))) (defconst cvs-tree-char-bob ;beginning of branch (pcase cvs-tree-use-charset - (`jisx0208 (make-char 'japanese-jisx0208 40 51)) - (`unicode "┳") + ('jisx0208 (make-char 'japanese-jisx0208 40 51)) + ('unicode "┳") (_ "+-"))) (defun cvs-tag-lessp (tag1 tag2) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index d8d35d6682e..0d5dc0e1c0c 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -55,6 +55,9 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) +(autoload 'vc-find-revision "vc") +(autoload 'vc-find-revision-no-save "vc") +(defvar vc-find-revision-no-save) (defvar add-log-buffer-file-name-function) @@ -66,14 +69,12 @@ (defcustom diff-default-read-only nil "If non-nil, `diff-mode' buffers default to being read-only." - :type 'boolean - :group 'diff-mode) + :type 'boolean) (defcustom diff-jump-to-old-file nil "Non-nil means `diff-goto-source' jumps to the old file. Else, it jumps to the new file." - :type 'boolean - :group 'diff-mode) + :type 'boolean) (defcustom diff-update-on-the-fly t "Non-nil means hunk headers are kept up-to-date on-the-fly. @@ -82,23 +83,70 @@ need to be kept consistent with the actual diff. This can either be done on the fly (but this sometimes interacts poorly with the undo mechanism) or whenever the file is written (can be slow when editing big diffs)." - :type 'boolean - :group 'diff-mode) + :type 'boolean) (defcustom diff-advance-after-apply-hunk t "Non-nil means `diff-apply-hunk' will move to the next hunk after applying." - :type 'boolean - :group 'diff-mode) + :type 'boolean) (defcustom diff-mode-hook nil "Run after setting up the `diff-mode' major mode." :type 'hook - :options '(diff-delete-empty-files diff-make-unified) - :group 'diff-mode) + :options '(diff-delete-empty-files diff-make-unified)) + +(defcustom diff-refine 'font-lock + "If non-nil, enable hunk refinement. + +The value `font-lock' means to refine during font-lock. +The value `navigation' means to refine each hunk as you visit it +with `diff-hunk-next' or `diff-hunk-prev'. + +You can always manually refine a hunk with `diff-refine-hunk'." + :version "27.1" + :type '(choice (const :tag "Don't refine hunks" nil) + (const :tag "Refine hunks during font-lock" font-lock) + (const :tag "Refine hunks during navigation" navigation))) + +(defcustom diff-font-lock-prettify nil + "If non-nil, font-lock will try and make the format prettier." + :version "27.1" + :type 'boolean) + +(defcustom diff-font-lock-syntax t + "If non-nil, diff hunk font-lock includes source language syntax highlighting. +This highlighting is the same as added by `font-lock-mode' +when corresponding source files are visited normally. +Syntax highlighting is added over diff-mode's own highlighted changes. + +If t, the default, highlight syntax only in Diff buffers created by Diff +commands that compare files or by VC commands that compare revisions. +These provide all necessary context for reliable highlighting. This value +requires support from a VC backend to find the files being compared. +For diffs against the working-tree version of a file, the highlighting is +based on the current file contents. File-based fontification tries to +infer fontification from the compared files. + +If `hunk-only' fontification is based on hunk alone, without full source. +It tries to highlight hunks without enough context that sometimes might result +in wrong fontification. This is the fastest option, but less reliable. + +If `hunk-also', use reliable file-based syntax highlighting when available +and hunk-based syntax highlighting otherwise as a fallback." + :version "27.1" + :type '(choice (const :tag "Don't highlight syntax" nil) + (const :tag "Hunk-based only" hunk-only) + (const :tag "Highlight syntax" t) + (const :tag "Allow hunk-based fallback" hunk-also))) (defvar diff-vc-backend nil "The VC backend that created the current Diff buffer, if any.") +(defvar diff-vc-revisions nil + "The VC revisions compared in the current Diff buffer, if any.") + +(defvar-local diff-default-directory nil + "The default directory where the current Diff buffer was created.") + (defvar diff-outline-regexp "\\([*+][*+][*+] [^0-9]\\|@@ ...\\|\\*\\*\\* [0-9].\\|--- [0-9]..\\)") @@ -207,133 +255,137 @@ when editing big diffs)." (defcustom diff-minor-mode-prefix "\C-c=" "Prefix key for `diff-minor-mode' commands." - :type '(choice (string "\e") (string "C-c=") string) - :group 'diff-mode) + :type '(choice (string "\e") (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'.") (define-minor-mode diff-auto-refine-mode - "Toggle automatic diff hunk highlighting (Diff Auto Refine mode). -With a prefix argument ARG, enable Diff Auto Refine mode if ARG -is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. + "Toggle automatic diff hunk finer highlighting (Diff Auto Refine mode). Diff Auto Refine mode is a buffer-local minor mode used with `diff-mode'. When enabled, Emacs automatically highlights changes in detail as the user visits hunks. When transitioning from disabled to enabled, it tries to refine the current hunk, as well." - :group 'diff-mode :init-value t :lighter nil ;; " Auto-Refine" - (when diff-auto-refine-mode - (condition-case-unless-debug nil (diff-refine-hunk) (error nil)))) + :group 'diff-mode :init-value nil :lighter nil ;; " Auto-Refine" + (if diff-auto-refine-mode + (progn + (customize-set-variable 'diff-refine 'navigation) + (condition-case-unless-debug nil (diff-refine-hunk) (error nil))) + (customize-set-variable 'diff-refine nil))) +(make-obsolete 'diff-auto-refine-mode "set `diff-refine' instead." "27.1") +(make-obsolete-variable 'diff-auto-refine-mode + "set `diff-refine' instead." "27.1") ;;;; ;;;; font-lock support ;;;; +;; Note: The colors used in a color-rich environments (a GUI or in a +;; terminal supporting 24 bit colors) doesn't render well in terminal +;; supporting only 256 colors. Concretely, both #ffeeee +;; (diff-removed) and #eeffee (diff-added) are mapped to the same +;; greyish color. "min-colors 257" ensures that those colors are not +;; used terminals supporting only 256 colors. However, any number +;; between 257 and 2^24 (16777216) would do. + (defface diff-header '((((class color) (min-colors 88) (background light)) - :background "grey80") + :background "grey85") (((class color) (min-colors 88) (background dark)) :background "grey45") (((class color)) :foreground "blue1" :weight bold) (t :weight bold)) - "`diff-mode' face inherited by hunk and index header faces." - :group 'diff-mode) + "`diff-mode' face inherited by hunk and index header faces.") (defface diff-file-header '((((class color) (min-colors 88) (background light)) - :background "grey70" :weight bold) + :background "grey75" :weight bold) (((class color) (min-colors 88) (background dark)) :background "grey60" :weight bold) (((class color)) :foreground "cyan" :weight bold) (t :weight bold)) ; :height 1.3 - "`diff-mode' face used to highlight file header lines." - :group 'diff-mode) + "`diff-mode' face used to highlight file header lines.") (defface diff-index '((t :inherit diff-file-header)) - "`diff-mode' face used to highlight index header lines." - :group 'diff-mode) + "`diff-mode' face used to highlight index header lines.") (defface diff-hunk-header '((t :inherit diff-header)) - "`diff-mode' face used to highlight hunk header lines." - :group 'diff-mode) + "`diff-mode' face used to highlight hunk header lines.") (defface diff-removed '((default :inherit diff-changed) + (((class color) (min-colors 257) (background light)) + :background "#ffeeee") (((class color) (min-colors 88) (background light)) :background "#ffdddd") (((class color) (min-colors 88) (background dark)) :background "#553333") (((class color)) :foreground "red")) - "`diff-mode' face used to highlight removed lines." - :group 'diff-mode) + "`diff-mode' face used to highlight removed lines.") (defface diff-added '((default :inherit diff-changed) + (((class color) (min-colors 257) (background light)) + :background "#eeffee") (((class color) (min-colors 88) (background light)) :background "#ddffdd") (((class color) (min-colors 88) (background dark)) :background "#335533") (((class color)) :foreground "green")) - "`diff-mode' face used to highlight added lines." - :group 'diff-mode) + "`diff-mode' face used to highlight added lines.") (defface diff-changed '((t nil)) "`diff-mode' face used to highlight changed lines." - :version "25.1" - :group 'diff-mode) + :version "25.1") (defface diff-indicator-removed - '((t :inherit diff-removed)) + '((default :inherit diff-removed) + (((class color) (min-colors 88)) + :foreground "#aa2222")) "`diff-mode' face used to highlight indicator of removed lines (-, <)." - :group 'diff-mode :version "22.1") (defvar diff-indicator-removed-face 'diff-indicator-removed) (defface diff-indicator-added - '((t :inherit diff-added)) + '((default :inherit diff-added) + (((class color) (min-colors 88)) + :foreground "#22aa22")) "`diff-mode' face used to highlight indicator of added lines (+, >)." - :group 'diff-mode :version "22.1") (defvar diff-indicator-added-face 'diff-indicator-added) (defface diff-indicator-changed - '((t :inherit diff-changed)) + '((default :inherit diff-changed) + (((class color) (min-colors 88)) + :foreground "#aaaa22")) "`diff-mode' face used to highlight indicator of changed lines." - :group 'diff-mode :version "22.1") (defvar diff-indicator-changed-face 'diff-indicator-changed) (defface diff-function '((t :inherit diff-header)) - "`diff-mode' face used to highlight function names produced by \"diff -p\"." - :group 'diff-mode) + "`diff-mode' face used to highlight function names produced by \"diff -p\".") (defface diff-context - '((((class color grayscale) (min-colors 88) (background light)) - :foreground "#333333") - (((class color grayscale) (min-colors 88) (background dark)) - :foreground "#dddddd")) + '((t nil)) "`diff-mode' face used to highlight context and other side-information." - :version "25.1" - :group 'diff-mode) + :version "25.1") (defface diff-nonexistent '((t :inherit diff-file-header)) - "`diff-mode' face used to highlight nonexistent files in recursive diffs." - :group 'diff-mode) + "`diff-mode' face used to highlight nonexistent files in recursive diffs.") (defconst diff-yank-handler '(diff-yank-function)) (defun diff-yank-function (text) @@ -408,11 +460,17 @@ and the face `diff-added' for added lines.") 'diff-removed)))))) ("^\\(?:Index\\|revno\\): \\(.+\\).*\n" (0 'diff-header) (1 'diff-index prepend)) + ("^\\(?:index .*\\.\\.\\|diff \\).*\n" . 'diff-header) + ("^\\(?:new\\|deleted\\) file mode .*\n" . 'diff-header) ("^Only in .*\n" . 'diff-nonexistent) + ("^Binary files .* differ\n" . 'diff-file-header) ("^\\(#\\)\\(.*\\)" (1 font-lock-comment-delimiter-face) (2 font-lock-comment-face)) - ("^[^-=+*!<>#].*\n" (0 'diff-context)))) + ("^[^-=+*!<>#].*\n" (0 'diff-context)) + (,#'diff--font-lock-syntax) + (,#'diff--font-lock-prettify) + (,#'diff--font-lock-refined))) (defconst diff-font-lock-defaults '(diff-font-lock-keywords t nil nil nil (font-lock-multiline . nil))) @@ -481,13 +539,14 @@ See https://lists.gnu.org/r/emacs-devel/2007-11/msg01990.html") (unless end (setq end (and (re-search-forward (pcase style - (`unified + ('unified (concat (if diff-valid-unified-empty-line "^[^-+# \\\n]\\|" "^[^-+# \\]\\|") ;; A `unified' header is ambiguous. diff-file-header-re)) - (`context "^[^-+#! \\]") - (`normal "^[^<>#\\]") + ('context (if diff-valid-unified-empty-line + "^[^-+#! \n\\]" "^[^-+#! \\]")) + ('normal "^[^<>#\\]") (_ "^[^-+#!<> \\]")) nil t) (match-beginning 0))) @@ -590,7 +649,7 @@ next hunk if TRY-HARDER is non-nil; otherwise signal an error." ;; Define diff-{hunk,file}-{prev,next} (easy-mmode-define-navigation diff-hunk diff-hunk-header-re "hunk" diff-end-of-hunk diff-restrict-view - (when diff-auto-refine-mode + (when (and (eq diff-refine 'navigation) (called-interactively-p 'interactive)) (unless (prog1 diff--auto-refine-data (setq diff--auto-refine-data (cons (current-buffer) (point-marker)))) @@ -891,7 +950,7 @@ PREFIX is only used internally: don't use it." (if (and newfile (file-exists-p newfile)) (cl-return newfile)))) ;; look for each file in turn. If none found, try again but ;; ignoring the first level of directory, ... - (cl-do* ((files fs (delq nil (mapcar 'diff-filename-drop-dir files))) + (cl-do* ((files fs (delq nil (mapcar #'diff-filename-drop-dir files))) (file nil nil)) ((or (null files) (setq file (cl-do* ((files files (cdr files)) @@ -1018,7 +1077,7 @@ else cover the whole buffer." " ----\n" hunk)) ;;(goto-char (point-min)) (forward-line 1) - (if (not (save-excursion (re-search-forward "^+" nil t))) + (if (not (save-excursion (re-search-forward "^\\+" nil t))) (delete-region (point) (point-max)) (let ((modif nil) (delete nil)) (if (save-excursion (re-search-forward "^\\+.*\n-" @@ -1351,6 +1410,14 @@ See `after-change-functions' for the meaning of BEG, END and LEN." (diff-hunk-next arg) (diff-goto-source)) +(defun diff--font-lock-cleanup () + (remove-overlays nil nil 'diff-mode 'fine) + (remove-overlays nil nil 'diff-mode 'syntax) + (when font-lock-mode + (make-local-variable 'font-lock-extra-managed-props) + ;; Added when diff--font-lock-prettify is non-nil! + (cl-pushnew 'display font-lock-extra-managed-props))) + (defvar whitespace-style) (defvar whitespace-trailing-regexp) @@ -1368,12 +1435,10 @@ You can also switch between context diff and unified diff with \\[diff-context-> or vice versa with \\[diff-unified->context] and you can also reverse the direction of a diff with \\[diff-reverse-direction]. - \\{diff-mode-map}" +\\{diff-mode-map}" (set (make-local-variable 'font-lock-defaults) diff-font-lock-defaults) - (add-hook 'font-lock-mode-hook - (lambda () (remove-overlays nil nil 'diff-mode 'fine)) - nil 'local) + (add-hook 'font-lock-mode-hook #'diff--font-lock-cleanup nil 'local) (set (make-local-variable 'outline-regexp) diff-outline-regexp) (set (make-local-variable 'imenu-generic-expression) diff-imenu-generic-expression) @@ -1387,12 +1452,12 @@ a diff with \\[diff-reverse-direction]. ;; (set (make-local-variable 'paragraph-separate) paragraph-start) ;; (set (make-local-variable 'page-delimiter) "--- [^\t]+\t") ;; compile support - (set (make-local-variable 'next-error-function) 'diff-next-error) + (set (make-local-variable 'next-error-function) #'diff-next-error) (set (make-local-variable 'beginning-of-defun-function) - 'diff-beginning-of-file-and-junk) + #'diff-beginning-of-file-and-junk) (set (make-local-variable 'end-of-defun-function) - 'diff-end-of-file) + #'diff-end-of-file) (diff-setup-whitespace) @@ -1400,10 +1465,10 @@ a diff with \\[diff-reverse-direction]. (setq buffer-read-only t)) ;; setup change hooks (if (not diff-update-on-the-fly) - (add-hook 'write-contents-functions 'diff-write-contents-hooks nil t) + (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)) + (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) @@ -1415,28 +1480,27 @@ a diff with \\[diff-reverse-direction]. nil t)) ;; add-log support (set (make-local-variable 'add-log-current-defun-function) - 'diff-current-defun) + #'diff-current-defun) (set (make-local-variable 'add-log-buffer-file-name-function) (lambda () (diff-find-file-name nil 'noprompt))) - (unless (buffer-file-name) + (add-function :filter-return (local 'filter-buffer-substring-function) + #'diff--filter-substring) + (unless buffer-file-name (hack-dir-local-variables-non-file-buffer))) ;;;###autoload (define-minor-mode diff-minor-mode "Toggle Diff minor mode. -With a prefix argument ARG, enable Diff minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. \\{diff-minor-mode-map}" :group 'diff-mode :lighter " Diff" ;; FIXME: setup font-lock ;; setup change hooks (if (not diff-update-on-the-fly) - (add-hook 'write-contents-functions 'diff-write-contents-hooks nil t) + (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))) + (add-hook 'after-change-functions #'diff-after-change-function nil t) + (add-hook 'post-command-hook #'diff-post-command-hook nil t))) ;;; Handy hook functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1463,12 +1527,12 @@ modified lines of the diff." ;; can just remove the file altogether. Very handy for .rej files if we ;; remove hunks as we apply them. (when (and buffer-file-name - (eq 0 (nth 7 (file-attributes buffer-file-name)))) + (eq 0 (file-attribute-size (file-attributes buffer-file-name)))) (delete-file buffer-file-name))) (defun diff-delete-empty-files () "Arrange for empty diff files to be removed." - (add-hook 'after-save-hook 'diff-delete-if-empty nil t)) + (add-hook 'after-save-hook #'diff-delete-if-empty nil t)) (defun diff-make-unified () "Turn context diffs into unified diffs if applicable." @@ -1662,10 +1726,11 @@ char-offset in TEXT." (delete-region divider-pos (point-max))) (delete-region (point-min) keep)) ;; Remove line-prefix characters, and unneeded lines (unified diffs). - (let ((kill-char (if destp ?- ?+))) + ;; Also skip lines like "\ No newline at end of file" + (let ((kill-chars (list (if destp ?- ?+) ?\\))) (goto-char (point-min)) (while (not (eobp)) - (if (eq (char-after) kill-char) + (if (memq (char-after) kill-chars) (delete-region (point) (progn (forward-line 1) (point))) (delete-char num-pfx-chars) (forward-line 1))))) @@ -1693,7 +1758,7 @@ If TEXT isn't found, nil is returned." Whitespace differences are ignored." (let* ((orig (point)) (re (concat "^[ \t\n]*" - (mapconcat 'regexp-quote (split-string text) "[ \t\n]+") + (mapconcat #'regexp-quote (split-string text) "[ \t\n]+") "[ \t\n]*\n")) (forw (and (re-search-forward re nil t) (cons (match-beginning 0) (match-end 0)))) @@ -1742,7 +1807,15 @@ NOPROMPT, if non-nil, means not to prompt the user." (match-string 1))))) (file (or (diff-find-file-name other noprompt) (error "Can't find the file"))) - (buf (find-file-noselect file))) + (revision (and other diff-vc-backend + (if reverse (nth 1 diff-vc-revisions) + (or (nth 0 diff-vc-revisions) + ;; When diff shows changes in working revision + (vc-working-revision file))))) + (buf (if revision + (let ((vc-find-revision-no-save t)) + (vc-find-revision (expand-file-name file) revision diff-vc-backend)) + (find-file-noselect file)))) ;; Update the user preference if he so wished. (when (> (prefix-numeric-value other-file) 8) (setq diff-jump-to-old-file other)) @@ -1868,18 +1941,24 @@ With a prefix argument, try to REVERSE the hunk." `diff-jump-to-old-file' (or its opposite if the OTHER-FILE prefix arg is given) determines whether to jump to the old or the new file. If the prefix arg is bigger than 8 (for example with \\[universal-argument] \\[universal-argument]) -then `diff-jump-to-old-file' is also set, for the next invocations." +then `diff-jump-to-old-file' is also set, for the next invocations. + +Under version control, the OTHER-FILE prefix arg means jump to the old +revision of the file if point is on an old changed line, or to the new +revision of the file otherwise." (interactive (list current-prefix-arg last-input-event)) ;; When pointing at a removal line, we probably want to jump to ;; the old location, and else to the new (i.e. as if reverting). ;; This is a convenient detail when using smerge-diff. (if event (posn-set-point (event-end event))) - (let ((rev (not (save-excursion (beginning-of-line) (looking-at "[-<]"))))) + (let ((buffer (when event (current-buffer))) + (reverse (not (save-excursion (beginning-of-line) (looking-at "[-<]"))))) (pcase-let ((`(,buf ,line-offset ,pos ,src ,_dst ,switched) - (diff-find-source-location other-file rev))) + (diff-find-source-location other-file reverse))) (pop-to-buffer buf) (goto-char (+ (car pos) (cdr src))) - (diff-hunk-status-msg line-offset (diff-xor rev switched) t)))) + (when buffer (next-error-found buffer (current-buffer))) + (diff-hunk-status-msg line-offset (diff-xor reverse switched) t)))) (defun diff-current-defun () @@ -1968,29 +2047,30 @@ For use in `add-log-current-defun-function'." (((class color) (min-colors 88) (background dark)) :background "#aaaa22") (t :inverse-video t)) - "Face used for char-based changes shown by `diff-refine-hunk'." - :group 'diff-mode) + "Face used for char-based changes shown by `diff-refine-hunk'.") (defface diff-refine-removed '((default :inherit diff-refine-changed) + (((class color) (min-colors 257) (background light)) + :background "#ffcccc") (((class color) (min-colors 88) (background light)) :background "#ffbbbb") (((class color) (min-colors 88) (background dark)) :background "#aa2222")) "Face used for removed characters shown by `diff-refine-hunk'." - :group 'diff-mode :version "24.3") (defface diff-refine-added '((default :inherit diff-refine-changed) + (((class color) (min-colors 257) (background light)) + :background "#bbffbb") (((class color) (min-colors 88) (background light)) :background "#aaffaa") (((class color) (min-colors 88) (background dark)) :background "#22aa22")) "Face used for added characters shown by `diff-refine-hunk'." - :group 'diff-mode :version "24.3") (defun diff-refine-preproc () @@ -2017,59 +2097,112 @@ Return new point, if it was moved." (defun diff-refine-hunk () "Highlight changes of hunk at point at a finer granularity." (interactive) - (require 'smerge-mode) (when (diff--some-hunks-p) (save-excursion - (diff-beginning-of-hunk t) - (let* ((start (point)) - (style (diff-hunk-style)) ;Skips the hunk header as well. - (beg (point)) - (props-c '((diff-mode . fine) (face diff-refine-changed))) - (props-r '((diff-mode . fine) (face diff-refine-removed))) - (props-a '((diff-mode . fine) (face diff-refine-added))) - ;; Be careful to go back to `start' so diff-end-of-hunk gets - ;; to read the hunk header's line info. - (end (progn (goto-char start) (diff-end-of-hunk) (point)))) - - (remove-overlays beg end 'diff-mode 'fine) + (let ((beg (diff-beginning-of-hunk t)) + ;; Be careful to start from the hunk header so diff-end-of-hunk + ;; gets to read the hunk header's line info. + (end (progn (diff-end-of-hunk) (point)))) + (diff--refine-hunk beg end))))) +(defun diff--refine-hunk (start end) + (require 'smerge-mode) + (goto-char start) + (let* ((style (diff-hunk-style)) ;Skips the hunk header as well. + (beg (point)) + (props-c '((diff-mode . fine) (face . diff-refine-changed))) + (props-r '((diff-mode . fine) (face . diff-refine-removed))) + (props-a '((diff-mode . fine) (face . diff-refine-added)))) + + (remove-overlays beg end 'diff-mode 'fine) + + (goto-char beg) + (pcase style + ('unified + (while (re-search-forward "^-" end t) + (let ((beg-del (progn (beginning-of-line) (point))) + beg-add end-add) + (when (and (diff--forward-while-leading-char ?- end) + ;; Allow for "\ No newline at end of file". + (progn (diff--forward-while-leading-char ?\\ end) + (setq beg-add (point))) + (diff--forward-while-leading-char ?+ end) + (progn (diff--forward-while-leading-char ?\\ end) + (setq end-add (point)))) + (smerge-refine-regions beg-del beg-add beg-add end-add + nil #'diff-refine-preproc props-r props-a))))) + ('context + (let* ((middle (save-excursion (re-search-forward "^---" end))) + (other middle)) + (while (re-search-forward "^\\(?:!.*\n\\)+" middle t) + (smerge-refine-regions (match-beginning 0) (match-end 0) + (save-excursion + (goto-char other) + (re-search-forward "^\\(?:!.*\n\\)+" end) + (setq other (match-end 0)) + (match-beginning 0)) + other + (if diff-use-changed-face props-c) + #'diff-refine-preproc + (unless diff-use-changed-face props-r) + (unless diff-use-changed-face props-a))))) + (_ ;; Normal diffs. + (let ((beg1 (1+ (point)))) + (when (re-search-forward "^---.*\n" end t) + ;; It's a combined add&remove, so there's something to do. + (smerge-refine-regions beg1 (match-beginning 0) + (match-end 0) end + nil #'diff-refine-preproc props-r props-a))))))) + +(defun diff--iterate-hunks (max fun) + "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) - (pcase style - (`unified - (while (re-search-forward "^-" end t) - (let ((beg-del (progn (beginning-of-line) (point))) - beg-add end-add) - (when (and (diff--forward-while-leading-char ?- end) - ;; Allow for "\ No newline at end of file". - (progn (diff--forward-while-leading-char ?\\ end) - (setq beg-add (point))) - (diff--forward-while-leading-char ?+ end) - (progn (diff--forward-while-leading-char ?\\ end) - (setq end-add (point)))) - (smerge-refine-regions beg-del beg-add beg-add end-add - nil 'diff-refine-preproc props-r props-a))))) - (`context - (let* ((middle (save-excursion (re-search-forward "^---"))) - (other middle)) - (while (re-search-forward "^\\(?:!.*\n\\)+" middle t) - (smerge-refine-regions (match-beginning 0) (match-end 0) - (save-excursion - (goto-char other) - (re-search-forward "^\\(?:!.*\n\\)+" end) - (setq other (match-end 0)) - (match-beginning 0)) - other - (if diff-use-changed-face props-c) - 'diff-refine-preproc - (unless diff-use-changed-face props-r) - (unless diff-use-changed-face props-a))))) - (_ ;; Normal diffs. - (let ((beg1 (1+ (point)))) - (when (re-search-forward "^---.*\n" end t) - ;; It's a combined add&remove, so there's something to do. - (smerge-refine-regions beg1 (match-beginning 0) - (match-end 0) end - nil 'diff-refine-preproc props-r props-a))))))))) + (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)))))))) + +(defun diff--font-lock-refined (max) + "Apply hunk refinement from font-lock." + (when (eq diff-refine 'font-lock) + (when (get-char-property (point) 'diff--font-lock-refined) + ;; Refinement works over a complete hunk, whereas font-lock limits itself + ;; to highlighting smallish chunks between point..max, so we may be + ;; called N times for a large hunk in which case we don't want to + ;; rehighlight that hunk N times (especially since each highlighting + ;; of a large hunk can itself take a long time, adding insult to injury). + ;; So, after refining a hunk (including a failed attempt), we place an + ;; overlay over the whole hunk to mark it as refined, to avoid redoing + ;; the job redundantly when asked to highlight subsequent parts of the + ;; same hunk. + (goto-char (next-single-char-property-change + (point) 'diff--font-lock-refined nil max))) + (diff--iterate-hunks + max + (lambda (beg end) + (unless (get-char-property beg 'diff--font-lock-refined) + (diff--refine-hunk beg end) + (let ((ol (make-overlay beg end))) + (overlay-put ol 'diff--font-lock-refined t) + (overlay-put ol 'diff-mode 'fine) + (overlay-put ol 'evaporate t) + (overlay-put ol 'modification-hooks + '(diff--overlay-auto-delete)))))))) + +(defun diff--overlay-auto-delete (ol _after _beg _end &optional _len) + (delete-overlay ol)) (defun diff-undo (&optional arg) "Perform `undo', ignoring the buffer's read-only status." @@ -2095,7 +2228,7 @@ I.e. like `add-change-log-entry-other-window' but applied to all hunks." ;; `add-change-log-entry-other-window' works better in ;; that case. (re-search-forward - (concat "\n[!+-<>]" + (concat "\n[!+<>-]" ;; If the hunk is a context hunk with an empty first ;; half, recognize the "--- NNN,MMM ----" line "\\(-- [0-9]+\\(,[0-9]+\\)? ----\n" @@ -2175,6 +2308,385 @@ fixed, visit it in a buffer." modified-buffers ", ")) (message "No trailing whitespace to delete."))))) + +;;; Prettifying from font-lock + +(define-fringe-bitmap 'diff-fringe-add + [#b00000000 + #b00000000 + #b00010000 + #b00010000 + #b01111100 + #b00010000 + #b00010000 + #b00000000 + #b00000000] + nil nil 'center) + +(define-fringe-bitmap 'diff-fringe-del + [#b00000000 + #b00000000 + #b00000000 + #b00000000 + #b01111100 + #b00000000 + #b00000000 + #b00000000 + #b00000000] + nil nil 'center) + +(define-fringe-bitmap 'diff-fringe-rep + [#b00000000 + #b00010000 + #b00010000 + #b00010000 + #b00010000 + #b00010000 + #b00000000 + #b00010000 + #b00000000] + nil nil 'center) + +(define-fringe-bitmap 'diff-fringe-nul + ;; Maybe there should be such an "empty" bitmap defined by default? + [#b00000000 + #b00000000 + #b00000000 + #b00000000 + #b00000000 + #b00000000 + #b00000000 + #b00000000 + #b00000000] + nil nil 'center) + +(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)))))) + (put-text-property (match-beginning 0) (match-end 0) 'display spec)))) + ;; Mimicks the output of Magit's diff. + ;; FIXME: This has only been tested with Git's diff output. + (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! + (when (save-excursion + (forward-line 0) + (looking-at + (eval-when-compile + (concat "diff.*\n" + "\\(?:\\(?:new file\\|deleted\\).*\n\\)?" + "\\(?:index.*\n\\)?" + "--- \\(?:/dev/null\\|a/\\(.*\\)\\)\n" + "\\+\\+\\+ \\(?:/dev/null\\|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 ""))))) + nil) + +;;; Syntax highlighting from font-lock + +(defun diff--font-lock-syntax (max) + "Apply source language syntax highlighting from font-lock. +Calls `diff-syntax-fontify' on every hunk found between point +and the position in MAX." + (when diff-font-lock-syntax + (when (get-char-property (point) 'diff--font-lock-syntax) + (goto-char (next-single-char-property-change + (point) 'diff--font-lock-syntax nil max))) + (diff--iterate-hunks + max + (lambda (beg end) + (unless (get-char-property beg 'diff--font-lock-syntax) + (diff-syntax-fontify beg end) + (let ((ol (make-overlay beg end))) + (overlay-put ol 'diff--font-lock-syntax t) + (overlay-put ol 'diff-mode 'syntax) + (overlay-put ol 'evaporate t) + (overlay-put ol 'modification-hooks + '(diff--overlay-auto-delete)))))))) + +(defun diff-syntax-fontify (beg end) + "Highlight source language syntax in diff hunk between BEG and END." + (remove-overlays beg end 'diff-mode 'syntax) + (save-excursion + (diff-syntax-fontify-hunk beg end t) + (diff-syntax-fontify-hunk beg end nil))) + +(eval-when-compile (require 'subr-x)) ; for string-trim-right + +(defvar-local diff--syntax-file-attributes nil) +(put 'diff--syntax-file-attributes 'permanent-local t) + +(defun diff-syntax-fontify-hunk (beg end old) + "Highlight source language syntax in diff hunk between BEG and END. +When OLD is non-nil, highlight the hunk from the old source." + (goto-char beg) + (let* ((hunk (buffer-substring-no-properties beg end)) + ;; 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)) + ""))) + (line (if (looking-at "\\(?:\\*\\{15\\}.*\n\\)?[-@* ]*\\([0-9,]+\\)\\([ acd+]+\\([0-9,]+\\)\\)?") + (if old (match-string 1) + (if (match-end 3) (match-string 3) (match-string 1))))) + (line-nb (when line + (if (string-match "\\([0-9]+\\),\\([0-9]+\\)" line) + (list (string-to-number (match-string 1 line)) + (string-to-number (match-string 2 line))) + (list (string-to-number line) 1)))) ; One-line diffs + (props + (or + (when (and diff-vc-backend + (not (eq diff-font-lock-syntax 'hunk-only))) + (let* ((file (diff-find-file-name old t)) + (file (and file (expand-file-name file))) + (revision (and file (if (not old) (nth 1 diff-vc-revisions) + (or (nth 0 diff-vc-revisions) + (vc-working-revision file)))))) + (when file + (if (not revision) + ;; Get properties from the current working revision + (when (and (not old) (file-readable-p file) + (file-regular-p file)) + (let ((buf (get-file-buffer file))) + ;; Try to reuse an existing buffer + (if buf + (with-current-buffer buf + (diff-syntax-fontify-props nil text line-nb)) + ;; Get properties from the file. + (with-current-buffer (get-buffer-create + " *diff-syntax-file*") + (let ((attrs (file-attributes file))) + (if (equal diff--syntax-file-attributes attrs) + ;; Same file as last-time, unmodified. + ;; Reuse buffer as-is. + (setq file nil) + (erase-buffer) + (insert-file-contents file) + (setq diff--syntax-file-attributes attrs))) + (diff-syntax-fontify-props file text line-nb))))) + ;; Get properties from a cached revision + (let* ((buffer-name (format " *diff-syntax:%s.~%s~*" + file revision)) + (buffer (get-buffer buffer-name))) + (if buffer + ;; Don't re-initialize the buffer (which would throw + ;; away the previous fontification work). + (setq file nil) + (setq buffer (ignore-errors + (vc-find-revision-no-save + file revision + diff-vc-backend + (get-buffer-create buffer-name))))) + (when buffer + (with-current-buffer buffer + (diff-syntax-fontify-props file text line-nb)))))))) + (let ((file (car (diff-hunk-file-names old)))) + (cond + ((and file diff-default-directory + (not (eq diff-font-lock-syntax 'hunk-only)) + (not diff-vc-backend) + (file-readable-p file) (file-regular-p file)) + ;; Try to get full text from the file. + (with-temp-buffer + (insert-file-contents file) + (diff-syntax-fontify-props file text line-nb))) + ;; Otherwise, get properties from the hunk alone + ((memq diff-font-lock-syntax '(hunk-also hunk-only)) + (with-temp-buffer + (insert text) + (diff-syntax-fontify-props file text line-nb t)))))))) + + ;; Put properties over the hunk text + (goto-char beg) + (when (and props (eq (diff-hunk-style) 'unified)) + (while (< (progn (forward-line 1) (point)) end) + ;; Skip the "\ No newline at end of file" lines as well as the lines + ;; corresponding to the "other" version. + (unless (looking-at-p (if old "[+>\\]" "[-<\\]")) + (if (and old (not (looking-at-p "[-<]"))) + ;; Fontify context lines only from new source, + ;; don't refontify context lines from old source. + (pop props) + (let ((line-props (pop props)) + (bol (1+ (point)))) + (dolist (prop line-props) + ;; Ideally, we'd want to use text-properties as in: + ;; + ;; (add-face-text-property + ;; (+ bol (nth 0 prop)) (+ bol (nth 1 prop)) + ;; (nth 2 prop) 'append) + ;; + ;; rather than overlays here, but they'd get removed by later + ;; font-locking. + ;; This is because we also apply faces outside of the + ;; beg...end chunk currently font-locked and when font-lock + ;; later comes to handle the rest of the hunk that we already + ;; handled we don't (want to) redo it (we work at + ;; hunk-granularity rather than font-lock's own chunk + ;; granularity). + ;; I see two ways to fix this: + ;; - don't immediately apply the props that fall outside of + ;; font-lock's chunk but stash them somewhere (e.g. in another + ;; text property) and only later when font-lock comes back + ;; move them to `face'. + ;; - change the code so work at font-lock's chunk granularity + ;; (this seems doable without too much extra overhead, + ;; contrary to the refine highlighting, which inherently + ;; works at a different granularity). + (let ((ol (make-overlay (+ bol (nth 0 prop)) + (+ bol (nth 1 prop)) + nil 'front-advance nil))) + (overlay-put ol 'diff-mode 'syntax) + (overlay-put ol 'evaporate t) + (overlay-put ol 'face (nth 2 prop))))))))))) + +(defun diff-syntax-fontify-props (file text line-nb &optional hunk-only) + "Get font-lock properties from the source code. +FILE is the name of the source file. If non-nil, it requests initialization +of the mode according to FILE. +TEXT is the literal source text from hunk. +LINE-NB is a pair of numbers: start line number and the number of +lines in the hunk. +When HUNK-ONLY is non-nil, then don't verify the existence of the +hunk text in the source file. Otherwise, don't highlight the hunk if the +hunk text is not found in the source file." + (when file + ;; When initialization is requested, we should be in a brand new + ;; temp buffer. + (cl-assert (null buffer-file-name)) + (let ((enable-local-variables :safe) ;; to find `mode:' + (buffer-file-name file)) + (set-auto-mode) + ;; FIXME: Is this really worth the trouble? + (when (and (fboundp 'generic-mode-find-file-hook) + (memq #'generic-mode-find-file-hook + ;; There's no point checking the buffer-local value, + ;; we're in a fresh new buffer. + (default-value 'find-file-hook))) + (generic-mode-find-file-hook)))) + + (let ((font-lock-defaults (or font-lock-defaults '(nil t))) + props beg end) + (goto-char (point-min)) + (if hunk-only + (setq beg (point-min) end (point-max)) + (forward-line (1- (nth 0 line-nb))) + ;; non-regexp looking-at to compare hunk text for verification + (if (search-forward text (+ (point) (length text)) t) + (setq beg (- (point) (length text)) end (point)) + (goto-char (point-min)) + (if (search-forward text nil t) + (setq beg (- (point) (length text)) end (point))))) + + (when (and beg end) + (goto-char beg) + (font-lock-ensure beg end) + + (while (< (point) end) + (let* ((bol (point)) + (eol (line-end-position)) + line-props + (searching t) + (from (point)) to + (val (get-text-property from 'face))) + (while searching + (setq to (next-single-property-change from 'face nil eol)) + (when val (push (list (- from bol) (- to bol) val) line-props)) + (setq val (get-text-property to 'face) from to) + (unless (< to eol) (setq searching nil))) + (when val (push (list from eol val) line-props)) + (push (nreverse line-props) props)) + (forward-line 1))) + (nreverse props))) + + +(defun diff--filter-substring (str) + (when diff-font-lock-prettify + ;; Strip the `display' properties added by diff-font-lock-prettify, + ;; since they look weird when you kill&yank! + (remove-text-properties 0 (length str) '(display nil) str) + ;; We could also try to only remove those `display' properties actually + ;; added by diff-font-lock-prettify rather than removing them all blindly. + ;; E.g.: + ;;(let ((len (length str)) + ;; (i 0)) + ;; (while (and (< i len) + ;; (setq i (text-property-not-all i len 'display nil str))) + ;; (let* ((val (get-text-property i 'display str)) + ;; (end (or (text-property-not-all i len 'display val str) len))) + ;; ;; FIXME: Check for display props that prettify the file header! + ;; (when (eq 'left-fringe (car-safe val)) + ;; ;; FIXME: Should we check that it's a diff-fringe-* bitmap? + ;; (remove-text-properties i end '(display nil) str)) + ;; (setq i end)))) + ) + str) + +;;; Support for converting a diff to diff3 markers via `wiggle'. + +;; Wiggle can be found at http://neil.brown.name/wiggle/ or in your nearest +;; Debian repository. + +(defun diff-wiggle () + "Use `wiggle' to apply the whole current file diff by hook or by crook. +When a hunk can't cleanly be applied, it gets turned into a diff3-style +conflict." + (interactive) + (let* ((bounds (diff-bounds-of-file)) + (file (diff-find-file-name)) + (tmpbuf (current-buffer)) + (filebuf (find-buffer-visiting file)) + (patchfile (make-temp-file + (expand-file-name "wiggle" (file-name-directory file)) + nil ".diff")) + (errfile (make-temp-file + (expand-file-name "wiggle" (file-name-directory file)) + nil ".error"))) + (unwind-protect + (with-temp-buffer + (set-buffer (prog1 tmpbuf (setq tmpbuf (current-buffer)))) + (when (buffer-modified-p filebuf) + (save-some-buffers nil (lambda () (eq (current-buffer) filebuf))) + (if (buffer-modified-p filebuf) (user-error "Abort!"))) + (write-region (car bounds) (cadr bounds) patchfile nil 'silent) + (let ((exitcode + (call-process "wiggle" nil (list tmpbuf errfile) nil + file patchfile))) + (if (not (memq exitcode '(0 1))) + (message "diff-wiggle error: %s" + (with-current-buffer tmpbuf + (goto-char (point-min)) + (insert-file-contents errfile) + (buffer-string))) + (with-current-buffer tmpbuf + (write-region nil nil file nil 'silent) + (with-current-buffer filebuf + (revert-buffer t t t) + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "^<<<<<<<" nil t) + (smerge-mode 1))) + (pop-to-buffer filebuf)))))) + (delete-file patchfile) + (delete-file errfile)))) + ;; provide the package (provide 'diff-mode) diff --git a/lisp/vc/diff.el b/lisp/vc/diff.el index c04ff17ade7..5fa771f5f1e 100644 --- a/lisp/vc/diff.el +++ b/lisp/vc/diff.el @@ -121,6 +121,17 @@ Possible values are: nil -- no, it does not check -- try to probe whether it does") +(defvar diff-default-directory) + +(defun diff-check-labels (&optional force) + (if (not (or force (eq 'check diff-use-labels))) + diff-use-labels + (setq diff-use-labels + (with-temp-buffer + (when (ignore-errors + (call-process diff-command nil t nil "--help")) + (if (search-backward "--label" nil t) t)))))) + (defun diff-no-select (old new &optional switches no-async buf) ;; Noninteractive helper for creating and reverting diff buffers (unless (bufferp new) (setq new (expand-file-name new))) @@ -128,11 +139,7 @@ Possible values are: (or switches (setq switches diff-switches)) ; If not specified, use default. (unless (listp switches) (setq switches (list switches))) (or buf (setq buf (get-buffer-create "*Diff*"))) - (when (eq 'check diff-use-labels) - (setq diff-use-labels - (with-temp-buffer - (when (ignore-errors (call-process diff-command nil t nil "--help")) - (if (search-backward "--label" nil t) t))))) + (diff-check-labels) (let* ((old-alt (diff-file-local-copy old)) (new-alt (diff-file-local-copy new)) (command @@ -165,6 +172,7 @@ Possible values are: (lambda (_ignore-auto _noconfirm) (diff-no-select old new switches no-async (current-buffer)))) (setq default-directory thisdir) + (setq diff-default-directory default-directory) (let ((inhibit-read-only t)) (insert command "\n")) (if (and (not no-async) (fboundp 'make-process)) @@ -226,8 +234,9 @@ With prefix arg, prompt for diff switches." "View the differences between BUFFER and its associated file. This requires the external program `diff' to be in your `exec-path'." (interactive "bBuffer: ") - (with-current-buffer (get-buffer (or buffer (current-buffer))) - (diff buffer-file-name (current-buffer) nil 'noasync))) + (let ((buf (get-buffer (or buffer (current-buffer))))) + (with-current-buffer (or (buffer-base-buffer buf) buf) + (diff buffer-file-name (current-buffer) nil 'noasync)))) (provide 'diff) diff --git a/lisp/vc/ediff-diff.el b/lisp/vc/ediff-diff.el index a1d27af79d1..d22c9399ac1 100644 --- a/lisp/vc/ediff-diff.el +++ b/lisp/vc/ediff-diff.el @@ -1,4 +1,4 @@ -;;; ediff-diff.el --- diff-related utilities +;;; ediff-diff.el --- diff-related utilities -*- lexical-binding:t -*- ;; Copyright (C) 1994-2019 Free Software Foundation, Inc. @@ -25,8 +25,6 @@ ;;; Code: -(provide 'ediff-diff) - (require 'ediff-init) (require 'ediff-util) @@ -37,13 +35,11 @@ (defcustom ediff-diff-program "diff" "Program to use for generating the differential of the two files." - :type 'string - :group 'ediff-diff) + :type 'string) (defcustom ediff-diff3-program "diff3" "Program to be used for three-way comparison. Must produce output compatible with Unix's diff3 program." - :type 'string - :group 'ediff-diff) + :type 'string) ;; The following functions must precede all defcustom-defined variables. @@ -60,21 +56,18 @@ will do. However, some people set $prompt or other things incorrectly, which leads to undesirable output messages. These may cause Ediff to fail. In such a case, set `ediff-shell' to a shell that you are not using or, better, fix your shell's startup file." - :type 'string - :group 'ediff-diff) + :type 'string) (defcustom ediff-cmp-program "cmp" "Utility to use to determine if two files are identical. It must return code 0, if its arguments are identical files." - :type 'string - :group 'ediff-diff) + :type 'string) (defcustom ediff-cmp-options nil "Options to pass to `ediff-cmp-program'. If GNU diff is used as `ediff-cmp-program', then the most useful options are `-I REGEXP', to ignore changes whose lines match the REGEXP." - :type '(repeat string) - :group 'ediff-diff) + :type '(repeat string)) (defun ediff-set-diff-options (symbol value) (set symbol value) @@ -95,8 +88,7 @@ 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." :set 'ediff-set-diff-options - :type 'string - :group 'ediff-diff) + :type 'string) (ediff-defvar-local ediff-ignore-case nil "If t, skip over difference regions that differ only in letter case. @@ -105,14 +97,12 @@ Use `setq-default' if setting it in .emacs") (defcustom ediff-ignore-case-option "-i" "Option that causes the diff program to ignore case of letters." - :type 'string - :group 'ediff-diff) + :type 'string) (defcustom ediff-ignore-case-option3 "" "Option that causes the diff3 program to ignore case of letters. GNU diff3 doesn't have such an option." - :type 'string - :group 'ediff-diff) + :type 'string) ;; the actual options used in comparison (ediff-defvar-local ediff-actual-diff-options ediff-diff-options "") @@ -120,12 +110,10 @@ GNU diff3 doesn't have such an option." (defcustom ediff-custom-diff-program ediff-diff-program "Program to use for generating custom diff output for saving it in a file. This output is not used by Ediff internally." - :type 'string - :group 'ediff-diff) + :type 'string) (defcustom ediff-custom-diff-options "-c" "Options to pass to `ediff-custom-diff-program'." - :type 'string - :group 'ediff-diff) + :type 'string) ;;; Support for diff3 @@ -134,8 +122,7 @@ This output is not used by Ediff internally." (defcustom ediff-diff3-options "" "Options to pass to `ediff-diff3-program'." :set 'ediff-set-diff-options - :type 'string - :group 'ediff-diff) + :type 'string) ;; the actual options used in comparison (ediff-defvar-local ediff-actual-diff3-options ediff-diff3-options "") @@ -144,8 +131,7 @@ This output is not used by Ediff internally." "^\\([1-3]:\\|====\\| \\|.*Warning *:\\|.*No newline\\|.*missing newline\\|^\C-m$\\)" "Regexp that matches normal output lines from `ediff-diff3-program'. Lines that do not match are assumed to be error messages." - :type 'regexp - :group 'ediff-diff) + :type 'regexp) ;; keeps the status of the current diff in 3-way jobs. ;; the status can be =diff(A), =diff(B), or =diff(A+B) @@ -842,7 +828,7 @@ delimiter regions")) ) (setq overlay-list (reverse overlay-list)) (ediff-set-fine-diff-vector - reg-num 'C (apply 'vector overlay-list)) + reg-num 'C (apply #'vector overlay-list)) )) @@ -1170,30 +1156,30 @@ are ignored." (eq buffer ediff-fine-diff-buffer) (setq args (delete "--binary" args))) (unwind-protect - (let ((directory default-directory) - proc) - (with-current-buffer buffer - (erase-buffer) - (setq default-directory directory) - (if (or (memq system-type '(ms-dos windows-nt)) - synch) - ;; In Windows do it synchronously, since Windows doesn't let us - ;; delete files used by other processes. Thus, in ediff-buffers - ;; and similar functions, we can't delete temp files because - ;; they might be used by the asynch process that computes - ;; custom diffs. So, we have to wait till custom diff - ;; subprocess is done. - ;; In DOS, must synchronize because DOS doesn't have - ;; asynchronous processes. - (apply 'call-process program nil buffer nil args) - ;; On other systems, do it asynchronously. - (setq proc (get-buffer-process buffer)) - (if proc (kill-process proc)) - (setq proc - (apply 'start-process "Custom Diff" buffer program args)) + (with-current-buffer buffer + (erase-buffer) + ;; default-directory may be on some remote machine + ;; (e.g. accessed via Tramp or url-handler) or a non-existing dir. + (setq default-directory "/") + (if (or (memq system-type '(ms-dos windows-nt)) + synch) + ;; In Windows do it synchronously, since Windows doesn't let us + ;; delete files used by other processes. Thus, in ediff-buffers + ;; and similar functions, we can't delete temp files because + ;; they might be used by the asynch process that computes + ;; custom diffs. So, we have to wait till custom diff + ;; subprocess is done. + ;; In DOS, must synchronize because DOS doesn't have + ;; asynchronous processes. + (apply #'call-process program nil buffer nil args) + ;; On other systems, do it asynchronously. + (let ((proc (get-buffer-process buffer))) + (if proc (kill-process proc))) + (let ((proc + (apply #'start-process "Custom Diff" buffer program args))) (setq mode-line-process '(":%s")) - (set-process-sentinel proc 'ediff-process-sentinel) - (set-process-filter proc 'ediff-process-filter) + (set-process-sentinel proc #'ediff-process-sentinel) + (set-process-filter proc #'ediff-process-filter) ))) (store-match-data data)))) @@ -1235,10 +1221,9 @@ are ignored." ;;; Word functions used to refine the current diff -(defvar ediff-forward-word-function 'ediff-forward-word +(defvar-local ediff-forward-word-function #'ediff-forward-word "Function to call to move to the next word. Used for splitting difference regions into individual words.") -(make-variable-buffer-local 'ediff-forward-word-function) ;; \240 is Unicode symbol for nonbreakable whitespace (defvar ediff-whitespace " \n\t\f\r\240" @@ -1358,7 +1343,7 @@ arguments to `skip-chars-forward'." (let ((res ;; In the remote case, this works only if F1 and F2 are ;; located on the same remote host. - (apply 'process-file ediff-cmp-program nil nil nil + (apply #'process-file ediff-cmp-program nil nil nil (append ediff-cmp-options (list (expand-file-name (file-local-name f1)) (expand-file-name (file-local-name f2))))) @@ -1418,8 +1403,8 @@ affects only files whose names match the expression." ;; First, check only the names (works quickly and ensures a ;; precondition for subsequent code) (if (and (= (length entries-1) (length entries-2)) - (equal (mapcar 'file-name-nondirectory entries-1) - (mapcar 'file-name-nondirectory entries-2))) + (equal (mapcar #'file-name-nondirectory entries-1) + (mapcar #'file-name-nondirectory entries-2))) ;; With name equality established, compare the entries ;; through recursion. (let ((continue t)) @@ -1482,12 +1467,5 @@ affects only files whose names match the expression." (ediff-update-diffs))) ) - - -;; Local Variables: -;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;; End: - +(provide 'ediff-diff) ;;; ediff-diff.el ends here diff --git a/lisp/vc/ediff-help.el b/lisp/vc/ediff-help.el index 11c8b35bca2..05f17acc1e7 100644 --- a/lisp/vc/ediff-help.el +++ b/lisp/vc/ediff-help.el @@ -1,4 +1,4 @@ -;;; ediff-help.el --- Code related to the contents of Ediff help buffers +;;; ediff-help.el --- Code related to the contents of Ediff help buffers -*- lexical-binding:t -*- ;; Copyright (C) 1996-2019 Free Software Foundation, Inc. @@ -30,6 +30,7 @@ ;; end pacifier (require 'ediff-init) +(defvar ediff-multiframe) ;; Help messages @@ -269,8 +270,7 @@ the value of this variable and the variables `ediff-help-message-*' in (defun ediff-set-help-message () (setq ediff-long-help-message (cond ((and ediff-long-help-message-function - (or (symbolp ediff-long-help-message-function) - (consp ediff-long-help-message-function))) + (functionp ediff-long-help-message-function)) (funcall ediff-long-help-message-function)) (ediff-word-mode (concat ediff-long-help-message-head @@ -294,8 +294,7 @@ the value of this variable and the variables `ediff-help-message-*' in ediff-long-help-message-tail)))) (setq ediff-brief-help-message (cond ((and ediff-brief-help-message-function - (or (symbolp ediff-brief-help-message-function) - (consp ediff-brief-help-message-function))) + (functionp ediff-brief-help-message-function)) (funcall ediff-brief-help-message-function)) ((stringp ediff-brief-help-message-function) ediff-brief-help-message-function) @@ -315,6 +314,4 @@ the value of this variable and the variables `ediff-help-message-*' in (provide 'ediff-help) - - ;;; ediff-help.el ends here diff --git a/lisp/vc/ediff-hook.el b/lisp/vc/ediff-hook.el index 84122150ad3..7a04249fc85 100644 --- a/lisp/vc/ediff-hook.el +++ b/lisp/vc/ediff-hook.el @@ -1,4 +1,4 @@ -;;; ediff-hook.el --- setup for Ediff's menus and autoloads +;;; ediff-hook.el --- setup for Ediff's menus and autoloads -*- lexical-binding:t -*- ;; Copyright (C) 1995-2019 Free Software Foundation, Inc. @@ -43,7 +43,6 @@ ;; end pacifier ;; allow menus to be set up without ediff-wind.el being loaded -(defvar ediff-window-setup-function) ;; This autoload is useless in Emacs because ediff-hook.el is dumped with ;; emacs, but it is needed in XEmacs @@ -114,10 +113,8 @@ ["Use separate frame for Ediff control buffer" ediff-toggle-multiframe :style toggle - :selected (if (and (featurep 'ediff-util) - (boundp 'ediff-window-setup-function)) - (eq ediff-window-setup-function - 'ediff-setup-windows-multiframe))] + :selected (eq (bound-and-true-p ediff-window-setup-function) + #'ediff-setup-windows-multiframe)] ["Use a toolbar with Ediff control buffer" ediff-toggle-use-toolbar :style toggle @@ -133,14 +130,14 @@ (defvar menu-bar-ediff-misc-menu (make-sparse-keymap "Ediff Miscellanea")) (fset 'menu-bar-ediff-misc-menu - (symbol-value 'menu-bar-ediff-misc-menu)) + menu-bar-ediff-misc-menu) (defvar menu-bar-epatch-menu (make-sparse-keymap "Apply Patch")) - (fset 'menu-bar-epatch-menu (symbol-value 'menu-bar-epatch-menu)) + (fset 'menu-bar-epatch-menu menu-bar-epatch-menu) (defvar menu-bar-ediff-merge-menu (make-sparse-keymap "Merge")) (fset 'menu-bar-ediff-merge-menu - (symbol-value 'menu-bar-ediff-merge-menu)) + menu-bar-ediff-merge-menu) (defvar menu-bar-ediff-menu (make-sparse-keymap "Compare")) - (fset 'menu-bar-ediff-menu (symbol-value 'menu-bar-ediff-menu)) + (fset 'menu-bar-ediff-menu menu-bar-ediff-menu) ;; define ediff compare menu (define-key menu-bar-ediff-menu [ediff-misc] @@ -245,7 +242,15 @@ (define-key menu-bar-ediff-misc-menu [emultiframe] `(menu-item ,(purecopy "Use separate control buffer frame") ediff-toggle-multiframe - :help ,(purecopy "Switch between the single-frame presentation mode and the multi-frame mode"))) + :help ,(purecopy "Switch between the single-frame presentation mode and the multi-frame mode") + :button (:toggle . (eq (bound-and-true-p ediff-window-setup-function) + #'ediff-setup-windows-multiframe)))) + ;; FIXME: Port XEmacs's toolbar support! + ;; ["Use a toolbar with Ediff control buffer" + ;; ediff-toggle-use-toolbar + ;; :style toggle + ;; :selected (if (featurep 'ediff-tbar) + ;; (ediff-use-toolbar-p))] (define-key menu-bar-ediff-misc-menu [eregistry] `(menu-item ,(purecopy "List Ediff Sessions") ediff-show-registry :help ,(purecopy "List all active Ediff sessions; it is a convenient way to find and resume such a session"))) @@ -257,6 +262,4 @@ :help ,(purecopy "Bring up the Ediff manual")))) (provide 'ediff-hook) - - ;;; ediff-hook.el ends here diff --git a/lisp/vc/ediff-init.el b/lisp/vc/ediff-init.el index c1526235dea..f98a7ed560c 100644 --- a/lisp/vc/ediff-init.el +++ b/lisp/vc/ediff-init.el @@ -1,4 +1,4 @@ -;;; ediff-init.el --- Macros, variables, and defsubsts used by Ediff +;;; ediff-init.el --- Macros, variables, and defsubsts used by Ediff -*- lexical-binding:t -*- ;; Copyright (C) 1994-2019 Free Software Foundation, Inc. @@ -86,7 +86,7 @@ that Ediff doesn't know about.") ;; Plagiarized from `emerge-defvar-local' for XEmacs. (defmacro ediff-defvar-local (var value doc) "Defines VAR as a local variable." - (declare (indent defun)) + (declare (indent defun) (doc-string 3)) `(progn (defvar ,var ,value ,doc) (make-variable-buffer-local ',var) @@ -267,17 +267,17 @@ It needs to be killed when we quit the session.") (and (ediff-window-display-p) ediff-multiframe)) (defmacro ediff-narrow-control-frame-p () - `(and (ediff-multiframe-setup-p) - (equal ediff-help-message ediff-brief-message-string))) + '(and (ediff-multiframe-setup-p) + (equal ediff-help-message ediff-brief-message-string))) (defmacro ediff-3way-comparison-job () - `(memq + '(memq ediff-job-name '(ediff-files3 ediff-buffers3))) (ediff-defvar-local ediff-3way-comparison-job nil "") (defmacro ediff-merge-job () - `(memq + '(memq ediff-job-name '(ediff-merge-files ediff-merge-buffers @@ -288,10 +288,10 @@ It needs to be killed when we quit the session.") (ediff-defvar-local ediff-merge-job nil "") (defmacro ediff-patch-job () - `(eq ediff-job-name 'epatch)) + '(eq ediff-job-name 'epatch)) (defmacro ediff-merge-with-ancestor-job () - `(memq + '(memq ediff-job-name '(ediff-merge-files-with-ancestor ediff-merge-buffers-with-ancestor @@ -299,26 +299,26 @@ It needs to be killed when we quit the session.") (ediff-defvar-local ediff-merge-with-ancestor-job nil "") (defmacro ediff-3way-job () - `(or ediff-3way-comparison-job ediff-merge-job)) + '(or ediff-3way-comparison-job ediff-merge-job)) (ediff-defvar-local ediff-3way-job nil "") ;; A diff3 job is like a 3way job, but ediff-merge doesn't require the use ;; of diff3. (defmacro ediff-diff3-job () - `(or ediff-3way-comparison-job + '(or ediff-3way-comparison-job ediff-merge-with-ancestor-job)) (ediff-defvar-local ediff-diff3-job nil "") (defmacro ediff-windows-job () - `(memq ediff-job-name '(ediff-windows-wordwise ediff-windows-linewise))) + '(memq ediff-job-name '(ediff-windows-wordwise ediff-windows-linewise))) (ediff-defvar-local ediff-windows-job nil "") (defmacro ediff-word-mode-job () - `(memq ediff-job-name '(ediff-windows-wordwise ediff-regions-wordwise))) + '(memq ediff-job-name '(ediff-windows-wordwise ediff-regions-wordwise))) (ediff-defvar-local ediff-word-mode-job nil "") (defmacro ediff-narrow-job () - `(memq ediff-job-name '(ediff-windows-wordwise + '(memq ediff-job-name '(ediff-windows-wordwise ediff-regions-wordwise ediff-windows-linewise ediff-regions-linewise))) @@ -502,7 +502,7 @@ set local variables that determine how the display looks like." ;; Selective browsing -(ediff-defvar-local ediff-skip-diff-region-function 'ediff-show-all-diffs +(ediff-defvar-local ediff-skip-diff-region-function #'ediff-show-all-diffs "Function that determines the next/previous diff region to show. Should return t for regions to be ignored and nil otherwise. This function gets a region number as an argument. The region number @@ -740,26 +740,6 @@ to temp files in buffer jobs and when Ediff needs to find fine differences." (defalias 'ediff-delete-overlay (if (featurep 'xemacs) 'delete-extent 'delete-overlay)) -;; Assumes that emacs-major-version and emacs-minor-version are defined. -(defun ediff-check-version (op major minor &optional type-of-emacs) - "Check the current version against MAJOR and MINOR version numbers. -The comparison uses operator OP, which may be any of: =, >, >=, <, <=. -TYPE-OF-EMACS is either `emacs' or `xemacs'." - (declare (obsolete version< "23.1")) - (and (cond ((eq type-of-emacs 'xemacs) (featurep 'xemacs)) - ((eq type-of-emacs 'emacs) (featurep 'emacs)) - (t)) - (cond ((eq op '=) (and (= emacs-minor-version minor) - (= emacs-major-version major))) - ((memq op '(> >= < <=)) - (and (or (funcall op emacs-major-version major) - (= emacs-major-version major)) - (if (= emacs-major-version major) - (funcall op emacs-minor-version minor) - t))) - (t - (user-error "%S: Invalid op in ediff-check-version" op))))) - (defun ediff-color-display-p () (condition-case nil (if (featurep 'xemacs) @@ -1508,7 +1488,7 @@ This default should work without changes." ;; this record is itself a vector (defsubst ediff-clear-fine-diff-vector (diff-record) (if diff-record - (mapc 'ediff-delete-overlay + (mapc #'ediff-delete-overlay (ediff-get-fine-diff-vector-from-diff-record diff-record)))) (defsubst ediff-clear-fine-differences-in-one-buffer (n buf-type) @@ -1779,7 +1759,7 @@ Unless optional argument INPLACE is non-nil, return a new string." (defsubst ediff-message-if-verbose (string &rest args) (if ediff-verbose-p - (apply 'message string args))) + (apply #'message string args))) (defun ediff-file-attributes (filename attr-number) (if (ediff-listable-file filename) @@ -1818,13 +1798,4 @@ Unless optional argument INPLACE is non-nil, return a new string." (provide 'ediff-init) - - - -;; Local Variables: -;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;; End: - ;;; ediff-init.el ends here diff --git a/lisp/vc/ediff-merg.el b/lisp/vc/ediff-merg.el index 27835f7bdc1..4e17dbeaefa 100644 --- a/lisp/vc/ediff-merg.el +++ b/lisp/vc/ediff-merg.el @@ -1,4 +1,4 @@ -;;; ediff-merg.el --- merging utilities +;;; ediff-merg.el --- merging utilities -*- lexical-binding:t -*- ;; Copyright (C) 1994-2019 Free Software Foundation, Inc. @@ -194,7 +194,7 @@ Buffer B." (defun ediff-set-merge-mode () (normal-mode t) - (remove-hook 'local-write-file-hooks 'ediff-set-merge-mode)) + (remove-hook 'write-file-functions 'ediff-set-merge-mode t)) ;; Go over all diffs starting with DIFF-NUM and copy regions into buffer C @@ -382,12 +382,4 @@ Combining is done according to the specifications in variable (provide 'ediff-merg) - - -;; Local Variables: -;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;; End: - ;;; ediff-merg.el ends here diff --git a/lisp/vc/ediff-mult.el b/lisp/vc/ediff-mult.el index 21f89168b3e..1bdaca268e5 100644 --- a/lisp/vc/ediff-mult.el +++ b/lisp/vc/ediff-mult.el @@ -1,4 +1,4 @@ -;;; ediff-mult.el --- support for multi-file/multi-buffer processing in Ediff +;;; ediff-mult.el --- support for multi-file/multi-buffer processing in Ediff -*- lexical-binding:t -*- ;; Copyright (C) 1995-2019 Free Software Foundation, Inc. @@ -103,8 +103,6 @@ ;;; Code: -(provide 'ediff-mult) - (defgroup ediff-mult nil "Multi-file and multi-buffer processing in Ediff." :prefix "ediff-" @@ -147,7 +145,20 @@ Useful commands (type ? to hide them and free up screen): (ediff-defvar-local ediff-meta-buffer-map nil "The keymap for the meta buffer.") -(defvar ediff-dir-diffs-buffer-map (make-sparse-keymap) +(defvar ediff-dir-diffs-buffer-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "q" 'ediff-bury-dir-diffs-buffer) + (define-key map " " 'next-line) + (define-key map "n" 'next-line) + (define-key map "\C-?" 'previous-line) + (define-key map "p" 'previous-line) + (define-key map "C" 'ediff-dir-diff-copy-file) + (define-key map (if (featurep 'emacs) [mouse-2] [button2]) + 'ediff-dir-diff-copy-file) + (define-key map [delete] 'previous-line) + (define-key map [backspace] 'previous-line) + map) "The keymap to be installed in the buffer showing differences between directories.") @@ -175,8 +186,7 @@ directories.") "The default regular expression used as a filename filter in multifile comparisons. Should be a sexp. For instance (car ediff-filtering-regexp-history) or nil." :type 'sexp ; yuck - why not just a regexp? - :risky t - :group 'ediff-mult) + :risky t) ;; This has the form ((meta-buf regexp dir1 dir2 dir3 merge-auto-store-dir) ;; (ctl-buf session-status (file1 . eq-status) (file2 . eq-status) (file3 @@ -202,18 +212,15 @@ Should be a sexp. For instance (car ediff-filtering-regexp-history) or nil." (defcustom ediff-meta-truncate-filenames t "If non-nil, truncate long file names in the session group buffers. This can be toggled with `ediff-toggle-filename-truncation'." - :type 'boolean - :group 'ediff-mult) + :type 'boolean) (defcustom ediff-meta-mode-hook nil "Hooks run just after setting up meta mode." - :type 'hook - :group 'ediff-mult) + :type 'hook) (defcustom ediff-registry-setup-hook nil "Hooks run just after the registry control panel is set up." - :type 'hook - :group 'ediff-mult) + :type 'hook) (defcustom ediff-before-session-group-setup-hooks nil ;FIXME: Bad name (should be -hook or -functions) and never run?? @@ -223,30 +230,29 @@ This hook can be used to save the previous window config, which can be restored on `ediff-quit', `ediff-suspend', or `ediff-quit-session-group-hook'." :type 'hook :group 'ediff-hook) +;; Because this variable is apparently never used, it's marked as +;; obsolete without replacement. +(make-obsolete-variable 'ediff-before-session-group-setup-hooks nil "27.1") + (defcustom ediff-after-session-group-setup-hook nil "Hooks run just after a meta-buffer controlling a session group, such as ediff-directories, is run." - :type 'hook - :group 'ediff-mult) + :type 'hook) (defcustom ediff-quit-session-group-hook nil "Hooks run just before exiting a session group." - :type 'hook - :group 'ediff-mult) + :type 'hook) (defcustom ediff-show-registry-hook nil "Hooks run just after the registry buffer is shown." - :type 'hook - :group 'ediff-mult) + :type 'hook) (defcustom ediff-show-session-group-hook '(delete-other-windows) "Hooks run just after a session group buffer is shown." - :type 'hook - :group 'ediff-mult) + :type 'hook) (defcustom ediff-meta-buffer-keymap-setup-hook nil "Hooks run just after setting up the `ediff-meta-buffer-map'. This keymap controls key bindings in the meta buffer and is a local variable. This means that you can set different bindings for different kinds of meta buffers." - :type 'hook - :group 'ediff-mult) + :type 'hook) ;; Buffer holding the multi-file patch. Local to the meta buffer (ediff-defvar-local ediff-meta-patchbufer nil "") @@ -436,7 +442,7 @@ Toggled by ediff-toggle-verbose-help-meta-buffer" ) (run-hooks 'ediff-meta-buffer-keymap-setup-hook)) -(defun ediff-meta-mode () +(define-derived-mode ediff-meta-mode nil "MetaEdiff" "This mode controls all operations on Ediff session groups. It is entered through one of the following commands: `ediff-directories' @@ -455,28 +461,7 @@ It is entered through one of the following commands: `edir-merge-revisions-with-ancestor' Commands: -\\{ediff-meta-buffer-map}" - ;; FIXME: Use define-derived-mode. - (kill-all-local-variables) - (setq major-mode 'ediff-meta-mode) - (setq mode-name "MetaEdiff") - ;; don't use run-mode-hooks here! - (run-hooks 'ediff-meta-mode-hook)) - - -;; the keymap for the buffer showing directory differences -(suppress-keymap ediff-dir-diffs-buffer-map) -(define-key ediff-dir-diffs-buffer-map "q" 'ediff-bury-dir-diffs-buffer) -(define-key ediff-dir-diffs-buffer-map " " 'next-line) -(define-key ediff-dir-diffs-buffer-map "n" 'next-line) -(define-key ediff-dir-diffs-buffer-map "\C-?" 'previous-line) -(define-key ediff-dir-diffs-buffer-map "p" 'previous-line) -(define-key ediff-dir-diffs-buffer-map "C" 'ediff-dir-diff-copy-file) -(if (featurep 'emacs) - (define-key ediff-dir-diffs-buffer-map [mouse-2] 'ediff-dir-diff-copy-file) - (define-key ediff-dir-diffs-buffer-map [button2] 'ediff-dir-diff-copy-file)) -(define-key ediff-dir-diffs-buffer-map [delete] 'previous-line) -(define-key ediff-dir-diffs-buffer-map [backspace] 'previous-line) +\\{ediff-meta-buffer-map}") (defun ediff-next-meta-item (count) "Move to the next item in Ediff registry or session group buffer. @@ -598,8 +583,7 @@ behavior." (defun ediff-intersect-directories (jobname regexp dir1 dir2 &optional - dir3 merge-autostore-dir comparison-func) - (setq comparison-func (or comparison-func 'string=)) + dir3 merge-autostore-dir) (let (lis1 lis2 lis3 common auxdir1 auxdir2 auxdir3 common-part difflist) (setq auxdir1 (file-name-as-directory dir1) @@ -632,24 +616,24 @@ behavior." (if (ediff-nonempty-string-p merge-autostore-dir) (setq merge-autostore-dir (file-name-as-directory merge-autostore-dir))) - (setq common (ediff-intersection lis1 lis2 comparison-func)) + (setq common (ediff-intersection lis1 lis2 #'string=)) ;; In merge with ancestor jobs, we don't intersect with lis3. ;; If there is no ancestor, we'll offer to merge without the ancestor. ;; So, we intersect with lis3 only when we are doing 3-way file comparison (if (and lis3 (ediff-comparison-metajob3 jobname)) - (setq common (ediff-intersection common lis3 comparison-func))) + (setq common (ediff-intersection common lis3 #'string=))) ;; copying is needed because sort sorts via side effects (setq common (sort (ediff-copy-list common) 'string-lessp)) ;; compute difference list (setq difflist (ediff-set-difference - (ediff-union (ediff-union lis1 lis2 comparison-func) + (ediff-union (ediff-union lis1 lis2 #'string=) lis3 - comparison-func) + #'string=) common - comparison-func) + #'string=) difflist (delete "." difflist) ;; copying is needed because sort sorts via side effects difflist (sort (ediff-copy-list (delete ".." difflist)) @@ -679,7 +663,7 @@ behavior." (ediff-make-new-meta-list-header regexp auxdir1 auxdir2 auxdir3 merge-autostore-dir - comparison-func) + #'string=) difflist)) (setq common-part @@ -688,7 +672,7 @@ behavior." (ediff-make-new-meta-list-header regexp auxdir1 auxdir2 auxdir3 merge-autostore-dir - comparison-func) + #'string=) (mapcar (lambda (elt) (ediff-make-new-meta-list-element @@ -714,7 +698,7 @@ behavior." ;; we may visit them recursively. DIR1 is the directory to inspect. ;; MERGE-AUTOSTORE-DIR is the directory where to auto-store the results of ;; merges. Can be nil. -(defun ediff-get-directory-files-under-revision (jobname +(defun ediff-get-directory-files-under-revision (_jobname regexp dir1 &optional merge-autostore-dir) (let (lis1 elt common auxdir1) @@ -760,16 +744,16 @@ behavior." auxdir1 nil nil merge-autostore-dir nil) (mapcar (lambda (elt) (ediff-make-new-meta-list-element - (expand-file-name (concat auxdir1 elt)) nil nil)) + (expand-file-name (concat auxdir1 elt)) nil nil)) common)) )) ;; If file groups selected by patterns will ever be implemented, this ;; comparison function might become useful. -;;;; uses external variables PAT1 PAT2 to compare str1/2 -;;;; patterns must be of the form ???*???? where ??? are strings of chars -;;;; containing no *. +;; ;; uses external variables PAT1 PAT2 to compare str1/2 +;; ;; patterns must be of the form ???*???? where ??? are strings of chars +;; ;; containing no *. ;;(defun ediff-pattern= (str1 str2) ;; (let (pos11 pos12 pos21 pos22 len1 len2) ;; (setq pos11 0 @@ -798,8 +782,8 @@ behavior." ;; Prepare meta-buffer in accordance with the argument-function and ;; redraw-function. Must return the created meta-buffer. (defun ediff-prepare-meta-buffer (action-func meta-list - meta-buffer-name redraw-function - jobname &optional startup-hooks) + meta-buffer-name redraw-function + jobname &optional startup-hooks) (let* ((meta-buffer-name (ediff-unique-buffer-name meta-buffer-name "*")) (meta-buffer (get-buffer-create meta-buffer-name))) @@ -841,7 +825,7 @@ behavior." (setq buffer-read-only t) (set-buffer-modified-p nil) - (run-hooks 'startup-hooks) + (mapc #'funcall startup-hooks) ;; Arrange to show directory contents differences ;; Must be after run startup-hooks, since ediff-dir-difference-list is @@ -1009,7 +993,7 @@ behavior." ;; was redrawn (if (featurep 'xemacs) (map-extents 'delete-extent) - (mapc 'delete-overlay (overlays-in 1 1))) + (mapc #'delete-overlay (overlays-in 1 1))) (setq regexp (ediff-get-group-regexp meta-list) merge-autostore-dir @@ -1221,13 +1205,12 @@ behavior." ;; TIME is like the output of decode-time (defun ediff-format-date (time) (format "%s %2d %4d %s:%s:%s" - (cdr (assoc (nth 4 time) ediff-months)) ; month - (nth 3 time) ; day - (nth 5 time) ; year - (ediff-fill-leading-zero (nth 2 time)) ; hour - (ediff-fill-leading-zero (nth 1 time)) ; min - (ediff-fill-leading-zero (nth 0 time)) ; sec - )) + (cdr (assoc (decoded-time-month time) ediff-months)) + (decoded-time-day time) + (decoded-time-year time) + (ediff-fill-leading-zero (decoded-time-hour time)) + (ediff-fill-leading-zero (decoded-time-minute time)) + (ediff-fill-leading-zero (decoded-time-second time)))) ;; Draw the directories (defun ediff-insert-dirs-in-meta-buffer (meta-list) @@ -1455,7 +1438,7 @@ Useful commands: ;; was redrawn (if (featurep 'xemacs) (map-extents 'delete-extent) - (mapc 'delete-overlay (overlays-in 1 1))) + (mapc #'delete-overlay (overlays-in 1 1))) (insert (substitute-command-keys "\ This is a registry of all active Ediff sessions. @@ -1583,8 +1566,7 @@ Useful commands: ;; Returns whether session was marked or unmarked (defun ediff-mark-session-for-hiding (info unmark) - (let ((session-buf (ediff-get-session-buffer info)) - ignore) + (let (ignore) (cond ((eq unmark 'mark) (setq unmark nil)) ((eq (ediff-get-session-status info) ?H) (setq unmark t)) (unmark ; says unmark, but the marker is different from H @@ -1758,7 +1740,7 @@ all marked sessions must be active." (ediff-with-current-buffer ediff-meta-diff-buffer (setq buffer-read-only nil) (erase-buffer)) - (if (> (ediff-operate-on-marked-sessions 'ediff-append-custom-diff) 0) + (if (> (ediff-operate-on-marked-sessions #'ediff-append-custom-diff) 0) ;; did something (progn (display-buffer ediff-meta-diff-buffer 'not-this-window) @@ -1813,7 +1795,7 @@ all marked sessions must be active." (info (ediff-get-meta-info meta-buf pos)) (session-buf (ediff-get-session-buffer info)) (session-number (ediff-get-session-number-at-pos pos meta-buf)) - (default-regexp (eval ediff-default-filtering-regexp)) + (default-regexp (eval ediff-default-filtering-regexp t)) merge-autostore-dir file1 file2 file3 regexp) (setq file1 (ediff-get-session-objA-name info) @@ -1851,7 +1833,7 @@ all marked sessions must be active." "Filter filenames through regular expression: ") nil 'ediff-filtering-regexp-history - (eval ediff-default-filtering-regexp))) + (eval ediff-default-filtering-regexp t))) (ediff-directories-internal file1 file2 file3 regexp ediff-session-action-function @@ -2199,10 +2181,10 @@ all marked sessions must be active." (if (ediff-buffer-live-p ediff-registry-buffer) (ediff-redraw-registry-buffer) (ediff-prepare-meta-buffer - 'ediff-registry-action + #'ediff-registry-action ediff-session-registry "*Ediff Registry" - 'ediff-redraw-registry-buffer + #'ediff-redraw-registry-buffer 'ediff-registry)) )) @@ -2475,12 +2457,5 @@ for operation, or simply indicate which are equal files. If it is nil, then )) )) - - -;; Local Variables: -;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;; End: - +(provide 'ediff-mult) ;;; ediff-mult.el ends here diff --git a/lisp/vc/ediff-ptch.el b/lisp/vc/ediff-ptch.el index 35d7e28f294..8e8f96e6d60 100644 --- a/lisp/vc/ediff-ptch.el +++ b/lisp/vc/ediff-ptch.el @@ -1,4 +1,4 @@ -;;; ediff-ptch.el --- Ediff's patch support +;;; ediff-ptch.el --- Ediff's patch support -*- lexical-binding:t -*- ;; Copyright (C) 1996-2019 Free Software Foundation, Inc. @@ -27,7 +27,6 @@ (require 'diff-mode) ; For `diff-file-junk-re'. -(provide 'ediff-ptch) (defgroup ediff-ptch nil "Ediff patch support." @@ -37,12 +36,12 @@ (require 'ediff-init) (require 'ediff-util) +(require 'ediff) (defcustom ediff-patch-program "patch" "Name of the program that applies patches. It is recommended to use GNU-compatible versions." - :type 'string - :group 'ediff-ptch) + :type 'string) (defcustom ediff-patch-options "-f" "Options to pass to ediff-patch-program. @@ -51,8 +50,7 @@ Note: the `-b' option should be specified in `ediff-backup-specs'. It is recommended to pass the `-f' option to the patch program, so it won't ask questions. However, some implementations don't accept this option, in which case the default value for this variable should be changed." - :type 'string - :group 'ediff-ptch) + :type 'string) (defvar ediff-last-dir-patch nil "Last directory used by an Ediff command for file to patch.") @@ -66,8 +64,7 @@ case the default value for this variable should be changed." (defcustom ediff-backup-extension ediff-default-backup-extension "Backup extension used by the patch program. See also `ediff-backup-specs'." - :type 'string - :group 'ediff-ptch) + :type 'string) (defun ediff-test-patch-utility () (condition-case nil @@ -110,14 +107,12 @@ still be set so Ediff will know which extension to use. Ediff tries to guess the appropriate value for this variables. It is believed to be working for `traditional' patch, all versions of GNU patch, and for POSIX patch. So, don't change these variables, unless the default doesn't work." - :type 'string - :group 'ediff-ptch) + :type 'string) (defcustom ediff-patch-default-directory nil "Default directory to look for patches." - :type '(choice (const nil) string) - :group 'ediff-ptch) + :type '(choice (const nil) string)) ;; This context diff does not recognize spaces inside files, but removing ' ' ;; from [^ \t] breaks normal patches for some reason @@ -131,8 +126,7 @@ patch. So, don't change these variables, unless the default doesn't work." "Regexp matching filename 2-liners at the start of each context diff. You probably don't want to change that, unless you are using an obscure patch program." - :type 'regexp - :group 'ediff-ptch) + :type 'regexp) ;; The buffer of the patch file. Local to control buffer. (ediff-defvar-local ediff-patchbufer nil "") @@ -297,11 +291,24 @@ program." ;; file names. This is a heuristic intended to improve guessing (let ((default-directory (file-name-directory filename))) (unless (or (file-name-absolute-p base-dir1) - (file-name-absolute-p base-dir2) - (not (file-exists-p base-dir1)) - (not (file-exists-p base-dir2))) - (setq base-dir1 "" - base-dir2 ""))) + (file-name-absolute-p base-dir2)) + (if (and (file-exists-p base-dir1) + (file-exists-p base-dir2)) + (setq base-dir1 "" + base-dir2 "") + ;; Strip possible source/destination prefixes + ;; such as a/ and b/ from dir names. + (save-match-data + (let ((m1 (when (string-match "^[^/]+/" base-dir1) + (cons (substring base-dir1 0 (match-end 0)) + (substring base-dir1 (match-end 0))))) + (m2 (when (string-match "^[^/]+/" base-dir2) + (cons (substring base-dir2 0 (match-end 0)) + (substring base-dir2 (match-end 0)))))) + (when (and (file-exists-p (cdr m1)) + (file-exists-p (cdr m2))) + (setq base-dir1 (car m1) + base-dir2 (car m2)))))))) (or (string= (car proposed-file-names) "/dev/null") (setcar proposed-file-names (ediff-file-name-sans-prefix @@ -325,8 +332,8 @@ program." (mapc (lambda (session-info) (let ((proposed-file-names (ediff-get-session-objA-name session-info))) - (if (and (string-match "^/null/" (car proposed-file-names)) - (string-match "^/null/" (cdr proposed-file-names))) + (if (and (string-match-p "^/null/" (car proposed-file-names)) + (string-match-p "^/null/" (cdr proposed-file-names))) ;; couldn't intuit the file name to patch, so ;; something is amiss (progn @@ -574,7 +581,7 @@ optional argument, then use it." (ediff-patch-file-internal patch-buf (if (and ediff-patch-map - (not (string-match + (not (string-match-p "^/dev/null" ;; this is the file to patch (ediff-get-session-objA-name (car ediff-patch-map)))) @@ -674,26 +681,26 @@ optional argument, then use it." ;; encoding that Emacs thinks is right for that type of text (coding-system-for-write (if (boundp 'buffer-file-coding-system) buffer-file-coding-system)) - target-buf buf-to-patch file-name-magic-p + (ediff--startup-hook startup-hooks) + target-buf buf-to-patch magic-file-name patch-return-code ctl-buf backup-style aux-wind) - (if (string-match "V" ediff-patch-options) + (if (string-match-p "V" ediff-patch-options) (error "Ediff doesn't take the -V option in `ediff-patch-options'--sorry")) - ;; Make a temp file, if source-filename has a magic file handler (or if + ;; Make a temp file, if source-filename has a magic file name handler (or if ;; it is handled via auto-mode-alist and similar magic). ;; Check if there is a buffer visiting source-filename and if they are in ;; sync; arrange for the deletion of temp file. - (ediff-find-file 'true-source-filename 'buf-to-patch - 'ediff-last-dir-patch 'startup-hooks) + (setq buf-to-patch (ediff-find-file true-source-filename + 'ediff-last-dir-patch)) + (setq startup-hooks ediff--startup-hook) ;; Check if source file name has triggered black magic, such as file name ;; handlers or auto mode alist, and make a note of it. - ;; true-source-filename should be either the original name or a - ;; temporary file where we put the after-product of the file handler. - (setq file-name-magic-p (not (equal (file-truename true-source-filename) - (file-truename source-filename)))) + (setq magic-file-name + (with-current-buffer buf-to-patch ediff--magic-file-name)) ;; Checkout orig file, if necessary, so that the patched file ;; could be checked back in. @@ -717,7 +724,7 @@ optional argument, then use it." ediff-patch-program ediff-patch-options ediff-backup-specs - (expand-file-name true-source-filename)) + (ediff--buffer-file-name buf-to-patch)) )) ;; restore environment for gnu patch @@ -731,7 +738,8 @@ optional argument, then use it." (or (and (ediff-patch-return-code-ok patch-return-code) (file-exists-p - (concat true-source-filename ediff-backup-extension))) + (concat (ediff--buffer-file-name buf-to-patch) + ediff-backup-extension))) (progn (with-output-to-temp-buffer ediff-msg-buffer (ediff-with-current-buffer standard-output @@ -776,7 +784,7 @@ you can still examine the changes via M-x ediff-files" ;; Without magic, the original file is renamed (usually into ;; old-name_orig) and the result of patching will have the same name as ;; the original. - (if (not file-name-magic-p) + (if (not magic-file-name) (ediff-with-current-buffer buf-to-patch (set-visited-file-name (concat source-filename ediff-backup-extension)) @@ -789,19 +797,19 @@ you can still examine the changes via M-x ediff-files" (setq target-filename (concat (if (ediff-file-remote-p (file-truename source-filename)) - true-source-filename + magic-file-name source-filename) "_patched")) - (rename-file true-source-filename target-filename t) + (rename-file magic-file-name target-filename t) ;; arrange that the temp copy of orig will be deleted - (rename-file (concat true-source-filename ediff-backup-extension) - true-source-filename t)) + (rename-file (concat magic-file-name + ediff-backup-extension) + magic-file-name t)) ;; make orig buffer read-only - (setq startup-hooks - (cons 'ediff-set-read-only-in-buf-A startup-hooks)) + (push #'ediff-set-read-only-in-buf-A startup-hooks) ;; set up a buf for the patched file (setq target-buf (find-file-noselect target-filename)) @@ -820,17 +828,16 @@ you can still examine the changes via M-x ediff-files" (defun ediff-multi-patch-internal (patch-buf &optional startup-hooks) (let (meta-buf) - (setq startup-hooks - ;; this sets various vars in the meta buffer inside - ;; ediff-prepare-meta-buffer - (cons `(lambda () - ;; tell what to do if the user clicks on a session record - (setq ediff-session-action-function - 'ediff-patch-file-form-meta - ediff-meta-patchbufer patch-buf) ) - startup-hooks)) + ;; this sets various vars in the meta buffer inside + ;; ediff-prepare-meta-buffer + (push (lambda () + ;; tell what to do if the user clicks on a session record + (setq ediff-session-action-function + 'ediff-patch-file-form-meta + ediff-meta-patchbufer patch-buf) ) + startup-hooks) (setq meta-buf (ediff-prepare-meta-buffer - 'ediff-filegroup-action + #'ediff-filegroup-action (ediff-with-current-buffer patch-buf (cons (ediff-make-new-meta-list-header nil ; regexp @@ -841,19 +848,11 @@ you can still examine the changes via M-x ediff-files" ) ediff-patch-map)) "*Ediff Session Group Panel" - 'ediff-redraw-directory-group-buffer + #'ediff-redraw-directory-group-buffer 'ediff-multifile-patch startup-hooks)) (ediff-show-meta-buffer meta-buf) )) - - - -;; Local Variables: -;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;; End: - +(provide 'ediff-ptch) ;;; ediff-ptch.el ends here diff --git a/lisp/vc/ediff-util.el b/lisp/vc/ediff-util.el index 2e9863048f9..796027deadb 100644 --- a/lisp/vc/ediff-util.el +++ b/lisp/vc/ediff-util.el @@ -25,7 +25,7 @@ ;;; Code: -(provide 'ediff-util) +(provide 'ediff-util) ;FIXME: Break cyclic dependencies and move to the end! ;; Compiler pacifier (defvar ediff-use-toolbar-p) @@ -39,9 +39,6 @@ (defvar ediff-after-quit-hook-internal nil) -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r)))) - ;; end pacifier @@ -347,7 +344,7 @@ to invocation.") (goto-char (point-min)) (funcall (ediff-with-current-buffer buf major-mode)) (widen) ; merge buffer is always widened - (add-hook 'local-write-file-hooks 'ediff-set-merge-mode nil t) + (add-hook 'write-file-functions 'ediff-set-merge-mode nil t) ))) (setq buffer-read-only nil ediff-buffer-A buffer-A @@ -393,8 +390,8 @@ to invocation.") ;; parameters are processed. (setq ediff-setup-diff-regions-function (if ediff-diff3-job - 'ediff-setup-diff-regions3 - 'ediff-setup-diff-regions)) + #'ediff-setup-diff-regions3 + #'ediff-setup-diff-regions)) (setq ediff-wide-bounds (list (ediff-make-bullet-proof-overlay @@ -778,8 +775,8 @@ Reestablish the default window display." (select-frame-set-input-focus ediff-control-frame) (raise-frame ediff-control-frame) (select-frame ediff-control-frame) - (if (fboundp 'focus-frame) - (focus-frame ediff-control-frame)))) + (and (featurep 'xemacs) (fboundp 'focus-frame) + (focus-frame ediff-control-frame)))) ;; Redisplay whatever buffers are showing, if there is a selected difference (let ((control-frame ediff-control-frame) @@ -888,8 +885,8 @@ Does nothing if file-A and file-B are in different frames." (eq frame-A frame-C) (eq frame-B frame-C)))) (setq ediff-split-window-function (if (eq ediff-split-window-function 'split-window-vertically) - 'split-window-horizontally - 'split-window-vertically)) + #'split-window-horizontally + #'split-window-vertically)) (message "Buffers being compared are in different frames")) (ediff-recenter 'no-rehighlight))) @@ -1303,25 +1300,25 @@ which see." (user-error "%sEmacs is not running as a window application" (if (featurep 'emacs) "" "X"))) - (cond ((eq ediff-window-setup-function 'ediff-setup-windows-multiframe) + (cond ((eq ediff-window-setup-function #'ediff-setup-windows-multiframe) (setq ediff-multiframe nil) - (setq window-setup-func 'ediff-setup-windows-plain) + (setq window-setup-func #'ediff-setup-windows-plain) (message "ediff is now in 'plain' mode")) - ((eq ediff-window-setup-function 'ediff-setup-windows-plain) + ((eq ediff-window-setup-function #'ediff-setup-windows-plain) (if (ediff-in-control-buffer-p) (ediff-kill-bottom-toolbar)) (if (and (ediff-buffer-live-p ediff-control-buffer) (window-live-p ediff-control-window)) (set-window-dedicated-p ediff-control-window nil)) (setq ediff-multiframe t) - (setq window-setup-func 'ediff-setup-windows-multiframe) + (setq window-setup-func #'ediff-setup-windows-multiframe) (message "ediff is now in 'multiframe' mode")) (t (if (and (ediff-buffer-live-p ediff-control-buffer) (window-live-p ediff-control-window)) (set-window-dedicated-p ediff-control-window nil)) (setq ediff-multiframe t) - (setq window-setup-func 'ediff-setup-windows-multiframe)) + (setq window-setup-func #'ediff-setup-windows-multiframe)) (message "ediff is now in 'multiframe' mode")) ;; change default @@ -1343,6 +1340,7 @@ which see." Works only in versions of Emacs that support toolbars. To change the default, set the variable `ediff-use-toolbar-p', which see." (interactive) + ;; FIXME: Make it work in Emacs! (if (featurep 'ediff-tbar) (progn (or (ediff-window-display-p) @@ -1547,8 +1545,8 @@ the one half of the height of window-A." (ediff-operate-on-windows (if (memq (ediff-last-command-char) '(?v ?\C-v)) - 'scroll-up - 'scroll-down) + #'scroll-up + #'scroll-down) ;; calculate argument to scroll-up/down ;; if there is an explicit argument (if (and arg (not (equal arg '-))) @@ -1604,10 +1602,10 @@ the width of the A/B/C windows." (if (= (ediff-last-command-char) ?<) (lambda (arg) (let ((prefix-arg arg)) - (call-interactively 'scroll-left))) + (call-interactively #'scroll-left))) (lambda (arg) (let ((prefix-arg arg)) - (call-interactively 'scroll-right)))) + (call-interactively #'scroll-right)))) ;; calculate argument to scroll-left/right ;; if there is an explicit argument (if (and arg (not (equal arg '-))) @@ -1721,9 +1719,9 @@ the width of the A/B/C windows." (ediff-with-current-buffer (or ctl-buf ediff-control-buffer) (if (ediff-valid-difference-p n) (let* ((func (cond ((eq op 'scroll-down) - 'ediff-get-lines-to-region-start) + #'ediff-get-lines-to-region-start) ((eq op 'scroll-up) - 'ediff-get-lines-to-region-end) + #'ediff-get-lines-to-region-end) (t (lambda (_a _b _c) 0)))) (max-lines (max (funcall func 'A n ctl-buf) (funcall func 'B n ctl-buf) @@ -2080,7 +2078,7 @@ ARG is a prefix argument. If nil, copy the current difference region." (ediff-save-diff-region n to-buf-type reg-to-delete)))) (error (message "ediff-copy-diff: %s %s" (car conds) - (mapconcat 'prin1-to-string (cdr conds) " ")) + (mapconcat #'prin1-to-string (cdr conds) " ")) (beep 1) (sit-for 2) ; let the user see the error msg (setq saved-p nil) @@ -2181,7 +2179,7 @@ ARG is a prefix argument. If nil, copy the current difference region." )) (error (message "ediff-pop-diff: %s %s" (car conds) - (mapconcat 'prin1-to-string (cdr conds) " ")) + (mapconcat #'prin1-to-string (cdr conds) " ")) (beep 1))) ;; Clearing fine diffs is necessary for @@ -2244,7 +2242,7 @@ a regular expression typed in by the user." ediff-hide-regexp-matches-function) (eq (ediff-last-command-char) ?h))) (message "Selective browsing by regexp turned off") - (setq ediff-skip-diff-region-function 'ediff-show-all-diffs)) + (setq ediff-skip-diff-region-function #'ediff-show-all-diffs)) ((eq (ediff-last-command-char) ?h) (setq ediff-skip-diff-region-function ediff-hide-regexp-matches-function regexp-A @@ -2932,7 +2930,7 @@ Hit \\[ediff-recenter] to reset the windows afterward." (princ "\nSkipping merge regions that differ from default setting")) - (cond ((eq ediff-skip-diff-region-function 'ediff-show-all-diffs) + (cond ((eq ediff-skip-diff-region-function #'ediff-show-all-diffs) (princ "\nSelective browsing by regexp is off\n")) ((eq ediff-skip-diff-region-function ediff-hide-regexp-matches-function) @@ -3224,9 +3222,9 @@ Hit \\[ediff-recenter] to reset the windows afterward." short-f (concat ediff-temp-file-prefix short-p) f (cond (given-file) ((find-file-name-handler f 'insert-file-contents) - ;; to thwart file handlers in write-region, e.g., if file - ;; name ends with .Z or .gz - ;; This is needed so that patches produced by ediff will + ;; to thwart file name handlers in write-region, + ;; e.g., if file name ends with .Z or .gz + ;; This is needed so that patches produced by ediff will ;; have more meaningful names (ediff-make-empty-tmp-file short-f)) (prefix @@ -3317,7 +3315,7 @@ Hit \\[ediff-recenter] to reset the windows afterward." (buffer-name) buffer-file-name)) (progn - (if file-magic + (if file-magic ;FIXME: Why? (erase-buffer)) (revert-buffer t t)) (user-error "Buffer out of sync for file %s" buffer-file-name)))) @@ -3549,25 +3547,19 @@ Ediff Control Panel to restore highlighting." (ediff-paint-background-regions 'unhighlight) (cond ((ediff-merge-job) - (setq bufB ediff-buffer-C) ;; ask which buffer to compare to the merge buffer - (while (cond ((eq answer ?A) - (setq bufA ediff-buffer-A - possibilities '(?B)) - nil) - ((eq answer ?B) - (setq bufA ediff-buffer-B - possibilities '(?A)) - nil) - ((equal answer "")) - (t (beep 1) - (message "Valid values are A or B") - (sit-for 2) - t)) - (let ((cursor-in-echo-area t)) - (message - "Which buffer to compare to the merge buffer (A or B)? ") - (setq answer (capitalize (read-char-exclusive)))))) + (setq answer (read-multiple-choice + "Which buffer to compare?" + '((?a "A") + (?b "B")))) + (if (eq (car answer) ?a) + (setq bufA ediff-buffer-A) + (setq bufA ediff-buffer-B)) + (setq bufB (if (and ediff-ancestor-buffer + (y-or-n-p (format "Compare %s against ancestor buffer?" + (cadr answer)))) + ediff-ancestor-buffer + ediff-buffer-C))) ((ediff-3way-comparison-job) ;; ask which two buffers to compare @@ -3582,12 +3574,12 @@ Ediff Control Panel to restore highlighting." (t (beep 1) (message "Valid values are %s" - (mapconcat 'char-to-string possibilities " or ")) + (mapconcat #'char-to-string possibilities " or ")) (sit-for 2) t)) (let ((cursor-in-echo-area t)) (message "Enter the 1st buffer you want to compare (%s): " - (mapconcat 'char-to-string possibilities " or ")) + (mapconcat #'char-to-string possibilities " or ")) (setq answer (capitalize (read-char-exclusive))))) (setq answer "") ; silence error msg (while (cond ((memq answer possibilities) @@ -3601,12 +3593,12 @@ Ediff Control Panel to restore highlighting." (t (beep 1) (message "Valid values are %s" - (mapconcat 'char-to-string possibilities " or ")) + (mapconcat #'char-to-string possibilities " or ")) (sit-for 2) t)) (let ((cursor-in-echo-area t)) (message "Enter the 2nd buffer you want to compare (%s): " - (mapconcat 'char-to-string possibilities "/")) + (mapconcat #'char-to-string possibilities "/")) (setq answer (capitalize (read-char-exclusive)))))) (t ; 2way comparison (setq bufA ediff-buffer-A @@ -4119,27 +4111,12 @@ Mail anyway? (y or n) ") (if (featurep 'xemacs) (zmacs-activate-region) (make-local-variable 'transient-mark-mode) - (setq mark-active t transient-mark-mode t))) + (setq mark-active 'ediff-util transient-mark-mode t))) (defun ediff-nuke-selective-display () (if (featurep 'xemacs) (nuke-selective-display) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (let ((mod-p (buffer-modified-p)) - buffer-read-only end) - (and (eq t selective-display) - (while (search-forward "\^M" nil t) - (end-of-line) - (setq end (point)) - (beginning-of-line) - (while (search-forward "\^M" end t) - (delete-char -1) - (insert "\^J")))) - (set-buffer-modified-p mod-p) - (setq selective-display nil)))))) + )) ;; The next two are modified versions from emerge.el. @@ -4253,7 +4230,7 @@ Mail anyway? (y or n) ") ;; fine-diff-vector (if (= (length (aref overl-vec 1)) 0) "none\n" - (mapconcat 'prin1-to-string + (mapconcat #'prin1-to-string (aref overl-vec 1) "\n\t\t\t ")) (aref overl-vec 2) ; no fine diff flag (aref overl-vec 3) ; state-of-diff @@ -4329,10 +4306,7 @@ Mail anyway? (y or n) ") (setq lis1 (cdr lis1))) (cdr result))) -(defun ediff-add-to-history (history-var newelt) - (if (fboundp 'add-to-history) - (add-to-history history-var newelt) - (set history-var (cons newelt (symbol-value history-var))))) +(define-obsolete-function-alias 'ediff-add-to-history #'add-to-history "27.1") (defalias 'ediff-copy-list 'copy-sequence) @@ -4342,11 +4316,4 @@ Mail anyway? (y or n) ") (run-hooks 'ediff-load-hook) - -;; Local Variables: -;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;; End: - ;;; ediff-util.el ends here diff --git a/lisp/vc/ediff-vers.el b/lisp/vc/ediff-vers.el index 664ae5ae94e..3826edad891 100644 --- a/lisp/vc/ediff-vers.el +++ b/lisp/vc/ediff-vers.el @@ -1,4 +1,4 @@ -;;; ediff-vers.el --- version control interface to Ediff +;;; ediff-vers.el --- version control interface to Ediff -*- lexical-binding:t -*- ;; Copyright (C) 1995-1997, 2001-2019 Free Software Foundation, Inc. @@ -96,11 +96,10 @@ comparison or merge operations are being performed." (ediff-vc-revision-other-window rev2)) (setq rev2buf (current-buffer) file2 (buffer-file-name))) - (setq startup-hooks - (cons `(lambda () - (ediff-delete-version-file ,file1) - (or ,(string= rev2 "") (ediff-delete-version-file ,file2))) - startup-hooks))) + (push (lambda () + (ediff-delete-version-file file1) + (or (string= rev2 "") (ediff-delete-version-file file2))) + startup-hooks)) (ediff-buffers rev1buf rev2buf startup-hooks @@ -124,7 +123,7 @@ comparison or merge operations are being performed." (let ((output-buffer (ediff-rcs-get-output-buffer filename buff))) (delete-windows-on output-buffer) (with-current-buffer output-buffer - (apply 'call-process "co" nil t nil + (apply #'call-process "co" nil t nil ;; -q: quiet (no diagnostics) (append switches rcs-default-co-switches (list "-q" filename))))) @@ -175,20 +174,20 @@ comparison or merge operations are being performed." (if ancestor-rev (save-excursion (if (string= ancestor-rev "") - (setq ancestor-rev (ediff-vc-working-revision buffer-file-name))) + (setq ancestor-rev (ediff-vc-working-revision + buffer-file-name))) (ediff-vc-revision-other-window ancestor-rev) (setq ancestor-buf (current-buffer)))) - (setq startup-hooks - (cons - `(lambda () - (ediff-delete-version-file ,(buffer-file-name buf1)) - (or ,(string= rev2 "") - (ediff-delete-version-file ,(buffer-file-name buf2))) - (or ,(string= ancestor-rev "") - ,(not ancestor-rev) - (ediff-delete-version-file ,(buffer-file-name ancestor-buf))) - ) - startup-hooks))) + (push (let ((f1 (buffer-file-name buf1)) + (f2 (unless (string= rev2 "") (buffer-file-name buf2))) + (fa (unless (or (string= ancestor-rev "") + (not ancestor-rev)) + (buffer-file-name ancestor-buf)))) + (lambda () + (ediff-delete-version-file f1) + (if f2 (ediff-delete-version-file f2)) + (if fa (ediff-delete-version-file fa)))) + startup-hooks)) (if ancestor-rev (ediff-merge-buffers-with-ancestor buf1 buf2 ancestor-buf @@ -227,12 +226,4 @@ comparison or merge operations are being performed." (provide 'ediff-vers) - - -;; Local Variables: -;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;; End: - ;;; ediff-vers.el ends here diff --git a/lisp/vc/ediff-wind.el b/lisp/vc/ediff-wind.el index bc41e3d9e5c..d4a60a16df1 100644 --- a/lisp/vc/ediff-wind.el +++ b/lisp/vc/ediff-wind.el @@ -1,4 +1,4 @@ -;;; ediff-wind.el --- window manipulation utilities +;;; ediff-wind.el --- window manipulation utilities -*- lexical-binding:t -*- ;; Copyright (C) 1994-1997, 2000-2019 Free Software Foundation, Inc. @@ -38,10 +38,6 @@ (defvar frame-icon-title-format) (defvar ediff-diff-status) -;; declare-function does not exist in XEmacs -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r)))) - (require 'ediff-init) (require 'ediff-help) ;; end pacifier @@ -64,10 +60,10 @@ (defun ediff-choose-window-setup-function-automatically () (declare (obsolete ediff-setup-windows-default "24.3")) (if (ediff-window-display-p) - 'ediff-setup-windows-multiframe - 'ediff-setup-windows-plain)) + #'ediff-setup-windows-multiframe + #'ediff-setup-windows-plain)) -(defcustom ediff-window-setup-function 'ediff-setup-windows-default +(defcustom ediff-window-setup-function #'ediff-setup-windows-default "Function called to set up windows. Ediff provides a choice of three functions: (1) `ediff-setup-windows-multiframe', which sets the control panel @@ -98,7 +94,6 @@ provided functions are written." (const :tag "Multi Frame" ediff-setup-windows-multiframe) (const :tag "Single Frame" ediff-setup-windows-plain) (function :tag "Other function")) - :group 'ediff-window :version "24.3") ;; indicates if we are in a multiframe setup @@ -132,7 +127,7 @@ provided functions are written." (Ancestor . ediff-window-Ancestor))) -(defcustom ediff-split-window-function 'split-window-vertically +(defcustom ediff-split-window-function #'split-window-vertically "The function used to split the main window between buffer-A and buffer-B. You can set it to a horizontal split instead of the default vertical split by setting this variable to `split-window-horizontally'. @@ -142,10 +137,9 @@ In this case, Ediff will use those frames to display these buffers." :type '(choice (const :tag "Split vertically" split-window-vertically) (const :tag "Split horizontally" split-window-horizontally) - function) - :group 'ediff-window) + function)) -(defcustom ediff-merge-split-window-function 'split-window-horizontally +(defcustom ediff-merge-split-window-function #'split-window-horizontally "The function used to split the main window between buffer-A and buffer-B. You can set it to a vertical split instead of the default horizontal split by setting this variable to `split-window-vertically'. @@ -155,8 +149,7 @@ In this case, Ediff will use those frames to display these buffers." :type '(choice (const :tag "Split vertically" split-window-vertically) (const :tag "Split horizontally" split-window-horizontally) - function) - :group 'ediff-window) + function)) ;; Definitions hidden from the compiler by compat wrappers. (declare-function ediff-display-pixel-width "ediff-init") @@ -209,16 +202,14 @@ Used internally---not a user option.") If `maybe', Ediff will do it sometimes, but not after operations that require relatively long time. If nil, the mouse will be entirely user's responsibility." - :type 'boolean - :group 'ediff-window) + :type 'boolean) -(defcustom ediff-control-frame-position-function 'ediff-make-frame-position +(defcustom ediff-control-frame-position-function #'ediff-make-frame-position "Function to call to determine the desired location for the control panel. Expects three parameters: the control buffer, the desired width and height of the control frame. It returns an association list of the form \((top . <position>) \(left . <position>))" - :type 'function - :group 'ediff-window) + :type 'function) (defcustom ediff-control-frame-upward-shift 42 "The upward shift of control frame from the top of buffer A's frame. @@ -226,8 +217,7 @@ Measured in pixels. This is used by the default control frame positioning function, `ediff-make-frame-position'. This variable is provided for easy customization of the default control frame positioning." - :type 'integer - :group 'ediff-window) + :type 'integer) (defcustom ediff-narrow-control-frame-leftward-shift (if (featurep 'xemacs) 7 3) "The leftward shift of control frame from the right edge of buf A's frame. @@ -236,8 +226,7 @@ This is used by the default control frame positioning function, `ediff-make-frame-position' to adjust the position of the control frame when it shows the short menu. This variable is provided for easy customization of the default." - :type 'integer - :group 'ediff-window) + :type 'integer) (defcustom ediff-wide-control-frame-rightward-shift 7 "The rightward shift of control frame from the left edge of buf A's frame. @@ -246,8 +235,7 @@ This is used by the default control frame positioning function, `ediff-make-frame-position' to adjust the position of the control frame when it shows the full menu. This variable is provided for easy customization of the default." - :type 'integer - :group 'ediff-window) + :type 'integer) ;; Wide frame display @@ -260,7 +248,7 @@ customization of the default." display off.") (ediff-defvar-local ediff-wide-display-frame nil "Frame to be used for wide display.") -(ediff-defvar-local ediff-make-wide-display-function 'ediff-make-wide-display +(ediff-defvar-local ediff-make-wide-display-function #'ediff-make-wide-display "The value is a function that is called to create a wide display. The function is called without arguments. It should resize the frame in which buffers A, B, and C are to be displayed, and it should save the old @@ -280,8 +268,7 @@ This is only useful in Emacs and only for certain kinds of window managers, such as TWM and its derivatives, since the window manager must permit keyboard input to go into icons. XEmacs completely ignores keyboard input into icons, regardless of the window manager." - :type 'boolean - :group 'ediff-window) + :type 'boolean) ;;; Functions @@ -336,25 +323,25 @@ into icons, regardless of the window manager." ;; in case user did a no-no on a tty (or (ediff-window-display-p) - (setq ediff-window-setup-function 'ediff-setup-windows-plain)) + (setq ediff-window-setup-function #'ediff-setup-windows-plain)) (or (ediff-keep-window-config control-buffer) (funcall - (ediff-with-current-buffer control-buffer ediff-window-setup-function) + (with-current-buffer control-buffer ediff-window-setup-function) buffer-A buffer-B buffer-C control-buffer)) (run-hooks 'ediff-after-setup-windows-hook)) (defun ediff-setup-windows-default (buffer-A buffer-B buffer-C control-buffer) (funcall (if (display-graphic-p) - 'ediff-setup-windows-multiframe - 'ediff-setup-windows-plain) + #'ediff-setup-windows-multiframe + #'ediff-setup-windows-plain) buffer-A buffer-B buffer-C control-buffer)) ;; Just set up 3 windows. ;; Usually used without windowing systems ;; With windowing, we want to use dedicated frames. (defun ediff-setup-windows-plain (buffer-A buffer-B buffer-C control-buffer) - (ediff-with-current-buffer control-buffer + (with-current-buffer control-buffer (setq ediff-multiframe nil)) (if ediff-merge-job (ediff-setup-windows-plain-merge @@ -368,14 +355,14 @@ into icons, regardless of the window manager." ;; skip dedicated and unsplittable frames (ediff-destroy-control-frame control-buffer) (let ((window-min-height 1) - (with-Ancestor-p (ediff-with-current-buffer control-buffer + (with-Ancestor-p (with-current-buffer control-buffer ediff-merge-with-ancestor-job)) split-window-function merge-window-share merge-window-lines - (buf-Ancestor (ediff-with-current-buffer control-buffer + (buf-Ancestor (with-current-buffer control-buffer ediff-ancestor-buffer)) wind-A wind-B wind-C wind-Ancestor) - (ediff-with-current-buffer control-buffer + (with-current-buffer control-buffer (setq merge-window-share ediff-merge-window-share ;; this lets us have local versions of ediff-split-window-function split-window-function ediff-split-window-function)) @@ -419,7 +406,7 @@ into icons, regardless of the window manager." (switch-to-buffer buf-B) (setq wind-B (selected-window)) - (ediff-with-current-buffer control-buffer + (with-current-buffer control-buffer (setq ediff-window-A wind-A ediff-window-B wind-B ediff-window-C wind-C @@ -438,7 +425,7 @@ into icons, regardless of the window manager." split-window-function wind-width-or-height three-way-comparison wind-A-start wind-B-start wind-A wind-B wind-C) - (ediff-with-current-buffer control-buffer + (with-current-buffer control-buffer (setq wind-A-start (ediff-overlay-start (ediff-get-value-according-to-buffer-type 'A ediff-narrow-bounds)) @@ -464,7 +451,7 @@ into icons, regardless of the window manager." (setq wind-A (selected-window)) (if three-way-comparison (setq wind-width-or-height - (/ (if (eq split-window-function 'split-window-vertically) + (/ (if (eq split-window-function #'split-window-vertically) (window-height wind-A) (window-width wind-A)) 3))) @@ -489,7 +476,7 @@ into icons, regardless of the window manager." (switch-to-buffer buf-C) (setq wind-C (selected-window)))) - (ediff-with-current-buffer control-buffer + (with-current-buffer control-buffer (setq ediff-window-A wind-A ediff-window-B wind-B ediff-window-C wind-C)) @@ -508,33 +495,33 @@ into icons, regardless of the window manager." ;; dispatch an appropriate window setup function (defun ediff-setup-windows-multiframe (buf-A buf-B buf-C control-buf) - (ediff-with-current-buffer control-buf + (with-current-buffer control-buf (setq ediff-multiframe t)) (if ediff-merge-job (ediff-setup-windows-multiframe-merge buf-A buf-B buf-C control-buf) (ediff-setup-windows-multiframe-compare buf-A buf-B buf-C control-buf))) (defun ediff-setup-windows-multiframe-merge (buf-A buf-B buf-C control-buf) -;;; Algorithm: -;;; 1. Never use frames that have dedicated windows in them---it is bad to -;;; destroy dedicated windows. -;;; 2. If A and B are in the same frame but C's frame is different---use one -;;; frame for A and B, and use a separate frame for C. -;;; 3. If C's frame is non-existent, then: if the first suitable -;;; non-dedicated frame is different from A&B's, then use it for C. -;;; Otherwise, put A, B, and C in one frame. -;;; 4. If buffers A, B, C are in separate frames, use them to display these -;;; buffers. + ;; Algorithm: + ;; 1. Never use frames that have dedicated windows in them---it is bad to + ;; destroy dedicated windows. + ;; 2. If A and B are in the same frame but C's frame is different--- use one + ;; frame for A and B and use a separate frame for C. + ;; 3. If C's frame is non-existent, then: if the first suitable + ;; non-dedicated frame is different from A&B's, then use it for C. + ;; Otherwise, put A,B, and C in one frame. + ;; 4. If buffers A, B, C are is separate frames, use them to display these + ;; buffers. ;; Skip dedicated or iconified frames. ;; Unsplittable frames are taken care of later. - (ediff-skip-unsuitable-frames 'ok-unsplittable) + ;; (ediff-skip-unsuitable-frames 'ok-unsplittable) (let* ((window-min-height 1) (wind-A (ediff-get-visible-buffer-window buf-A)) (wind-B (ediff-get-visible-buffer-window buf-B)) (wind-C (ediff-get-visible-buffer-window buf-C)) - (buf-Ancestor (ediff-with-current-buffer control-buf + (buf-Ancestor (with-current-buffer control-buf ediff-ancestor-buffer)) (wind-Ancestor (ediff-get-visible-buffer-window buf-Ancestor)) (frame-A (if wind-A (window-frame wind-A))) @@ -543,10 +530,10 @@ into icons, regardless of the window manager." (frame-Ancestor (if wind-Ancestor (window-frame wind-Ancestor))) ;; on wide display, do things in one frame (force-one-frame - (ediff-with-current-buffer control-buf ediff-wide-display-p)) + (with-current-buffer control-buf ediff-wide-display-p)) ;; this lets us have local versions of ediff-split-window-function (split-window-function - (ediff-with-current-buffer control-buf ediff-split-window-function)) + (with-current-buffer control-buf ediff-split-window-function)) (orig-wind (selected-window)) (orig-frame (selected-frame)) (use-same-frame (or force-one-frame @@ -568,11 +555,11 @@ into icons, regardless of the window manager." ;; use-same-frame-for-AB implies wind A and B are ok for display (use-same-frame-for-AB (and (not use-same-frame) (eq frame-A frame-B))) - (merge-window-share (ediff-with-current-buffer control-buf + (merge-window-share (with-current-buffer control-buf ediff-merge-window-share)) merge-window-lines designated-minibuffer-frame ; ediff-merge-with-ancestor-job - (with-Ancestor-p (ediff-with-current-buffer control-buf + (with-Ancestor-p (with-current-buffer control-buf ediff-merge-with-ancestor-job)) (done-Ancestor (not with-Ancestor-p)) done-A done-B done-C) @@ -726,7 +713,7 @@ into icons, regardless of the window manager." (switch-to-buffer buf-Ancestor) (setq wind-Ancestor (selected-window)))) - (ediff-with-current-buffer control-buf + (with-current-buffer control-buf (setq ediff-window-A wind-A ediff-window-B wind-B ediff-window-C wind-C @@ -740,21 +727,17 @@ into icons, regardless of the window manager." ;; Window setup for all comparison jobs, including 3way comparisons (defun ediff-setup-windows-multiframe-compare (buf-A buf-B buf-C control-buf) -;;; Algorithm: -;;; If a buffer is seen in a frame, use that frame for that buffer. -;;; If it is not seen, use the current frame. -;;; If both buffers are not seen, they share the current frame. If one -;;; of the buffers is not seen, it is placed in the current frame (where -;;; ediff started). If that frame is displaying the other buffer, it is -;;; shared between the two buffers. -;;; However, if we decide to put both buffers in one frame -;;; and the selected frame isn't splittable, we create a new frame and -;;; put both buffers there, event if one of this buffers is visible in -;;; another frame. - - ;; Skip dedicated or iconified frames. - ;; Unsplittable frames are taken care of later. - (ediff-skip-unsuitable-frames 'ok-unsplittable) + ;; Algorithm: + ;; If a buffer is seen in a frame, use that frame for that buffer. + ;; If it is not seen, use the current frame. + ;; If both buffers are not seen, they share the current frame. If one + ;; of the buffers is not seen, it is placed in the current frame (where + ;; ediff started). If that frame is displaying the other buffer, it is + ;; shared between the two buffers. + ;; However, if we decide to put both buffers in one frame + ;; and the selected frame isn't splittable, we create a new frame and + ;; put both buffers there, event if one of this buffers is visible in + ;; another frame. (let* ((window-min-height 1) (wind-A (ediff-get-visible-buffer-window buf-A)) @@ -763,17 +746,16 @@ into icons, regardless of the window manager." (frame-A (if wind-A (window-frame wind-A))) (frame-B (if wind-B (window-frame wind-B))) (frame-C (if wind-C (window-frame wind-C))) - (ctl-frame-exists-p (ediff-with-current-buffer control-buf + (ctl-frame-exists-p (with-current-buffer control-buf (frame-live-p ediff-control-frame))) ;; on wide display, do things in one frame (force-one-frame - (ediff-with-current-buffer control-buf ediff-wide-display-p)) + (with-current-buffer control-buf ediff-wide-display-p)) ;; this lets us have local versions of ediff-split-window-function (split-window-function - (ediff-with-current-buffer control-buf ediff-split-window-function)) + (with-current-buffer control-buf ediff-split-window-function)) (three-way-comparison - (ediff-with-current-buffer control-buf ediff-3way-comparison-job)) - (orig-wind (selected-window)) + (with-current-buffer control-buf ediff-3way-comparison-job)) (use-same-frame (or force-one-frame (eq frame-A frame-B) (not (ediff-window-ok-for-display wind-A)) @@ -792,10 +774,9 @@ into icons, regardless of the window manager." (or ctl-frame-exists-p (eq frame-B (selected-frame)))))) wind-A-start wind-B-start - designated-minibuffer-frame - done-A done-B done-C) + designated-minibuffer-frame) - (ediff-with-current-buffer control-buf + (with-current-buffer control-buf (setq wind-A-start (ediff-overlay-start (ediff-get-value-according-to-buffer-type 'A ediff-narrow-bounds)) @@ -803,30 +784,6 @@ into icons, regardless of the window manager." (ediff-get-value-according-to-buffer-type 'B ediff-narrow-bounds)))) - (if (and (window-live-p wind-A) (null use-same-frame)) ; buf-A on its own - (progn - ;; buffer buf-A is seen in live wind-A - (select-window wind-A) ; must be displaying buf-A - (delete-other-windows) - (setq wind-A (selected-window)) - (setq done-A t))) - - (if (and (window-live-p wind-B) (null use-same-frame)) ; buf B on its own - (progn - ;; buffer buf-B is seen in live wind-B - (select-window wind-B) ; must be displaying buf-B - (delete-other-windows) - (setq wind-B (selected-window)) - (setq done-B t))) - - (if (and (window-live-p wind-C) (null use-same-frame)) ; buf C on its own - (progn - ;; buffer buf-C is seen in live wind-C - (select-window wind-C) ; must be displaying buf-C - (delete-other-windows) - (setq wind-C (selected-window)) - (setq done-C t))) - (if use-same-frame (let (wind-width-or-height) ; this affects 3way setups only (if (and (eq frame-A frame-B) (frame-live-p frame-A)) @@ -840,7 +797,7 @@ into icons, regardless of the window manager." (if three-way-comparison (setq wind-width-or-height (/ - (if (eq split-window-function 'split-window-vertically) + (if (eq split-window-function #'split-window-vertically) (window-height wind-A) (window-width wind-A)) 3))) @@ -857,46 +814,57 @@ into icons, regardless of the window manager." (if (memq (selected-window) (list wind-A wind-B)) (other-window 1)) (switch-to-buffer buf-C) - (setq wind-C (selected-window)))) - (setq done-A t - done-B t - done-C t) - )) - - (or done-A ; Buf A to be set in its own frame - ;;; or it was set before because use-same-frame = 1 - (progn - ;; Buf-A was not set up yet as it wasn't visible, - ;; and use-same-frame = nil - (select-window orig-wind) - (delete-other-windows) - (switch-to-buffer buf-A) - (setq wind-A (selected-window)) - )) - (or done-B ; Buf B to be set in its own frame - ;;; or it was set before because use-same-frame = 1 - (progn - ;; Buf-B was not set up yet as it wasn't visible, - ;; and use-same-frame = nil - (select-window orig-wind) - (delete-other-windows) - (switch-to-buffer buf-B) - (setq wind-B (selected-window)) - )) - - (if three-way-comparison - (or done-C ; Buf C to be set in its own frame - ;;; or it was set before because use-same-frame = 1 + (setq wind-C (selected-window))))) + + (if (window-live-p wind-A) ; buf-A on its own + (progn + ;; buffer buf-A is seen in live wind-A + (select-window wind-A) ; must be displaying buf-A + (delete-other-windows) + (setq wind-A (selected-window))) ;FIXME: Why? + ;; Buf-A was not set up yet as it wasn't visible, + ;; and use-same-frame = nil + ;; Skip dedicated or iconified frames. + ;; Unsplittable frames are taken care of later. + (ediff-skip-unsuitable-frames 'ok-unsplittable) + (delete-other-windows) + (switch-to-buffer buf-A) + (setq wind-A (selected-window))) + + (if (window-live-p wind-B) ; buf B on its own + (progn + ;; buffer buf-B is seen in live wind-B + (select-window wind-B) ; must be displaying buf-B + (delete-other-windows) + (setq wind-B (selected-window))) ;FIXME: Why? + ;; Buf-B was not set up yet as it wasn't visible, + ;; and use-same-frame = nil + ;; Skip dedicated or iconified frames. + ;; Unsplittable frames are taken care of later. + (ediff-skip-unsuitable-frames 'ok-unsplittable) + (delete-other-windows) + (switch-to-buffer buf-B) + (setq wind-B (selected-window))) + + (if (window-live-p wind-C) ; buf C on its own + (progn + ;; buffer buf-C is seen in live wind-C + (select-window wind-C) ; must be displaying buf-C + (delete-other-windows) + (setq wind-C (selected-window))) ;FIXME: Why? + (if three-way-comparison (progn ;; Buf-C was not set up yet as it wasn't visible, ;; and use-same-frame = nil - (select-window orig-wind) + ;; Skip dedicated or iconified frames. + ;; Unsplittable frames are taken care of later. + (ediff-skip-unsuitable-frames 'ok-unsplittable) (delete-other-windows) (switch-to-buffer buf-C) (setq wind-C (selected-window)) - ))) + )))) - (ediff-with-current-buffer control-buf + (with-current-buffer control-buf (setq ediff-window-A wind-A ediff-window-B wind-B ediff-window-C wind-C) @@ -915,9 +883,9 @@ into icons, regardless of the window manager." (ediff-setup-control-frame control-buf designated-minibuffer-frame) )) -;; skip unsplittable frames and frames that have dedicated windows. -;; create a new splittable frame if none is found (defun ediff-skip-unsuitable-frames (&optional ok-unsplittable) + "Skip unsplittable frames and frames that have dedicated windows. +create a new splittable frame if none is found." (if (ediff-window-display-p) (let ((wind-frame (window-frame)) seen-windows) @@ -977,14 +945,14 @@ into icons, regardless of the window manager." ;; user-grabbed-mouse fheight fwidth adjusted-parameters) - (ediff-with-current-buffer ctl-buffer + (with-current-buffer ctl-buffer (if (and (featurep 'xemacs) (featurep 'menubar)) (set-buffer-menubar nil)) ;;(setq user-grabbed-mouse (ediff-user-grabbed-mouse)) (run-hooks 'ediff-before-setup-control-frame-hook)) - (setq old-ctl-frame (ediff-with-current-buffer ctl-buffer ediff-control-frame)) - (ediff-with-current-buffer ctl-buffer + (setq old-ctl-frame (with-current-buffer ctl-buffer ediff-control-frame)) + (with-current-buffer ctl-buffer (setq ctl-frame (if (frame-live-p old-ctl-frame) old-ctl-frame (make-frame ediff-control-frame-parameters)) @@ -1004,7 +972,7 @@ into icons, regardless of the window manager." ;; must be before ediff-setup-control-buffer ;; just a precaution--we should be in ctl-buffer already - (ediff-with-current-buffer ctl-buffer + (with-current-buffer ctl-buffer (make-local-variable 'frame-title-format) (make-local-variable 'frame-icon-title-format) ; XEmacs (make-local-variable 'icon-title-format)) ; Emacs @@ -1103,12 +1071,12 @@ into icons, regardless of the window manager." (not (eq ediff-grab-mouse t))))) (when (featurep 'xemacs) - (ediff-with-current-buffer ctl-buffer + (with-current-buffer ctl-buffer (make-local-hook 'select-frame-hook) (add-hook 'select-frame-hook - 'ediff-xemacs-select-frame-hook nil 'local))) + #'ediff-xemacs-select-frame-hook nil 'local))) - (ediff-with-current-buffer ctl-buffer + (with-current-buffer ctl-buffer (run-hooks 'ediff-after-setup-control-frame-hook)))) @@ -1128,7 +1096,7 @@ into icons, regardless of the window manager." ;; finds a good place to clip control frame (defun ediff-make-frame-position (ctl-buffer ctl-frame-width ctl-frame-height) - (ediff-with-current-buffer ctl-buffer + (with-current-buffer ctl-buffer (let* ((frame-A (window-frame ediff-window-A)) (frame-A-parameters (frame-parameters frame-A)) (frame-A-top (eval (cdr (assoc 'top frame-A-parameters)))) @@ -1382,12 +1350,4 @@ It assumes that it is called from within the control buffer." (provide 'ediff-wind) - - -;; Local Variables: -;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;; End: - ;;; ediff-wind.el ends here diff --git a/lisp/vc/ediff.el b/lisp/vc/ediff.el index 68c4fa2722a..20e27003dac 100644 --- a/lisp/vc/ediff.el +++ b/lisp/vc/ediff.el @@ -1,21 +1,18 @@ -;;; ediff.el --- a comprehensive visual interface to diff & patch +;;; ediff.el --- a comprehensive visual interface to diff & patch -*- lexical-binding:t -*- ;; Copyright (C) 1994-2019 Free Software Foundation, Inc. ;; Author: Michael Kifer <kifer@cs.stonybrook.edu> ;; Created: February 2, 1994 ;; Keywords: comparing, merging, patching, vc, tools, unix -;; Version: 2.81.4 +;; Version: 2.81.6 +(defconst ediff-version "2.81.6" "The current version of Ediff") ;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this ;; file on 20/3/2008, and the maintainer agreed that when a bug is ;; filed in the Emacs bug reporting system against this file, a copy ;; of the bug report be sent to the maintainer's email address. -(defconst ediff-version "2.81.5" "The current version of Ediff") -(defconst ediff-date "July 4, 2013" "Date of last update") - - ;; This file is part of GNU Emacs. ;; GNU Emacs is free software: you can redistribute it and/or modify @@ -110,12 +107,6 @@ ;;; Code: -(provide 'ediff) - -;; Compiler pacifier -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r)))) - (require 'ediff-util) ;; end pacifier @@ -130,8 +121,7 @@ (defcustom ediff-use-last-dir nil "If t, Ediff will use previous directory as default when reading file name." - :type 'boolean - :group 'ediff) + :type 'boolean) ;; Last directory used by an Ediff command for file-A. (defvar ediff-last-dir-A nil) @@ -153,7 +143,7 @@ (declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep)) (declare-function dired-get-marked-files "dired" - (&optional localp arg filter distinguish-one-marked)) + (&optional localp arg filter distinguish-one-marked error)) ;; Return a plausible default for ediff's first file: ;; In dired, return the file number FILENO (or 0) in the list @@ -204,7 +194,7 @@ arguments after setting up the Ediff buffers." ediff-last-dir-B (file-name-directory f))) (progn - (ediff-add-to-history + (add-to-history 'file-name-history (ediff-abbreviate-file-name (expand-file-name @@ -242,7 +232,7 @@ arguments after setting up the Ediff buffers." ediff-last-dir-B (file-name-directory f))) (progn - (ediff-add-to-history + (add-to-history 'file-name-history (ediff-abbreviate-file-name (expand-file-name @@ -254,7 +244,7 @@ arguments after setting up the Ediff buffers." ediff-last-dir-C (file-name-directory ff))) (progn - (ediff-add-to-history + (add-to-history 'file-name-history (ediff-abbreviate-file-name (expand-file-name @@ -277,20 +267,24 @@ arguments after setting up the Ediff buffers." ;;;###autoload (defalias 'ediff3 'ediff-files3) +(defvar-local ediff--magic-file-name nil + "Name of file where buffer's content was saved. +Only non-nil in \"magic\" buffers such as those of remote files.") -(defun ediff-find-file (file-var buffer-name &optional last-dir hooks-var) +(defvar ediff--startup-hook nil) + +(defun ediff-find-file (file &optional last-dir) "Visit FILE and arrange its buffer to Ediff's liking. -FILE-VAR is actually a variable symbol whose value must contain a true -file name. -BUFFER-NAME is a variable symbol, which will get the buffer object into -which FILE is read. +FILE is the file name. LAST-DIR is the directory variable symbol where FILE's -directory name should be returned. HOOKS-VAR is a variable symbol that will -be assigned the hook to be executed after `ediff-startup' is finished. +directory name should be returned. May push to `ediff--startup-hook' +functions to be executed after `ediff-startup' is finished. `ediff-find-file' arranges that the temp files it might create will be -deleted." - (let* ((file (symbol-value file-var)) - (file-magic (ediff-filename-magic-p file)) +deleted. +Returns the buffer into which the file is visited. +Also sets `ediff--magic-file-name' to indicate where the file's content +has been saved (if not in `buffer-file-name')." + (let* ((file-magic (ediff-filename-magic-p file)) (temp-file-name-prefix (file-name-nondirectory file))) (cond ((not (file-readable-p file)) (user-error "File `%s' does not exist or is not readable" file)) @@ -305,58 +299,61 @@ deleted." (set last-dir (expand-file-name (file-name-directory file)))) ;; Setup the buffer - (set buffer-name (find-file-noselect file)) - - (ediff-with-current-buffer (symbol-value buffer-name) - (widen) ; Make sure the entire file is seen - (cond (file-magic ; file has a handler, such as jka-compr-handler or - ;;; ange-ftp-hook-function--arrange for temp file + (with-current-buffer (find-file-noselect file) + (widen) ; Make sure the entire file is seen + (setq ediff--magic-file-name nil) + (cond (file-magic ; File has a handler, such as jka-compr-handler or + ; ange-ftp-hook-function--arrange for temp file (ediff-verify-file-buffer 'magic) - (setq file - (ediff-make-temp-file - (current-buffer) temp-file-name-prefix)) - (set hooks-var (cons `(lambda () (delete-file ,file)) - (symbol-value hooks-var)))) + (let ((file + (ediff-make-temp-file + (current-buffer) temp-file-name-prefix))) + (add-hook 'ediff--startup-hook (lambda () (delete-file file))) + (setq ediff--magic-file-name file))) ;; file processed via auto-mode-alist, a la uncompress.el ((not (equal (file-truename file) - (file-truename (buffer-file-name)))) - (setq file - (ediff-make-temp-file - (current-buffer) temp-file-name-prefix)) - (set hooks-var (cons `(lambda () (delete-file ,file)) - (symbol-value hooks-var)))) + (file-truename buffer-file-name))) + (let ((file + (ediff-make-temp-file + (current-buffer) temp-file-name-prefix))) + (add-hook 'ediff--startup-hook (lambda () (delete-file file))) + (setq ediff--magic-file-name file))) (t ;; plain file---just check that the file matches the buffer - (ediff-verify-file-buffer)))) - (set file-var file))) + (ediff-verify-file-buffer))) + (current-buffer)))) + +(defun ediff--buffer-file-name (buf) + (when buf + (with-current-buffer buf (or ediff--magic-file-name buffer-file-name)))) ;; MERGE-BUFFER-FILE is the file to be associated with the merge buffer (defun ediff-files-internal (file-A file-B file-C startup-hooks job-name &optional merge-buffer-file) - (let (buf-A buf-B buf-C) - (if (string= file-A file-B) - (error "Files A and B are the same")) - (if (stringp file-C) - (or (and (string= file-A file-C) (error "Files A and C are the same")) - (and (string= file-B file-C) (error "Files B and C are the same")))) + (if (string= file-A file-B) + (error "Files A and B are the same")) + (if (stringp file-C) + (or (and (string= file-A file-C) (error "Files A and C are the same")) + (and (string= file-B file-C) (error "Files B and C are the same")))) + (let ((ediff--startup-hook startup-hooks) + buf-A buf-B buf-C) + (message "Reading file %s ... " file-A) ;;(sit-for 0) - (ediff-find-file 'file-A 'buf-A 'ediff-last-dir-A 'startup-hooks) + (setq buf-A (ediff-find-file file-A 'ediff-last-dir-A)) (message "Reading file %s ... " file-B) ;;(sit-for 0) - (ediff-find-file 'file-B 'buf-B 'ediff-last-dir-B 'startup-hooks) - (if (stringp file-C) - (progn - (message "Reading file %s ... " file-C) - ;;(sit-for 0) - (ediff-find-file - 'file-C 'buf-C - (if (eq job-name 'ediff-merge-files-with-ancestor) - 'ediff-last-dir-ancestor 'ediff-last-dir-C) - 'startup-hooks))) - (ediff-setup buf-A file-A - buf-B file-B - buf-C file-C - startup-hooks + (setq buf-B (ediff-find-file file-B 'ediff-last-dir-B)) + (when (stringp file-C) + (message "Reading file %s ... " file-C) + ;;(sit-for 0) + (setq buf-C (ediff-find-file + file-C + (if (eq job-name 'ediff-merge-files-with-ancestor) + 'ediff-last-dir-ancestor 'ediff-last-dir-C)))) + (ediff-setup buf-A (ediff--buffer-file-name buf-A) + buf-B (ediff--buffer-file-name buf-B) + buf-C (ediff--buffer-file-name buf-C) + ediff--startup-hook (list (cons 'ediff-job-name job-name)) merge-buffer-file))) @@ -522,10 +519,10 @@ symbol describing the Ediff job type; it defaults to (get-buffer buf-B) file-B (if buf-C-is-alive (get-buffer buf-C)) file-C - (cons `(lambda () - (delete-file ,file-A) - (delete-file ,file-B) - (if (stringp ,file-C) (delete-file ,file-C))) + (cons (lambda () + (delete-file file-A) + (delete-file file-B) + (if (stringp file-C) (delete-file file-C))) startup-hooks) (list (cons 'ediff-job-name job-name)) merge-buffer-file)) @@ -579,7 +576,7 @@ expression; only file names that match the regexp are considered." (eval ediff-default-filtering-regexp)) ))) (ediff-directories-internal - dir1 dir2 nil regexp 'ediff-files 'ediff-directories + dir1 dir2 nil regexp #'ediff-files 'ediff-directories )) ;;;###autoload @@ -645,7 +642,7 @@ regular expression; only file names that match the regexp are considered." (eval ediff-default-filtering-regexp)) ))) (ediff-directories-internal - dir1 dir2 dir3 regexp 'ediff-files3 'ediff-directories3 + dir1 dir2 dir3 regexp #'ediff-files3 'ediff-directories3 )) ;;;###autoload @@ -678,7 +675,7 @@ MERGE-AUTOSTORE-DIR is the directory in which to store merged files." (eval ediff-default-filtering-regexp)) ))) (ediff-directories-internal - dir1 dir2 nil regexp 'ediff-merge-files 'ediff-merge-directories + dir1 dir2 nil regexp #'ediff-merge-files 'ediff-merge-directories nil merge-autostore-dir )) @@ -721,7 +718,7 @@ MERGE-AUTOSTORE-DIR is the directory in which to store merged files." ))) (ediff-directories-internal dir1 dir2 ancestor-dir regexp - 'ediff-merge-files-with-ancestor 'ediff-merge-directories-with-ancestor + #'ediff-merge-files-with-ancestor 'ediff-merge-directories-with-ancestor nil merge-autostore-dir )) @@ -851,21 +848,20 @@ MERGE-AUTOSTORE-DIR is the directory in which to store merged files." (setq dir-diff-struct (ediff-intersect-directories jobname regexp dir1 dir2 dir3 merge-autostore-dir)) - (setq startup-hooks - ;; this sets various vars in the meta buffer inside - ;; ediff-prepare-meta-buffer - (cons `(lambda () - ;; tell what to do if the user clicks on a session record - (setq ediff-session-action-function (quote ,action)) - ;; set ediff-dir-difference-list - (setq ediff-dir-difference-list - (cdr (quote ,dir-diff-struct)))) - startup-hooks)) + ;; this sets various vars in the meta buffer inside + ;; ediff-prepare-meta-buffer + (push (lambda () + ;; tell what to do if the user clicks on a session record + (setq ediff-session-action-function action) + ;; set ediff-dir-difference-list + (setq ediff-dir-difference-list + (cdr dir-diff-struct))) + startup-hooks) (setq meta-buf (ediff-prepare-meta-buffer - 'ediff-filegroup-action + #'ediff-filegroup-action (car dir-diff-struct) "*Ediff Session Group Panel" - 'ediff-redraw-directory-group-buffer + #'ediff-redraw-directory-group-buffer jobname startup-hooks)) (ediff-show-meta-buffer meta-buf) @@ -904,18 +900,17 @@ MERGE-AUTOSTORE-DIR is the directory in which to store merged files." (setq file-list (ediff-get-directory-files-under-revision jobname regexp dir1 merge-autostore-dir)) - (setq startup-hooks - ;; this sets various vars in the meta buffer inside - ;; ediff-prepare-meta-buffer - (cons `(lambda () - ;; tell what to do if the user clicks on a session record - (setq ediff-session-action-function (quote ,action))) - startup-hooks)) + ;; this sets various vars in the meta buffer inside + ;; ediff-prepare-meta-buffer + (push (lambda () + ;; tell what to do if the user clicks on a session record + (setq ediff-session-action-function action)) + startup-hooks) (setq meta-buf (ediff-prepare-meta-buffer - 'ediff-filegroup-action + #'ediff-filegroup-action file-list "*Ediff Session Group Panel" - 'ediff-redraw-directory-group-buffer + #'ediff-redraw-directory-group-buffer jobname startup-hooks)) (ediff-show-meta-buffer meta-buf) @@ -1128,9 +1123,9 @@ arguments after setting up the Ediff buffers." (ediff-setup buffer-A file-A buffer-B file-B nil nil ; buffer & file C - (cons `(lambda () - (delete-file ,file-A) - (delete-file ,file-B)) + (cons (lambda () + (delete-file file-A) + (delete-file file-B)) startup-hooks) (append (list (cons 'ediff-word-mode word-mode) @@ -1183,7 +1178,7 @@ is the name of the file to be associated with the merge buffer.." ediff-last-dir-B (file-name-directory f))) (progn - (ediff-add-to-history + (add-to-history 'file-name-history (ediff-abbreviate-file-name (expand-file-name @@ -1232,7 +1227,7 @@ the file to be associated with the merge buffer." ediff-last-dir-B (file-name-directory f))) (progn - (ediff-add-to-history + (add-to-history 'file-name-history (ediff-abbreviate-file-name (expand-file-name @@ -1245,7 +1240,7 @@ the file to be associated with the merge buffer." ediff-last-dir-ancestor (file-name-directory ff))) (progn - (ediff-add-to-history + (add-to-history 'file-name-history (ediff-abbreviate-file-name (expand-file-name @@ -1550,7 +1545,7 @@ When called interactively, displays the version." (interactive-p) (called-interactively-p 'interactive)) (message "%s" (ediff-version)) - (format "Ediff %s of %s" ediff-version ediff-date))) + (format "Ediff %s" ediff-version))) ;; info is run first, and will autoload info.el. (declare-function Info-goto-node "info" (nodename &optional fork strict-case)) @@ -1657,17 +1652,7 @@ With optional NODE, goes to that node." (setq command-line-args-left (nthcdr 4 command-line-args-left)) (ediff-merge-directories-with-ancestor file-a file-b ancestor regexp))) - - -(require 'ediff-util) - (run-hooks 'ediff-load-hook) - -;; Local Variables: -;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;; End: - +(provide 'ediff) ;;; ediff.el ends here diff --git a/lisp/vc/emerge.el b/lisp/vc/emerge.el index 0da14d07fd3..fc8c318e3af 100644 --- a/lisp/vc/emerge.el +++ b/lisp/vc/emerge.el @@ -1,6 +1,6 @@ -;;; emerge.el --- merge diffs under Emacs control +;;; emerge.el --- merge diffs under Emacs control -*- lexical-binding:t -*- -;;; The author has placed this file in the public domain. +;; The author has placed this file in the public domain. ;; This file is part of GNU Emacs. @@ -24,42 +24,20 @@ ;;; Code: -;; There aren't really global variables, just dynamic bindings -(defvar A-begin) -(defvar A-end) -(defvar B-begin) -(defvar B-end) -(defvar diff-vector) -(defvar merge-begin) -(defvar merge-end) -(defvar valid-diff) - ;;; Macros (defmacro emerge-defvar-local (var value doc) - "Defines SYMBOL as an advertised variable. + "Define SYMBOL as an advertised buffer-local variable. Performs a defvar, then executes `make-variable-buffer-local' on the variable. Also sets the `permanent-local' property, so that `kill-all-local-variables' (called by major-mode setting commands) won't destroy Emerge control variables." `(progn - (defvar ,var ,value ,doc) - (make-variable-buffer-local ',var) - (put ',var 'permanent-local t))) - -;; Add entries to minor-mode-alist so that emerge modes show correctly -(defvar emerge-minor-modes-list - '((emerge-mode " Emerge") - (emerge-fast-mode " F") - (emerge-edit-mode " E") - (emerge-auto-advance " A") - (emerge-skip-prefers " S"))) -(if (not (assq 'emerge-mode minor-mode-alist)) - (setq minor-mode-alist (append emerge-minor-modes-list - minor-mode-alist))) + (defvar-local ,var ,value ,doc) + (put ',var 'permanent-local t))) ;; We need to define this function so describe-mode can describe Emerge mode. -(defun emerge-mode () +(define-minor-mode emerge-mode "Emerge mode is used by the Emerge file-merging package. It is entered only through one of the functions: `emerge-files' @@ -74,7 +52,13 @@ It is entered only through one of the functions: Commands: \\{emerge-basic-keymap} Commands must be prefixed by \\<emerge-fast-keymap>\\[emerge-basic-keymap] in `edit' mode, -but can be invoked directly in `fast' mode.") +but can be invoked directly in `fast' mode." + :lighter (" Emerge" + (emerge-fast-mode " F") + (emerge-edit-mode " E") + (emerge-auto-advance " A") + (emerge-skip-prefers " S"))) +(put 'emerge-mode 'permanent-local t) ;;; Emerge configuration variables @@ -453,8 +437,6 @@ Must be set before Emerge is loaded." ;; Variables which control each merge. They are local to the merge buffer. ;; Mode variables -(emerge-defvar-local emerge-mode nil - "Indicator for emerge-mode.") (emerge-defvar-local emerge-fast-mode nil "Indicator for emerge-mode fast submode.") (emerge-defvar-local emerge-edit-mode nil @@ -556,7 +538,7 @@ This is *not* a user option, since Emerge uses it for its own processing.") (if temp (setq file-A temp startup-hooks - (cons `(lambda () (delete-file ,file-A)) + (cons (lambda () (delete-file file-A)) startup-hooks)) ;; Verify that the file matches the buffer (emerge-verify-file-buffer)))) @@ -567,7 +549,7 @@ This is *not* a user option, since Emerge uses it for its own processing.") (if temp (setq file-B temp startup-hooks - (cons `(lambda () (delete-file ,file-B)) + (cons (lambda () (delete-file file-B)) startup-hooks)) ;; Verify that the file matches the buffer (emerge-verify-file-buffer)))) @@ -584,48 +566,49 @@ This is *not* a user option, since Emerge uses it for its own processing.") ;; create the merge buffer from buffer A, so it inherits buffer A's ;; default directory, etc. (merge-buffer (with-current-buffer - buffer-A - (get-buffer-create merge-buffer-name)))) + buffer-A + (get-buffer-create merge-buffer-name)))) (with-current-buffer - merge-buffer - (emerge-copy-modes buffer-A) - (setq buffer-read-only nil) - (auto-save-mode 1) - (setq emerge-mode t) - (setq emerge-A-buffer buffer-A) - (setq emerge-B-buffer buffer-B) - (setq emerge-ancestor-buffer nil) - (setq emerge-merge-buffer merge-buffer) - (setq emerge-output-description - (if output-file - (concat "Output to file: " output-file) - (concat "Output to buffer: " (buffer-name merge-buffer)))) - (save-excursion (insert-buffer-substring emerge-A-buffer)) - (emerge-set-keys) - (setq emerge-difference-list (emerge-make-diff-list file-A file-B)) - (setq emerge-number-of-differences (length emerge-difference-list)) - (setq emerge-current-difference -1) - (setq emerge-quit-hook quit-hooks) - (emerge-remember-buffer-characteristics) - (emerge-handle-local-variables)) + merge-buffer + (emerge-copy-modes buffer-A) + (setq buffer-read-only nil) + (auto-save-mode 1) + (setq emerge-mode t) + (setq emerge-A-buffer buffer-A) + (setq emerge-B-buffer buffer-B) + (setq emerge-ancestor-buffer nil) + (setq emerge-merge-buffer merge-buffer) + (setq emerge-output-description + (if output-file + (concat "Output to file: " output-file) + (concat "Output to buffer: " (buffer-name merge-buffer)))) + (save-excursion (insert-buffer-substring emerge-A-buffer)) + (emerge-set-keys) + (setq emerge-difference-list (emerge-make-diff-list file-A file-B)) + (setq emerge-number-of-differences (length emerge-difference-list)) + (setq emerge-current-difference -1) + (setq emerge-quit-hook quit-hooks) + (emerge-remember-buffer-characteristics) + (emerge-handle-local-variables)) (emerge-setup-windows buffer-A buffer-B merge-buffer t) (with-current-buffer merge-buffer - (run-hooks 'startup-hooks 'emerge-startup-hook) - (setq buffer-read-only t)))) + (mapc #'funcall startup-hooks) + (run-hooks 'emerge-startup-hook) + (setq buffer-read-only t)))) ;; Generate the Emerge difference list between two files (defun emerge-make-diff-list (file-A file-B) (setq emerge-diff-buffer (get-buffer-create "*emerge-diff*")) (with-current-buffer - emerge-diff-buffer - (erase-buffer) - (shell-command - (format "%s %s %s %s" - (shell-quote-argument emerge-diff-program) - emerge-diff-options - (shell-quote-argument file-A) - (shell-quote-argument file-B)) - t)) + emerge-diff-buffer + (erase-buffer) + (shell-command + (format "%s %s %s %s" + (shell-quote-argument emerge-diff-program) + emerge-diff-options + (shell-quote-argument file-A) + (shell-quote-argument file-B)) + t)) (emerge-prepare-error-list emerge-diff-ok-lines-regexp) (emerge-convert-diffs-to-markers emerge-A-buffer emerge-B-buffer emerge-merge-buffer @@ -711,7 +694,7 @@ This is *not* a user option, since Emerge uses it for its own processing.") (if temp (setq file-A temp startup-hooks - (cons `(lambda () (delete-file ,file-A)) + (cons (lambda () (delete-file file-A)) startup-hooks)) ;; Verify that the file matches the buffer (emerge-verify-file-buffer)))) @@ -722,7 +705,7 @@ This is *not* a user option, since Emerge uses it for its own processing.") (if temp (setq file-B temp startup-hooks - (cons `(lambda () (delete-file ,file-B)) + (cons (lambda () (delete-file file-B)) startup-hooks)) ;; Verify that the file matches the buffer (emerge-verify-file-buffer)))) @@ -733,7 +716,7 @@ This is *not* a user option, since Emerge uses it for its own processing.") (if temp (setq file-ancestor temp startup-hooks - (cons `(lambda () (delete-file ,file-ancestor)) + (cons (lambda () (delete-file file-ancestor)) startup-hooks)) ;; Verify that the file matches the buffer (emerge-verify-file-buffer)))) @@ -746,6 +729,7 @@ This is *not* a user option, since Emerge uses it for its own processing.") buffer-ancestor file-ancestor &optional startup-hooks quit-hooks output-file) + ;; FIXME: Duplicated code! (setq file-A (expand-file-name file-A)) (setq file-B (expand-file-name file-B)) (setq file-ancestor (expand-file-name file-ancestor)) @@ -754,36 +738,37 @@ This is *not* a user option, since Emerge uses it for its own processing.") ;; create the merge buffer from buffer A, so it inherits buffer A's ;; default directory, etc. (merge-buffer (with-current-buffer - buffer-A - (get-buffer-create merge-buffer-name)))) + buffer-A + (get-buffer-create merge-buffer-name)))) (with-current-buffer - merge-buffer - (emerge-copy-modes buffer-A) - (setq buffer-read-only nil) - (auto-save-mode 1) - (setq emerge-mode t) - (setq emerge-A-buffer buffer-A) - (setq emerge-B-buffer buffer-B) - (setq emerge-ancestor-buffer buffer-ancestor) - (setq emerge-merge-buffer merge-buffer) - (setq emerge-output-description - (if output-file - (concat "Output to file: " output-file) - (concat "Output to buffer: " (buffer-name merge-buffer)))) - (save-excursion (insert-buffer-substring emerge-A-buffer)) - (emerge-set-keys) - (setq emerge-difference-list - (emerge-make-diff3-list file-A file-B file-ancestor)) - (setq emerge-number-of-differences (length emerge-difference-list)) - (setq emerge-current-difference -1) - (setq emerge-quit-hook quit-hooks) - (emerge-remember-buffer-characteristics) - (emerge-select-prefer-Bs) - (emerge-handle-local-variables)) + merge-buffer + (emerge-copy-modes buffer-A) + (setq buffer-read-only nil) + (auto-save-mode 1) + (setq emerge-mode t) + (setq emerge-A-buffer buffer-A) + (setq emerge-B-buffer buffer-B) + (setq emerge-ancestor-buffer buffer-ancestor) + (setq emerge-merge-buffer merge-buffer) + (setq emerge-output-description + (if output-file + (concat "Output to file: " output-file) + (concat "Output to buffer: " (buffer-name merge-buffer)))) + (save-excursion (insert-buffer-substring emerge-A-buffer)) + (emerge-set-keys) + (setq emerge-difference-list + (emerge-make-diff3-list file-A file-B file-ancestor)) + (setq emerge-number-of-differences (length emerge-difference-list)) + (setq emerge-current-difference -1) + (setq emerge-quit-hook quit-hooks) + (emerge-remember-buffer-characteristics) + (emerge-select-prefer-Bs) + (emerge-handle-local-variables)) (emerge-setup-windows buffer-A buffer-B merge-buffer t) (with-current-buffer merge-buffer - (run-hooks 'startup-hooks 'emerge-startup-hook) - (setq buffer-read-only t)))) + (mapc #'funcall startup-hooks) + (run-hooks 'emerge-startup-hook) + (setq buffer-read-only t)))) ;; Generate the Emerge difference list between two files with an ancestor (defun emerge-make-diff3-list (file-A file-B file-ancestor) @@ -872,7 +857,7 @@ This is *not* a user option, since Emerge uses it for its own processing.") (emerge-read-file-name "Output file" emerge-last-dir-output f f nil))))) (if file-out - (add-hook 'quit-hooks `(lambda () (emerge-files-exit ,file-out)))) + (push (lambda () (emerge-files-exit file-out)) quit-hooks)) (emerge-files-internal file-A file-B startup-hooks quit-hooks @@ -894,7 +879,7 @@ This is *not* a user option, since Emerge uses it for its own processing.") (emerge-read-file-name "Output file" emerge-last-dir-output f f nil))))) (if file-out - (add-hook 'quit-hooks `(lambda () (emerge-files-exit ,file-out)))) + (push (lambda () (emerge-files-exit file-out)) quit-hooks)) (emerge-files-with-ancestor-internal file-A file-B file-ancestor startup-hooks quit-hooks @@ -922,9 +907,9 @@ This is *not* a user option, since Emerge uses it for its own processing.") (write-region (point-min) (point-max) emerge-file-B nil 'no-message)) (emerge-setup (get-buffer buffer-A) emerge-file-A (get-buffer buffer-B) emerge-file-B - (cons `(lambda () - (delete-file ,emerge-file-A) - (delete-file ,emerge-file-B)) + (cons (lambda () + (delete-file emerge-file-A) + (delete-file emerge-file-B)) startup-hooks) quit-hooks nil))) @@ -953,11 +938,10 @@ This is *not* a user option, since Emerge uses it for its own processing.") (get-buffer buffer-B) emerge-file-B (get-buffer buffer-ancestor) emerge-file-ancestor - (cons `(lambda () - (delete-file ,emerge-file-A) - (delete-file ,emerge-file-B) - (delete-file - ,emerge-file-ancestor)) + (cons (lambda () + (delete-file emerge-file-A) + (delete-file emerge-file-B) + (delete-file emerge-file-ancestor)) startup-hooks) quit-hooks nil))) @@ -972,7 +956,7 @@ This is *not* a user option, since Emerge uses it for its own processing.") (setq command-line-args-left (nthcdr 3 command-line-args-left)) (emerge-files-internal file-a file-b nil - (list `(lambda () (emerge-command-exit ,file-out)))))) + (list (lambda () (emerge-command-exit file-out)))))) ;;;###autoload (defun emerge-files-with-ancestor-command () @@ -994,7 +978,7 @@ This is *not* a user option, since Emerge uses it for its own processing.") (setq command-line-args-left (nthcdr 4 command-line-args-left))) (emerge-files-with-ancestor-internal file-a file-b file-anc nil - (list `(lambda () (emerge-command-exit ,file-out)))))) + (list (lambda () (emerge-command-exit file-out)))))) (defun emerge-command-exit (file-out) (emerge-write-and-delete file-out) @@ -1007,7 +991,8 @@ This is *not* a user option, since Emerge uses it for its own processing.") (setq emerge-file-out file-out) (emerge-files-internal file-a file-b nil - (list `(lambda () (emerge-remote-exit ,file-out ',emerge-exit-func))) + (let ((f emerge-exit-func)) + (list (lambda () (emerge-remote-exit file-out f)))) file-out) (throw 'client-wait nil)) @@ -1016,14 +1001,15 @@ This is *not* a user option, since Emerge uses it for its own processing.") (setq emerge-file-out file-out) (emerge-files-with-ancestor-internal file-a file-b file-anc nil - (list `(lambda () (emerge-remote-exit ,file-out ',emerge-exit-func))) + (let ((f emerge-exit-func)) + (list (lambda () (emerge-remote-exit file-out f)))) file-out) (throw 'client-wait nil)) -(defun emerge-remote-exit (file-out emerge-exit-func) +(defun emerge-remote-exit (file-out exit-func) (emerge-write-and-delete file-out) (kill-buffer emerge-merge-buffer) - (funcall emerge-exit-func (if emerge-prefix-argument 1 0))) + (funcall exit-func (if emerge-prefix-argument 1 0))) ;;; Functions to start Emerge on RCS versions @@ -1041,10 +1027,9 @@ This is *not* a user option, since Emerge uses it for its own processing.") (emerge-revisions-internal file revision-A revision-B startup-hooks (if arg - (cons `(lambda () - (shell-command - ,(format "%s %s" emerge-rcs-ci-program file))) - quit-hooks) + (let ((cmd (format "%s %s" emerge-rcs-ci-program file))) + (cons (lambda () (shell-command cmd)) + quit-hooks)) quit-hooks))) ;;;###autoload @@ -1065,12 +1050,10 @@ This is *not* a user option, since Emerge uses it for its own processing.") (emerge-revision-with-ancestor-internal file revision-A revision-B ancestor startup-hooks (if arg - (let ((cmd )) - (cons `(lambda () - (shell-command - ,(format "%s %s" emerge-rcs-ci-program file))) + (let ((cmd (format "%s %s" emerge-rcs-ci-program file))) + (cons (lambda () (shell-command cmd)) quit-hooks)) - quit-hooks))) + quit-hooks))) (defun emerge-revisions-internal (file revision-A revision-B &optional startup-hooks quit-hooks _output-file) @@ -1098,11 +1081,11 @@ This is *not* a user option, since Emerge uses it for its own processing.") ;; Do the merge (emerge-setup buffer-A emerge-file-A buffer-B emerge-file-B - (cons `(lambda () - (delete-file ,emerge-file-A) - (delete-file ,emerge-file-B)) + (cons (lambda () + (delete-file emerge-file-A) + (delete-file emerge-file-B)) startup-hooks) - (cons `(lambda () (emerge-files-exit ,file)) + (cons (lambda () (emerge-files-exit file)) quit-hooks) nil))) @@ -1146,12 +1129,12 @@ This is *not* a user option, since Emerge uses it for its own processing.") (emerge-setup-with-ancestor buffer-A emerge-file-A buffer-B emerge-file-B buffer-ancestor emerge-ancestor - (cons `(lambda () - (delete-file ,emerge-file-A) - (delete-file ,emerge-file-B) - (delete-file ,emerge-ancestor)) + (cons (lambda () + (delete-file emerge-file-A) + (delete-file emerge-file-B) + (delete-file emerge-ancestor)) startup-hooks) - (cons `(lambda () (emerge-files-exit ,file)) + (cons (lambda () (emerge-files-exit file)) quit-hooks) output-file))) @@ -1233,20 +1216,20 @@ Otherwise, the A or B file present is copied to the output file." file-ancestor file-out nil ;; When done, return to this buffer. - (list - `(lambda () - (switch-to-buffer ,(current-buffer)) - (message "Merge done."))))) + (let ((buf (current-buffer))) + (list (lambda () + (switch-to-buffer buf) + (message "Merge done")))))) ;; Merge of two files without ancestor ((and file-A file-B) (message "Merging %s and %s..." file-A file-B) (emerge-files (not (not file-out)) file-A file-B file-out nil ;; When done, return to this buffer. - (list - `(lambda () - (switch-to-buffer ,(current-buffer)) - (message "Merge done."))))) + (let ((buf (current-buffer))) + (list (lambda () + (switch-to-buffer buf) + (message "Merge done")))))) ;; There is an output file (or there would have been an error above), ;; but only one input file. ;; The file appears to have been deleted in one version; do nothing. @@ -1456,9 +1439,8 @@ These characteristics are restored by `emerge-restore-buffer-characteristics'." merge-buffer lineno-list) (let* (marker-list - (A-point-min (with-current-buffer A-buffer (point-min))) - (offset (1- A-point-min)) - (B-point-min (with-current-buffer B-buffer (point-min))) + (offset (with-current-buffer A-buffer + (- (point-min) (save-restriction (widen) (point-min))))) ;; Record current line number in each buffer ;; so we don't have to count from the beginning. (a-line 1) @@ -1480,17 +1462,17 @@ These characteristics are restored by `emerge-restore-buffer-characteristics'." (state (aref list-element 4))) ;; place markers at the appropriate places in the buffers (with-current-buffer - A-buffer - (setq a-line (emerge-goto-line a-begin a-line)) - (setq a-begin-marker (point-marker)) - (setq a-line (emerge-goto-line a-end a-line)) - (setq a-end-marker (point-marker))) + A-buffer + (setq a-line (emerge-goto-line a-begin a-line)) + (setq a-begin-marker (point-marker)) + (setq a-line (emerge-goto-line a-end a-line)) + (setq a-end-marker (point-marker))) (with-current-buffer - B-buffer - (setq b-line (emerge-goto-line b-begin b-line)) - (setq b-begin-marker (point-marker)) - (setq b-line (emerge-goto-line b-end b-line)) - (setq b-end-marker (point-marker))) + B-buffer + (setq b-line (emerge-goto-line b-begin b-line)) + (setq b-begin-marker (point-marker)) + (setq b-line (emerge-goto-line b-end b-line)) + (setq b-end-marker (point-marker))) (setq merge-begin-marker (set-marker (make-marker) (- (marker-position a-begin-marker) @@ -1502,15 +1484,15 @@ These characteristics are restored by `emerge-restore-buffer-characteristics'." offset) merge-buffer)) ;; record all the markers for this difference - (setq marker-list (cons (vector a-begin-marker a-end-marker - b-begin-marker b-end-marker - merge-begin-marker merge-end-marker - state) - marker-list))) + (push (vector a-begin-marker a-end-marker + b-begin-marker b-end-marker + merge-begin-marker merge-end-marker + state) + marker-list)) (setq lineno-list (cdr lineno-list))) ;; convert the list of difference information into a vector for ;; fast access - (setq emerge-difference-list (apply 'vector (nreverse marker-list))))) + (setq emerge-difference-list (apply #'vector (nreverse marker-list))))) ;; If we have an ancestor, select all B variants that we prefer (defun emerge-select-prefer-Bs () @@ -1636,7 +1618,7 @@ the height of the merge window. `C-u -' alone as argument scrolls half the height of the merge window." (interactive "P") (emerge-operate-on-windows - 'scroll-up + #'scroll-up ;; calculate argument to scroll-up ;; if there is an explicit argument (if (and arg (not (equal arg '-))) @@ -1663,7 +1645,7 @@ the height of the merge window. `C-u -' alone as argument scrolls half the height of the merge window." (interactive "P") (emerge-operate-on-windows - 'scroll-down + #'scroll-down ;; calculate argument to scroll-down ;; if there is an explicit argument (if (and arg (not (equal arg '-))) @@ -1690,7 +1672,7 @@ the width of the A and B windows. `C-u -' alone as argument scrolls half the width of the A and B windows." (interactive "P") (emerge-operate-on-windows - 'scroll-left + #'scroll-left ;; calculate argument to scroll-left ;; if there is an explicit argument (if (and arg (not (equal arg '-))) @@ -1718,7 +1700,7 @@ the width of the A and B windows. `C-u -' alone as argument scrolls half the width of the A and B windows." (interactive "P") (emerge-operate-on-windows - 'scroll-right + #'scroll-right ;; calculate argument to scroll-right ;; if there is an explicit argument (if (and arg (not (equal arg '-))) @@ -1745,18 +1727,18 @@ This resets the horizontal scrolling of all three merge buffers to the left margin, if they are in windows." (interactive) (emerge-operate-on-windows - (lambda (x) (set-window-hscroll (selected-window) 0)) + (lambda (_) (set-window-hscroll (selected-window) 0)) nil)) -;; Attempt to show the region nicely. -;; If there are min-lines lines above and below the region, then don't do -;; anything. -;; If not, recenter the region to make it so. -;; If that isn't possible, remove context lines evenly from top and bottom -;; so the entire region shows. -;; If that isn't possible, show the top of the region. -;; BEG must be at the beginning of a line. (defun emerge-position-region (beg end pos) + "Attempt to show the region nicely. +If there are min-lines lines above and below the region, then don't do +anything. +If not, recenter the region to make it so. +If that isn't possible, remove context lines evenly from top and bottom +so the entire region shows. +If that isn't possible, show the top of the region. +BEG must be at the beginning of a line." ;; First test whether the entire region is visible with ;; emerge-min-visible-lines above and below it (if (not (and (<= (progn @@ -1795,7 +1777,7 @@ to the left margin, if they are in windows." (memq (aref (aref emerge-difference-list n) 6) '(prefer-A prefer-B))) (setq n (1+ n))) - (let ((buffer-read-only nil)) + (let ((inhibit-read-only t)) (emerge-unselect-and-select-difference n))) (error "At end"))) @@ -1809,14 +1791,14 @@ to the left margin, if they are in windows." (memq (aref (aref emerge-difference-list n) 6) '(prefer-A prefer-B))) (setq n (1- n))) - (let ((buffer-read-only nil)) + (let ((inhibit-read-only t)) (emerge-unselect-and-select-difference n))) (error "At beginning"))) (defun emerge-jump-to-difference (difference-number) "Go to the N-th difference." (interactive "p") - (let ((buffer-read-only nil)) + (let ((inhibit-read-only t)) (setq difference-number (1- difference-number)) (if (and (>= difference-number -1) (< difference-number (1+ emerge-number-of-differences))) @@ -1878,6 +1860,13 @@ buffer after this will cause serious problems." (let ((emerge-prefix-argument arg)) (run-hooks 'emerge-quit-hook))) +(defmacro emerge--current-beg (diff-vector side) + ;; +1 because emerge-place-flags-in-buffer1 moved the marker by 1. + `(1+ (aref ,diff-vector ,(pcase-exhaustive side ('A 0) ('B 2) ('merge 4))))) +(defmacro emerge--current-end (diff-vector side) + ;; -1 because emerge-place-flags-in-buffer1 moved the marker by 1. + `(1- (aref ,diff-vector ,(pcase-exhaustive side ('A 1) ('B 3) ('merge 5))))) + (defun emerge-select-A (&optional force) "Select the A variant of this difference. Refuses to function if this difference has been edited, i.e., if it @@ -1885,26 +1874,25 @@ is neither the A nor the B variant. A prefix argument forces the variant to be selected even if the difference has been edited." (interactive "P") - (let ((operate - (lambda () - (emerge-select-A-edit merge-begin merge-end A-begin A-end) - (if emerge-auto-advance - (emerge-next-difference)))) + (let ((operate #'emerge-select-A-edit) (operate-no-change - (lambda () (if emerge-auto-advance - (emerge-next-difference))))) + (lambda (_diff-vector) + (if emerge-auto-advance (emerge-next-difference))))) (emerge-select-version force operate-no-change operate operate))) ;; Actually select the A variant -(defun emerge-select-A-edit (merge-begin merge-end A-begin A-end) +(defun emerge-select-A-edit (diff-vector) (with-current-buffer - emerge-merge-buffer - (delete-region merge-begin merge-end) - (goto-char merge-begin) - (insert-buffer-substring emerge-A-buffer A-begin A-end) - (goto-char merge-begin) - (aset diff-vector 6 'A) - (emerge-refresh-mode-line))) + emerge-merge-buffer + (goto-char (emerge--current-beg diff-vector merge)) + (delete-region (point) (emerge--current-end diff-vector merge)) + (save-excursion + (insert-buffer-substring emerge-A-buffer + (emerge--current-beg diff-vector A) + (emerge--current-end diff-vector A))) + (aset diff-vector 6 'A) + (emerge-refresh-mode-line) + (if emerge-auto-advance (emerge-next-difference)))) (defun emerge-select-B (&optional force) "Select the B variant of this difference. @@ -1913,26 +1901,25 @@ is neither the A nor the B variant. A prefix argument forces the variant to be selected even if the difference has been edited." (interactive "P") - (let ((operate - (lambda () - (emerge-select-B-edit merge-begin merge-end B-begin B-end) - (if emerge-auto-advance - (emerge-next-difference)))) + (let ((operate #'emerge-select-B-edit) (operate-no-change - (lambda () (if emerge-auto-advance - (emerge-next-difference))))) + (lambda (_diff-vector) + (if emerge-auto-advance (emerge-next-difference))))) (emerge-select-version force operate operate-no-change operate))) ;; Actually select the B variant -(defun emerge-select-B-edit (merge-begin merge-end B-begin B-end) +(defun emerge-select-B-edit (diff-vector) (with-current-buffer - emerge-merge-buffer - (delete-region merge-begin merge-end) - (goto-char merge-begin) - (insert-buffer-substring emerge-B-buffer B-begin B-end) - (goto-char merge-begin) - (aset diff-vector 6 'B) - (emerge-refresh-mode-line))) + emerge-merge-buffer + (goto-char (emerge--current-beg diff-vector merge)) + (delete-region (point) (emerge--current-end diff-vector merge)) + (save-excursion + (insert-buffer-substring emerge-B-buffer + (emerge--current-beg diff-vector B) + (emerge--current-end diff-vector B))) + (aset diff-vector 6 'B) + (emerge-refresh-mode-line) + (if emerge-auto-advance (emerge-next-difference)))) (defun emerge-default-A () "Make the A variant the default from here down. @@ -1940,7 +1927,7 @@ This selects the A variant for all differences from here down in the buffer which are still defaulted, i.e., which the user has not selected and for which there is no preference." (interactive) - (let ((buffer-read-only nil)) + (let ((inhibit-read-only t)) (let ((selected-difference emerge-current-difference) (n (max emerge-current-difference 0))) (while (< n emerge-number-of-differences) @@ -1962,7 +1949,7 @@ This selects the B variant for all differences from here down in the buffer which are still defaulted, i.e., which the user has not selected and for which there is no preference." (interactive) - (let ((buffer-read-only nil)) + (let ((inhibit-read-only t)) (let ((selected-difference emerge-current-difference) (n (max emerge-current-difference 0))) (while (< n emerge-number-of-differences) @@ -2071,7 +2058,7 @@ With prefix argument, puts point before, mark after." (A-begin (1+ (aref diff-vector 0))) (A-end (1- (aref diff-vector 1))) (opoint (point)) - (buffer-read-only nil)) + (inhibit-read-only t)) (insert-buffer-substring emerge-A-buffer A-begin A-end) (if (not arg) (set-mark opoint) @@ -2089,7 +2076,7 @@ With prefix argument, puts point before, mark after." (B-begin (1+ (aref diff-vector 2))) (B-end (1- (aref diff-vector 3))) (opoint (point)) - (buffer-read-only nil)) + (inhibit-read-only t)) (insert-buffer-substring emerge-B-buffer B-begin B-end) (if (not arg) (set-mark opoint) @@ -2450,28 +2437,28 @@ the nearest previous difference." (1- index) (error "No difference contains or precedes point"))))))) +(defvar emerge-line-diff) + (defun emerge-line-numbers () "Display the current line numbers. This function displays the line numbers of the points in the A, B, and merge buffers." (interactive) (let* ((valid-diff - (and (>= emerge-current-difference 0) - (< emerge-current-difference emerge-number-of-differences))) + (and (>= emerge-current-difference 0) + (< emerge-current-difference emerge-number-of-differences))) (emerge-line-diff (and valid-diff (aref emerge-difference-list emerge-current-difference))) - (merge-line (emerge-line-number-in-buf 4 5)) + (merge-line (emerge-line-number-in-buf valid-diff 4 5)) (A-line (with-current-buffer emerge-A-buffer - (emerge-line-number-in-buf 0 1))) + (emerge-line-number-in-buf valid-diff 0 1))) (B-line (with-current-buffer emerge-B-buffer - (emerge-line-number-in-buf 2 3)))) + (emerge-line-number-in-buf valid-diff 2 3)))) (message "At lines: merge = %d, A = %d, B = %d" merge-line A-line B-line))) -(defvar emerge-line-diff) - -(defun emerge-line-number-in-buf (begin-marker end-marker) +(defun emerge-line-number-in-buf (valid-diff begin-marker end-marker) ;; FIXME point-min rather than 1? widen? (let ((temp (1+ (count-lines 1 (line-beginning-position))))) (if valid-diff @@ -2537,46 +2524,41 @@ Interactively, reads the register using `register-read-with-preview'." (error "Register does not contain text")) (emerge-combine-versions-internal template force))) -(defun emerge-combine-versions-internal (emerge-combine-template force) - (let ((operate - (lambda () - (emerge-combine-versions-edit merge-begin merge-end - A-begin A-end B-begin B-end) - (if emerge-auto-advance - (emerge-next-difference))))) +(defun emerge-combine-versions-internal (combine-template force) + (let ((operate (lambda (diff-vector) + (emerge-combine-versions-edit diff-vector + combine-template)))) (emerge-select-version force operate operate operate))) -(defvar emerge-combine-template) - -(defun emerge-combine-versions-edit (merge-begin merge-end - A-begin A-end B-begin B-end) +(defun emerge-combine-versions-edit (diff-vector combine-template) (with-current-buffer - emerge-merge-buffer - (delete-region merge-begin merge-end) - (goto-char merge-begin) - (let ((i 0)) - (while (< i (length emerge-combine-template)) - (let ((c (aref emerge-combine-template i))) - (if (= c ?%) - (progn - (setq i (1+ i)) - (setq c - (condition-case nil - (aref emerge-combine-template i) - (error ?%))) - (cond ((= c ?a) - (insert-buffer-substring emerge-A-buffer A-begin A-end)) - ((= c ?b) - (insert-buffer-substring emerge-B-buffer B-begin B-end)) - ((= c ?%) - (insert ?%)) - (t - (insert c)))) - (insert c))) - (setq i (1+ i)))) - (goto-char merge-begin) - (aset diff-vector 6 'combined) - (emerge-refresh-mode-line))) + emerge-merge-buffer + (goto-char (emerge--current-beg diff-vector merge)) + (delete-region (point) (emerge--current-end diff-vector merge)) + (save-excursion + (let ((i 0)) + (while (< i (length combine-template)) + (let ((c (aref combine-template i))) + (if (not (= c ?%)) + (insert c) + (setq i (1+ i)) + (pcase (condition-case nil + (aref combine-template i) + (error ?%)) + (?a + (insert-buffer-substring emerge-A-buffer + (emerge--current-beg diff-vector A) + (emerge--current-end diff-vector A))) + (?b + (insert-buffer-substring emerge-B-buffer + (emerge--current-beg diff-vector B) + (emerge--current-end diff-vector B))) + (?% (insert ?%)) + (c (insert c))))) + (setq i (1+ i))))) + (aset diff-vector 6 'combined) + (emerge-refresh-mode-line) + (if emerge-auto-advance (emerge-next-difference)))) (defun emerge-set-merge-mode (mode) "Set the major mode in a merge buffer. @@ -2617,7 +2599,7 @@ keymap. Leaves merge in fast mode." (emerge-place-flags-in-buffer1 difference before-index after-index))) (defun emerge-place-flags-in-buffer1 (difference before-index after-index) - (let ((buffer-read-only nil)) + (let ((inhibit-read-only t)) ;; insert the flag before the difference (let ((before (aref (aref emerge-globalized-difference-list difference) before-index)) @@ -2682,7 +2664,7 @@ keymap. Leaves merge in fast mode." (defun emerge-remove-flags-in-buffer (buffer before after) (with-current-buffer buffer - (let ((buffer-read-only nil)) + (let ((inhibit-read-only t)) ;; remove the flags, if they're there (goto-char (- before (1- emerge-before-flag-length))) (if (looking-at emerge-before-flag-match) @@ -2717,18 +2699,18 @@ keymap. Leaves merge in fast mode." (emerge-recenter) (emerge-refresh-mode-line)))) -;; Perform tests to see whether user should be allowed to select a version -;; of this difference: -;; a valid difference has been selected; and -;; the difference text in the merge buffer is: -;; the A version (execute a-version), or -;; the B version (execute b-version), or -;; empty (execute neither-version), or -;; argument FORCE is true (execute neither-version) -;; Otherwise, signal an error. (defun emerge-select-version (force a-version b-version neither-version) + "Perform tests to see whether user should be allowed to select a version +of this difference: + a valid difference has been selected; and + the difference text in the merge buffer is: + the A version (execute a-version), or + the B version (execute b-version), or + empty (execute neither-version), or + argument FORCE is true (execute neither-version) +Otherwise, signal an error." (emerge-validate-difference) - (let ((buffer-read-only nil)) + (let ((inhibit-read-only t)) (let* ((diff-vector (aref emerge-difference-list emerge-current-difference)) (A-begin (1+ (aref diff-vector 0))) @@ -2740,13 +2722,13 @@ keymap. Leaves merge in fast mode." (if (emerge-compare-buffers emerge-A-buffer A-begin A-end emerge-merge-buffer merge-begin merge-end) - (funcall a-version) + (funcall a-version diff-vector) (if (emerge-compare-buffers emerge-B-buffer B-begin B-end emerge-merge-buffer merge-begin merge-end) - (funcall b-version) + (funcall b-version diff-vector) (if (or force (= merge-begin merge-end)) - (funcall neither-version) + (funcall neither-version diff-vector) (error "This difference region has been edited"))))))) ;; Read a file name, handling all of the various defaulting rules. @@ -2972,78 +2954,6 @@ If some prefix of KEY has a non-prefix definition, it is redefined." ;; Now define the key (define-key keymap key definition)) -;;;;; Improvements to describe-mode, so that it describes minor modes as well -;;;;; as the major mode -;;(defun describe-mode (&optional minor) -;; "Display documentation of current major mode. -;;If optional arg MINOR is non-nil (or prefix argument is given if interactive), -;;display documentation of active minor modes as well. -;;For this to work correctly for a minor mode, the mode's indicator variable -;;\(listed in `minor-mode-alist') must also be a function whose documentation -;;describes the minor mode." -;; (interactive) -;; (with-output-to-temp-buffer "*Help*" -;; (princ mode-name) -;; (princ " Mode:\n") -;; (princ (documentation major-mode)) -;; (let ((minor-modes minor-mode-alist) -;; (locals (buffer-local-variables))) -;; (while minor-modes -;; (let* ((minor-mode (car (car minor-modes))) -;; (indicator (car (cdr (car minor-modes)))) -;; (local-binding (assq minor-mode locals))) -;; ;; Document a minor mode if it is listed in minor-mode-alist, -;; ;; bound locally in this buffer, non-nil, and has a function -;; ;; definition. -;; (if (and local-binding -;; (cdr local-binding) -;; (fboundp minor-mode)) -;; (progn -;; (princ (format "\n\n\n%s minor mode (indicator%s):\n" -;; minor-mode indicator)) -;; (princ (documentation minor-mode))))) -;; (setq minor-modes (cdr minor-modes)))) -;; (with-current-buffer standard-output -;; (help-mode)) -;; (help-print-return-message))) - -;; This goes with the redefinition of describe-mode. -;;;; Adjust things so that keyboard macro definitions are documented correctly. -;;(fset 'defining-kbd-macro (symbol-function 'start-kbd-macro)) - -;; substitute-key-definition should work now. -;;;; Function to shadow a definition in a keymap with definitions in another. -;;(defun emerge-shadow-key-definition (olddef newdef keymap shadowmap) -;; "Shadow OLDDEF with NEWDEF for any keys in KEYMAP with entries in SHADOWMAP. -;;In other words, SHADOWMAP will now shadow all definitions of OLDDEF in KEYMAP -;;with NEWDEF. Does not affect keys that are already defined in SHADOWMAP, -;;including those whose definition is OLDDEF." -;; ;; loop through all keymaps accessible from keymap -;; (let ((maps (accessible-keymaps keymap))) -;; (while maps -;; (let ((prefix (car (car maps))) -;; (map (cdr (car maps)))) -;; ;; examine a keymap -;; (if (arrayp map) -;; ;; array keymap -;; (let ((len (length map)) -;; (i 0)) -;; (while (< i len) -;; (if (eq (aref map i) olddef) -;; ;; set the shadowing definition -;; (let ((key (concat prefix (char-to-string i)))) -;; (emerge-define-key-if-possible shadowmap key newdef))) -;; (setq i (1+ i)))) -;; ;; sparse keymap -;; (while map -;; (if (eq (cdr-safe (car-safe map)) olddef) -;; ;; set the shadowing definition -;; (let ((key -;; (concat prefix (char-to-string (car (car map)))))) -;; (emerge-define-key-if-possible shadowmap key newdef))) -;; (setq map (cdr map))))) -;; (setq maps (cdr maps))))) - ;; Define a key if it (or a prefix) is not already defined in the map. (defun emerge-define-key-if-possible (keymap key definition) ;; look up the present definition of the key @@ -3057,18 +2967,6 @@ If some prefix of KEY has a non-prefix definition, it is redefined." (if (not present) (define-key keymap key definition))))) -;; Ordinary substitute-key-definition should do this now. -;;(defun emerge-recursively-substitute-key-definition (olddef newdef keymap) -;; "Like `substitute-key-definition', but act recursively on subkeymaps. -;;Make sure that subordinate keymaps aren't shared with other keymaps! -;;\(`copy-keymap' will suffice.)" -;; ;; Loop through all keymaps accessible from keymap -;; (let ((maps (accessible-keymaps keymap))) -;; (while maps -;; ;; Substitute in this keymap -;; (substitute-key-definition olddef newdef (cdr (car maps))) -;; (setq maps (cdr maps))))) - ;; Show the name of the file in the buffer. (defun emerge-show-file-name () "Displays the name of the file loaded into the current buffer. diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el index 963edb49dd3..91e18c1ec5c 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -52,7 +52,7 @@ ;; The main keymap (easy-mmode-defmap log-edit-mode-map - `(("\C-c\C-c" . log-edit-done) + '(("\C-c\C-c" . log-edit-done) ("\C-c\C-a" . log-edit-insert-changelog) ("\C-c\C-d" . log-edit-show-diff) ("\C-c\C-f" . log-edit-show-files) @@ -203,10 +203,7 @@ when this variable is set to nil.") (defconst log-edit-maximum-comment-ring-size 32 "Maximum number of saved comments in the comment ring.") -(define-obsolete-variable-alias 'vc-comment-ring 'log-edit-comment-ring "22.1") (defvar log-edit-comment-ring (make-ring log-edit-maximum-comment-ring-size)) -(define-obsolete-variable-alias 'vc-comment-ring-index - 'log-edit-comment-ring-index "22.1") (defvar log-edit-comment-ring-index nil) (defvar log-edit-last-comment-match "") @@ -311,13 +308,6 @@ automatically." (or (eobp) (looking-at "\n\n") (insert "\n")))) -;; Compatibility with old names. -(define-obsolete-function-alias 'vc-previous-comment 'log-edit-previous-comment "22.1") -(define-obsolete-function-alias 'vc-next-comment 'log-edit-next-comment "22.1") -(define-obsolete-function-alias 'vc-comment-search-reverse 'log-edit-comment-search-backward "22.1") -(define-obsolete-function-alias 'vc-comment-search-forward 'log-edit-comment-search-forward "22.1") -(define-obsolete-function-alias 'vc-comment-to-change-log 'log-edit-comment-to-change-log "22.1") - ;;; ;;; Actual code ;;; @@ -360,7 +350,7 @@ The first subexpression is the actual text of the field.") (defun log-edit-goto-eoh () ;FIXME: Almost rfc822-goto-eoh! (goto-char (point-min)) (when (re-search-forward - "^\\([^[:alpha:]]\\|[[:alnum:]-]+[^[:alnum:]-:]\\)" nil 'move) + "^\\([^[:alpha:]]\\|[[:alnum:]-]+[^[:alnum:]-]\\)" nil 'move) (goto-char (match-beginning 0)))) (defun log-edit--match-first-line (limit) @@ -623,7 +613,7 @@ Also saves its contents in the comment history and hides (setq buffer-read-only nil) (erase-buffer) (cvs-insert-strings files) - (setq buffer-read-only t) + (special-mode) (goto-char (point-min)) (save-selected-window (cvs-pop-to-buffer-same-frame buf) @@ -764,7 +754,9 @@ regardless of user name or time." (log-edit-insert-changelog-entries (log-edit-files))))) (log-edit-set-common-indentation) ;; Add an Author: field if appropriate. - (when author (log-edit-add-field "Author" (car author))) + (when author + (log-edit-add-field "Author" (car author)) + (log-edit-add-field "Summary" "")) ;; Add a Fixes: field if applicable. (when (consp log-edit-rewrite-fixes) (rfc822-goto-eoh) @@ -923,8 +915,10 @@ where LOGBUFFER is the name of the ChangeLog buffer, and each (setq change-log-default-name nil) (find-change-log))))) (when (or (find-buffer-visiting changelog-file-name) - (file-exists-p changelog-file-name)) - (with-current-buffer (find-file-noselect changelog-file-name) + (file-exists-p changelog-file-name) + add-log-dont-create-changelog-file) + (with-current-buffer + (add-log-find-changelog-buffer changelog-file-name) (unless (eq major-mode 'change-log-mode) (change-log-mode)) (goto-char (point-min)) (if (looking-at "\\s-*\n") (goto-char (match-end 0))) @@ -1093,6 +1087,22 @@ line of MSG." (if summary (insert summary "\n\n")) (cons (buffer-string) res)))) +(defun log-edit--toggle-amend (last-msg-fn) + (when (log-edit-toggle-header "Amend" "yes") + (goto-char (point-max)) + (unless (bolp) (insert "\n")) + (insert (funcall last-msg-fn)) + (save-excursion + (rfc822-goto-eoh) + (forward-line 1) + (let ((pt (point))) + (and (zerop (forward-line 1)) + (looking-at "\n\\|\\'") + (let ((summary (buffer-substring-no-properties pt (1- (point))))) + (skip-chars-forward " \n") + (delete-region pt (point)) + (log-edit-set-header "Summary" summary))))))) + (provide 'log-edit) ;;; log-edit.el ends here diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el index b9f386d5158..3389264ce6e 100644 --- a/lisp/vc/log-view.el +++ b/lisp/vc/log-view.el @@ -157,7 +157,7 @@ (easy-menu-define log-view-mode-menu log-view-mode-map "Log-View Display Menu" - `("Log-View" + '("Log-View" ;; XXX Do we need menu entries for these? ;; ["Quit" quit-window] ;; ["Kill This Buffer" kill-this-buffer] @@ -217,7 +217,7 @@ If it is nil, `log-view-toggle-entry-display' does nothing.") The match group number 1 should match the file name itself.") (defvar log-view-per-file-logs t - "Set if to t if the logs are shown one file at a time.") + "Set to t if the logs are shown one file at a time.") (defvar log-view-message-re (concat "^\\(?:revision \\(?1:[.0-9]+\\)\\(?:\t.*\\)?" ; RCS and CVS. @@ -517,8 +517,10 @@ Works like `end-of-defun'." If called interactively, visit the version at point." (interactive "d") (unless log-view-per-file-logs - (when (> (length log-view-vc-fileset) 1) - (error "Multiple files shown in this buffer, cannot use this command here"))) + (when (or (> (length log-view-vc-fileset) 1) + (null (car log-view-vc-fileset)) + (file-directory-p (car log-view-vc-fileset))) + (user-error "Multiple files shown in this buffer, cannot use this command here"))) (save-excursion (goto-char pos) (switch-to-buffer (vc-find-revision (if log-view-per-file-logs @@ -561,8 +563,10 @@ If called interactively, visit the version at point." If called interactively, annotate the version at point." (interactive "d") (unless log-view-per-file-logs - (when (> (length log-view-vc-fileset) 1) - (error "Multiple files shown in this buffer, cannot use this command here"))) + (when (or (> (length log-view-vc-fileset) 1) + (null (car log-view-vc-fileset)) + (file-directory-p (car log-view-vc-fileset))) + (user-error "Multiple files shown in this buffer, cannot use this command here"))) (save-excursion (goto-char pos) (vc-annotate (if log-view-per-file-logs @@ -614,10 +618,11 @@ considered file(s)." ;; When TO and FR are the same, or when point is on a line after ;; the last entry, look at the previous revision. (when (or (string-equal fr to) - (>= (point) + (>= end (save-excursion - (goto-char (car fr-entry)) - (forward-line)))) + (goto-char end) + (log-view-end-of-defun) + (point)))) (setq fr (vc-call-backend log-view-vc-backend 'previous-revision nil fr))) (vc-diff-internal t (list log-view-vc-backend diff --git a/lisp/vc/pcvs-info.el b/lisp/vc/pcvs-info.el index 28cfccbf293..224bab314d7 100644 --- a/lisp/vc/pcvs-info.el +++ b/lisp/vc/pcvs-info.el @@ -39,9 +39,6 @@ ;;;; config variables ;;;; -(define-obsolete-variable-alias 'cvs-display-full-path - 'cvs-display-full-name "22.1") - (defcustom cvs-display-full-name t "Specifies how the filenames should be displayed in the listing. If non-nil, their full filename name will be displayed, else only the @@ -211,8 +208,6 @@ to confuse some users sometimes." ;; Here, I use `concat' rather than `expand-file-name' because I want ;; the resulting path to stay relative if `dir' is relative. (concat dir (cvs-fileinfo->file fileinfo))))) -(define-obsolete-function-alias 'cvs-fileinfo->full-path - 'cvs-fileinfo->full-name "22.1") (defun cvs-fileinfo->pp-name (fi) "Return the filename of FI as it should be displayed." @@ -268,9 +263,9 @@ to confuse some users sometimes." (setq check 'type) (symbolp type) (setq check 'consistency) (pcase type - (`DIRCHANGE (and (null subtype) (string= "." file))) - ((or `NEED-UPDATE `ADDED `MISSING `DEAD `MODIFIED `MESSAGE - `UP-TO-DATE `REMOVED `NEED-MERGE `CONFLICT `UNKNOWN) + ('DIRCHANGE (and (null subtype) (string= "." file))) + ((or 'NEED-UPDATE 'ADDED 'MISSING 'DEAD 'MODIFIED 'MESSAGE + 'UP-TO-DATE 'REMOVED 'NEED-MERGE 'CONFLICT 'UNKNOWN) t))) fi (error "Invalid :%s in cvs-fileinfo %s" check fi)))) @@ -331,11 +326,11 @@ For use by the ewoc package." (subtype (cvs-fileinfo->subtype fileinfo))) (insert (pcase type - (`DIRCHANGE (concat "In directory " + ('DIRCHANGE (concat "In directory " (cvs-add-face (cvs-fileinfo->full-name fileinfo) 'cvs-header t 'cvs-goal-column t) ":")) - (`MESSAGE + ('MESSAGE (cvs-add-face (format "Message: %s" (cvs-fileinfo->full-log fileinfo)) 'cvs-msg)) (_ @@ -349,7 +344,7 @@ For use by the ewoc package." (type (let ((str (pcase type ;;(MOD-CONFLICT "Not Removed") - (`DEAD "") + ('DEAD "") (_ (capitalize (symbol-name type))))) (face (let ((sym (intern-soft (concat "cvs-fi-" @@ -456,7 +451,8 @@ DIR can also be a file." ((not (file-exists-p (concat dir f))) (setq type 'MISSING)) ((equal rev "0") (setq type 'ADDED rev nil)) ((equal date "Result of merge") (setq subtype 'MERGED)) - ((let ((mtime (nth 5 (file-attributes (concat dir f)))) + ((let ((mtime (file-attribute-modification-time + (file-attributes (concat dir f)))) (system-time-locale "C")) (setq timestamp (format-time-string "%c" mtime t)) ;; Solaris sometimes uses "Wed Sep 05", not "Wed Sep 5". diff --git a/lisp/vc/pcvs-parse.el b/lisp/vc/pcvs-parse.el index 9525ff93be5..0596ccb9129 100644 --- a/lisp/vc/pcvs-parse.el +++ b/lisp/vc/pcvs-parse.el @@ -32,6 +32,7 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) (require 'pcvs-util) (require 'pcvs-info) diff --git a/lisp/vc/pcvs-util.el b/lisp/vc/pcvs-util.el index 55da04ff40a..5a50393d622 100644 --- a/lisp/vc/pcvs-util.el +++ b/lisp/vc/pcvs-util.el @@ -1,4 +1,4 @@ -;;; pcvs-util.el --- utility functions for PCL-CVS -*- byte-compile-dynamic: t -*- +;;; pcvs-util.el --- utility functions for PCL-CVS ;; Copyright (C) 1991-2019 Free Software Foundation, Inc. diff --git a/lisp/vc/pcvs.el b/lisp/vc/pcvs.el index fafeaaedae6..4679996b35b 100644 --- a/lisp/vc/pcvs.el +++ b/lisp/vc/pcvs.el @@ -430,11 +430,11 @@ If non-nil, NEW means to create a new buffer no matter what." (set-buffer buffer) (and (cvs-buffer-p) (pcase cvs-reuse-cvs-buffer - (`always t) - (`subdir + ('always t) + ('subdir (or (string-prefix-p default-directory dir) (string-prefix-p dir default-directory))) - (`samedir (string= default-directory dir))) + ('samedir (string= default-directory dir))) (cl-return buffer))))) ;; we really have to create a new buffer: ;; we temporarily bind cwd to "" to prevent @@ -700,7 +700,7 @@ OLD-FIS is the list of fileinfos on which the cvs command was applied and ;; because of the call to `process-send-eof'. (save-excursion (goto-char (point-min)) - (while (re-search-forward "^\\^D+" nil t) + (while (re-search-forward "^\\^D\^H+" nil t) (let ((inhibit-read-only t)) (delete-region (match-beginning 0) (match-end 0)))))) (let* ((fileinfos (cvs-parse-buffer 'cvs-parse-table dcd subdir)) @@ -876,11 +876,11 @@ RM-MSGS if non-nil means remove messages." (keep (pcase type ;; Remove temp messages and keep the others. - (`MESSAGE (not (or rm-msgs (eq subtype 'TEMP)))) + ('MESSAGE (not (or rm-msgs (eq subtype 'TEMP)))) ;; Remove dead entries. - (`DEAD nil) + ('DEAD nil) ;; Handled also? - (`UP-TO-DATE + ('UP-TO-DATE (not (if (find-buffer-visiting (cvs-fileinfo->full-name fi)) (eq rm-handled 'all) diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index cb0083a9851..f032b084167 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@ -44,7 +44,8 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) -(require 'diff-mode) ;For diff-auto-refine-mode. +(require 'diff) ;For diff-check-labels. +(require 'diff-mode) ;For diff-refine. (require 'newcomment) ;;; The real definition comes later. @@ -104,7 +105,6 @@ Used in `smerge-diff-base-upper' and related functions." (((class color)) :foreground "yellow")) "Face for the base code.") -(define-obsolete-face-alias 'smerge-base-face 'smerge-base "22.1") (defvar smerge-base-face 'smerge-base) (defface smerge-markers @@ -113,7 +113,6 @@ Used in `smerge-diff-base-upper' and related functions." (((background dark)) (:background "grey30"))) "Face for the conflict markers.") -(define-obsolete-face-alias 'smerge-markers-face 'smerge-markers "22.1") (defvar smerge-markers-face 'smerge-markers) (defface smerge-refined-changed @@ -266,7 +265,7 @@ Can be nil if the style is undecided, or else: ;; Define smerge-next and smerge-prev (easy-mmode-define-navigation smerge smerge-begin-re "conflict" nil nil - (if diff-auto-refine-mode + (if diff-refine (condition-case nil (smerge-refine) (error nil)))) (defconst smerge-match-names ["conflict" "upper" "base" "lower"]) @@ -365,9 +364,9 @@ function should only apply safe heuristics) and with the match data set according to `smerge-match-conflict'.") (defvar smerge-text-properties - `(help-echo "merge conflict: mouse-3 shows a menu" - ;; mouse-face highlight - keymap (keymap (down-mouse-3 . smerge-popup-context-menu)))) + '(help-echo "merge conflict: mouse-3 shows a menu" + ;; mouse-face highlight + keymap (keymap (down-mouse-3 . smerge-popup-context-menu)))) (defun smerge-remove-props (beg end) (remove-overlays beg end 'smerge 'refine) @@ -1077,9 +1076,10 @@ used to replace chars to try and eliminate some spurious differences." (if smerge-refine-weight-hack (make-hash-table :test #'equal)))) (unless (markerp beg1) (setq beg1 (copy-marker beg1))) (unless (markerp beg2) (setq beg2 (copy-marker beg2))) - ;; Chop up regions into smaller elements and save into files. - (smerge--refine-chopup-region beg1 end1 file1 preproc) - (smerge--refine-chopup-region beg2 end2 file2 preproc) + (let ((write-region-inhibit-fsync t)) ; Don't fsync temp files (Bug#12747). + ;; Chop up regions into smaller elements and save into files. + (smerge--refine-chopup-region beg1 end1 file1 preproc) + (smerge--refine-chopup-region beg2 end2 file2 preproc)) ;; Call diff on those files. (unwind-protect @@ -1244,9 +1244,12 @@ spacing of the \"Lower\" chunk." (let ((status (apply 'call-process diff-command nil t nil (append smerge-diff-switches - (list "-L" (concat name1 "/" file) - "-L" (concat name2 "/" file) - file1 file2))))) + (and (diff-check-labels) + (list "--label" + (concat name1 "/" file) + "--label" + (concat name2 "/" file))) + (list file1 file2))))) (if (eq status 0) (insert "No differences found.\n")))) (goto-char (point-min)) (diff-mode) @@ -1400,9 +1403,7 @@ with a \\[universal-argument] prefix, makes up a 3-way conflict." ;;;###autoload (define-minor-mode smerge-mode "Minor mode to simplify editing output from the diff3 program. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. + \\{smerge-mode-map}" :group 'smerge :lighter " SMerge" (when (and (boundp 'font-lock-mode) font-lock-mode) @@ -1435,6 +1436,40 @@ If no conflict maker is found, turn off `smerge-mode'." (smerge-next)) (error (smerge-auto-leave)))) +(defcustom smerge-change-buffer-confirm t + "If non-nil, request confirmation before moving to another buffer." + :type 'boolean) + +(defun smerge-vc-next-conflict () + "Go to next conflict, possibly in another file. +First tries to go to the next conflict in the current buffer, and if not +found, uses VC to try and find the next file with conflict." + (interactive) + (let ((buffer (current-buffer))) + (condition-case nil + ;; FIXME: Try again from BOB before moving to the next file. + (smerge-next) + (error + (if (and (or smerge-change-buffer-confirm + (and (buffer-modified-p) buffer-file-name)) + (not (or (eq last-command this-command) + (eq ?\r last-command-event)))) ;Called via M-x!? + ;; FIXME: Don't emit this message if `vc-find-conflicted-file' won't + ;; go to another file anyway (because there are no more conflicted + ;; files). + (message (if (buffer-modified-p) + "No more conflicts here. Repeat to save and go to next buffer" + "No more conflicts here. Repeat to go to next buffer")) + (if (and (buffer-modified-p) buffer-file-name) + (save-buffer)) + (vc-find-conflicted-file) + (if (eq buffer (current-buffer)) + ;; Do nothing: presumably `vc-find-conflicted-file' already + ;; emitted a message explaining there aren't any more conflicts. + nil + (goto-char (point-min)) + (smerge-next))))))) + (provide 'smerge-mode) ;;; smerge-mode.el ends here diff --git a/lisp/vc/vc-annotate.el b/lisp/vc/vc-annotate.el index 86fc8686c39..2cc0f3c40ac 100644 --- a/lisp/vc/vc-annotate.el +++ b/lisp/vc/vc-annotate.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1997-1998, 2000-2019 Free Software Foundation, Inc. -;; Author: Martin Lorentzson <emwson@emw.ericsson.se> +;; Author: Martin Lorentzson <emwson@emw.ericsson.se> ;; Maintainer: emacs-devel@gnu.org ;; Keywords: vc tools ;; Package: vc @@ -541,7 +541,9 @@ Return a cons (REV . FILENAME)." (setq prev-rev (vc-call-backend vc-annotate-backend 'previous-revision fname rev)) - (vc-annotate-warp-revision prev-rev fname))))) + (if (not prev-rev) + (message "No previous revisions") + (vc-annotate-warp-revision prev-rev fname)))))) (defvar log-view-vc-backend) (defvar log-view-vc-fileset) diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el index a33560aa47a..89f1fcce376 100644 --- a/lisp/vc/vc-bzr.el +++ b/lisp/vc/vc-bzr.el @@ -268,8 +268,8 @@ in the repository root directory of FILE." ;; If file is in dirstate, can only be added (b#8025). ((or (not (match-beginning 4)) (eq (char-after (match-beginning 4)) ?a)) 'added) - ((or (and (eq (string-to-number (match-string 3)) - (nth 7 (file-attributes file))) + ((or (and (eql (string-to-number (match-string 3)) + (file-attribute-size (file-attributes file))) (equal (match-string 5) (save-match-data (vc-bzr-sha1 file))) ;; For a file, does the executable state match? @@ -281,7 +281,8 @@ in the repository root directory of FILE." ?x (mapcar 'identity - (nth 8 (file-attributes file)))))) + (file-attribute-modes + (file-attributes file)))))) (if (eq (char-after (match-beginning 7)) ?y) exe @@ -291,8 +292,8 @@ in the repository root directory of FILE." ;; checkouts \2 is empty and we need to ;; look for size in \6. (eq (match-beginning 2) (match-end 2)) - (eq (string-to-number (match-string 6)) - (nth 7 (file-attributes file))) + (eql (string-to-number (match-string 6)) + (file-attribute-size (file-attributes file))) (equal (match-string 5) (vc-bzr-sha1 file)))) 'up-to-date) @@ -331,7 +332,7 @@ in the repository root directory of FILE." (file-relative-name filename* rootdir)))) (defvar vc-bzr-error-regexp-alist - '(("^\\( M[* ]\\|+N \\|-D \\|\\| \\*\\|R[M ] \\) \\(.+\\)" 2 nil nil 1) + '(("^\\( M[* ]\\|\\+N \\|-D \\|\\| \\*\\|R[M ] \\) \\(.+\\)" 2 nil nil 1) ("^C \\(.+\\)" 2) ("^Text conflict in \\(.+\\)" 1 nil nil 2) ("^Using saved parent location: \\(.+\\)" 1 nil nil 0)) @@ -694,7 +695,6 @@ or a superior directory.") (defvar log-view-message-re) (defvar log-view-file-re) (defvar log-view-font-lock-keywords) -(defvar log-view-current-tag-function) (defvar log-view-per-file-logs) (defvar log-view-expanded-log-entry-function) @@ -702,7 +702,7 @@ or a superior directory.") (remove-hook 'log-view-mode-hook 'vc-bzr-log-view-mode) ;Deactivate the hack. (require 'add-log) (set (make-local-variable 'log-view-per-file-logs) nil) - (set (make-local-variable 'log-view-file-re) "\\`a\\`") + (set (make-local-variable 'log-view-file-re) regexp-unmatchable) (set (make-local-variable 'log-view-message-re) (if (eq vc-log-view-type 'short) "^ *\\([0-9.]+\\): \\(.*?\\)[ \t]+\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\)\\( \\[merge\\]\\)?" @@ -782,7 +782,11 @@ If LIMIT is non-nil, show no more than this many entries." (defun vc-bzr-expanded-log-entry (revision) (with-temp-buffer (apply 'vc-bzr-command "log" t nil nil - (list "--long" (format "-r%s" revision))) + (append + (list "--long" (format "-r%s" revision)) + (if (stringp vc-bzr-log-switches) + (list vc-bzr-log-switches) + vc-bzr-log-switches))) (goto-char (point-min)) (when (looking-at "^-+\n") ;; Indent the expanded log entry. @@ -865,61 +869,25 @@ Each line is tagged with the revision number, which has a `help-echo' property containing author and date information." (apply #'vc-bzr-command "annotate" buffer 'async file "--long" "--all" (append (vc-switches 'bzr 'annotate) - (if revision (list "-r" revision)))) - (let ((table (make-hash-table :test 'equal))) - (set-process-filter - (get-buffer-process buffer) - (lambda (proc string) - (when (process-buffer proc) - (with-current-buffer (process-buffer proc) - (setq string (concat (process-get proc :vc-left-over) string)) - ;; Eg: 102020 Gnus developers 20101020 | regexp." - ;; As of bzr 2.2.2, no email address in whoami (which can - ;; lead to spaces in the author field) is allowed but discouraged. - ;; See bug#7792. - (while (string-match "^\\( *[0-9.]+ *\\) \\(.+?\\) +\\([0-9]\\{8\\}\\)\\( |.*\n\\)" string) - (let* ((rev (match-string 1 string)) - (author (match-string 2 string)) - (date (match-string 3 string)) - (key (substring string (match-beginning 0) - (match-beginning 4))) - (line (match-string 4 string)) - (tag (gethash key table)) - (inhibit-read-only t)) - (setq string (substring string (match-end 0))) - (unless tag - (setq tag - (propertize - (format "%s %-7.7s" rev author) - 'help-echo (format "Revision: %d, author: %s, date: %s" - (string-to-number rev) - author date) - 'mouse-face 'highlight)) - (puthash key tag table)) - (goto-char (process-mark proc)) - (insert tag line) - (move-marker (process-mark proc) (point)))) - (process-put proc :vc-left-over string))))))) + (if revision (list "-r" revision))))) (declare-function vc-annotate-convert-time "vc-annotate" (&optional time)) (defun vc-bzr-annotate-time () - (when (re-search-forward "^ *[0-9.]+ +.+? +|" nil t) - (let ((prop (get-text-property (line-beginning-position) 'help-echo))) - (string-match "[0-9]+\\'" prop) - (let ((str (match-string-no-properties 0 prop))) + (when (re-search-forward "^[0-9.]+ +[^\n ]* +\\([0-9]\\{8\\}\\) |" nil t) + (let ((str (match-string-no-properties 1))) (vc-annotate-convert-time (encode-time 0 0 0 - (string-to-number (substring str 6 8)) - (string-to-number (substring str 4 6)) - (string-to-number (substring str 0 4)))))))) + (string-to-number (substring str 6 8)) + (string-to-number (substring str 4 6)) + (string-to-number (substring str 0 4))))))) (defun vc-bzr-annotate-extract-revision-at-line () "Return revision for current line of annotation buffer, or nil. Return nil if current line isn't annotated." (save-excursion (beginning-of-line) - (if (looking-at "^ *\\([0-9.]+\\) +.* +|") + (if (looking-at "^\\([0-9.]+\\) +[^\n ]* +\\([0-9]\\{8\\}\\) |") (match-string-no-properties 1)))) (defun vc-bzr-command-discarding-stderr (command &rest args) @@ -1243,7 +1211,11 @@ stream. Standard error output is discarded." (let ((vc-bzr-revisions '()) (default-directory (file-name-directory (car files)))) (with-temp-buffer - (vc-bzr-command "log" t 0 files "--line") + (apply 'vc-bzr-command "log" t 0 files + (append '("--line") + (if (stringp vc-bzr-log-switches) + (list vc-bzr-log-switches) + vc-bzr-log-switches))) (let ((start (point-min)) (loglines (buffer-substring-no-properties (point-min) (point-max)))) (while (string-match "^\\([0-9]+\\):" loglines) @@ -1311,7 +1283,8 @@ stream. Standard error output is discarded." ((string-match "\\`annotate:" string) (completion-table-with-context (substring string 0 (match-end 0)) - (apply-partially #'completion-table-with-terminator '(":" . "\\`a\\`") + (apply-partially #'completion-table-with-terminator + (cons ":" regexp-unmatchable) #'completion-file-name-table) (substring string (match-end 0)) pred action)) diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el index b4419a4db30..6fb5fa09c7e 100644 --- a/lisp/vc/vc-cvs.el +++ b/lisp/vc/vc-cvs.el @@ -2,8 +2,7 @@ ;; Copyright (C) 1995, 1998-2019 Free Software Foundation, Inc. -;; Author: FSF (see vc.el for full credits) -;; Maintainer: emacs-devel@gnu.org +;; Author: FSF (see vc.el for full credits) ;; Package: vc ;; This file is part of GNU Emacs. @@ -57,7 +56,7 @@ ;; (We actually shouldn't trust this, but there is ;; no other way to learn this from CVS at the ;; moment (version 1.9).) - (string-match "r-..-..-." (nth 8 attrib))) + (string-match "r-..-..-." (file-attribute-modes attrib))) 'announce 'implicit)))))) @@ -257,7 +256,7 @@ See also variable `vc-cvs-sticky-date-format-string'." ;; If the file has not changed since checkout, consider it `up-to-date'. ;; Otherwise consider it `edited'. (let ((checkout-time (vc-file-getprop file 'vc-checkout-time)) - (lastmod (nth 5 (file-attributes file)))) + (lastmod (file-attribute-modification-time (file-attributes file)))) (cond ((equal checkout-time lastmod) 'up-to-date) ((string= (vc-working-revision file) "0") 'added) @@ -524,7 +523,8 @@ The changes are between FIRST-REVISION and SECOND-REVISION." (string= (match-string 1) "P ")) (vc-file-setprop file 'vc-state 'up-to-date) (vc-file-setprop file 'vc-checkout-time - (nth 5 (file-attributes file))) + (file-attribute-modification-time + (file-attributes file))) 0);; indicate success to the caller ;; Merge successful, but our own changes are still in the file ((string= (match-string 1) "M ") @@ -649,7 +649,7 @@ Optional arg REVISION is a revision to annotate from." "Return the current time, based at midnight of the current day, and encoded as fractional days." (vc-annotate-convert-time - (apply 'encode-time 0 0 0 (nthcdr 3 (decode-time))))) + (apply #'encode-time 0 0 0 (nthcdr 3 (decode-time))))) (defun vc-cvs-annotate-time () "Return the time of the next annotation (as fraction of days) @@ -748,7 +748,8 @@ If UPDATE is non-nil, then update (resynch) any affected buffers." (vc-file-setprop file 'vc-state 'up-to-date) (vc-file-setprop file 'vc-working-revision nil) (vc-file-setprop file 'vc-checkout-time - (nth 5 (file-attributes file)))) + (file-attribute-modification-time + (file-attributes file)))) ((or (string= state "M") (string= state "C")) (vc-file-setprop file 'vc-state 'edited) @@ -908,7 +909,7 @@ essential information. Note that this can never set the `ignored' state." (let (file status missing) (goto-char (point-min)) - (while (looking-at "? \\(.*\\)") + (while (looking-at "\\? \\(.*\\)") (setq file (expand-file-name (match-string 1))) (vc-file-setprop file 'vc-state 'unregistered) (forward-line 1)) @@ -931,7 +932,8 @@ state." (cond ((string-match "Up-to-date" status) (vc-file-setprop file 'vc-checkout-time - (nth 5 (file-attributes file))) + (file-attribute-modification-time + (file-attributes file))) 'up-to-date) ((string-match "Locally Modified" status) 'edited) ((string-match "Needs Merge" status) 'needs-merge) @@ -1084,7 +1086,7 @@ CVS/Entries should only be accessed through this function." ;; an uppercase or lowercase letter and can contain uppercase and ;; lowercase letters, digits, `-', and `_'. (and (string-match "^[a-zA-Z]" tag) - (not (string-match "[^a-z0-9A-Z-_]" tag)))) + (not (string-match "[^a-z0-9A-Z_-]" tag)))) (defun vc-cvs-valid-revision-number-p (tag) "Return non-nil if TAG is a valid revision number." @@ -1174,16 +1176,15 @@ is non-nil." ;; (which is based on textual comparison), because there can be problems ;; generating a time string that looks exactly like the one from CVS. (let* ((time (match-string 2)) - (mtime (nth 5 (file-attributes file))) + (mtime (file-attribute-modification-time (file-attributes file))) (parsed-time (progn (require 'parse-time) (parse-time-string (concat time " +0000"))))) (cond ((and (not (string-match "\\+" time)) (car parsed-time) ;; Compare just the seconds part of the file time, ;; since CVS file time stamp resolution is just 1 second. - (let ((ptime (apply 'encode-time parsed-time))) - (and (eq (car mtime) (car ptime)) - (eq (cadr mtime) (cadr ptime))))) + (= (encode-time mtime 'integer) + (encode-time parsed-time 'integer))) (vc-file-setprop file 'vc-checkout-time mtime) (if set-state (vc-file-setprop file 'vc-state 'up-to-date))) (t diff --git a/lisp/vc/vc-dav.el b/lisp/vc/vc-dav.el index d0b202cd5fa..693056c2b9a 100644 --- a/lisp/vc/vc-dav.el +++ b/lisp/vc/vc-dav.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2001, 2004-2019 Free Software Foundation, Inc. ;; Author: Bill Perry <wmperry@gnu.org> -;; Maintainer: Bill Perry <wmperry@gnu.org> ;; Keywords: url, vc ;; Package: vc diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index 39894952e05..9a6f6bb6874 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2007-2019 Free Software Foundation, Inc. -;; Author: Dan Nicolaescu <dann@ics.uci.edu> +;; Author: Dan Nicolaescu <dann@ics.uci.edu> ;; Keywords: vc tools ;; Package: vc @@ -41,10 +41,13 @@ (require 'vc) (require 'tool-bar) (require 'ewoc) +(require 'seq) ;;; Code: (eval-when-compile (require 'cl-lib)) +(declare-function fileloop-continue "fileloop") + (defcustom vc-dir-mode-hook nil "Normal hook run by `vc-dir-mode'. See `run-hooks'." @@ -178,6 +181,9 @@ See `run-hooks'." (define-key map [open] '(menu-item "Open File" vc-dir-find-file :help "Find the file on the current line")) + (define-key map [delete] + '(menu-item "Delete" vc-dir-clean-files + :help "Delete the unregistered marked files")) (define-key map [sepvcdet] '("--")) ;; FIXME: This needs a key binding. And maybe a better name ;; ("Insert" like PCL-CVS uses does not sound that great either)... @@ -262,6 +268,7 @@ See `run-hooks'." ;; bound by `special-mode'. ;; Marking. (define-key map "m" 'vc-dir-mark) + (define-key map "d" 'vc-dir-clean-files) (define-key map "M" 'vc-dir-mark-all-files) (define-key map "u" 'vc-dir-unmark) (define-key map "U" 'vc-dir-unmark-all-files) @@ -554,11 +561,15 @@ If a prefix argument is given, move by that many lines." (defun vc-dir-mark-unmark (mark-unmark-function) (if (use-region-p) - (let (;; (firstl (line-number-at-pos (region-beginning))) + (let ((processed-line nil) (lastl (line-number-at-pos (region-end)))) (save-excursion (goto-char (region-beginning)) - (while (<= (line-number-at-pos) lastl) + (while (and (<= (line-number-at-pos) lastl) + ;; We make sure to not get stuck processing the + ;; same line in an infinite loop. + (not (eq processed-line (line-number-at-pos)))) + (setq processed-line (line-number-at-pos)) (condition-case nil (funcall mark-unmark-function) ;; `vc-dir-mark-file' signals an error if we try marking @@ -756,8 +767,30 @@ that share the same state." (interactive "e") (vc-dir-at-event e (vc-dir-mark-unmark 'vc-dir-toggle-mark-file))) +(defun vc-dir-clean-files () + "Delete the marked files, or the current file if no marks. +The files will not be marked as deleted in the version control +system; see `vc-dir-delete-file'." + (interactive) + (let* ((files (or (vc-dir-marked-files) + (list (vc-dir-current-file)))) + (tracked + (seq-filter (lambda (file) + (not (eq (vc-call-backend vc-dir-backend 'state file) + 'unregistered))) + files))) + (when tracked + (user-error (ngettext "Trying to clean tracked file: %s" + "Trying to clean tracked files: %s" + (length tracked)) + (mapconcat #'file-name-nondirectory tracked ", "))) + (map-y-or-n-p "Delete %s? " #'delete-file files) + (revert-buffer))) + (defun vc-dir-delete-file () - "Delete the marked files, or the current file if no marks." + "Delete the marked files, or the current file if no marks. +The files will also be marked as deleted in the version control +system." (interactive) (mapc 'vc-delete-file (or (vc-dir-marked-files) (list (vc-dir-current-file))))) @@ -780,6 +813,11 @@ that share the same state." (display-buffer (find-file-noselect (vc-dir-current-file)) t)) +(defun vc-dir-view-file () + "Examine a file on the current line in view mode." + (interactive) + (view-file (vc-dir-current-file))) + (defun vc-dir-isearch () "Search for a string through all marked buffers using Isearch." (interactive) @@ -798,7 +836,8 @@ For marked directories, use the files displayed from those directories. Stops when a match is found. To continue searching for next match, use command \\[tags-loop-continue]." (interactive "sSearch marked files (regexp): ") - (tags-search regexp '(mapcar 'car (vc-dir-marked-only-files-and-states)))) + (tags-search regexp + (mapcar #'car (vc-dir-marked-only-files-and-states)))) (defun vc-dir-query-replace-regexp (from to &optional delimited) "Do `query-replace-regexp' of FROM with TO, on all marked files. @@ -819,8 +858,11 @@ with the command \\[tags-loop-continue]." (if (and buffer (with-current-buffer buffer buffer-read-only)) (error "File `%s' is visited read-only" file)))) - (tags-query-replace from to delimited - '(mapcar 'car (vc-dir-marked-only-files-and-states)))) + (fileloop-initialize-replace + from to (mapcar 'car (vc-dir-marked-only-files-and-states)) + (if (equal from (downcase from)) nil 'default) + delimited) + (fileloop-continue)) (defun vc-dir-ignore () "Ignore the current file." diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el index 54c0880d444..40c392b21de 100644 --- a/lisp/vc/vc-dispatcher.el +++ b/lisp/vc/vc-dispatcher.el @@ -2,8 +2,7 @@ ;; Copyright (C) 2008-2019 Free Software Foundation, Inc. -;; Author: FSF (see below for full credits) -;; Maintainer: emacs-devel@gnu.org +;; Author: FSF (see below for full credits) ;; Keywords: vc tools ;; Package: vc @@ -290,16 +289,16 @@ case, and the process object in the asynchronous case." (let* ((files (mapcar (lambda (f) (file-relative-name (expand-file-name f))) (if (listp file-or-list) file-or-list (list file-or-list)))) + ;; Keep entire commands in *Messages* but avoid resizing the + ;; echo area. Messages in this function are formatted in + ;; a such way that the important parts are at the beginning, + ;; due to potential truncation of long messages. + (message-truncate-lines t) (full-command - ;; What we're doing here is preparing a version of the command - ;; for display in a debug-progress message. If it's fewer than - ;; 20 characters display the entire command (without trailing - ;; newline). Otherwise display the first 20 followed by an ellipsis. (concat (if (string= (substring command -1) "\n") (substring command 0 -1) command) - " " - (vc-delistify (mapcar (lambda (s) (if (> (length s) 20) (concat (substring s 0 2) "...") s)) flags)) + " " (vc-delistify flags) " " (vc-delistify files)))) (save-current-buffer (unless (or (eq buffer t) @@ -324,7 +323,8 @@ case, and the process object in the asynchronous case." (apply 'start-file-process command (current-buffer) command squeezed)))) (when vc-command-messages - (message "Running %s in background..." full-command)) + (let ((inhibit-message (eq (selected-window) (active-minibuffer-window)))) + (message "Running in background: %s" full-command))) ;; Get rid of the default message insertion, in case we don't ;; set a sentinel explicitly. (set-process-sentinel proc #'ignore) @@ -332,10 +332,13 @@ case, and the process object in the asynchronous case." (setq status proc) (when vc-command-messages (vc-run-delayed - (message "Running %s in background... done" full-command)))) + (let ((message-truncate-lines t) + (inhibit-message (eq (selected-window) (active-minibuffer-window)))) + (message "Done in background: %s" full-command))))) ;; Run synchronously (when vc-command-messages - (message "Running %s in foreground..." full-command)) + (let ((inhibit-message (eq (selected-window) (active-minibuffer-window)))) + (message "Running in foreground: %s" full-command))) (let ((buffer-undo-list t)) (setq status (apply 'process-file command nil t nil squeezed))) (when (and (not (eq t okstatus)) @@ -345,13 +348,15 @@ case, and the process object in the asynchronous case." (pop-to-buffer (current-buffer)) (goto-char (point-min)) (shrink-window-if-larger-than-buffer)) - (error "Running %s...FAILED (%s)" full-command - (if (integerp status) (format "status %d" status) status))) + (error "Failed (%s): %s" + (if (integerp status) (format "status %d" status) status) + full-command)) (when vc-command-messages - (message "Running %s...OK = %d" full-command status)))) + (let ((inhibit-message (eq (selected-window) (active-minibuffer-window)))) + (message "Done (status=%d): %s" status full-command))))) (vc-run-delayed - (run-hook-with-args 'vc-post-command-functions - command file-or-list flags)) + (run-hook-with-args 'vc-post-command-functions + command file-or-list flags)) status)))) (defun vc-do-async-command (buffer root command &rest args) diff --git a/lisp/vc/vc-filewise.el b/lisp/vc/vc-filewise.el index f05e8efff90..c1cf1c2feaa 100644 --- a/lisp/vc/vc-filewise.el +++ b/lisp/vc/vc-filewise.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1992-1996, 1998-2019 Free Software Foundation, Inc. -;; Author: FSF (see vc.el for full credits) +;; Author: FSF (see vc.el for full credits) ;; Maintainer: emacs-devel@gnu.org ;; Package: vc diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 610cbde7a49..9715aea1fdc 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -74,6 +74,9 @@ ;; - steal-lock (file &optional revision) NOT NEEDED ;; HISTORY FUNCTIONS ;; * print-log (files buffer &optional shortlog start-revision limit) OK +;; * log-outgoing (buffer remote-location) OK +;; * log-incoming (buffer remote-location) OK +;; - log-search (buffer pattern) OK ;; - log-view-mode () OK ;; - show-log-entry (revision) OK ;; - comment-history (file) ?? @@ -101,9 +104,9 @@ (eval-when-compile (require 'cl-lib) + (require 'subr-x) ; for string-trim-right (require 'vc) - (require 'vc-dir) - (require 'grep)) + (require 'vc-dir)) (defgroup vc-git nil "VC Git backend." @@ -180,9 +183,22 @@ Should be consistent with the Git config value i18n.logOutputEncoding." :type '(coding-system :tag "Coding system to decode Git log output") :version "25.1") +(defcustom vc-git-grep-template "git --no-pager grep -n <C> -e <R> -- <F>" + "The default command to run for \\[vc-git-grep]. +The following place holders should be present in the string: + <C> - place to put the options like -i. + <F> - file names and wildcards to search. + <R> - the regular expression searched for." + :type 'string + :version "27.1") + ;; History of Git commands. (defvar vc-git-history nil) +;; Clear up the cache to force vc-call to check again and discover +;; new functions when we reload this file. +(put 'Git 'vc-functions nil) + ;;; BACKEND PROPERTIES (defun vc-git-revision-granularity () 'repository) @@ -242,7 +258,7 @@ Should be consistent with the Git config value i18n.logOutputEncoding." ;; Git for Windows appends ".windows.N" to the ;; numerical version reported by Git. (string-match - "git version \\([0-9.]+\\)\\(\.windows.[0-9]+\\)?$" + "git version \\([0-9.]+\\)\\(\\.windows\\.[0-9]+\\)?$" version-string)) (match-string 1 version-string) "0"))))) @@ -278,7 +294,7 @@ in the order given by 'git status'." ;; 2. When a file A is renamed to B in the index and then back to A ;; in the working tree. ;; In both of these instances, `unregistered' is a reasonable response. - (`("D " "??") 'unregistered) + ('("D " "??") 'unregistered) ;; In other cases, let us return `edited'. (_ 'edited))) @@ -364,8 +380,8 @@ in the order given by 'git status'." (defun vc-git-file-type-as-string (old-perm new-perm) "Return a string describing the file type based on its permissions." - (let* ((old-type (lsh (or old-perm 0) -9)) - (new-type (lsh (or new-perm 0) -9)) + (let* ((old-type (ash (or old-perm 0) -9)) + (new-type (ash (or new-perm 0) -9)) (str (pcase new-type (?\100 ;; File. (pcase old-type @@ -475,9 +491,9 @@ or an empty string if none." (files (vc-git-dir-status-state->files git-state))) (goto-char (point-min)) (pcase (vc-git-dir-status-state->stage git-state) - (`update-index + ('update-index (setq next-stage (if (vc-git--empty-db-p) 'ls-files-added 'diff-index))) - (`ls-files-added + ('ls-files-added (setq next-stage 'ls-files-unknown) (while (re-search-forward "\\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} 0\t\\([^\0]+\\)\0" nil t) (let ((new-perm (string-to-number (match-string 1) 8)) @@ -485,7 +501,7 @@ or an empty string if none." (vc-git-dir-status-update-file git-state name 'added (vc-git-create-extra-fileinfo 0 new-perm))))) - (`ls-files-up-to-date + ('ls-files-up-to-date (setq next-stage 'ls-files-unknown) (while (re-search-forward "\\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} \\([0-3]\\)\t\\([^\0]+\\)\0" nil t) (let ((perm (string-to-number (match-string 1) 8)) @@ -496,7 +512,7 @@ or an empty string if none." 'up-to-date 'conflict) (vc-git-create-extra-fileinfo perm perm))))) - (`ls-files-conflict + ('ls-files-conflict (setq next-stage 'ls-files-unknown) ;; It's enough to look for "3" to notice a conflict. (while (re-search-forward "\\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} 3\t\\([^\0]+\\)\0" nil t) @@ -505,16 +521,16 @@ or an empty string if none." (vc-git-dir-status-update-file git-state name 'conflict (vc-git-create-extra-fileinfo perm perm))))) - (`ls-files-unknown + ('ls-files-unknown (when files (setq next-stage 'ls-files-ignored)) (while (re-search-forward "\\([^\0]*?\\)\0" nil t 1) (vc-git-dir-status-update-file git-state (match-string 1) 'unregistered (vc-git-create-extra-fileinfo 0 0)))) - (`ls-files-ignored + ('ls-files-ignored (while (re-search-forward "\\([^\0]*?\\)\0" nil t 1) (vc-git-dir-status-update-file git-state (match-string 1) 'ignored (vc-git-create-extra-fileinfo 0 0)))) - (`diff-index + ('diff-index (setq next-stage (if files 'ls-files-up-to-date 'ls-files-conflict)) (while (re-search-forward ":\\([0-7]\\{6\\}\\) \\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} [0-9a-f]\\{40\\} \\(\\([ADMUT]\\)\0\\([^\0]+\\)\\|\\([CR]\\)[0-9]*\0\\([^\0]+\\)\0\\([^\0]+\\)\\)\0" @@ -566,30 +582,30 @@ or an empty string if none." (let ((files (vc-git-dir-status-state->files git-state))) (erase-buffer) (pcase (vc-git-dir-status-state->stage git-state) - (`update-index + ('update-index (if files (vc-git-command (current-buffer) 'async files "add" "--refresh" "--") (vc-git-command (current-buffer) 'async nil "update-index" "--refresh"))) - (`ls-files-added + ('ls-files-added (vc-git-command (current-buffer) 'async files "ls-files" "-z" "-c" "-s" "--")) - (`ls-files-up-to-date + ('ls-files-up-to-date (vc-git-command (current-buffer) 'async files "ls-files" "-z" "-c" "-s" "--")) - (`ls-files-conflict + ('ls-files-conflict (vc-git-command (current-buffer) 'async files "ls-files" "-z" "-u" "--")) - (`ls-files-unknown + ('ls-files-unknown (vc-git-command (current-buffer) 'async files "ls-files" "-z" "-o" "--directory" "--no-empty-directory" "--exclude-standard" "--")) - (`ls-files-ignored + ('ls-files-ignored (vc-git-command (current-buffer) 'async files "ls-files" "-z" "-o" "-i" "--directory" "--no-empty-directory" "--exclude-standard" "--")) ;; --relative added in Git 1.5.5. - (`diff-index + ('diff-index (vc-git-command (current-buffer) 'async files "diff-index" "--relative" "-z" "-M" "HEAD" "--"))) (vc-run-delayed @@ -738,7 +754,7 @@ The car of the list is the current branch." (declare-function log-edit-mode "log-edit" ()) (declare-function log-edit-toggle-header "log-edit" (header value)) (declare-function log-edit-extract-headers "log-edit" (headers string)) -(declare-function log-edit-set-header "log-edit" (header value &optional toggle)) +(declare-function log-edit--toggle-amend "log-edit" (last-msg-fn)) (defun vc-git-log-edit-toggle-signoff () "Toggle whether to add the \"Signed-off-by\" line at the end of @@ -746,31 +762,26 @@ the commit message." (interactive) (log-edit-toggle-header "Sign-Off" "yes")) +(defun vc-git-log-edit-toggle-no-verify () + "Toggle whether to bypass the pre-commit and commit-msg hooks." + (interactive) + (log-edit-toggle-header "No-Verify" "yes")) + (defun vc-git-log-edit-toggle-amend () "Toggle whether this will amend the previous commit. If toggling on, also insert its message into the buffer." (interactive) - (when (log-edit-toggle-header "Amend" "yes") - (goto-char (point-max)) - (unless (bolp) (insert "\n")) - (insert (with-output-to-string - (vc-git-command - standard-output 1 nil - "log" "--max-count=1" "--pretty=format:%B" "HEAD"))) - (save-excursion - (rfc822-goto-eoh) - (forward-line 1) - (let ((pt (point))) - (and (zerop (forward-line 1)) - (looking-at "\n\\|\\'") - (let ((summary (buffer-substring-no-properties pt (1- (point))))) - (skip-chars-forward " \n") - (delete-region pt (point)) - (log-edit-set-header "Summary" summary))))))) + (log-edit--toggle-amend + (lambda () + (with-output-to-string + (vc-git-command + standard-output 1 nil + "log" "--max-count=1" "--pretty=format:%B" "HEAD"))))) (defvar vc-git-log-edit-mode-map (let ((map (make-sparse-keymap "Git-Log-Edit"))) (define-key map "\C-c\C-s" 'vc-git-log-edit-toggle-signoff) + (define-key map "\C-c\C-n" 'vc-git-log-edit-toggle-no-verify) (define-key map "\C-c\C-e" 'vc-git-log-edit-toggle-amend) map)) @@ -814,6 +825,7 @@ It is based on `log-edit-mode', and has Git-specific extensions.") `(("Author" . "--author") ("Date" . "--date") ("Amend" . ,(boolean-arg-fn "--amend")) + ("No-Verify" . ,(boolean-arg-fn "--no-verify")) ("Sign-Off" . ,(boolean-arg-fn "--signoff"))) comment))) (when msg-file @@ -863,6 +875,8 @@ It is based on `log-edit-mode', and has Git-specific extensions.") ;; To be called via vc-pull from vc.el, which requires vc-dispatcher. (declare-function vc-compilation-mode "vc-dispatcher" (backend)) +(defvar compilation-directory) +(defvar compilation-arguments) (defun vc-git--pushpull (command prompt extra-args) "Run COMMAND (a string; either push or pull) on the current Git branch. @@ -997,7 +1011,8 @@ This prompts for a branch to merge from." If SHORTLOG is non-nil, use a short format based on `vc-git-root-log-format'. \(This requires at least Git version 1.5.6, for the --graph option.) If START-REVISION is non-nil, it is the newest revision to show. -If LIMIT is non-nil, show no more than this many entries." +If LIMIT is a number, show no more than this many entries. +If LIMIT is a revision string, use it as an end-revision." (let ((coding-system-for-read (or coding-system-for-read vc-git-log-output-coding-system))) ;; `vc-do-command' creates the buffer, but we need it before running @@ -1025,12 +1040,17 @@ If LIMIT is non-nil, show no more than this many entries." ,(format "--pretty=tformat:%s" (car vc-git-root-log-format)) "--abbrev-commit")) - (when limit (list "-n" (format "%s" limit))) - (when start-revision (list start-revision)) + (when (numberp limit) + (list "-n" (format "%s" limit))) + (when start-revision + (if (and limit (not (numberp limit))) + (list (concat start-revision ".." (if (equal limit "") + "HEAD" + limit))) + (list start-revision))) '("--"))))))) (defun vc-git-log-outgoing (buffer remote-location) - (interactive) (vc-setup-buffer buffer) (vc-git-command buffer 'async nil @@ -1044,7 +1064,6 @@ If LIMIT is non-nil, show no more than this many entries." "..HEAD"))) (defun vc-git-log-incoming (buffer remote-location) - (interactive) (vc-setup-buffer buffer) (vc-git-command nil 0 nil "fetch") (vc-git-command @@ -1057,6 +1076,31 @@ If LIMIT is non-nil, show no more than this many entries." "@{upstream}" remote-location)))) +(defun vc-git-log-search (buffer pattern) + "Search the log of changes for PATTERN and output results into BUFFER. + +PATTERN is a basic regular expression by default in Git. + +Display all entries that match log messages in long format. +With a prefix argument, ask for a command to run that will output +log entries." + (let ((args `("log" "--no-color" "-i" + ,(format "--grep=%s" (or pattern ""))))) + (when current-prefix-arg + (setq args (cdr (split-string + (read-shell-command + "Search log with command: " + (format "%s %s" vc-git-program + (mapconcat 'identity args " ")) + 'vc-git-history) + " " t)))) + (vc-setup-buffer buffer) + (apply 'vc-git-command buffer 'async nil args))) + +(defun vc-git-mergebase (rev1 &optional rev2) + (unless rev2 (setq rev2 "HEAD")) + (string-trim-right (vc-git--run-command-string nil "merge-base" rev1 rev2))) + (defvar log-view-message-re) (defvar log-view-file-re) (defvar log-view-font-lock-keywords) @@ -1066,19 +1110,19 @@ If LIMIT is non-nil, show no more than this many entries." (define-derived-mode vc-git-log-view-mode log-view-mode "Git-Log-View" (require 'add-log) ;; We need the faces add-log. ;; Don't have file markers, so use impossible regexp. - (set (make-local-variable 'log-view-file-re) "\\`a\\`") + (set (make-local-variable 'log-view-file-re) regexp-unmatchable) (set (make-local-variable 'log-view-per-file-logs) nil) (set (make-local-variable 'log-view-message-re) - (if (not (eq vc-log-view-type 'long)) + (if (not (memq vc-log-view-type '(long log-search))) (cadr vc-git-root-log-format) "^commit *\\([0-9a-z]+\\)")) ;; Allow expanding short log entries. - (when (memq vc-log-view-type '(short log-outgoing log-incoming)) + (when (memq vc-log-view-type '(short log-outgoing log-incoming mergebase)) (setq truncate-lines t) (set (make-local-variable 'log-view-expanded-log-entry-function) 'vc-git-expanded-log-entry)) (set (make-local-variable 'log-view-font-lock-keywords) - (if (not (eq vc-log-view-type 'long)) + (if (not (memq vc-log-view-type '(long log-search))) (list (cons (nth 1 vc-git-root-log-format) (nth 2 vc-git-root-log-format))) (append @@ -1176,7 +1220,7 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." (defvar vc-git--log-view-long-font-lock-keywords nil) (defvar font-lock-keywords) (defvar vc-git-region-history-font-lock-keywords - `((vc-git-region-history-font-lock))) + '((vc-git-region-history-font-lock))) (defun vc-git-region-history-font-lock (limit) (let ((in-diff (save-excursion @@ -1373,6 +1417,9 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." (define-key map [git-grep] '(menu-item "Git grep..." vc-git-grep :help "Run the `git grep' command")) + (define-key map [git-ds] + '(menu-item "Delete Stash..." vc-git-stash-delete + :help "Delete a stash")) (define-key map [git-sn] '(menu-item "Stash a Snapshot" vc-git-stash-snapshot :help "Stash the current state of the tree and keep the current state")) @@ -1397,6 +1444,7 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." (declare-function grep-read-files "grep" (regexp)) (declare-function grep-expand-template "grep" (template &optional regexp files dir excl)) +(defvar compilation-environment) ;; Derived from `lgrep'. (defun vc-git-grep (regexp &optional files dir) @@ -1423,8 +1471,7 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (cond ((equal current-prefix-arg '(16)) (list (read-from-minibuffer "Run: " "git grep" - nil nil 'grep-history) - nil)) + nil nil 'grep-history))) (t (let* ((regexp (grep-read-regexp)) (files (mapconcat #'shell-quote-argument @@ -1434,13 +1481,15 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (list regexp files dir)))))) (require 'grep) (when (and (stringp regexp) (> (length regexp) 0)) + (unless (and dir (file-accessible-directory-p dir)) + (setq dir default-directory)) (let ((command regexp)) (if (null files) (if (string= command "git grep") (setq command nil)) (setq dir (file-name-as-directory (expand-file-name dir))) (setq command - (grep-expand-template "git --no-pager grep -n -e <R> -- <F>" + (grep-expand-template vc-git-grep-template regexp files)) (when command (if (equal current-prefix-arg '(4)) @@ -1457,17 +1506,36 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (if (eq next-error-last-buffer (current-buffer)) (setq default-directory dir)))))) +(autoload 'vc-dir-marked-files "vc-dir") + (defun vc-git-stash (name) "Create a stash." (interactive "sStash name: ") (let ((root (vc-git-root default-directory))) (when root - (vc-git--call nil "stash" "save" name) + (apply #'vc-git--call nil "stash" "push" "-m" name + (when (derived-mode-p 'vc-dir-mode) + (vc-dir-marked-files))) (vc-resynch-buffer root t t)))) +(defvar vc-git-stash-read-history nil + "History for `vc-git-stash-read'.") + +(defun vc-git-stash-read (prompt) + "Read a Git stash. PROMPT is a string to prompt with." + (let ((stash (completing-read + prompt + (split-string + (or (vc-git--run-command-string nil "stash" "list") "") "\n") + nil :require-match nil 'vc-git-stash-read-history))) + (if (string-equal stash "") + (user-error "Not a stash") + (string-match "^stash@{[[:digit:]]+}" stash) + (match-string 0 stash)))) + (defun vc-git-stash-show (name) "Show the contents of stash NAME." - (interactive "sStash name: ") + (interactive (list (vc-git-stash-read "Show stash: "))) (vc-setup-buffer "*vc-git-stash*") (vc-git-command "*vc-git-stash*" 'async nil "stash" "show" "-p" name) (set-buffer "*vc-git-stash*") @@ -1477,24 +1545,27 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (defun vc-git-stash-apply (name) "Apply stash NAME." - (interactive "sApply stash: ") + (interactive (list (vc-git-stash-read "Apply stash: "))) (vc-git-command "*vc-git-stash*" 0 nil "stash" "apply" "-q" name) (vc-resynch-buffer (vc-git-root default-directory) t t)) (defun vc-git-stash-pop (name) "Pop stash NAME." - (interactive "sPop stash: ") + (interactive (list (vc-git-stash-read "Pop stash: "))) (vc-git-command "*vc-git-stash*" 0 nil "stash" "pop" "-q" name) (vc-resynch-buffer (vc-git-root default-directory) t t)) +(defun vc-git-stash-delete (name) + "Delete stash NAME." + (interactive (list (vc-git-stash-read "Delete stash: "))) + (vc-git-command "*vc-git-stash*" 0 nil "stash" "drop" "-q" name) + (vc-resynch-buffer (vc-git-root default-directory) t t)) + (defun vc-git-stash-snapshot () "Create a stash with the current tree state." (interactive) (vc-git--call nil "stash" "save" - (let ((ct (current-time))) - (concat - (format-time-string "Snapshot on %Y-%m-%d" ct) - (format-time-string " at %H:%M" ct)))) + (format-time-string "Snapshot on %Y-%m-%d at %H:%M")) (vc-git-command "*vc-git-stash*" 0 nil "stash" "apply" "-q" "stash@{0}") (vc-resynch-buffer (vc-git-root default-directory) t t)) @@ -1518,6 +1589,7 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (declare-function vc-dir-refresh "vc-dir" ()) (defun vc-git-stash-delete-at-point () + "Delete the stash at point." (interactive) (let ((stash (vc-git-stash-get-at-point (point)))) (when (y-or-n-p (format "Remove stash %s ? " stash)) @@ -1525,16 +1597,19 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (vc-dir-refresh)))) (defun vc-git-stash-show-at-point () + "Show the stash at point." (interactive) (vc-git-stash-show (format "stash@%s" (vc-git-stash-get-at-point (point))))) (defun vc-git-stash-apply-at-point () + "Apply the stash at point." (interactive) (let (vc-dir-buffers) ; Small optimization. (vc-git-stash-apply (format "stash@%s" (vc-git-stash-get-at-point (point))))) (vc-dir-refresh)) (defun vc-git-stash-pop-at-point () + "Pop the stash at point." (interactive) (let (vc-dir-buffers) ; Likewise. (vc-git-stash-pop (format "stash@%s" (vc-git-stash-get-at-point (point))))) @@ -1555,7 +1630,14 @@ The difference to vc-do-command is that this function always invokes (or coding-system-for-read vc-git-log-output-coding-system)) (coding-system-for-write (or coding-system-for-write vc-git-commits-coding-system)) - (process-environment (cons "GIT_DIR" process-environment))) + (process-environment + (append + `("GIT_DIR" + ;; Avoid repository locking during background operations + ;; (bug#21559). + ,@(when revert-buffer-in-progress-p + '("GIT_OPTIONAL_LOCKS=0"))) + process-environment))) (apply 'vc-do-command (or buffer "*vc*") okstatus vc-git-program ;; https://debbugs.gnu.org/16897 (unless (and (not (cdr-safe file-or-list)) @@ -1575,15 +1657,22 @@ The difference to vc-do-command is that this function always invokes (defun vc-git--call (buffer command &rest args) ;; We don't need to care the arguments. If there is a file name, it ;; is always a relative one. This works also for remote - ;; directories. We enable `inhibit-null-byte-detection', otherwise + ;; directories. We enable `inhibit-nul-byte-detection', otherwise ;; Tramp's eol conversion might be confused. - (let ((inhibit-null-byte-detection t) + (let ((inhibit-nul-byte-detection t) (coding-system-for-read (or coding-system-for-read vc-git-log-output-coding-system)) (coding-system-for-write (or coding-system-for-write vc-git-commits-coding-system)) - (process-environment (cons "PAGER=" process-environment))) - (push "GIT_DIR" process-environment) + (process-environment + (append + `("GIT_DIR" + "PAGER=" + ;; Avoid repository locking during background operations + ;; (bug#21559). + ,@(when revert-buffer-in-progress-p + '("GIT_OPTIONAL_LOCKS=0"))) + process-environment))) (apply 'process-file vc-git-program nil buffer nil command args))) (defun vc-git--out-ok (command &rest args) diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index eab7e566b27..876d824ceac 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -101,12 +101,12 @@ ;;; Code: +(require 'cl-lib) + (eval-when-compile (require 'vc) (require 'vc-dir)) -(require 'cl-lib) - (declare-function vc-compilation-mode "vc-dispatcher" (backend)) ;;; Customization options @@ -145,6 +145,15 @@ switches." :version "25.1" :group 'vc-hg) +(defcustom vc-hg-revert-switches nil + "String or list of strings specifying switches for hg revert +under VC." + :type '(choice (const :tag "None" nil) + (string :tag "Argument String") + (repeat :tag "Argument List" :value ("") string)) + :version "27.1" + :group 'vc-hg) + (defcustom vc-hg-program "hg" "Name of the Mercurial executable (excluding any arguments)." :type 'string @@ -175,6 +184,10 @@ highlighting the Log View buffer." :version "24.5") +;; Clear up the cache to force vc-call to check again and discover +;; new functions when we reload this file. +(put 'Hg 'vc-functions nil) + ;;; Properties of the backend (defvar vc-hg-history nil) @@ -431,7 +444,7 @@ If LIMIT is non-nil, show no more than this many entries." (define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View" (require 'add-log) ;; we need the add-log faces - (set (make-local-variable 'log-view-file-re) "\\`a\\`") + (set (make-local-variable 'log-view-file-re) regexp-unmatchable) (set (make-local-variable 'log-view-per-file-logs) nil) (set (make-local-variable 'log-view-message-re) (if (eq vc-log-view-type 'short) @@ -579,15 +592,14 @@ back to running Mercurial directly." (defsubst vc-hg--read-u8 () "Read and advance over an unsigned byte. -Return a fixnum." +Return the byte's value as an integer." (prog1 (char-after) (forward-char))) (defsubst vc-hg--read-u32-be () - "Read and advance over a big-endian unsigned 32-bit integer. -Return a fixnum; on overflow, result is undefined." + "Read and advance over a big-endian unsigned 32-bit integer." ;; Because elisp bytecode has an instruction for multiply and - ;; doesn't have one for lsh, it's somewhat counter-intuitively + ;; doesn't have one for shift, it's somewhat counter-intuitively ;; faster to multiply than to shift. (+ (* (vc-hg--read-u8) (* 256 256 256)) (* (vc-hg--read-u8) (* 256 256)) @@ -623,9 +635,7 @@ Return a fixnum; on overflow, result is undefined." ;; hundreds of thousands of times, so performance is important ;; here (while (< (point) search-limit) - ;; 1+4*4 is the length of the dirstate item header, which we - ;; spell as a literal for performance, since the elisp - ;; compiler lacks constant propagation + ;; 1+4*4 is the length of the dirstate item header. (forward-char (1+ (* 3 4))) (let ((this-flen (vc-hg--read-u32-be))) (if (and (or (eq this-flen flen) @@ -832,7 +842,7 @@ if we don't understand a construct, we signal (with-temp-buffer (let ((attr (file-attributes hgignore))) (when attr (insert-file-contents hgignore)) - (push (list hgignore (nth 5 attr) (nth 7 attr)) + (push (list hgignore (file-attribute-modification-time attr) (file-attribute-size attr)) vc-hg--hgignore-filenames)) (while (not (eobp)) ;; This list of pattern-file commands isn't complete, but it @@ -896,8 +906,8 @@ REPO must be the directory name of an hg repository." (saved-mtime (nth 1 fs)) (saved-size (nth 2 fs)) (attr (file-attributes (nth 0 fs))) - (current-mtime (nth 5 attr)) - (current-size (nth 7 attr))) + (current-mtime (file-attribute-modification-time attr)) + (current-size (file-attribute-size attr))) (unless (and (equal saved-mtime current-mtime) (equal saved-size current-size)) (setf valid nil)))) @@ -913,9 +923,6 @@ FILENAME must be the file's true absolute name." (setf ignored (string-match (pop patterns) filename))) ignored)) -(defun vc-hg--time-to-fixnum (ts) - (+ (* 65536 (car ts)) (cadr ts))) - (defvar vc-hg--cached-ignore-patterns nil "Cached pre-parsed hg ignore patterns.") @@ -967,8 +974,8 @@ Avoids the need to repeatedly scan dirstate on repeated calls to `vc-hg-state', as we see during registration queries.") (defun vc-hg--cached-dirstate-search (dirstate dirstate-attr ascii-fname) - (let* ((mtime (nth 5 dirstate-attr)) - (size (nth 7 dirstate-attr)) + (let* ((mtime (file-attribute-modification-time dirstate-attr)) + (size (file-attribute-size dirstate-attr)) (cache vc-hg--dirstate-scan-cache) ) (if (and cache @@ -1011,9 +1018,7 @@ hg binary." ;; Repository must be in an understood format (not (vc-hg--requirements-understood-p repo)) ;; Dirstate too small to be valid - (< (nth 7 dirstate-attr) 40) - ;; We want to store 32-bit unsigned values in fixnums - (< most-positive-fixnum 4294967295) + (< (file-attribute-size dirstate-attr) 40) (progn (setf repo-relative-filename (file-relative-name truename repo)) @@ -1037,8 +1042,10 @@ hg binary." ((eq state ?n) (let ((vc-hg-size (nth 2 dirstate-entry)) (vc-hg-mtime (nth 3 dirstate-entry)) - (fs-size (nth 7 stat)) - (fs-mtime (vc-hg--time-to-fixnum (nth 5 stat)))) + (fs-size (file-attribute-size stat)) + (fs-mtime (encode-time + (file-attribute-modification-time stat) + 'integer))) (if (and (eql vc-hg-size fs-size) (eql vc-hg-mtime fs-mtime)) 'up-to-date 'edited))) @@ -1097,15 +1104,42 @@ hg binary." (vc-hg-command nil 0 file "forget")) (declare-function log-edit-extract-headers "log-edit" (headers string)) +(declare-function log-edit-mode "log-edit" ()) +(declare-function log-edit--toggle-amend "log-edit" (last-msg-fn)) + +(defun vc-hg-log-edit-toggle-amend () + "Toggle whether this will amend the previous commit. +If toggling on, also insert its message into the buffer." + (interactive) + (log-edit--toggle-amend + (lambda () + (with-output-to-string + (vc-hg-command + standard-output 1 nil + "log" "--limit=1" "--template" "{desc}"))))) + +(defvar vc-hg-log-edit-mode-map + (let ((map (make-sparse-keymap "Hg-Log-Edit"))) + (define-key map "\C-c\C-e" 'vc-hg-log-edit-toggle-amend) + map)) + +(define-derived-mode vc-hg-log-edit-mode log-edit-mode "Log-Edit/hg" + "Major mode for editing Hg log messages. +It is based on `log-edit-mode', and has Hg-specific extensions.") (defun vc-hg-checkin (files comment &optional _rev) "Hg-specific version of `vc-backend-checkin'. REV is ignored." - (apply 'vc-hg-command nil 0 files - (nconc (list "commit" "-m") - (log-edit-extract-headers '(("Author" . "--user") - ("Date" . "--date")) - comment)))) + (let ((amend-extract-fn + (lambda (value) + (when (equal value "yes") + (list "--amend"))))) + (apply 'vc-hg-command nil 0 files + (nconc (list "commit" "-m") + (log-edit-extract-headers `(("Author" . "--user") + ("Date" . "--date") + ("Amend" . ,amend-extract-fn)) + comment))))) (defun vc-hg-find-revision (file rev buffer) (let ((coding-system-for-read 'binary) @@ -1142,11 +1176,9 @@ REV is the revision to check out into WORKFILE." (defun vc-hg-find-file-hook () (when (and buffer-file-name - (file-exists-p (concat buffer-file-name ".orig")) ;; Hg does not seem to have a "conflict" status, eg ;; hg http://bz.selenic.com/show_bug.cgi?id=2724 - (memq (vc-file-getprop buffer-file-name 'vc-state) - '(edited conflict)) + (memq (vc-state buffer-file-name) '(edited conflict)) ;; Maybe go on to check that "hg resolve -l" says "U"? ;; If "hg resolve -l" says there's a conflict but there are no ;; conflict markers, it's not clear what we should do. @@ -1163,7 +1195,11 @@ REV is the revision to check out into WORKFILE." ;; Modeled after the similar function in vc-bzr.el (defun vc-hg-revert (file &optional contents-done) (unless contents-done - (with-temp-buffer (vc-hg-command t 0 file "revert")))) + (with-temp-buffer + (apply #'vc-hg-command + t 0 file + "revert" + (append (vc-switches 'hg 'revert)))))) ;;; Hg specific functionality. @@ -1194,9 +1230,9 @@ REV is the revision to check out into WORKFILE." (insert (propertize (format " (%s %s)" (pcase (vc-hg-extra-fileinfo->rename-state extra) - (`copied "copied from") - (`renamed-from "renamed from") - (`renamed-to "renamed to")) + ('copied "copied from") + ('renamed-from "renamed from") + ('renamed-to "renamed to")) (vc-hg-extra-fileinfo->extra-name extra)) 'face 'font-lock-comment-face))))) diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index c3ff41088ca..2d9187642c0 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -1,8 +1,8 @@ -;;; vc-hooks.el --- resident support for version-control +;;; vc-hooks.el --- resident support for version-control -*- lexical-binding:t -*- ;; Copyright (C) 1992-1996, 1998-2019 Free Software Foundation, Inc. -;; Author: FSF (see vc.el for full credits) +;; Author: FSF (see vc.el for full credits) ;; Maintainer: emacs-devel@gnu.org ;; Package: vc @@ -173,9 +173,9 @@ Otherwise, not displayed." (make-variable-buffer-local 'vc-mode) (put 'vc-mode 'permanent-local t) -;;; We signal this error when we try to do something a VC backend -;;; doesn't support. Two arguments: the method that's not supported -;;; and the backend +;; We signal this error when we try to do something a VC backend +;; doesn't support. Two arguments: the method that's not supported +;; and the backend (define-error 'vc-not-supported "VC method not implemented for backend") (defun vc-mode (&optional _arg) @@ -243,12 +243,12 @@ if that doesn't exist either, return nil." "Call for BACKEND the implementation of FUNCTION-NAME with the given ARGS. Calls - (apply \\='vc-BACKEND-FUN ARGS) + (apply #\\='vc-BACKEND-FUN ARGS) if vc-BACKEND-FUN exists (after trying to find it in vc-BACKEND.el) and else calls - (apply \\='vc-default-FUN BACKEND ARGS) + (apply #\\='vc-default-FUN BACKEND ARGS) It is usually called via the `vc-call' macro." (let ((f (assoc function-name (get backend 'vc-functions)))) @@ -603,7 +603,7 @@ a regexp for matching all such backup files, regardless of the version." "Delete all existing automatic version backups for FILE." (condition-case nil (mapc - 'delete-file + #'delete-file (directory-files (or (file-name-directory file) default-directory) t (vc-version-backup-file-name file nil nil t))) ;; Don't fail when the directory doesn't exist. @@ -658,7 +658,7 @@ Before doing that, check if there are any old backups and get rid of them." ;; If the file was saved in the same second in which it was ;; checked out, clear the checkout-time to avoid confusion. (if (equal (vc-file-getprop file 'vc-checkout-time) - (nth 5 (file-attributes file))) + (file-attribute-modification-time (file-attributes file))) (vc-file-setprop file 'vc-checkout-time nil)) (if (vc-state-refresh file backend) (vc-mode-line file backend))) @@ -692,24 +692,26 @@ visiting FILE. If BACKEND is passed use it as the VC backend when computing the result." (interactive (list buffer-file-name)) (setq backend (or backend (vc-backend file))) - (if (not backend) - (setq vc-mode nil) + (cond + ((not backend) + (setq vc-mode nil)) + ((null vc-display-status) + (setq vc-mode (concat " " (symbol-name backend)))) + (t (let* ((ml-string (vc-call-backend backend 'mode-line-string file)) (ml-echo (get-text-property 0 'help-echo ml-string))) (setq vc-mode (concat " " - (if (null vc-display-status) - (symbol-name backend) - (propertize - ml-string - 'mouse-face 'mode-line-highlight - 'help-echo - (concat (or ml-echo - (format "File under the %s version control system" - backend)) - "\nmouse-1: Version Control menu") - 'local-map vc-mode-line-map))))) + (propertize + ml-string + 'mouse-face 'mode-line-highlight + 'help-echo + (concat (or ml-echo + (format "File under the %s version control system" + backend)) + "\nmouse-1: Version Control menu") + 'local-map vc-mode-line-map)))) ;; If the user is root, and the file is not owner-writable, ;; then pretend that we can't write it ;; even though we can (because root can write anything). @@ -718,7 +720,7 @@ If BACKEND is passed use it as the VC backend when computing the result." (not buffer-read-only) (zerop (user-real-uid)) (zerop (logand (file-modes buffer-file-name) 128)) - (setq buffer-read-only t))) + (setq buffer-read-only t)))) (force-mode-line-update) backend) @@ -809,7 +811,7 @@ In the latter case, VC mode is deactivated for this buffer." (when buffer-file-name (vc-file-clearprops buffer-file-name) ;; FIXME: Why use a hook? Why pass it buffer-file-name? - (add-hook 'vc-mode-line-hook 'vc-mode-line nil t) + (add-hook 'vc-mode-line-hook #'vc-mode-line nil t) (let (backend) (cond ((setq backend (with-demoted-errors (vc-backend buffer-file-name))) @@ -860,13 +862,13 @@ In the latter case, VC mode is deactivated for this buffer." ))))))))) (add-hook 'find-file-hook #'vc-refresh-state) -(define-obsolete-function-alias 'vc-find-file-hook 'vc-refresh-state "25.1") +(define-obsolete-function-alias 'vc-find-file-hook #'vc-refresh-state "25.1") (defun vc-kill-buffer-hook () "Discard VC info about a file when we kill its buffer." (when buffer-file-name (vc-file-clearprops buffer-file-name))) -(add-hook 'kill-buffer-hook 'vc-kill-buffer-hook) +(add-hook 'kill-buffer-hook #'vc-kill-buffer-hook) ;; Now arrange for (autoloaded) bindings of the main package. ;; Bindings for this have to go in the global map, as we'll often @@ -888,6 +890,8 @@ In the latter case, VC mode is deactivated for this buffer." (define-key map "L" 'vc-print-root-log) (define-key map "I" 'vc-log-incoming) (define-key map "O" 'vc-log-outgoing) + (define-key map "ML" 'vc-log-mergebase) + (define-key map "MD" 'vc-diff-mergebase) (define-key map "m" 'vc-merge) (define-key map "r" 'vc-retrieve-tag) (define-key map "s" 'vc-create-tag) @@ -948,8 +952,7 @@ In the latter case, VC mode is deactivated for this buffer." (bindings--define-key map [separator2] menu-bar-separator) (bindings--define-key map [vc-insert-header] '(menu-item "Insert Header" vc-insert-headers - :help "Insert headers into a file for use with a version control system. -")) + :help "Insert headers into a file for use with a version control system.")) (bindings--define-key map [vc-revert] '(menu-item "Revert to Base Version" vc-revert :help "Revert working copies of the selected file set to their repository contents")) diff --git a/lisp/vc/vc-mtn.el b/lisp/vc/vc-mtn.el index 748c2ae23ff..91cc28021cf 100644 --- a/lisp/vc/vc-mtn.el +++ b/lisp/vc/vc-mtn.el @@ -190,8 +190,8 @@ switches." (setq branch (replace-match (cdr rule) t nil branch)))) (format "Mtn%c%s" (pcase (vc-state file) - ((or `up-to-date `needs-update) ?-) - (`added ?@) + ((or 'up-to-date 'needs-update) ?-) + ('added ?@) (_ ?:)) branch)) ""))) @@ -240,7 +240,7 @@ If LIMIT is non-nil, show no more than this many entries." (define-derived-mode vc-mtn-log-view-mode log-view-mode "Mtn-Log-View" ;; Don't match anything. - (set (make-local-variable 'log-view-file-re) "\\`a\\`") + (set (make-local-variable 'log-view-file-re) regexp-unmatchable) (set (make-local-variable 'log-view-per-file-logs) nil) ;; TODO: Use a more precise regexp than "[ |/]+" to avoid false positives ;; in the ChangeLog text. diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el index 11a8d396953..d4485d88e48 100644 --- a/lisp/vc/vc-rcs.el +++ b/lisp/vc/vc-rcs.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1992-2019 Free Software Foundation, Inc. -;; Author: FSF (see vc.el for full credits) +;; Author: FSF (see vc.el for full credits) ;; Maintainer: emacs-devel@gnu.org ;; Package: vc @@ -684,13 +684,13 @@ Optional arg REVISION is a revision to annotate from." (forward-line (1- (pop insn))) (setq p (point)) (pcase (pop insn) - (`k (setq s (buffer-substring-no-properties + ('k (setq s (buffer-substring-no-properties p (progn (forward-line (car insn)) (point)))) (when prda (push `(,p . ,(propertize s :vc-rcs-r/d/a prda)) path)) (delete-region p (point))) - (`i (setq s (car insn)) + ('i (setq s (car insn)) (when prda (push `(,p . ,(length s)) path)) (insert s))))) @@ -716,10 +716,10 @@ Optional arg REVISION is a revision to annotate from." (goto-char (point-min)) (forward-line (1- (pop insn))) (pcase (pop insn) - (`k (delete-region + ('k (delete-region (point) (progn (forward-line (car insn)) (point)))) - (`i (insert (propertize + ('i (insert (propertize (car insn) :vc-rcs-r/d/a (or prda (setq prda (r/d/a)))))))) @@ -955,11 +955,10 @@ Uses `rcs2log' which only works for RCS and CVS." "Return non-nil if FILE is newer than its RCS master. This likely means that FILE has been changed with respect to its master version." - (let ((file-time (nth 5 (file-attributes file))) - (master-time (nth 5 (file-attributes (vc-master-name file))))) - (or (> (nth 0 file-time) (nth 0 master-time)) - (and (= (nth 0 file-time) (nth 0 master-time)) - (> (nth 1 file-time) (nth 1 master-time)))))) + (let ((file-time (file-attribute-modification-time (file-attributes file))) + (master-time (file-attribute-modification-time + (file-attributes (vc-master-name file))))) + (time-less-p master-time file-time))) (defun vc-rcs-find-most-recent-rev (branch) "Find most recent revision on BRANCH." diff --git a/lisp/vc/vc-sccs.el b/lisp/vc/vc-sccs.el index 4e9f5a025fb..805e738f7a9 100644 --- a/lisp/vc/vc-sccs.el +++ b/lisp/vc/vc-sccs.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1992-2019 Free Software Foundation, Inc. -;; Author: FSF (see vc.el for full credits) +;; Author: FSF (see vc.el for full credits) ;; Maintainer: emacs-devel@gnu.org ;; Package: vc diff --git a/lisp/vc/vc-src.el b/lisp/vc/vc-src.el index f8475925b02..eb97a9aa5e3 100644 --- a/lisp/vc/vc-src.el +++ b/lisp/vc/vc-src.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1992-2019 Free Software Foundation, Inc. -;; Author: FSF (see vc.el for full credits) +;; Author: FSF (see vc.el for full credits) ;; Maintainer: emacs-devel@gnu.org ;; Package: vc diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el index e10cdd21698..3c50c8fff64 100644 --- a/lisp/vc/vc-svn.el +++ b/lisp/vc/vc-svn.el @@ -479,7 +479,8 @@ The changes are between FIRST-VERSION and SECOND-VERSION." ((string= (match-string 2) "U") (vc-file-setprop file 'vc-state 'up-to-date) (vc-file-setprop file 'vc-checkout-time - (nth 5 (file-attributes file))) + (file-attribute-modification-time + (file-attributes file))) 0);; indicate success to the caller ;; Merge successful, but our own changes are still in the file ((string= (match-string 2) "G") @@ -729,7 +730,8 @@ Set file properties accordingly. If FILENAME is non-nil, return its status." (if (eq (char-after (match-beginning 1)) ?*) 'needs-update (vc-file-setprop file 'vc-checkout-time - (nth 5 (file-attributes file))) + (file-attribute-modification-time + (file-attributes file))) 'up-to-date)) ((eq status ?A) ;; If the file was actually copied, (match-string 2) is "-". @@ -757,7 +759,7 @@ Set file properties accordingly. If FILENAME is non-nil, return its status." ;; an uppercase or lowercase letter and can contain uppercase and ;; lowercase letters, digits, `-', and `_'. (and (string-match "^[a-zA-Z]" tag) - (not (string-match "[^a-z0-9A-Z-_]" tag)))) + (not (string-match "[^a-z0-9A-Z_-]" tag)))) (defun vc-svn-valid-revision-number-p (tag) "Return non-nil if TAG is a valid revision number." diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 353299cbed9..4cac1539289 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1992-1998, 2000-2019 Free Software Foundation, Inc. -;; Author: FSF (see below for full credits) +;; Author: FSF (see below for full credits) ;; Maintainer: emacs-devel@gnu.org ;; Keywords: vc tools @@ -337,6 +337,10 @@ ;; Insert in BUFFER the revision log for the changes that will be ;; received when performing a pull operation from REMOTE-LOCATION. ;; +;; - log-search (pattern) +;; +;; Search for PATTERN in the revision log. +;; ;; - log-view-mode () ;; ;; Mode to use for the output of print-log. This defaults to @@ -429,6 +433,10 @@ ;; - region-history-mode () ;; ;; Major mode to use for the output of `region-history'. +;; +;; - mergebase (rev1 &optional rev2) +;; +;; Return the common ancestor between REV1 and REV2 revisions. ;; TAG SYSTEM ;; @@ -729,13 +737,6 @@ "Emacs interface to version control systems." :group 'tools) -(defcustom vc-initial-comment nil - "If non-nil, prompt for initial comment when a file is registered." - :type 'boolean - :group 'vc) - -(make-obsolete-variable 'vc-initial-comment "it has no effect." "23.2") - (defcustom vc-checkin-switches nil "A string or list of strings specifying extra switches for checkin. These are passed to the checkin program by \\[vc-checkin]." @@ -743,8 +744,7 @@ These are passed to the checkin program by \\[vc-checkin]." (string :tag "Argument String") (repeat :tag "Argument List" :value ("") - string)) - :group 'vc) + string))) (defcustom vc-checkout-switches nil "A string or list of strings specifying extra switches for checkout. @@ -753,8 +753,7 @@ These are passed to the checkout program by \\[vc-checkout]." (string :tag "Argument String") (repeat :tag "Argument List" :value ("") - string)) - :group 'vc) + string))) (defcustom vc-register-switches nil "A string or list of strings; extra switches for registering a file. @@ -763,8 +762,7 @@ These are passed to the checkin program by \\[vc-register]." (string :tag "Argument String") (repeat :tag "Argument List" :value ("") - string)) - :group 'vc) + string))) (defcustom vc-diff-switches nil "A string or list of strings specifying switches for diff under VC. @@ -779,7 +777,6 @@ not specific to any particular backend." (const :tag "None" t) (string :tag "Argument String") (repeat :tag "Argument List" :value ("") string)) - :group 'vc :version "21.1") (defcustom vc-annotate-switches nil @@ -799,15 +796,13 @@ for the backend you use." (const :tag "None" t) (string :tag "Argument String") (repeat :tag "Argument List" :value ("") string)) - :group 'vc :version "25.1") (defcustom vc-log-show-limit 2000 "Limit the number of items shown by the VC log commands. Zero means unlimited. Not all VC backends are able to support this feature." - :type 'integer - :group 'vc) + :type 'integer) (defcustom vc-allow-async-revert nil "Specifies whether the diff during \\[vc-revert] may be asynchronous. @@ -815,7 +810,6 @@ Enabling this option means that you can confirm a revert operation even if the local changes in the file have not been found and displayed yet." :type '(choice (const :tag "No" nil) (const :tag "Yes" t)) - :group 'vc :version "22.1") ;;;###autoload @@ -823,7 +817,6 @@ if the local changes in the file have not been found and displayed yet." "Normal hook (list of functions) run after checking out a file. See `run-hooks'." :type 'hook - :group 'vc :version "21.1") ;;;###autoload @@ -831,20 +824,22 @@ See `run-hooks'." "Normal hook (list of functions) run after commit or file checkin. See also `log-edit-done-hook'." :type 'hook - :options '(log-edit-comment-to-change-log) - :group 'vc) + :options '(log-edit-comment-to-change-log)) ;;;###autoload (defcustom vc-before-checkin-hook nil "Normal hook (list of functions) run before a commit or a file checkin. See `run-hooks'." + :type 'hook) + +(defcustom vc-retrieve-tag-hook nil + "Normal hook (list of functions) run after retrieving a tag." :type 'hook - :group 'vc) + :version "27.1") (defcustom vc-revert-show-diff t "If non-nil, `vc-revert' shows a `vc-diff' buffer before querying." :type 'boolean - :group 'vc :version "24.1") ;; Header-insertion hair @@ -857,8 +852,7 @@ A %s in the template is replaced with the first string associated with the file's version control type in `vc-BACKEND-header'." :type '(repeat (cons :format "%v" (regexp :tag "File Type") - (string :tag "Header String"))) - :group 'vc) + (string :tag "Header String")))) (defcustom vc-comment-alist '((nroff-mode ".\\\"" "")) @@ -869,8 +863,12 @@ is sensitive to blank lines." :type '(repeat (list :format "%v" (symbol :tag "Mode") (string :tag "Comment Start") - (string :tag "Comment End"))) - :group 'vc) + (string :tag "Comment End")))) + +(defcustom vc-find-revision-no-save nil + "If non-nil, `vc-find-revision' doesn't write the created buffer to file." + :type 'boolean + :version "27.1") ;; File property caching @@ -935,7 +933,7 @@ use." ;; 'create-repo method. (completing-read (format "%s is not in a version controlled directory.\nUse VC backend: " file) - (mapcar 'symbol-name possible-backends) nil t))) + (mapcar #'symbol-name possible-backends) nil t))) (repo-dir (let ((def-dir (file-name-directory file))) ;; read the directory where to create the @@ -988,6 +986,7 @@ Within directories, only files already under version control are noticed." (defvar log-view-vc-backend) (defvar log-edit-vc-backend) (defvar diff-vc-backend) +(defvar diff-vc-revisions) (defun vc-deduce-backend () (cond ((derived-mode-p 'vc-dir-mode) vc-dir-backend) @@ -1062,27 +1061,27 @@ BEWARE: this function may change the current buffer." (t (error "File is not under version control"))))) (defun vc-dired-deduce-fileset () - (let ((backend (vc-responsible-backend default-directory))) - (unless backend (error "Directory not under VC")) - (list backend - (dired-map-over-marks (dired-get-filename nil t) nil)))) + (list (vc-responsible-backend default-directory) + (dired-map-over-marks (dired-get-filename nil t) nil))) (defun vc-ensure-vc-buffer () "Make sure that the current buffer visits a version-controlled file." (cond ((derived-mode-p 'vc-dir-mode) (set-buffer (find-file-noselect (vc-dir-current-file)))) + ((derived-mode-p 'dired-mode) + (set-buffer (find-file-noselect (dired-get-filename)))) (t (while (and vc-parent-buffer (buffer-live-p vc-parent-buffer) ;; Avoid infinite looping when vc-parent-buffer and ;; current buffer are the same buffer. (not (eq vc-parent-buffer (current-buffer)))) - (set-buffer vc-parent-buffer)) - (if (not buffer-file-name) - (error "Buffer %s is not associated with a file" (buffer-name)) - (unless (vc-backend buffer-file-name) - (error "File %s is not under version control" buffer-file-name)))))) + (set-buffer vc-parent-buffer)))) + (if (not buffer-file-name) + (error "Buffer %s is not associated with a file" (buffer-name)) + (unless (vc-backend buffer-file-name) + (error "File %s is not under version control" buffer-file-name)))) ;;; Support for the C-x v v command. ;; This is where all the single-file-oriented code from before the fileset @@ -1103,7 +1102,7 @@ BEWARE: this function may change the current buffer." (defun vc-read-backend (prompt) (intern - (completing-read prompt (mapcar 'symbol-name vc-handled-backends) + (completing-read prompt (mapcar #'symbol-name vc-handled-backends) nil 'require-match))) ;; Here's the major entry point. @@ -1361,7 +1360,7 @@ first backend that could register the file is used." (set-buffer-modified-p t)) (vc-buffer-sync))))) (message "Registering %s... " files) - (mapc 'vc-file-clearprops files) + (mapc #'vc-file-clearprops files) (vc-call-backend backend 'register files comment) (mapc (lambda (file) @@ -1488,7 +1487,8 @@ After check-out, runs the normal hook `vc-checkout-hook'." nil) 'up-to-date 'edited)) - (vc-checkout-time . ,(nth 5 (file-attributes file)))))) + (vc-checkout-time . ,(file-attribute-modification-time + (file-attributes file)))))) (vc-resynch-buffer file t t) (run-hooks 'vc-checkout-hook)) @@ -1542,8 +1542,7 @@ The optional argument REV may be a string specifying the new revision level (only supported for some older VCSes, like RCS and CVS). Runs the normal hooks `vc-before-checkin-hook' and `vc-checkin-hook'." - (when vc-before-checkin-hook - (run-hooks 'vc-before-checkin-hook)) + (run-hooks 'vc-before-checkin-hook) (vc-start-logentry files comment initial-contents "Enter a change comment." @@ -1563,9 +1562,10 @@ Runs the normal hooks `vc-before-checkin-hook' and `vc-checkin-hook'." ;; not a well-defined concept for filesets. (progn (vc-call-backend backend 'checkin files comment rev) - (mapc 'vc-delete-automatic-version-backups files)) + (mapc #'vc-delete-automatic-version-backups files)) `((vc-state . up-to-date) - (vc-checkout-time . ,(nth 5 (file-attributes file))) + (vc-checkout-time . ,(file-attribute-modification-time + (file-attributes file))) (vc-working-revision . nil))) (message "Checking in %s...done" (vc-delistify files))) 'vc-checkin-hook @@ -1649,11 +1649,6 @@ to override the value of `vc-diff-switches' and `diff-switches'." ;; any switches in diff-switches. (when (listp switches) switches)))) -;; Old def for compatibility with Emacs-21.[123]. -(defmacro vc-diff-switches-list (backend) - (declare (obsolete vc-switches "22.1")) - `(vc-switches ',backend 'diff)) - (defun vc-diff-finish (buffer messages) ;; The empty sync output case has already been handled, so the only ;; possibility of an empty output is for an async process. @@ -1725,7 +1720,7 @@ Return t if the buffer had changes, nil otherwise." (error "No revisions of %s exist" file) ;; We regard this as "changed". ;; Diff it against /dev/null. - (apply 'vc-do-command buffer + (apply #'vc-do-command buffer (if async 'async 1) "diff" file (append (vc-switches nil 'diff) '("/dev/null")))))) (setq files (nreverse filtered)))) @@ -1733,6 +1728,7 @@ Return t if the buffer had changes, nil otherwise." (set-buffer buffer) (diff-mode) (set (make-local-variable 'diff-vc-backend) (car vc-fileset)) + (set (make-local-variable 'diff-vc-revisions) (list rev1 rev2)) (set (make-local-variable 'revert-buffer-function) (lambda (_ignore-auto _noconfirm) (vc-diff-internal async vc-fileset rev1 rev2 verbose))) @@ -1774,9 +1770,9 @@ Return t if the buffer had changes, nil otherwise." nil nil initial-input 'vc-revision-history default) (read-string prompt initial-input nil default)))) -(defun vc-diff-build-argument-list-internal () +(defun vc-diff-build-argument-list-internal (&optional fileset) "Build argument list for calling internal diff functions." - (let* ((vc-fileset (vc-deduce-fileset t)) ;FIXME: why t? --Stef + (let* ((vc-fileset (or fileset (vc-deduce-fileset t))) ;FIXME: why t? --Stef (files (cadr vc-fileset)) (backend (car vc-fileset)) (first (car files)) @@ -1830,6 +1826,32 @@ state of each file in the fileset." (called-interactively-p 'interactive))) ;;;###autoload +(defun vc-root-version-diff (_files rev1 rev2) + "Report diffs between REV1 and REV2 revisions of the whole tree." + (interactive + (vc-diff-build-argument-list-internal + (or (ignore-errors (vc-deduce-fileset t)) + (let ((backend (or (vc-deduce-backend) (vc-responsible-backend default-directory)))) + (list backend (list (vc-call-backend backend 'root default-directory))))))) + ;; This is a mix of `vc-root-diff' and `vc-version-diff' + (when (and (not rev1) rev2) + (error "Not a valid revision range")) + (let ((backend (vc-deduce-backend)) + (default-directory default-directory) + rootdir) + (if backend + (setq rootdir (vc-call-backend backend 'root default-directory)) + (setq rootdir (read-directory-name "Directory for VC root-diff: ")) + (setq backend (vc-responsible-backend rootdir)) + (if backend + (setq default-directory rootdir) + (error "Directory is not version controlled"))) + (let ((default-directory rootdir)) + (vc-diff-internal + t (list backend (list rootdir)) rev1 rev2 + (called-interactively-p 'interactive))))) + +;;;###autoload (defun vc-diff (&optional historic not-urgent) "Display diffs between file revisions. Normally this compares the currently selected fileset with their @@ -1845,6 +1867,33 @@ saving the buffer." (vc-diff-internal t (vc-deduce-fileset t) nil nil (called-interactively-p 'interactive)))) +;;;###autoload +(defun vc-diff-mergebase (_files rev1 rev2) + "Report diffs between the merge base of REV1 and REV2 revisions. +The merge base is a common ancestor between REV1 and REV2 revisions." + (interactive + (vc-diff-build-argument-list-internal + (or (ignore-errors (vc-deduce-fileset t)) + (let ((backend (or (vc-deduce-backend) (vc-responsible-backend default-directory)))) + (list backend (list (vc-call-backend backend 'root default-directory))))))) + (when (and (not rev1) rev2) + (error "Not a valid revision range")) + (let ((backend (vc-deduce-backend)) + (default-directory default-directory) + rootdir) + (if backend + (setq rootdir (vc-call-backend backend 'root default-directory)) + (setq rootdir (read-directory-name "Directory for VC root-diff: ")) + (setq backend (vc-responsible-backend rootdir)) + (if backend + (setq default-directory rootdir) + (error "Directory is not version controlled"))) + (let ((default-directory rootdir) + (rev1 (vc-call-backend backend 'mergebase rev1 rev2))) + (vc-diff-internal + t (list backend (list rootdir)) rev1 rev2 + (called-interactively-p 'interactive))))) + (declare-function ediff-load-version-control "ediff" (&optional silent)) (declare-function ediff-vc-internal "ediff-vers" (rev1 rev2 &optional startup-hooks)) @@ -1908,10 +1957,8 @@ The optional argument NOT-URGENT non-nil means it is ok to say no to saving the buffer." (interactive (list current-prefix-arg t)) (if historic - ;; FIXME: this does not work right, `vc-version-diff' ends up - ;; calling `vc-deduce-fileset' to find the files to diff, and - ;; that's not what we want here, we want the diff for the VC root dir. - (call-interactively 'vc-version-diff) + ;; We want the diff for the VC root dir. + (call-interactively 'vc-root-version-diff) (when buffer-file-name (vc-buffer-sync not-urgent)) (let ((backend (vc-deduce-backend)) (default-directory default-directory) @@ -1967,6 +2014,13 @@ If `F.~REV~' already exists, use it instead of checking it out again." (defun vc-find-revision (file revision &optional backend) "Read REVISION of FILE into a buffer and return the buffer. Use BACKEND as the VC backend if specified." + (if vc-find-revision-no-save + (vc-find-revision-no-save file revision backend) + (vc-find-revision-save file revision backend))) + +(defun vc-find-revision-save (file revision &optional backend) + "Read REVISION of FILE into a buffer and return the buffer. +Saves the buffer to the file." (let ((automatic-backup (vc-version-backup-file-name file revision)) (filebuf (or (get-file-buffer file) (current-buffer))) (filename (vc-version-backup-file-name file revision 'manual))) @@ -2002,6 +2056,51 @@ Use BACKEND as the VC backend if specified." (set (make-local-variable 'vc-parent-buffer) filebuf)) result-buf))) +(defun vc-find-revision-no-save (file revision &optional backend buffer) + "Read REVISION of FILE into BUFFER and return the buffer. +If BUFFER omitted or nil, this function creates a new buffer and sets +`buffer-file-name' to the name constructed from the file name and the +revision number. +Unlike `vc-find-revision-save', doesn't save the buffer to the file." + (let* ((buffer (when (buffer-live-p buffer) buffer)) + (filebuf (or buffer (get-file-buffer file) (current-buffer))) + (filename (unless buffer (vc-version-backup-file-name file revision 'manual)))) + (unless (and (not buffer) + (or (get-file-buffer filename) + (file-exists-p filename))) + (with-current-buffer filebuf + (let ((failed t)) + (unwind-protect + (with-current-buffer (or buffer (create-file-buffer filename)) + (unless buffer (setq buffer-file-name filename)) + (let ((outbuf (current-buffer))) + (with-current-buffer filebuf + (if backend + (vc-call-backend backend 'find-revision file revision outbuf) + (vc-call find-revision file revision outbuf)))) + (decode-coding-inserted-region (point-min) (point-max) file) + (after-insert-file-set-coding (- (point-max) (point-min))) + (goto-char (point-min)) + (if buffer + ;; For non-interactive, skip any questions + (let ((enable-local-variables :safe) ;; to find `mode:' + (buffer-file-name file)) + (ignore-errors (set-auto-mode))) + (normal-mode)) + (set-buffer-modified-p nil) + (setq buffer-read-only t)) + (setq failed nil) + (when (and failed (unless buffer (get-file-buffer filename))) + (with-current-buffer (get-file-buffer filename) + (set-buffer-modified-p nil)) + (kill-buffer (get-file-buffer filename))))))) + (let ((result-buf (or buffer + (get-file-buffer filename) + (find-file-noselect filename)))) + (with-current-buffer result-buf + (set (make-local-variable 'vc-parent-buffer) filebuf)) + result-buf))) + ;; Header-insertion code ;;;###autoload @@ -2108,6 +2207,7 @@ changes from the current branch." ;; `default-next-file' variable for its default file (M-n), and ;; we could then set it upon mark-resolve, so C-x C-s C-x C-f M-n would ;; automatically offer the next conflicted file. +;;;###autoload (defun vc-find-conflicted-file () "Visit the next conflicted file in the current project." (interactive) @@ -2178,7 +2278,8 @@ otherwise use the repository root of the current buffer. If NAME is empty, it refers to the latest revisions of the current branch. If locking is used for the files in DIR, then there must not be any locked files at or below DIR (but if NAME is empty, locked files are -allowed and simply skipped)." +allowed and simply skipped). +This function runs the hook `vc-retrieve-tag-hook' when finished." (interactive (let* ((granularity (vc-call-backend (vc-responsible-backend default-directory) @@ -2205,6 +2306,7 @@ allowed and simply skipped)." (vc-call-backend (vc-responsible-backend dir) 'retrieve-tag dir name update) (vc-resynch-buffer dir t t t) + (run-hooks 'vc-retrieve-tag-hook) (message "%s" (concat msg "done")))) @@ -2294,11 +2396,11 @@ earlier revisions. Show up to LIMIT entries (non-nil means unlimited)." setup-buttons-func goto-location-func rev-buff-func) - (let (retval) - (with-current-buffer (get-buffer-create buffer-name) + (let (retval (buffer (get-buffer-create buffer-name))) + (with-current-buffer buffer (set (make-local-variable 'vc-log-view-type) type)) (setq retval (funcall backend-func backend buffer-name type files)) - (with-current-buffer (get-buffer buffer-name) + (with-current-buffer buffer (let ((inhibit-read-only t)) ;; log-view-mode used to be called with inhibit-read-only bound ;; to t, so let's keep doing it, just in case. @@ -2309,7 +2411,7 @@ earlier revisions. Show up to LIMIT entries (non-nil means unlimited)." rev-buff-func))) ;; Display after setting up major-mode, so display-buffer-alist can know ;; the major-mode. - (pop-to-buffer buffer-name) + (pop-to-buffer buffer) (vc-run-delayed (let ((inhibit-read-only t)) (funcall setup-buttons-func backend files retval) @@ -2429,17 +2531,60 @@ When called interactively with a prefix argument, prompt for REMOTE-LOCATION." "*vc-outgoing*" 'log-outgoing))) ;;;###autoload +(defun vc-log-search (pattern) + "Search the log of changes for PATTERN. + +PATTERN is usually interpreted as a regular expression. However, its +exact semantics is up to the backend's log search command; some can +only match fixed strings. + +Display all entries that match log messages in long format. +With a prefix argument, ask for a command to run that will output +log entries." + (interactive (list (unless current-prefix-arg + (read-regexp "Search log with pattern: ")))) + (let ((backend (vc-deduce-backend))) + (unless backend + (error "Buffer is not version controlled")) + (vc-incoming-outgoing-internal backend pattern + "*vc-search-log*" 'log-search))) + +;;;###autoload +(defun vc-log-mergebase (_files rev1 rev2) + "Show a log of changes between the merge base of REV1 and REV2 revisions. +The merge base is a common ancestor between REV1 and REV2 revisions." + (interactive + (vc-diff-build-argument-list-internal + (or (ignore-errors (vc-deduce-fileset t)) + (let ((backend (or (vc-deduce-backend) (vc-responsible-backend default-directory)))) + (list backend (list (vc-call-backend backend 'root default-directory))))))) + (let ((backend (vc-deduce-backend)) + (default-directory default-directory) + rootdir) + (if backend + (setq rootdir (vc-call-backend backend 'root default-directory)) + (setq rootdir (read-directory-name "Directory for VC root-log: ")) + (setq backend (vc-responsible-backend rootdir)) + (unless backend + (error "Directory is not version controlled"))) + (setq default-directory rootdir) + (setq rev1 (vc-call-backend backend 'mergebase rev1 rev2)) + (vc-print-log-internal backend (list rootdir) rev1 t (or rev2 "")))) + +;;;###autoload (defun vc-region-history (from to) "Show the history of the region between FROM and TO. If called interactively, show the history between point and mark." (interactive "r") - (let* ((lfrom (line-number-at-pos from)) - (lto (line-number-at-pos (1- to))) + (let* ((lfrom (line-number-at-pos from t)) + (lto (line-number-at-pos (1- to) t)) (file buffer-file-name) (backend (vc-backend file)) (buf (get-buffer-create "*VC-history*"))) + (unless backend + (error "Buffer is not version controlled")) (with-current-buffer buf (setq-local vc-log-view-type 'long)) (vc-call region-history file buf lfrom lto) @@ -2592,7 +2737,8 @@ its name; otherwise return nil." (vc-delete-automatic-version-backups file)) (vc-call revert file backup-file)) `((vc-state . up-to-date) - (vc-checkout-time . ,(nth 5 (file-attributes file))))) + (vc-checkout-time . ,(file-attribute-modification-time + (file-attributes file))))) (vc-resynch-buffer file t t)) ;;;###autoload @@ -2703,7 +2849,8 @@ If called interactively, read FILE, defaulting to the current buffer's file name if it's under version control." (interactive (list (read-file-name "VC delete file: " nil (when (vc-backend buffer-file-name) - buffer-file-name) t))) + buffer-file-name) + t))) (setq file (expand-file-name file)) (let ((buf (get-file-buffer file)) (backend (vc-backend file))) diff --git a/lisp/vcursor.el b/lisp/vcursor.el index 84482ef6b85..9047936f56b 100644 --- a/lisp/vcursor.el +++ b/lisp/vcursor.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1994, 1996, 1998, 2001-2019 Free Software Foundation, ;; Inc. -;; Author: Peter Stephenson <pws@ibmth.df.unipi.it> +;; Author: Peter Stephenson <pws@ibmth.df.unipi.it> ;; Maintainer: emacs-devel@gnu.org ;; Keywords: virtual cursor, convenience @@ -815,8 +815,7 @@ out how much to copy." (define-minor-mode vcursor-use-vcursor-map "Toggle the state of the vcursor key map. -With a prefix argument ARG, enable it if ARG is positive, and disable -it otherwise. If called from Lisp, enable it if ARG is omitted or nil. + When on, the keys defined in it are mapped directly on top of the main keymap, allowing you to move the vcursor with ordinary motion keys. An indication \"!VC\" appears in the mode list. The effect is diff --git a/lisp/version.el b/lisp/version.el index cb9d0442ccf..b9e2e50d1f7 100644 --- a/lisp/version.el +++ b/lisp/version.el @@ -99,15 +99,15 @@ to the system configuration; look at `system-configuration' instead." ;; We hope that this alias is easier for people to find. (defalias 'version 'emacs-version) +(define-obsolete-variable-alias 'emacs-bzr-version + 'emacs-repository-version "24.4") + ;; Set during dumping, this is a defvar so that it can be setq'd. (defvar emacs-repository-version nil "String giving the repository revision from which this Emacs was built. Value is nil if Emacs was not built from a repository checkout, or if we could not determine the revision.") -(define-obsolete-variable-alias 'emacs-bzr-version - 'emacs-repository-version "24.4") - (define-obsolete-function-alias 'emacs-bzr-get-version 'emacs-repository-get-version "24.4") @@ -120,7 +120,7 @@ or if we could not determine the revision.") (with-demoted-errors "Error running git rev-parse: %S" (call-process "git" nil '(t nil) nil "rev-parse" "HEAD"))) (progn (goto-char (point-min)) - (looking-at "[0-9a-fA-F]\\{40\\}")) + (looking-at "[[:xdigit:]]\\{40\\}")) (match-string 0))))) (defun emacs-repository-get-version (&optional dir external) @@ -135,6 +135,34 @@ Optional argument DIR is a directory to use instead of `source-directory'. Optional argument EXTERNAL is ignored." (emacs-repository-version-git (or dir source-directory))) +(defvar emacs-repository-branch nil + "String giving the repository branch from which this Emacs was built. +Value is nil if Emacs was not built from a repository checkout, +or if we could not determine the branch.") + +(defun emacs-repository-branch-git (dir) + "Ask git itself for the branch information for directory DIR." + (message "Waiting for git...") + (with-temp-buffer + (let ((default-directory (file-name-as-directory dir))) + (and (zerop + (with-demoted-errors "Error running git rev-parse --abbrev-ref: %S" + (call-process "git" nil '(t nil) nil + "rev-parse" "--abbrev-ref" "HEAD"))) + (goto-char (point-min)) + (buffer-substring (point) (line-end-position)))))) + +(defun emacs-repository-get-branch (&optional dir) + "Try to return as a string the repository branch of the Emacs sources. +The format of the returned string is dependent on the VCS in use. +Value is nil if the sources do not seem to be under version +control, or if we could not determine the branch. Note that +this reports on the current state of the sources, which may not +correspond to the running Emacs. + +Optional argument DIR is a directory to use instead of `source-directory'." + (emacs-repository-branch-git (or dir source-directory))) + ;; We put version info into the executable in the form that `ident' uses. (purecopy (concat "\n$Id: " (subst-char-in-string ?\n ?\s (emacs-version)) " $\n")) diff --git a/lisp/view.el b/lisp/view.el index 5e6f3e2caa9..deda061cd39 100644 --- a/lisp/view.el +++ b/lisp/view.el @@ -381,9 +381,6 @@ own View-like bindings." ;; bindings instead of using the \\[] construction. The reason for this ;; is that most commands have more than one key binding. "Toggle View mode, a minor mode for viewing text but not editing it. -With a prefix argument ARG, enable View mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable View mode -if ARG is omitted or nil. When View mode is enabled, commands that do not change the buffer contents are available as usual. Kill commands save text but @@ -746,18 +743,19 @@ invocations return to earlier marks." (setq backward (not backward) lines (- lines))) (when (and maxdefault lines (> lines (view-window-size))) (setq lines nil)) - (cond (backward (scroll-down lines)) + (cond (backward (scroll-down-command lines)) ((view-really-at-end) (if view-scroll-auto-exit (View-quit) (ding) (view-end-message))) - (t (scroll-up lines) + (t (scroll-up-command lines) (if (view-really-at-end) (view-end-message))))) (defun view-really-at-end () ;; Return true if buffer end visible. Maybe revert buffer and test. - (and (pos-visible-in-window-p (point-max)) + (and (or (null scroll-error-top-bottom) (eobp)) + (pos-visible-in-window-p (point-max)) (let ((buf (current-buffer)) (bufname (buffer-name)) (file (buffer-file-name))) @@ -960,7 +958,7 @@ for highlighting the match that is found." (t (error "No previous View-mode search"))) (save-excursion (if end (goto-char (if (< times 0) (point-max) (point-min))) - (move-to-window-line (if (< times 0) 0 -1))) + (forward-line (if (< times 0) -1 1))) (if (if no (view-search-no-match-lines times regexp) (re-search-forward regexp nil t times)) (setq where (point)))) diff --git a/lisp/vt-control.el b/lisp/vt-control.el index 7175095d40a..ee2463475e0 100644 --- a/lisp/vt-control.el +++ b/lisp/vt-control.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1993-1994, 2001-2019 Free Software Foundation, Inc. ;; Author: Rob Riepel <riepel@networking.stanford.edu> -;; Maintainer: Rob Riepel <riepel@networking.stanford.edu> ;; Keywords: terminals ;; This file is part of GNU Emacs. diff --git a/lisp/w32-fns.el b/lisp/w32-fns.el index 938331d5372..443a995cb8d 100644 --- a/lisp/w32-fns.el +++ b/lisp/w32-fns.el @@ -31,13 +31,15 @@ ;;;; Function keys -(declare-function set-message-beep "w32fns.c" (sound)) (declare-function w32-get-locale-info "w32proc.c" (lcid &optional longform)) (declare-function w32-get-valid-locale-ids "w32proc.c" ()) -;; Map all versions of a filename (8.3, longname, mixed case) to the -;; same buffer. -(setq find-file-visit-truename t) +(if (eq system-type 'windows-nt) + ;; Map all versions of a filename (8.3, longname, mixed case) to the + ;; same buffer. + (setq find-file-visit-truename t)) + +;;;; Shells (defun w32-shell-name () "Return the name of the shell being used." @@ -120,28 +122,24 @@ You should set this to t when using a non-system shell.\n\n")))) (add-hook 'after-init-hook 'w32-check-shell-configuration) +;;;; Coding-systems, locales, etc. + ;; Override setting chosen at startup. (defun w32-set-default-process-coding-system () ;; Most programs on Windows will accept Unix line endings on input ;; (and some programs ported from Unix require it) but most will ;; produce DOS line endings on output. (setq default-process-coding-system - (if (default-value 'enable-multibyte-characters) - '(undecided-dos . undecided-unix) - '(raw-text-dos . raw-text-unix))) + '(undecided-dos . undecided-unix)) ;; Make cmdproxy default to using DOS line endings for input, ;; because some Windows programs (including command.com) require it. (add-to-list 'process-coding-system-alist - `("[cC][mM][dD][pP][rR][oO][xX][yY]" - . ,(if (default-value 'enable-multibyte-characters) - '(undecided-dos . undecided-dos) - '(raw-text-dos . raw-text-dos)))) + '("[cC][mM][dD][pP][rR][oO][xX][yY]" + . (undecided-dos . undecided-dos))) ;; plink needs DOS input when entering the password. (add-to-list 'process-coding-system-alist - `("[pP][lL][iI][nN][kK]" - . ,(if (default-value 'enable-multibyte-characters) - '(undecided-dos . undecided-dos) - '(raw-text-dos . raw-text-dos))))) + '("[pP][lL][iI][nN][kK]" + . (undecided-dos . undecided-dos)))) (define-obsolete-function-alias 'set-default-process-coding-system #'w32-set-default-process-coding-system "26.1") (add-hook 'before-init-hook #'w32-set-default-process-coding-system) @@ -193,31 +191,6 @@ You should set this to t when using a non-system shell.\n\n")))) ;; (setq source-directory (file-name-as-directory ;; (expand-file-name ".." exec-directory))))) -(defun w32-convert-standard-filename (filename) - "Convert a standard file's name to something suitable for MS-Windows. -This means to guarantee valid names and perhaps to canonicalize -certain patterns. - -This function is called by `convert-standard-filename'. - -Replace invalid characters and turn Cygwin names into native -names." - (save-match-data - (let ((name - (if (string-match "\\`/cygdrive/\\([a-zA-Z]\\)/" filename) - (replace-match "\\1:/" t nil filename) - (copy-sequence filename))) - (start 0)) - ;; leave ':' if part of drive specifier - (if (and (> (length name) 1) - (eq (aref name 1) ?:)) - (setq start 2)) - ;; destructively replace invalid filename characters with ! - (while (string-match "[?*:<>|\"\000-\037]" name start) - (aset name (match-beginning 0) ?!) - (setq start (match-end 0))) - name))) - (defun w32-set-system-coding-system (coding-system) "Set the coding system used by the Windows system to CODING-SYSTEM. This is used for things like passing font names with non-ASCII @@ -242,7 +215,8 @@ This function is provided for backward compatibility, since (defvaralias 'w32-system-coding-system 'locale-coding-system) ;; Set to a system sound if you want a fancy bell. -(set-message-beep nil) +(if (fboundp 'set-message-beep) ; w32fns.c + (set-message-beep nil)) (defvar w32-charset-info-alist) ; w32font.c @@ -259,47 +233,121 @@ bit output with no translation." (add-to-list 'w32-charset-info-alist (cons xlfd-charset (cons windows-charset codepage)))) -;; The last charset we add becomes the "preferred" charset for the return -;; value from x-select-font etc, so list the most important charsets last. -(w32-add-charset-info "iso8859-14" 'w32-charset-ansi 28604) -(w32-add-charset-info "iso8859-15" 'w32-charset-ansi 28605) -;; The following two are included for pattern matching. -(w32-add-charset-info "jisx0201" 'w32-charset-shiftjis 932) -(w32-add-charset-info "jisx0208" 'w32-charset-shiftjis 932) -(w32-add-charset-info "jisx0201-latin" 'w32-charset-shiftjis 932) -(w32-add-charset-info "jisx0201-katakana" 'w32-charset-shiftjis 932) -(w32-add-charset-info "ksc5601.1989" 'w32-charset-hangeul 949) -(w32-add-charset-info "big5" 'w32-charset-chinesebig5 950) -(w32-add-charset-info "gb2312.1980" 'w32-charset-gb2312 936) -(w32-add-charset-info "ms-symbol" 'w32-charset-symbol nil) -(w32-add-charset-info "ms-oem" 'w32-charset-oem 437) -(w32-add-charset-info "ms-oemlatin" 'w32-charset-oem 850) -(w32-add-charset-info "iso8859-2" 'w32-charset-easteurope 28592) -(w32-add-charset-info "iso8859-3" 'w32-charset-turkish 28593) -(w32-add-charset-info "iso8859-4" 'w32-charset-baltic 28594) -(w32-add-charset-info "iso8859-6" 'w32-charset-arabic 28596) -(w32-add-charset-info "iso8859-7" 'w32-charset-greek 28597) -(w32-add-charset-info "iso8859-8" 'w32-charset-hebrew 1255) -(w32-add-charset-info "iso8859-9" 'w32-charset-turkish 1254) -(w32-add-charset-info "iso8859-13" 'w32-charset-baltic 1257) -(w32-add-charset-info "koi8-r" 'w32-charset-russian 20866) -(w32-add-charset-info "iso8859-5" 'w32-charset-russian 28595) -(w32-add-charset-info "tis620-2533" 'w32-charset-thai 874) -(w32-add-charset-info "windows-1258" 'w32-charset-vietnamese 1258) -(w32-add-charset-info "ksc5601.1992" 'w32-charset-johab 1361) -(w32-add-charset-info "mac-roman" 'w32-charset-mac 10000) -(w32-add-charset-info "iso10646-1" 'w32-charset-default t) - -;; ;; If Unicode Windows charset is not defined, use ansi fonts. -;; (w32-add-charset-info "iso10646-1" 'w32-charset-ansi t)) - -;; Preferred names -(w32-add-charset-info "big5-0" 'w32-charset-chinesebig5 950) -(w32-add-charset-info "gb2312.1980-0" 'w32-charset-gb2312 936) -(w32-add-charset-info "jisx0208-sjis" 'w32-charset-shiftjis 932) -(w32-add-charset-info "ksc5601.1987-0" 'w32-charset-hangeul 949) -(w32-add-charset-info "tis620-0" 'w32-charset-thai 874) -(w32-add-charset-info "iso8859-1" 'w32-charset-ansi 1252) +(when (boundp 'w32-charset-info-alist) + ;; The last charset we add becomes the "preferred" charset for the return + ;; value from x-select-font etc, so list the most important charsets last. + (w32-add-charset-info "iso8859-14" 'w32-charset-ansi 28604) + (w32-add-charset-info "iso8859-15" 'w32-charset-ansi 28605) + ;; The following two are included for pattern matching. + (w32-add-charset-info "jisx0201" 'w32-charset-shiftjis 932) + (w32-add-charset-info "jisx0208" 'w32-charset-shiftjis 932) + (w32-add-charset-info "jisx0201-latin" 'w32-charset-shiftjis 932) + (w32-add-charset-info "jisx0201-katakana" 'w32-charset-shiftjis 932) + (w32-add-charset-info "ksc5601.1989" 'w32-charset-hangeul 949) + (w32-add-charset-info "big5" 'w32-charset-chinesebig5 950) + (w32-add-charset-info "gb2312.1980" 'w32-charset-gb2312 936) + (w32-add-charset-info "ms-symbol" 'w32-charset-symbol nil) + (w32-add-charset-info "ms-oem" 'w32-charset-oem 437) + (w32-add-charset-info "ms-oemlatin" 'w32-charset-oem 850) + (w32-add-charset-info "iso8859-2" 'w32-charset-easteurope 28592) + (w32-add-charset-info "iso8859-3" 'w32-charset-turkish 28593) + (w32-add-charset-info "iso8859-4" 'w32-charset-baltic 28594) + (w32-add-charset-info "iso8859-6" 'w32-charset-arabic 28596) + (w32-add-charset-info "iso8859-7" 'w32-charset-greek 28597) + (w32-add-charset-info "iso8859-8" 'w32-charset-hebrew 1255) + (w32-add-charset-info "iso8859-9" 'w32-charset-turkish 1254) + (w32-add-charset-info "iso8859-13" 'w32-charset-baltic 1257) + (w32-add-charset-info "koi8-r" 'w32-charset-russian 20866) + (w32-add-charset-info "tis620-2533" 'w32-charset-russian 28595) + (w32-add-charset-info "iso8859-11" 'w32-charset-thai 874) + (w32-add-charset-info "windows-1258" 'w32-charset-vietnamese 1258) + (w32-add-charset-info "ksc5601.1992" 'w32-charset-johab 1361) + (w32-add-charset-info "mac-roman" 'w32-charset-mac 10000) + (w32-add-charset-info "iso10646-1" 'w32-charset-default t) + + ;; ;; If Unicode Windows charset is not defined, use ansi fonts. + ;; (w32-add-charset-info "iso10646-1" 'w32-charset-ansi t)) + + ;; Preferred names + (w32-add-charset-info "big5-0" 'w32-charset-chinesebig5 950) + (w32-add-charset-info "gb2312.1980-0" 'w32-charset-gb2312 936) + (w32-add-charset-info "jisx0208-sjis" 'w32-charset-shiftjis 932) + (w32-add-charset-info "ksc5601.1987-0" 'w32-charset-hangeul 949) + (w32-add-charset-info "tis620-0" 'w32-charset-thai 874) + (w32-add-charset-info "iso8859-1" 'w32-charset-ansi 1252)) + +;;;; Standard filenames + +(defun w32-convert-standard-filename (filename) + "Convert a standard file's name to something suitable for MS-Windows. +This means to guarantee valid names and perhaps to canonicalize +certain patterns. + +This function is called by `convert-standard-filename'. + +Replace invalid characters and turn Cygwin names into native +names." + (save-match-data + (let ((name + (if (string-match "\\`/cygdrive/\\([a-zA-Z]\\)/" filename) + (replace-match "\\1:/" t nil filename) + (copy-sequence filename))) + (start 0)) + ;; leave ':' if part of drive specifier + (if (and (> (length name) 1) + (eq (aref name 1) ?:)) + (setq start 2)) + ;; destructively replace invalid filename characters with ! + (while (string-match "[?*:<>|\"\000-\037]" name start) + (aset name (match-beginning 0) ?!) + (setq start (match-end 0))) + name))) + +;;;; System name and version for emacsbug.el + +(declare-function w32-version "w32-win" ()) +(declare-function w32-read-registry "w32fns" (root key name)) + +(defun w32--os-description () + "Return a string describing the underlying OS and its version." + (let* ((w32ver (car (w32-version))) + (w9x-p (< w32ver 5)) + (key (if w9x-p + "SOFTWARE/Microsoft/Windows/CurrentVersion" + "SOFTWARE/Microsoft/Windows NT/CurrentVersion")) + (os-name (w32-read-registry 'HKLM key "ProductName")) + (os-version (if w9x-p + (w32-read-registry 'HKLM key "VersionNumber") + (let ((vmajor + (w32-read-registry 'HKLM key + "CurrentMajorVersionNumber")) + (vminor + (w32-read-registry 'HKLM key + "CurrentMinorVersionNumber"))) + (if (and vmajor vmajor) + (format "%d.%d" vmajor vminor) + (w32-read-registry 'HKLM key "CurrentVersion"))))) + (os-csd (w32-read-registry 'HKLM key "CSDVersion")) + (os-rel (or (w32-read-registry 'HKLM key "ReleaseID") + (w32-read-registry 'HKLM key "CSDBuildNumber") + "0")) ; No Release ID before Windows Vista + (os-build (w32-read-registry 'HKLM key "CurrentBuildNumber")) + (os-rev (w32-read-registry 'HKLM key "UBR")) + (os-rev (if os-rev (format "%d" os-rev)))) + (if w9x-p + (concat + (if (not (string-match "\\`Microsoft " os-name)) "Microsoft ") + os-name + " (v" os-version ")") + (concat + (if (not (string-match "\\`Microsoft " os-name)) "Microsoft ") + os-name ; Windows 7 Enterprise + " " + os-csd ; Service Pack 1 + (if (and os-csd (> (length os-csd) 0)) " " "") + "(v" + os-version "." os-rel "." os-build (if os-rev (concat "." os-rev)) + ")")))) ;;;; Support for build process diff --git a/lisp/w32-vars.el b/lisp/w32-vars.el index 72acf205ff7..2861a3572da 100644 --- a/lisp/w32-vars.el +++ b/lisp/w32-vars.el @@ -47,10 +47,6 @@ after changing the value of this variable." (setq mouse-appearance-menu-map nil)) :group 'w32) -(defvar w32-list-proportional-fonts nil - "Include proportional fonts in the default font dialog.") -(make-obsolete-variable 'w32-list-proportional-fonts "no longer used." "23.1") - (unless (eq system-type 'cygwin) (defcustom w32-allow-system-shell nil "Disable startup warning when using \"system\" shells." diff --git a/lisp/wdired.el b/lisp/wdired.el index cf73b7bf249..44f083bb7fb 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -240,7 +240,7 @@ directories to reflect your edits. See `wdired-mode'." (interactive) - (unless (eq major-mode 'dired-mode) + (unless (derived-mode-p 'dired-mode) (error "Not a Dired buffer")) (set (make-local-variable 'wdired-old-content) (buffer-substring (point-min) (point-max))) @@ -255,6 +255,7 @@ See `wdired-mode'." (setq buffer-read-only nil) (dired-unadvertise default-directory) (add-hook 'kill-buffer-hook 'wdired-check-kill-buffer nil t) + (add-hook 'after-change-functions 'wdired--restore-dired-filename-prop nil t) (setq major-mode 'wdired-mode) (setq mode-name "Editable Dired") (setq revert-buffer-function 'wdired-revert) @@ -363,6 +364,7 @@ non-nil means return old filename." (setq mode-name "Dired") (dired-advertise) (remove-hook 'kill-buffer-hook 'wdired-check-kill-buffer t) + (remove-hook 'after-change-functions 'wdired--restore-dired-filename-prop t) (set (make-local-variable 'revert-buffer-function) 'dired-revert)) @@ -381,7 +383,6 @@ non-nil means return old filename." (defun wdired-finish-edit () "Actually rename files based on your editing in the Dired buffer." (interactive) - (wdired-change-to-dired-mode) (let ((changes nil) (errors 0) files-deleted @@ -423,6 +424,11 @@ non-nil means return old filename." (forward-line -1))) (when files-renamed (setq errors (+ errors (wdired-do-renames files-renamed)))) + ;; We have to be in wdired-mode when wdired-do-renames is executed + ;; so that wdired--restore-dired-filename-prop runs, but we have + ;; to change back to dired-mode before reverting the buffer to + ;; avoid using wdired-revert, which changes back to wdired-mode. + (wdired-change-to-dired-mode) (if changes (progn ;; If we are displaying a single file (rather than the @@ -543,39 +549,25 @@ and proceed depending on the answer." (goto-char (point-max)) (forward-line -1) (let ((done nil) - (failed t) + (failed t) curr-filename) (while (and (not done) (not (bobp))) (setq curr-filename (wdired-get-filename nil t)) (if (equal curr-filename filename-ori) - (unwind-protect - (progn - (setq done t) - (let ((inhibit-read-only t)) - ;; Remove dired-filename text property in order to - ;; find filename-new when it only partially - ;; replaces filename-ori (bug#32173); the text - ;; property is added again when renaming succeeds. - (remove-text-properties - (line-beginning-position) (line-end-position) - '(dired-filename nil)) - (dired-move-to-filename) - (search-forward (wdired-get-filename t) nil t) - (replace-match (file-name-nondirectory filename-ori) t t)) - (dired-do-create-files-regexp - (function dired-rename-file) - "Move" 1 ".*" filename-new nil t) - (setq failed nil)) - ;; If user quits before renaming succeeds, restore the - ;; dired-filename text property. - (when failed - (beginning-of-line) - (let ((beg (re-search-forward - directory-listing-before-filename-regexp - (line-end-position) t)) - (end (dired-move-to-end-of-filename)) - (inhibit-read-only t)) - (add-text-properties beg end '(dired-filename t))))) + (unwind-protect + (progn + (setq done t) + (let ((inhibit-read-only t)) + (dired-move-to-filename) + (search-forward (wdired-get-filename t) nil t) + (replace-match (file-name-nondirectory filename-ori) t t)) + (dired-do-create-files-regexp + (function dired-rename-file) + "Move" 1 ".*" filename-new nil t) + (setq failed nil)) + ;; If user types C-g when prompted to change the file + ;; name, make sure we return to dired-mode. + (when failed (wdired-change-to-dired-mode))) (forward-line -1)))))) ;; marks a list of files for deletion @@ -606,6 +598,41 @@ Optional arguments are ignored." (not (y-or-n-p "Buffer changed. Discard changes and kill buffer? "))) (error "Error"))) +;; Added to after-change-functions in wdired-change-to-wdired-mode to +;; ensure that, on editing a file name, new characters get the +;; dired-filename text property, which allows functions that look for +;; this property (e.g. dired-isearch-filenames) to work in wdired-mode +;; and also avoids an error with non-nil wdired-use-interactive-rename +;; (bug#32173). +(defun wdired--restore-dired-filename-prop (beg end _len) + (save-match-data + (save-excursion + (let ((lep (line-end-position))) + (beginning-of-line) + (when (re-search-forward + directory-listing-before-filename-regexp lep t) + (setq beg (point) + end (if (or + ;; If the file is a symlink, put the + ;; dired-filename property only on the link + ;; name. (Using (file-symlink-p + ;; (dired-get-filename)) fails in + ;; wdired-mode, bug#32673.) + (and (re-search-backward + dired-permission-flags-regexp nil t) + (looking-at "l") + (search-forward " -> " lep t)) + ;; When dired-listing-switches includes "F" + ;; or "classify", don't treat appended + ;; indicator characters as part of the file + ;; name (bug#34915). + (and (dired-check-switches dired-actual-switches + "F" "classify") + (re-search-forward "[*/@|=>]$" lep t))) + (goto-char (match-beginning 0)) + lep)) + (put-text-property beg end 'dired-filename t)))))) + (defun wdired-next-line (arg) "Move down lines then position at filename or the current column. See `wdired-use-dired-vertical-movement'. Optional prefix ARG @@ -650,8 +677,7 @@ says how many lines to move; default is one line." 'rear-nonsticky '(read-only)) (put-text-property (match-beginning 1) (match-end 1) 'read-only nil))) - (forward-line) - (beginning-of-line))))) + (forward-line))))) (defun wdired-get-previous-link (&optional old move) @@ -886,9 +912,4 @@ Like original function but it skips read-only words." (cons changes errors))) (provide 'wdired) - -;; Local Variables: -;; byte-compile-dynamic: t -;; End: - ;;; wdired.el ends here diff --git a/lisp/whitespace.el b/lisp/whitespace.el index 79bc5c88348..d0368b54a80 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -2,8 +2,7 @@ ;; Copyright (C) 2000-2019 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: data, wp ;; Version: 13.2.2 ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre @@ -924,11 +923,6 @@ Any other value is treated as nil." ;;;###autoload (define-minor-mode whitespace-mode "Toggle whitespace visualization (Whitespace mode). -With a prefix argument ARG, enable Whitespace mode if ARG is -positive, and disable it otherwise. - -If called from Lisp, also enables the mode if ARG is omitted or nil, -and toggles it if ARG is `toggle'. See also `whitespace-style', `whitespace-newline' and `whitespace-display-mappings'." @@ -949,11 +943,6 @@ See also `whitespace-style', `whitespace-newline' and ;;;###autoload (define-minor-mode whitespace-newline-mode "Toggle newline visualization (Whitespace Newline mode). -With a prefix argument ARG, enable Whitespace Newline mode if ARG -is positive, and disable it otherwise. - -If called from Lisp, also enables the mode if ARG is omitted or nil, -and toggles it if ARG is `toggle'. Use `whitespace-newline-mode' only for NEWLINE visualization exclusively. For other visualizations, including NEWLINE @@ -979,11 +968,6 @@ See also `whitespace-newline' and `whitespace-display-mappings'." ;;;###autoload (define-minor-mode global-whitespace-mode "Toggle whitespace visualization globally (Global Whitespace mode). -With a prefix argument ARG, enable Global Whitespace mode if ARG -is positive, and disable it otherwise. - -If called from Lisp, also enables the mode if ARG is omitted or nil, -and toggles it if ARG is `toggle'. See also `whitespace-style', `whitespace-newline' and `whitespace-display-mappings'." @@ -1040,11 +1024,6 @@ This variable is normally modified via `add-function'.") ;;;###autoload (define-minor-mode global-whitespace-newline-mode "Toggle global newline visualization (Global Whitespace Newline mode). -With a prefix argument ARG, enable Global Whitespace Newline mode -if ARG is positive, and disable it otherwise. - -If called from Lisp, also enables the mode if ARG is omitted or nil, -and toggles it if ARG is `toggle'. Use `global-whitespace-newline-mode' only for NEWLINE visualization exclusively. For other visualizations, including @@ -1728,7 +1707,7 @@ cleaning up these problems." (setq has-bogus (memq (car option) style))) t))) whitespace-report-list))) - (when (pcase report-if-bogus (`nil t) (`never nil) (_ has-bogus)) + (when (pcase report-if-bogus ('nil t) ('never nil) (_ has-bogus)) (whitespace-kill-buffer whitespace-report-buffer-name) ;; `indent-tabs-mode' may be local to current buffer ;; `tab-width' may be local to current buffer diff --git a/lisp/wid-browse.el b/lisp/wid-browse.el index 0094152ddfe..dbc41009c77 100644 --- a/lisp/wid-browse.el +++ b/lisp/wid-browse.el @@ -269,10 +269,7 @@ VALUE is assumed to be a list of widgets." ;;;###autoload (define-minor-mode widget-minor-mode - "Minor mode for traversing widgets. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "Minor mode for traversing widgets." :lighter " Widget") ;;; The End: diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 52c0b5b74d2..dd03a24bb36 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1,4 +1,4 @@ -;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t; lexical-binding:t -*- +;;; wid-edit.el --- Functions for creating and using widgets -*- lexical-binding:t -*- ;; ;; Copyright (C) 1996-1997, 1999-2019 Free Software Foundation, Inc. ;; @@ -56,6 +56,7 @@ ;;; Code: (require 'cl-lib) +(eval-when-compile (require 'subr-x)) ; when-let ;;; Compatibility. @@ -252,7 +253,10 @@ minibuffer." (define-key map [?\M--] 'negative-argument) (save-window-excursion (let ((buf (get-buffer " widget-choose"))) - (fit-window-to-buffer (display-buffer buf)) + (display-buffer buf + '(display-buffer-in-direction + (direction . bottom) + (window-height . fit-window-to-buffer))) (let ((cursor-in-echo-area t) (arg 1)) (while (not value) @@ -828,6 +832,13 @@ button end points." (delete-overlay field)) (mapc 'widget-leave-text (widget-get widget :children)))) +(defun widget-text (widget) + "Get the text representation of the widget." + (when-let ((from (widget-get widget :from)) + (to (widget-get widget :to))) + (when (eq (marker-buffer from) (marker-buffer to)) ; is this check necessary? + (buffer-substring-no-properties from to)))) + ;;; Keymap and Commands. ;; This alias exists only so that one can choose in doc-strings (e.g. @@ -1029,9 +1040,11 @@ POS defaults to the value of (point)." "If non-nil, use overlay change functions to tab around in the buffer. This is much faster.") -(defun widget-move (arg) +(defun widget-move (arg &optional suppress-echo) "Move point to the ARG next field or button. -ARG may be negative to move backward." +ARG may be negative to move backward. +When the second optional argument is non-nil, +nothing is shown in the echo area." (or (bobp) (> arg 0) (backward-char)) (let ((wrapped 0) (number arg) @@ -1073,7 +1086,8 @@ ARG may be negative to move backward." (while (eq (widget-tabable-at) new) (backward-char))) (forward-char)) - (widget-echo-help (point)) + (unless suppress-echo + (widget-echo-help (point))) (run-hooks 'widget-move-hook)) (defun widget-forward (arg) @@ -1163,8 +1177,9 @@ When not inside a field, signal an error." (defun widget-at (&optional pos) "The button or field at POS (default, point)." - (or (get-char-property (or pos (point)) 'button) - (widget-field-at pos))) + (let ((widget (or (get-char-property (or pos (point)) 'button) + (widget-field-at pos)))) + (and (widgetp widget) widget))) ;;;###autoload (defun widget-setup () @@ -1993,6 +2008,7 @@ But if NO-TRUNCATE is non-nil, include them." (define-widget 'text 'editable-field "A multiline text area." + :format "%{%t%}: %v" :keymap widget-text-keymap) ;;; The `menu-choice' Widget. diff --git a/lisp/widget.el b/lisp/widget.el index 4028fa1a20e..2b4c91668ee 100644 --- a/lisp/widget.el +++ b/lisp/widget.el @@ -44,7 +44,8 @@ ;; (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")) + nil) ;;(define-widget-keywords :documentation-indent ;; :complete-function :complete :button-overlay diff --git a/lisp/windmove.el b/lisp/windmove.el index cf7b65a6ed7..ab47565dfae 100644 --- a/lisp/windmove.el +++ b/lisp/windmove.el @@ -1,4 +1,4 @@ -;;; windmove.el --- directional window-selection routines +;;; windmove.el --- directional window-selection routines -*- lexical-binding:t -*- ;; ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. ;; @@ -149,6 +149,15 @@ is inactive." :type 'boolean :group 'windmove) +(defcustom windmove-create-window nil + "Whether movement off the edge of the frame creates a new window. +If this variable is set to t, moving left from the leftmost window in +a frame will create a new window on the left, and similarly for the other +directions." + :type 'boolean + :group 'windmove + :version "27.1") + ;; If your Emacs sometimes places an empty column between two adjacent ;; windows, you may wish to set this delta to 2. (defcustom windmove-window-distance-delta 1 @@ -159,8 +168,7 @@ placement bugs in old versions of Emacs." :type 'number :group 'windmove) - - + ;; Implementation overview: ;; ;; The conceptual framework behind this code is all fairly simple. We @@ -459,25 +467,28 @@ movement is relative to." windmove-window-distance-delta))) ; (x, y1+d-1) (t (error "Invalid direction of movement: %s" dir))))) + ;; Rewritten on 2013-12-13 using `window-in-direction'. After the ;; pixelwise change the old approach didn't work any more. martin (defun windmove-find-other-window (dir &optional arg window) "Return the window object in direction DIR. DIR, ARG, and WINDOW are handled as by `windmove-other-window-loc'." - (window-in-direction - (cond - ((eq dir 'up) 'above) - ((eq dir 'down) 'below) - (t dir)) - window nil arg windmove-wrap-around t)) + (window-in-direction dir window nil arg windmove-wrap-around t)) ;; Selects the window that's hopefully at the location returned by ;; `windmove-other-window-loc', or screams if there's no window there. (defun windmove-do-window-select (dir &optional arg window) "Move to the window at direction DIR. DIR, ARG, and WINDOW are handled as by `windmove-other-window-loc'. -If no window is at direction DIR, an error is signaled." +If no window is at direction DIR, an error is signaled. +If `windmove-create-window' is non-nil, try to create a new window +in direction DIR instead." (let ((other-window (windmove-find-other-window dir arg window))) + (when (and windmove-create-window + (or (null other-window) + (and (window-minibuffer-p other-window) + (not (minibuffer-window-active-p other-window))))) + (setq other-window (split-window window nil dir))) (cond ((null other-window) (user-error "No window %s from selected window" dir)) ((and (window-minibuffer-p other-window) @@ -486,9 +497,9 @@ If no window is at direction DIR, an error is signaled." (t (select-window other-window))))) - -;;; end-user functions -;; these are all simple interactive wrappers to + +;;; End-user functions +;; These are all simple interactive wrappers to ;; `windmove-do-window-select', meant to be bound to keys. ;;;###autoload @@ -498,9 +509,10 @@ With no prefix argument, or with prefix argument equal to zero, \"left\" is relative to the position of point in the window; otherwise it is relative to the top edge (for positive ARG) or the bottom edge \(for negative ARG) of the current window. -If no window is at the desired location, an error is signaled." +If no window is at the desired location, an error is signaled +unless `windmove-create-window' is non-nil and a new window is created." (interactive "P") - (windmove-do-window-select 'left arg)) + (windmove-do-window-select 'left (and arg (prefix-numeric-value arg)))) ;;;###autoload (defun windmove-up (&optional arg) @@ -509,9 +521,10 @@ With no prefix argument, or with prefix argument equal to zero, \"up\" is relative to the position of point in the window; otherwise it is relative to the left edge (for positive ARG) or the right edge (for negative ARG) of the current window. -If no window is at the desired location, an error is signaled." +If no window is at the desired location, an error is signaled +unless `windmove-create-window' is non-nil and a new window is created." (interactive "P") - (windmove-do-window-select 'up arg)) + (windmove-do-window-select 'up (and arg (prefix-numeric-value arg)))) ;;;###autoload (defun windmove-right (&optional arg) @@ -520,9 +533,10 @@ With no prefix argument, or with prefix argument equal to zero, \"right\" is relative to the position of point in the window; otherwise it is relative to the top edge (for positive ARG) or the bottom edge (for negative ARG) of the current window. -If no window is at the desired location, an error is signaled." +If no window is at the desired location, an error is signaled +unless `windmove-create-window' is non-nil and a new window is created." (interactive "P") - (windmove-do-window-select 'right arg)) + (windmove-do-window-select 'right (and arg (prefix-numeric-value arg)))) ;;;###autoload (defun windmove-down (&optional arg) @@ -531,9 +545,10 @@ With no prefix argument, or with prefix argument equal to zero, \"down\" is relative to the position of point in the window; otherwise it is relative to the left edge (for positive ARG) or the right edge \(for negative ARG) of the current window. -If no window is at the desired location, an error is signaled." +If no window is at the desired location, an error is signaled +unless `windmove-create-window' is non-nil and a new window is created." (interactive "P") - (windmove-do-window-select 'down arg)) + (windmove-do-window-select 'down (and arg (prefix-numeric-value arg)))) ;;; set up keybindings @@ -543,18 +558,255 @@ If no window is at the desired location, an error is signaled." ;; probably want to use different bindings in that case. ;;;###autoload -(defun windmove-default-keybindings (&optional modifier) +(defun windmove-default-keybindings (&optional modifiers) "Set up keybindings for `windmove'. -Keybindings are of the form MODIFIER-{left,right,up,down}. -Default MODIFIER is `shift'." +Keybindings are of the form MODIFIERS-{left,right,up,down}, +where MODIFIERS is either a list of modifiers or a single modifier. +Default value of MODIFIERS is `shift'." + (interactive) + (unless modifiers (setq modifiers 'shift)) + (unless (listp modifiers) (setq modifiers (list modifiers))) + (global-set-key (vector (append modifiers '(left))) 'windmove-left) + (global-set-key (vector (append modifiers '(right))) 'windmove-right) + (global-set-key (vector (append modifiers '(up))) 'windmove-up) + (global-set-key (vector (append modifiers '(down))) 'windmove-down)) + + +;;; Directional window display and selection + +(defcustom windmove-display-no-select nil + "Whether the window should be selected after displaying the buffer in it." + :type 'boolean + :group 'windmove + :version "27.1") + +(defun windmove-display-in-direction (dir &optional arg) + "Display the next buffer in the window at direction DIR. +The next buffer is the buffer displayed by the next command invoked +immediately after this command (ignoring reading from the minibuffer). +Create a new window if there is no window in that direction. +By default, select the window with a displayed buffer. +If prefix ARG is `C-u', reselect a previously selected window. +If `windmove-display-no-select' is non-nil, this command doesn't +select the window with a displayed buffer, and the meaning of +the prefix argument is reversed. +When `switch-to-buffer-obey-display-actions' is non-nil, +`switch-to-buffer' commands are also supported." + (let* ((no-select (not (eq (consp arg) windmove-display-no-select))) ; xor + (old-window (or (minibuffer-selected-window) (selected-window))) + (new-window) + (minibuffer-depth (minibuffer-depth)) + (action (lambda (buffer alist) + (unless (> (minibuffer-depth) minibuffer-depth) + (let ((window (if (eq dir 'same-window) + (selected-window) + (window-in-direction + dir nil nil + (and arg (prefix-numeric-value arg)) + windmove-wrap-around))) + (type 'reuse)) + (unless window + (setq window (split-window nil nil dir) type 'window)) + (setq new-window (window--display-buffer buffer window + type alist)))))) + (command this-command) + (clearfun (make-symbol "clear-display-buffer-overriding-action")) + (exitfun + (lambda () + (setq display-buffer-overriding-action + (delq action display-buffer-overriding-action)) + (when (window-live-p (if no-select old-window new-window)) + (select-window (if no-select old-window new-window))) + (remove-hook 'post-command-hook clearfun)))) + (fset clearfun + (lambda () + (unless (or + ;; Remove the hook immediately + ;; after exiting the minibuffer. + (> (minibuffer-depth) minibuffer-depth) + ;; But don't remove immediately after + ;; adding the hook by the same command below. + (eq this-command command)) + (funcall exitfun)))) + (add-hook 'post-command-hook clearfun) + (push action display-buffer-overriding-action) + (message "[display-%s]" dir))) + +;;;###autoload +(defun windmove-display-left (&optional arg) + "Display the next buffer in window to the left of the current one. +See the logic of the prefix ARG in `windmove-display-in-direction'." + (interactive "P") + (windmove-display-in-direction 'left arg)) + +;;;###autoload +(defun windmove-display-up (&optional arg) + "Display the next buffer in window above the current one. +See the logic of the prefix ARG in `windmove-display-in-direction'." + (interactive "P") + (windmove-display-in-direction 'up arg)) + +;;;###autoload +(defun windmove-display-right (&optional arg) + "Display the next buffer in window to the right of the current one. +See the logic of the prefix ARG in `windmove-display-in-direction'." + (interactive "P") + (windmove-display-in-direction 'right arg)) + +;;;###autoload +(defun windmove-display-down (&optional arg) + "Display the next buffer in window below the current one. +See the logic of the prefix ARG in `windmove-display-in-direction'." + (interactive "P") + (windmove-display-in-direction 'down arg)) + +;;;###autoload +(defun windmove-display-same-window (&optional arg) + "Display the next buffer in the same window." + (interactive "P") + (windmove-display-in-direction 'same-window arg)) + +;;;###autoload +(defun windmove-display-default-keybindings (&optional modifiers) + "Set up keybindings for directional buffer display. +Keys are bound to commands that display the next buffer in the specified +direction. Keybindings are of the form MODIFIERS-{left,right,up,down}, +where MODIFIERS is either a list of modifiers or a single modifier. +Default value of MODIFIERS is `shift-meta'." + (interactive) + (unless modifiers (setq modifiers '(shift meta))) + (unless (listp modifiers) (setq modifiers (list modifiers))) + (global-set-key (vector (append modifiers '(left))) 'windmove-display-left) + (global-set-key (vector (append modifiers '(right))) 'windmove-display-right) + (global-set-key (vector (append modifiers '(up))) 'windmove-display-up) + (global-set-key (vector (append modifiers '(down))) 'windmove-display-down) + (global-set-key (vector (append modifiers '(?0))) 'windmove-display-same-window)) + + +;;; Directional window deletion + +(defun windmove-delete-in-direction (dir &optional arg) + "Delete the window at direction DIR. +If prefix ARG is `\\[universal-argument]', also kill the buffer in that window. +With `M-0' prefix, delete the selected window and +select the window at direction DIR. +When `windmove-wrap-around' is non-nil, takes the window +from the opposite side of the frame." + (let ((other-window (window-in-direction dir nil nil arg + windmove-wrap-around t))) + (cond ((null other-window) + (user-error "No window %s from selected window" dir)) + (t + (when (equal arg '(4)) + (kill-buffer (window-buffer other-window))) + (if (not (equal arg 0)) + (delete-window other-window) + (delete-window (selected-window)) + (select-window other-window)))))) + +;;;###autoload +(defun windmove-delete-left (&optional arg) + "Delete the window to the left of the current one. +If prefix ARG is `C-u', delete the selected window and +select the window that was to the left of the current one." + (interactive "P") + (windmove-delete-in-direction 'left arg)) + +;;;###autoload +(defun windmove-delete-up (&optional arg) + "Delete the window above the current one. +If prefix ARG is `C-u', delete the selected window and +select the window that was above the current one." + (interactive "P") + (windmove-delete-in-direction 'up arg)) + +;;;###autoload +(defun windmove-delete-right (&optional arg) + "Delete the window to the right of the current one. +If prefix ARG is `C-u', delete the selected window and +select the window that was to the right of the current one." + (interactive "P") + (windmove-delete-in-direction 'right arg)) + +;;;###autoload +(defun windmove-delete-down (&optional arg) + "Delete the window below the current one. +If prefix ARG is `C-u', delete the selected window and +select the window that was below the current one." + (interactive "P") + (windmove-delete-in-direction 'down arg)) + +;;;###autoload +(defun windmove-delete-default-keybindings (&optional prefix modifiers) + "Set up keybindings for directional window deletion. +Keys are bound to commands that delete windows in the specified +direction. Keybindings are of the form PREFIX MODIFIERS-{left,right,up,down}, +where PREFIX is a prefix key and MODIFIERS is either a list of modifiers or +a single modifier. Default value of PREFIX is `C-x' and MODIFIERS is `shift'." (interactive) - (unless modifier (setq modifier 'shift)) - (global-set-key (vector (list modifier 'left)) 'windmove-left) - (global-set-key (vector (list modifier 'right)) 'windmove-right) - (global-set-key (vector (list modifier 'up)) 'windmove-up) - (global-set-key (vector (list modifier 'down)) 'windmove-down)) + (unless prefix (setq prefix '(?\C-x))) + (unless (listp prefix) (setq prefix (list prefix))) + (unless modifiers (setq modifiers '(shift))) + (unless (listp modifiers) (setq modifiers (list modifiers))) + (global-set-key (vector prefix (append modifiers '(left))) 'windmove-delete-left) + (global-set-key (vector prefix (append modifiers '(right))) 'windmove-delete-right) + (global-set-key (vector prefix (append modifiers '(up))) 'windmove-delete-up) + (global-set-key (vector prefix (append modifiers '(down))) 'windmove-delete-down)) + + +;;; Directional window swap states + +(defun windmove-swap-states-in-direction (dir) + "Swap the states of the selected window and the window at direction DIR. +When `windmove-wrap-around' is non-nil, takes the window +from the opposite side of the frame." + (let ((other-window (window-in-direction dir nil nil nil + windmove-wrap-around t))) + (cond ((or (null other-window) (window-minibuffer-p other-window)) + (user-error "No window %s from selected window" dir)) + (t + (window-swap-states nil other-window))))) + +;;;###autoload +(defun windmove-swap-states-left () + "Swap the states with the window on the left from the current one." + (interactive) + (windmove-swap-states-in-direction 'left)) + +;;;###autoload +(defun windmove-swap-states-up () + "Swap the states with the window above from the current one." + (interactive) + (windmove-swap-states-in-direction 'up)) +;;;###autoload +(defun windmove-swap-states-down () + "Swap the states with the window below from the current one." + (interactive) + (windmove-swap-states-in-direction 'down)) +;;;###autoload +(defun windmove-swap-states-right () + "Swap the states with the window on the right from the current one." + (interactive) + (windmove-swap-states-in-direction 'right)) + +;;;###autoload +(defun windmove-swap-states-default-keybindings (&optional modifiers) + "Set up keybindings for directional window swap states. +Keys are bound to commands that swap the states of the selected window +with the window in the specified direction. Keybindings are of the form +MODIFIERS-{left,right,up,down}, where MODIFIERS is either a list of modifiers +or a single modifier. Default value of MODIFIERS is `shift-super'." + (interactive) + (unless modifiers (setq modifiers '(shift super))) + (unless (listp modifiers) (setq modifiers (list modifiers))) + (global-set-key (vector (append modifiers '(left))) 'windmove-swap-states-left) + (global-set-key (vector (append modifiers '(right))) 'windmove-swap-states-right) + (global-set-key (vector (append modifiers '(up))) 'windmove-swap-states-up) + (global-set-key (vector (append modifiers '(down))) 'windmove-swap-states-down)) + + (provide 'windmove) ;;; windmove.el ends here diff --git a/lisp/window.el b/lisp/window.el index a86c2f96bdc..8b12c4381f4 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -181,7 +181,7 @@ This construct is similar to `with-output-to-temp-buffer' but, neither runs `temp-buffer-setup-hook' which usually puts the buffer in Help mode, nor `temp-buffer-show-function' (the ACTION argument replaces this)." - (declare (debug t)) + (declare (debug t) (indent 3)) (let ((buffer (make-symbol "buffer")) (window (make-symbol "window")) (value (make-symbol "value"))) @@ -204,7 +204,7 @@ argument replaces this)." This construct is like `with-temp-buffer-window' but unlike that, makes the buffer specified by BUFFER-OR-NAME current for running BODY." - (declare (debug t)) + (declare (debug t) (indent 3)) (let ((buffer (make-symbol "buffer")) (window (make-symbol "window")) (value (make-symbol "value"))) @@ -226,7 +226,7 @@ BODY." "Show a buffer BUFFER-OR-NAME and evaluate BODY in that buffer. This construct is like `with-current-buffer-window' but unlike that, displays the buffer specified by BUFFER-OR-NAME before running BODY." - (declare (debug t)) + (declare (debug t) (indent 3)) (let ((buffer (make-symbol "buffer")) (window (make-symbol "window")) (value (make-symbol "value"))) @@ -434,7 +434,8 @@ shorter, explicitly specify the SIZE argument of that function." (defun window-min-pixel-height (&optional window) "Return the minimum pixel height of window WINDOW." - (* (max window-min-height window-safe-min-height) + (* (max (if (window-minibuffer-p window) 1 window-min-height) + window-safe-min-height) (frame-char-size window))) ;; This must go to C, finally (or get removed). @@ -509,11 +510,14 @@ child if WINDOW is a horizontal combination." (window-left-child window) (window-top-child window))) -(defun window-combinations (window &optional horizontal) +(defun window-combinations (window &optional horizontal ignore-fixed) "Return largest number of windows vertically arranged within WINDOW. WINDOW must be a valid window and defaults to the selected one. If HORIZONTAL is non-nil, return the largest number of -windows horizontally arranged within WINDOW." +windows horizontally arranged within WINDOW. + +Optional argument IGNORE-FIXED, if non-nil, means to ignore +fixed-size windows in the calculation." (setq window (window-normalize-window window)) (cond ((window-live-p window) @@ -527,9 +531,10 @@ windows horizontally arranged within WINDOW." (let ((child (window-child window)) (count 0)) (while child - (setq count - (+ (window-combinations child horizontal) - count)) + (unless (and ignore-fixed (window-size-fixed-p child horizontal)) + (setq count + (+ (window-combinations child horizontal ignore-fixed) + count))) (setq child (window-right child))) count)) (t @@ -538,9 +543,10 @@ windows horizontally arranged within WINDOW." (let ((child (window-child window)) (count 1)) (while child - (setq count - (max (window-combinations child horizontal) - count)) + (unless (and ignore-fixed (window-size-fixed-p child horizontal)) + (setq count + (max (window-combinations child horizontal ignore-fixed) + count))) (setq child (window-right child))) count)))) @@ -571,23 +577,25 @@ FRAME. Optional argument MINIBUF t means run FUN on FRAME's minibuffer window even if it isn't active. MINIBUF nil or omitted means run -FUN on FRAME's minibuffer window only if it's active. In both -cases the minibuffer window must be part of FRAME. MINIBUF +FUN on FRAME's minibuffer window only if it's active. In either +case the minibuffer window must be part of FRAME. MINIBUF neither nil nor t means never run FUN on the minibuffer window. This function performs a pre-order, depth-first traversal of the window tree. If FUN changes the window tree, the result is unpredictable." - (setq frame (window-normalize-frame frame)) - (walk-window-tree-1 fun (frame-root-window frame) any) - (when (memq minibuf '(nil t)) + (let ((root (frame-root-window frame)) + (mini (minibuffer-window frame))) + (setq frame (window-normalize-frame frame)) + (unless (eq root mini) + (walk-window-tree-1 fun root any)) ;; Run FUN on FRAME's minibuffer window if requested. - (let ((minibuffer-window (minibuffer-window frame))) - (when (and (window-live-p minibuffer-window) - (eq (window-frame minibuffer-window) frame) - (or (eq minibuf t) - (minibuffer-window-active-p minibuffer-window))) - (funcall fun minibuffer-window))))) + (when (and (window-live-p mini) + (eq (window-frame mini) frame) + (or (eq minibuf t) + (and (not minibuf) + (minibuffer-window-active-p mini)))) + (funcall fun mini)))) (defun walk-window-subtree (fun &optional window any) "Run function FUN on the subtree of windows rooted at WINDOW. @@ -700,8 +708,7 @@ failed." (set-window-parameter window 'window-atom 'main)) (set-window-parameter new 'window-atom side) ;; Display BUFFER in NEW and return NEW. - (window--display-buffer - buffer new 'window alist display-buffer-mark-dedicated)))) + (window--display-buffer buffer new 'window alist)))) (defun window--atom-check-1 (window) "Subroutine of `window--atom-check'." @@ -958,7 +965,11 @@ and may be called only if no window on SIDE exists yet." ;; window and not make a new parent window unless needed. (window-combination-resize 'side) (window-combination-limit nil) - (window (split-window-no-error next-to nil on-side))) + (window (split-window-no-error next-to nil on-side)) + (alist (if (assq 'dedicated alist) + alist + (cons `(dedicated . ,(or display-buffer-mark-dedicated 'side)) + alist)))) (when window ;; Initialize `window-side' parameter of new window to SIDE and ;; make that parameter persistent. @@ -985,7 +996,7 @@ and may be called only if no window on SIDE exists yet." (with-current-buffer buffer (setq window--sides-shown t)) ;; Install BUFFER in new window and return WINDOW. - (window--display-buffer buffer window 'window alist 'side)))) + (window--display-buffer buffer window 'window alist)))) (defun display-buffer-in-side-window (buffer alist) "Display BUFFER in a side window of the selected frame. @@ -1019,10 +1030,7 @@ nor installs any other window parameters unless they have been explicitly provided via a `window-parameters' entry in ALIST." (let* ((side (or (cdr (assq 'side alist)) 'bottom)) (slot (or (cdr (assq 'slot alist)) 0)) - (left-or-right (memq side '(left right))) - ;; Softly dedicate window to BUFFER unless - ;; `display-buffer-mark-dedicated' already asks for it. - (dedicated (or display-buffer-mark-dedicated 'side))) + (left-or-right (memq side '(left right)))) (cond ((not (memq side '(top bottom left right))) (error "Invalid side %s specified" side)) @@ -1055,7 +1063,11 @@ explicitly provided via a `window-parameters' entry in ALIST." ((eq side 'bottom) 3)) window-sides-slots)) (window--sides-inhibit-check t) - window this-window this-slot prev-window next-window + (alist (if (assq 'dedicated alist) + alist + (cons `(dedicated . ,(or display-buffer-mark-dedicated 'side)) + alist))) + window this-window this-slot prev-window next-window best-window best-slot abs-slot) (cond @@ -1113,8 +1125,7 @@ explicitly provided via a `window-parameters' entry in ALIST." ;; Reuse `this-window'. (with-current-buffer buffer (setq window--sides-shown t)) - (window--display-buffer - buffer this-window 'reuse alist dedicated)) + (window--display-buffer buffer this-window 'reuse alist)) (and (or (not max-slots) (< slots max-slots)) (or (and next-window ;; Make new window before `next-window'. @@ -1131,8 +1142,7 @@ explicitly provided via a `window-parameters' entry in ALIST." (set-window-parameter window 'window-slot slot) (with-current-buffer buffer (setq window--sides-shown t)) - (window--display-buffer - buffer window 'window alist dedicated)) + (window--display-buffer buffer window 'window alist)) (and best-window ;; Reuse `best-window'. (progn @@ -1141,7 +1151,7 @@ explicitly provided via a `window-parameters' entry in ALIST." (with-current-buffer buffer (setq window--sides-shown t)) (window--display-buffer - buffer best-window 'reuse alist dedicated))))))))) + buffer best-window 'reuse alist))))))))) (defun window-toggle-side-windows (&optional frame) "Toggle display of side windows on specified FRAME. @@ -1594,8 +1604,6 @@ return the minimum pixel-size of WINDOW." value) (with-current-buffer (window-buffer window) (cond - ((window-minibuffer-p window) - (if pixelwise (frame-char-height (window-frame window)) 1)) ((window-size-fixed-p window horizontal ignore) ;; The minimum size of a fixed size window is its size. (window-size window horizontal pixelwise)) @@ -2041,6 +2049,8 @@ doc-string of `window-resizable'." ;; Aliases of functions defined in window.c. (defalias 'window-height 'window-total-height) (defalias 'window-width 'window-body-width) +(defalias 'window-pixel-width-before-size-change 'window-old-pixel-width) +(defalias 'window-pixel-height-before-size-change 'window-old-pixel-height) (defun window-full-height-p (&optional window) "Return t if WINDOW is as high as its containing frame. @@ -2262,14 +2272,14 @@ SIDE can be any of the symbols `left', `top', `right' or "Return window in DIRECTION as seen from WINDOW. More precisely, return the nearest window in direction DIRECTION as seen from the position of `window-point' in window WINDOW. -DIRECTION must be one of `above', `below', `left' or `right'. +DIRECTION should be one of 'above', 'below', 'left' or 'right'. WINDOW must be a live window and defaults to the selected one. -Do not return a window whose `no-other-window' parameter is -non-nil. If the nearest window's `no-other-window' parameter is +Do not return a window whose 'no-other-window' parameter is +non-nil. If the nearest window's 'no-other-window' parameter is non-nil, try to find another window in the indicated direction. If, however, the optional argument IGNORE is non-nil, return that -window even if its `no-other-window' parameter is non-nil. +window even if its 'no-other-window' parameter is non-nil. Optional argument SIGN a negative number means to use the right or bottom edge of WINDOW as reference position instead of @@ -2278,7 +2288,7 @@ top edge of WINDOW as reference position. Optional argument WRAP non-nil means to wrap DIRECTION around frame borders. This means to return for WINDOW at the top of the -frame and DIRECTION `above' the minibuffer window if the frame +frame and DIRECTION 'above' the minibuffer window if the frame has one, and a window at the bottom of the frame otherwise. Optional argument MINI nil means to return the minibuffer window @@ -2288,8 +2298,13 @@ if WRAP is non-nil, always act as if MINI were nil. Return nil if no suitable window can be found." (setq window (window-normalize-window window t)) - (unless (memq direction '(above below left right)) - (error "Wrong direction %s" direction)) + (cond + ((eq direction 'up) + (setq direction 'above)) + ((eq direction 'down) + (setq direction 'below)) + ((not (memq direction '(above below left right))) + (error "Wrong direction %s" direction))) (let* ((frame (window-frame window)) (hor (memq direction '(left right))) (first (if hor @@ -2723,49 +2738,50 @@ windows." (when (window-right window) (window--resize-reset-1 (window-right window) horizontal))) +;; The following is the internal function used when resizing mini +;; windows "manually", for example, when dragging a divider between +;; root and mini window. The routines for automatic minibuffer window +;; resizing call `window--resize-root-window-vertically' instead. (defun window--resize-mini-window (window delta) - "Resize minibuffer window WINDOW by DELTA pixels. + "Change height of mini window WINDOW by DELTA pixels. If WINDOW cannot be resized by DELTA pixels make it as large (or as small) as possible, but don't signal an error." (when (window-minibuffer-p window) (let* ((frame (window-frame window)) (root (frame-root-window frame)) (height (window-pixel-height window)) - (min-delta - (- (window-pixel-height root) - (window-min-size root nil nil t)))) - ;; Sanitize DELTA. - (cond - ((<= (+ height delta) 0) - (setq delta (- (frame-char-height (window-frame window)) height))) - ((> delta min-delta) - (setq delta min-delta))) + (min-height (+ (frame-char-height frame) + (- (window-pixel-height window) + (window-body-height window t)))) + (max-delta (- (window-pixel-height root) + (window-min-size root nil nil t)))) + ;; Don't make mini window too small. + (when (< (+ height delta) min-height) + (setq delta (- min-height height))) + ;; Don't make root window too small. + (when (> delta max-delta) + (setq delta max-delta)) (unless (zerop delta) - ;; Resize now. (window--resize-reset frame) - ;; Ideally we should be able to resize just the last child of root - ;; here. See the comment in `resize-root-window-vertically' for - ;; why we do not do that. (window--resize-this-window root (- delta) nil nil t) (set-window-new-pixel window (+ height delta)) ;; The following routine catches the case where we want to resize ;; a minibuffer-only frame. (when (resize-mini-window-internal window) - (window--pixel-to-total frame) - (run-window-configuration-change-hook frame)))))) + (window--pixel-to-total frame)))))) (defun window--resize-apply-p (frame &optional horizontal) "Return t when a window on FRAME shall be resized vertically. Optional argument HORIZONTAL non-nil means return t when a window shall be resized horizontally." -(catch 'apply + (catch 'apply (walk-window-tree (lambda (window) (unless (= (window-new-pixel window) (window-size window horizontal t)) (throw 'apply t))) - frame t) + frame t t) nil)) (defun window-resize (window delta &optional horizontal ignore pixelwise) @@ -2851,9 +2867,7 @@ instead." (window--resize-siblings window delta horizontal ignore)) (when (window--resize-apply-p frame horizontal) (if (window-resize-apply frame horizontal) - (progn - (window--pixel-to-total frame horizontal) - (run-window-configuration-change-hook frame)) + (window--pixel-to-total frame horizontal) (error "Failed to apply resizing %s" window)))) (t (error "Cannot resize window %s" window))))) @@ -3084,11 +3098,12 @@ already set by this routine." (while (and best-window (not (zerop delta))) (setq sub last) (setq best-window nil) - (setq best-value most-negative-fixnum) + (setq best-value nil) (while sub (when (and (consp (window-new-normal sub)) (not (<= (car (window-new-normal sub)) 0)) - (> (cdr (window-new-normal sub)) best-value)) + (or (not best-value) + (> (cdr (window-new-normal sub)) best-value))) (setq best-window sub) (setq best-value (cdr (window-new-normal sub)))) @@ -3113,10 +3128,11 @@ already set by this routine." (while (and best-window (not (zerop delta))) (setq sub last) (setq best-window nil) - (setq best-value most-positive-fixnum) + (setq best-value nil) (while sub (when (and (numberp (window-new-normal sub)) - (< (window-new-normal sub) best-value)) + (or (not best-value) + (< (window-new-normal sub) best-value))) (setq best-window sub) (setq best-value (window-new-normal sub))) @@ -3366,6 +3382,12 @@ routines." pixel-delta (/ pixel-delta (frame-char-height frame))))) +(defun window--resize-mini-frame (frame) + "Resize minibuffer-only frame FRAME." + (if (functionp resize-mini-frames) + (funcall resize-mini-frames frame) + (fit-frame-to-buffer frame))) + (defun window--sanitize-window-sizes (horizontal) "Assert that all windows on selected frame are large enough. If necessary and possible, make sure that every window on frame @@ -3385,7 +3407,8 @@ may happen when the FRAME is not large enough to accommodate it." (when (> delta 0) (if (window-resizable-p window delta horizontal nil t) (window-resize window delta horizontal nil t) - (setq value nil)))))) + (setq value nil))))) + nil nil 'nomini) value)) (defun adjust-window-trailing-edge (window delta &optional horizontal pixelwise) @@ -3570,9 +3593,7 @@ move it as far as possible in the desired direction." ;; Don't report an error in the standard case. (when (window--resize-apply-p frame horizontal) (if (window-resize-apply frame horizontal) - (progn - (window--pixel-to-total frame horizontal) - (run-window-configuration-change-hook frame)) + (window--pixel-to-total frame horizontal) ;; But do report an error if applying the changes fails. (error "Failed adjusting window %s" window)))))))) @@ -3686,6 +3707,8 @@ WINDOW must be a valid window and defaults to the selected one. If the option `window-resize-pixelwise' is non-nil minimize WINDOW pixelwise." (interactive) + (when switch-to-buffer-preserve-window-point + (window--before-delete-windows window)) (setq window (window-normalize-window window)) (window-resize window @@ -4023,6 +4046,41 @@ frame can be safely deleted." (throw 'done t) (setq parent (window-parent parent)))))))) +;; This function is called by `delete-window' and +;; `delete-other-windows' when `switch-to-buffer-preserve-window-point' +;; evaluates non-nil: it allows `winner-undo' to restore the +;; buffer point from deleted windows (Bug#23621). +(defun window--before-delete-windows (&optional window) + "Update `window-prev-buffers' before delete a window. +Optional arg WINDOW, if non-nil, update WINDOW-START and POS +in `window-prev-buffers' for all windows displaying same +buffer as WINDOW. Otherwise, update `window-prev-buffers' for +all windows. + +The new values for WINDOW-START and POS are those +returned by `window-start' and `window-point' respectively. + +This function is called only if `switch-to-buffer-preserve-window-point' +evaluates non-nil." + (dolist (win (window-list)) + (let* ((buf (window-buffer (or window win))) + (start (window-start win)) + (pos (window-point win)) + (entry (assq buf (window-prev-buffers win)))) + (cond (entry + (let ((marker (nth 2 entry))) + (unless (= pos marker) + (set-marker (nth 1 entry) start buf) + (set-marker marker pos buf)))) + (t + (let ((prev-buf (window-prev-buffers win)) + (start-m (make-marker)) + (pos-m (make-marker))) + (set-marker start-m start buf) + (set-marker pos-m pos buf) + (push (list buf start-m pos-m) prev-buf) + (set-window-prev-buffers win prev-buf))))))) + (defun delete-window (&optional window) "Delete WINDOW. WINDOW must be a valid window and defaults to the selected one. @@ -4041,6 +4099,8 @@ argument. Signal an error if WINDOW is either the only window on its frame, the last non-side window, or part of an atomic window that is its frame's root window." (interactive) + (when switch-to-buffer-preserve-window-point + (window--before-delete-windows)) (setq window (window-normalize-window window)) (let* ((frame (window-frame window)) (function (window-parameter window 'delete-window)) @@ -4103,7 +4163,6 @@ that is its frame's root window." ;; `delete-window-internal' has selected a window that should ;; not be selected, fix this here. (other-window -1 frame)) - (run-window-configuration-change-hook frame) (window--check frame) ;; Always return nil. nil)))) @@ -4166,7 +4225,8 @@ any window whose `no-delete-other-windows' parameter is non-nil." (and (not (window-parameter other 'window-side)) (window-parameter other 'no-delete-other-windows))) - (throw 'tag nil)))) + (throw 'tag nil))) + nil nil 'nomini) t) (setq main (window-main-window frame))) (t @@ -4189,7 +4249,6 @@ any window whose `no-delete-other-windows' parameter is non-nil." ;; If WINDOW is the main window of its frame do nothing. (unless (eq window main) (delete-other-windows-internal window main) - (run-window-configuration-change-hook frame) (window--check frame)) ;; Always return nil. nil))) @@ -4271,7 +4330,7 @@ WINDOW must be a live window and defaults to the selected one." (list (copy-marker start) (copy-marker ;; Preserve window-point-insertion-type - ;; (Bug#12588). + ;; (Bug#12855). point window-point-insertion-type))))) (set-window-prev-buffers window (cons entry (window-prev-buffers window))))) @@ -4721,7 +4780,7 @@ 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 "bDelete windows on (buffer):\nP") (let ((buffer (window-normalize-buffer buffer-or-name)) ;; Handle the "inverted" meaning of the FRAME argument wrt other ;; `window-list-1' based function. @@ -4904,7 +4963,7 @@ BUFFER-OR-NAME. Optional argument FRAME is handled as by This function calls `quit-window' on all candidate windows showing BUFFER-OR-NAME." - (interactive "BQuit windows on (buffer):\nP") + (interactive "bQuit windows on (buffer):\nP") (let ((buffer (window-normalize-buffer buffer-or-name)) ;; Handle the "inverted" meaning of the FRAME argument wrt other ;; `window-list-1' based function. @@ -4915,6 +4974,24 @@ showing BUFFER-OR-NAME." ;; If a window doesn't show BUFFER, unrecord BUFFER in it. (unrecord-window-buffer window buffer))))) +(defun window--combination-resizable (parent &optional horizontal) + "Return number of pixels recoverable from height of window PARENT. +PARENT must be a vertical (horizontal if HORIZONTAL is non-nil) +window combination. The return value is the sum of the pixel +heights of all non-fixed height child windows of PARENT divided +by their number plus 1. If HORIZONTAL is non-nil, return the sum +of the pixel widths of all non-fixed width child windows of +PARENT divided by their number plus 1." + (let ((sibling (window-child parent)) + (number 0) + (size 0)) + (while sibling + (unless (window-size-fixed-p sibling horizontal) + (setq number (1+ number)) + (setq size (+ (window-size sibling horizontal t) size))) + (setq sibling (window-next-sibling sibling))) + (/ size (1+ number)))) + (defun split-window (&optional window size side pixelwise) "Make a new window adjacent to WINDOW. WINDOW must be a valid window and defaults to the selected one. @@ -4928,26 +5005,29 @@ absolute value can be less than `window-min-height' or small as one line or two columns. SIZE defaults to half of WINDOW's size. -Optional third argument SIDE nil (or `below') specifies that the -new window shall be located below WINDOW. SIDE `above' means the +Optional third argument SIDE nil (or 'below') specifies that the +new window shall be located below WINDOW. SIDE 'above' means the new window shall be located above WINDOW. In both cases SIZE specifies the new number of lines for WINDOW (or the new window if SIZE is negative) including space reserved for the mode and/or header line. -SIDE t (or `right') specifies that the new window shall be -located on the right side of WINDOW. SIDE `left' means the new +SIDE t (or 'right') specifies that the new window shall be +located on the right side of WINDOW. SIDE 'left' means the new window shall be located on the left of WINDOW. In both cases SIZE specifies the new number of columns for WINDOW (or the new window provided SIZE is negative) including space reserved for -fringes and the scrollbar or a divider column. Any other non-nil -value for SIDE is currently handled like t (or `right'). +fringes and the scrollbar or a divider column. + +For compatibility reasons, SIDE 'up' and 'down' are interpreted +as 'above' and 'below'. Any other non-nil value for SIDE is +currently handled like t (or 'right'). PIXELWISE, if non-nil, means to interpret SIZE pixelwise. If the variable `ignore-window-parameters' is non-nil or the -`split-window' parameter of WINDOW equals t, do not process any -parameters of WINDOW. Otherwise, if the `split-window' parameter +'split-window' parameter of WINDOW equals t, do not process any +parameters of WINDOW. Otherwise, if the 'split-window' parameter of WINDOW specifies a function, call that function with all three arguments and return the value returned by that function. @@ -4963,6 +5043,8 @@ frame. The selected window is not changed by this function." (setq window (window-normalize-window window)) (let* ((side (cond ((not side) 'below) + ((eq side 'up) 'above) + ((eq side 'down) 'below) ((memq side '(below above right left)) side) (t 'right))) (horizontal (not (memq side '(below above)))) @@ -4986,10 +5068,10 @@ frame. The selected window is not changed by this function." (catch 'done (cond ;; Ignore window parameters if either `ignore-window-parameters' - ;; is t or the `split-window' parameter equals t. + ;; is t or the 'split-window' parameter equals t. ((or ignore-window-parameters (eq function t))) ((functionp function) - ;; The `split-window' parameter specifies the function to call. + ;; The 'split-window' parameter specifies the function to call. ;; If that function is `ignore', do nothing. (throw 'done (funcall function window size side))) ;; If WINDOW is part of an atomic window, split the root window @@ -5022,10 +5104,10 @@ frame. The selected window is not changed by this function." (setq window-combination-limit t)) (let* ((parent-pixel-size - ;; `parent-pixel-size' is the pixel size of WINDOW's + ;; 'parent-pixel-size' is the pixel size of WINDOW's ;; parent, provided it has one. (when parent (window-size parent horizontal t))) - ;; `resize' non-nil means we are supposed to resize other + ;; 'resize' non-nil means we are supposed to resize other ;; windows in WINDOW's combination. (resize (and window-combination-resize @@ -5034,9 +5116,9 @@ frame. The selected window is not changed by this function." (not (eq window-combination-limit t)) ;; Resize makes sense in iso-combinations only. (window-combined-p window horizontal))) - ;; `old-pixel-size' is the current pixel size of WINDOW. + ;; 'old-pixel-size' is the current pixel size of WINDOW. (old-pixel-size (window-size window horizontal t)) - ;; `new-size' is the specified or calculated size of the + ;; 'new-size' is the specified or calculated size of the ;; new window. new-pixel-size new-parent new-normal) (cond @@ -5047,8 +5129,7 @@ frame. The selected window is not changed by this function." ;; average size of a window in its combination. (max (min (- parent-pixel-size (window-min-size parent horizontal nil t)) - (/ parent-pixel-size - (1+ (window-combinations parent horizontal)))) + (window--combination-resizable parent horizontal)) (window-min-pixel-size)) ;; Else try to give the new window half the size ;; of WINDOW (plus an eventual odd pixel). @@ -5133,7 +5214,7 @@ frame. The selected window is not changed by this function." (pixel-size (/ (float new-pixel-size) (if new-parent old-pixel-size parent-pixel-size))) (new-parent 0.5) - (resize (/ 1.0 (1+ (window-combinations parent horizontal)))) + (resize (/ 1.0 (1+ (window-combinations parent horizontal t)))) (t (/ (window-normal-size window horizontal) 2.0)))) (if resize @@ -5190,7 +5271,6 @@ frame. The selected window is not changed by this function." (unless size (window--sanitize-window-sizes horizontal)) - (run-window-configuration-change-hook frame) (run-window-scroll-functions new) (window--check frame) ;; Always return the new window. @@ -5323,11 +5403,12 @@ is non-nil)." (total-sum parent-size) failed size sub-total sub-delta sub-amount rest) (while sub - (setq number-of-children (1+ number-of-children)) - (when (window-size-fixed-p sub horizontal) - (setq total-sum - (- total-sum (window-size sub horizontal t))) - (set-window-new-normal sub 'ignore)) + (if (window-size-fixed-p sub horizontal) + (progn + (setq total-sum + (- total-sum (window-size sub horizontal t))) + (set-window-new-normal sub 'ignore)) + (setq number-of-children (1+ number-of-children))) (setq sub (window-right sub))) (setq failed t) @@ -5352,16 +5433,16 @@ is non-nil)." (set-window-new-normal sub 'skip))) (setq sub (window-right sub)))) - ;; How can we be sure that `number-of-children' is NOT zero here ? - (setq rest (% total-sum number-of-children)) - ;; Fix rounding by trying to enlarge non-stuck windows by one line - ;; (column) until `rest' is zero. - (setq sub first) - (while (and sub (> rest 0)) - (unless (window--resize-child-windows-skip-p window) - (set-window-new-pixel sub (min rest char-size) t) - (setq rest (- rest char-size))) - (setq sub (window-right sub))) + (when (> number-of-children 0) + (setq rest (% total-sum number-of-children)) + ;; Fix rounding by trying to enlarge non-stuck windows by one line + ;; (column) until `rest' is zero. + (setq sub first) + (while (and sub (> rest 0)) + (unless (window--resize-child-windows-skip-p window) + (set-window-new-pixel sub (min rest char-size) t) + (setq rest (- rest char-size))) + (setq sub (window-right sub)))) ;; Fix rounding by trying to enlarge stuck windows by one line ;; (column) until `rest' equals zero. @@ -5420,15 +5501,13 @@ window." (balance-windows-1 window) (when (window--resize-apply-p frame) (window-resize-apply frame) - (window--pixel-to-total frame) - (run-window-configuration-change-hook frame)) + (window--pixel-to-total frame)) ;; Balance horizontally. (window--resize-reset (window-frame window) t) (balance-windows-1 window t) (when (window--resize-apply-p frame t) (window-resize-apply frame t) - (window--pixel-to-total frame t) - (run-window-configuration-change-hook frame)))) + (window--pixel-to-total frame t)))) (defun window-fixed-size-p (&optional window direction) "Return t if WINDOW cannot be resized in DIRECTION. @@ -5557,9 +5636,18 @@ specific buffers." (t 'leaf))) (buffer (window-buffer window)) (selected (eq window (selected-window))) + (next-buffers (when (window-live-p window) + (delq nil (mapcar (lambda (buffer) + (and (buffer-live-p buffer) buffer)) + (window-next-buffers window))))) + (prev-buffers (when (window-live-p window) + (delq nil (mapcar (lambda (entry) + (and (buffer-live-p (nth 0 entry)) + entry)) + (window-prev-buffers window))))) (head `(,type - ,@(unless (window-next-sibling window) `((last . t))) + ,@(unless (window-next-sibling window) '((last . t))) (pixel-width . ,(window-pixel-width window)) (pixel-height . ,(window-pixel-height window)) (total-width . ,(window-total-width window)) @@ -5591,7 +5679,7 @@ specific buffers." (let ((point (window-point window)) (start (window-start window))) `((buffer - ,(buffer-name buffer) + ,(if writable (buffer-name buffer) buffer) (selected . ,selected) (hscroll . ,(window-hscroll window)) (fringes . ,(window-fringes window)) @@ -5609,7 +5697,22 @@ specific buffers." (start . ,(if writable start (with-current-buffer buffer - (copy-marker start)))))))))) + (copy-marker start)))))))) + ,@(when next-buffers + `((next-buffers + . ,(if writable + (mapcar (lambda (buffer) (buffer-name buffer)) + next-buffers) + next-buffers)))) + ,@(when prev-buffers + `((prev-buffers + . ,(if writable + (mapcar (lambda (entry) + (list (buffer-name (nth 0 entry)) + (marker-position (nth 1 entry)) + (marker-position (nth 2 entry)))) + prev-buffers) + prev-buffers)))))) (tail (when (memq type '(vc hc)) (let (list) @@ -5752,7 +5855,9 @@ value can be also stored on disk and read back in a new session." (let ((window (car item)) (combination-limit (cdr (assq 'combination-limit item))) (parameters (cdr (assq 'parameters item))) - (state (cdr (assq 'buffer item)))) + (state (cdr (assq 'buffer item))) + (next-buffers (cdr (assq 'next-buffers item))) + (prev-buffers (cdr (assq 'prev-buffers item)))) (when combination-limit (set-window-combination-limit window combination-limit)) ;; Reset window's parameters and assign saved ones (we might want @@ -5764,7 +5869,8 @@ value can be also stored on disk and read back in a new session." (set-window-parameter window (car parameter) (cdr parameter)))) ;; Process buffer related state. (when state - (let ((buffer (get-buffer (car state)))) + (let ((buffer (get-buffer (car state))) + (state (cdr state))) (if buffer (with-current-buffer buffer (set-window-buffer window buffer) @@ -5776,7 +5882,7 @@ value can be also stored on disk and read back in a new session." (let ((scroll-bars (cdr (assq 'scroll-bars state)))) (set-window-scroll-bars window (car scroll-bars) (nth 2 scroll-bars) - (nth 3 scroll-bars) (nth 5 scroll-bars))) + (nth 3 scroll-bars) (nth 5 scroll-bars) (nth 6 scroll-bars))) (set-window-vscroll window (cdr (assq 'vscroll state))) ;; Adjust vertically. (if (or (memq window-size-fixed '(t height)) @@ -5833,7 +5939,30 @@ value can be also stored on disk and read back in a new session." (set-window-point window (cdr (assq 'point state)))) ;; Select window if it's the selected one. (when (cdr (assq 'selected state)) - (select-window window))) + (select-window window)) + (when next-buffers + (set-window-next-buffers + window + (delq nil (mapcar (lambda (buffer) + (setq buffer (get-buffer buffer)) + (when (buffer-live-p buffer) buffer)) + next-buffers)))) + (when prev-buffers + (set-window-prev-buffers + window + (delq nil (mapcar (lambda (entry) + (let ((buffer (get-buffer (nth 0 entry))) + (m1 (nth 1 entry)) + (m2 (nth 2 entry))) + (when (buffer-live-p buffer) + (list buffer + (if (markerp m1) m1 + (set-marker (make-marker) m1 + buffer)) + (if (markerp m2) m2 + (set-marker (make-marker) m2 + buffer)))))) + prev-buffers))))) ;; We don't want to raise an error in case the buffer does ;; not exist anymore, so we switch to a previous one and ;; save the window with the intention of deleting it later @@ -5845,29 +5974,34 @@ value can be also stored on disk and read back in a new session." "Put window state STATE into WINDOW. STATE should be the state of a window returned by an earlier invocation of `window-state-get'. Optional argument WINDOW must -specify a valid window and defaults to the selected one. If -WINDOW is not live, replace WINDOW by a live one before putting -STATE into it. +specify a valid window. If WINDOW is not a live window, +replace WINDOW by a new live window created on the same frame. +If WINDOW is nil, create a new window before putting STATE into it. Optional argument IGNORE non-nil means ignore minimum window sizes and fixed size restrictions. IGNORE equal `safe' means windows can get as small as `window-safe-min-height' and `window-safe-min-width'." (setq window-state-put-stale-windows nil) - (setq window (window-normalize-window window)) - ;; When WINDOW is internal, reduce it to a live one to put STATE into, - ;; see Bug#16793. + ;; When WINDOW is internal or nil, reduce it to a live one, + ;; then create a new window on the same frame to put STATE into. (unless (window-live-p window) (let ((root window)) - (setq window (catch 'live - (walk-window-subtree - (lambda (window) - (when (and (window-live-p window) - (not (window-parameter window 'window-side))) - (throw 'live window))) - root))) - (delete-other-windows-internal window root))) + (setq window (if root + (catch 'live + (walk-window-subtree + (lambda (window) + (when (and (window-live-p window) + (not (window-parameter + window 'window-side))) + (throw 'live window))) + root)) + (selected-window))) + (delete-other-windows-internal window root) + ;; Create a new window to replace the existing one. + (setq window (prog1 (split-window window) + (delete-window window))))) (set-window-dedicated-p window nil) @@ -6023,23 +6157,26 @@ not resized by this function." (defun display-buffer-record-window (type window buffer) "Record information for window used by `display-buffer'. +WINDOW is the window used for or created by a buffer display +action function. BUFFER is the buffer to display. Note that +this function must be called before BUFFER is explicitly made +WINDOW's buffer (although WINDOW may show BUFFER already). + TYPE specifies the type of the calling operation and must be one -of the symbols `reuse' (when WINDOW existed already and was -reused for displaying BUFFER), `window' (when WINDOW was created -on an already existing frame), or `frame' (when WINDOW was -created on a new frame). WINDOW is the window used for or created -by the `display-buffer' routines. BUFFER is the buffer that -shall be displayed. - -This function installs or updates the quit-restore parameter of -WINDOW. The quit-restore parameter is a list of four elements: -The first element is one of the symbols `window', `frame', `same' or -`other'. The second element is either one of the symbols `window' -or `frame' or a list whose elements are the buffer previously -shown in the window, that buffer's window start and window point, -and the window's height. The third element is the window -selected at the time the parameter was created. The fourth -element is BUFFER." +of the symbols 'reuse' (meaning that WINDOW exists already and +will be used for displaying BUFFER), 'window' (WINDOW was created +on an already existing frame) or 'frame' (WINDOW was created on a +new frame). + +This function installs or updates the 'quit-restore' parameter of +WINDOW. The 'quit-restore' parameter is a list of four elements: +The first element is one of the symbols 'window', 'frame', 'same' +or 'other'. The second element is either one of the symbols +'window' or 'frame' or a list whose elements are the buffer +previously shown in the window, that buffer's window start and +window point, and the window's height. The third element is the +window selected at the time the parameter was created. The +fourth element is BUFFER." (cond ((eq type 'reuse) (if (eq (window-buffer window) buffer) @@ -6060,7 +6197,7 @@ element is BUFFER." (list 'other ;; A quadruple of WINDOW's buffer, start, point and height. (list (current-buffer) (window-start window) - ;; Preserve window-point-insertion-type (Bug#12588). + ;; Preserve window-point-insertion-type (Bug#12855). (copy-marker (window-point window) window-point-insertion-type) (if (window-combined-p window) @@ -6608,7 +6745,7 @@ split." (unless (or (eq w window) (window-dedicated-p w)) (throw 'done nil))) - frame) + frame nil 'nomini) t))) (not (window-minibuffer-p window)) (let ((split-height-threshold 0)) @@ -6660,6 +6797,7 @@ represents a live window, nil otherwise." )) frame)))) +(defvaralias 'even-window-heights 'even-window-sizes) (defcustom even-window-sizes t "If non-nil `display-buffer' will try to even window sizes. Otherwise `display-buffer' will leave the window configuration @@ -6673,7 +6811,6 @@ any of them." (const :tag "Always" t)) :version "25.1" :group 'windows) -(defvaralias 'even-window-heights 'even-window-sizes) (defun window--even-window-sizes (window) "Even sizes of WINDOW and selected window. @@ -6698,20 +6835,51 @@ window is larger than WINDOW." (/ (- (window-total-height window) (window-total-height)) 2)) (error nil)))))) -(defun window--display-buffer (buffer window type &optional alist dedicated) +(defun window--display-buffer (buffer window type &optional alist) "Display BUFFER in WINDOW. -TYPE must be one of the symbols `reuse', `window' or `frame' and -is passed unaltered to `display-buffer-record-window'. ALIST is -the alist argument of `display-buffer'. Set `window-dedicated-p' -to DEDICATED if non-nil. Return WINDOW if BUFFER and WINDOW are -live." +WINDOW must be a live window chosen by a buffer display action +function for showing BUFFER. TYPE tells whether WINDOW existed +already before that action function was called or is a new window +created by that function. ALIST is a buffer display action alist +as compiled by `display-buffer'. + +TYPE must be one of the following symbols: 'reuse' (which means +WINDOW existed before the call of `display-buffer' and may +already show BUFFER or not), 'window' (WINDOW was created on an +existing frame) or 'frame' (WINDOW was created on a new frame). +TYPE is passed unaltered to `display-buffer-record-window'. + +Handle WINDOW's dedicated flag as follows: If WINDOW already +shows BUFFER, leave it alone. Otherwise, if ALIST contains a +'dedicated' entry and WINDOW is either new or that entry's value +equals 'side', set WINDOW's dedicated flag to the value of that +entry. Otherwise, if WINDOW is new and the value of +'display-buffer-mark-dedicated' is non-nil, set WINDOW's +dedicated flag to that value. In any other case, reset WINDOW's +dedicated flag to nil. + +Return WINDOW if BUFFER and WINDOW are live." (when (and (buffer-live-p buffer) (window-live-p window)) (display-buffer-record-window type window buffer) (unless (eq buffer (window-buffer window)) + ;; Unless WINDOW already shows BUFFER reset its dedicated flag. (set-window-dedicated-p window nil) (set-window-buffer window buffer)) - (when dedicated - (set-window-dedicated-p window dedicated)) + (let ((alist-dedicated (assq 'dedicated alist))) + ;; Maybe dedicate WINDOW to BUFFER if asked for. + (cond + ;; Don't dedicate WINDOW if it is dedicated because it shows + ;; BUFFER already or it is reused and is not a side window. + ((or (window-dedicated-p window) + (and (eq type 'reuse) (not (eq (cdr alist-dedicated) 'side))))) + ;; Otherwise, if ALIST contains a 'dedicated' entry, use that + ;; entry's value (which may be nil). + (alist-dedicated + (set-window-dedicated-p window (cdr alist-dedicated))) + ;; Otherwise, if 'display-buffer-mark-dedicated' is non-nil, + ;; use that. + (display-buffer-mark-dedicated + (set-window-dedicated-p window display-buffer-mark-dedicated)))) (when (memq type '(window frame)) (set-window-prev-buffers window nil)) (let ((quit-restore (window-parameter window 'quit-restore)) @@ -7106,7 +7274,7 @@ on all the frames on the current terminal, skipping the selected window; if that fails, it pops up a new frame. This uses the function `display-buffer' as a subroutine; see its documentation for additional customization information." - (interactive "BDisplay buffer in other frame: ") + (interactive "bDisplay buffer in other frame: ") (display-buffer buffer display-buffer--other-frame-action t)) ;;; `display-buffer' action functions: @@ -7140,8 +7308,7 @@ that allows the selected frame)." frame nil (cdr (assq 'inhibit-same-window alist)))))) (when window (prog1 - (window--display-buffer - buffer window 'reuse alist display-buffer-mark-dedicated) + (window--display-buffer buffer window 'reuse alist) (unless (cdr (assq 'inhibit-switch-frame alist)) (window--maybe-raise-frame frame)))))) @@ -7166,25 +7333,26 @@ return nil." (defun display-buffer-reuse-window (buffer alist) "Return a window that is already displaying BUFFER. -Return nil if no usable window is found. +Preferably use a window on the selected frame if such a window +exists. Return nil if no usable window is found. -If ALIST has a non-nil `inhibit-same-window' entry, the selected +If ALIST has a non-nil 'inhibit-same-window' entry, the selected window is not eligible for reuse. -If ALIST contains a `reusable-frames' entry, its value determines +If ALIST contains a 'reusable-frames' entry, its value determines which frames to search for a reusable window: nil -- the selected frame (actually the last non-minibuffer frame) A frame -- just that frame - `visible' -- all visible frames + 'visible' -- all visible frames 0 -- all frames on the current terminal t -- all frames. -If ALIST contains no `reusable-frames' entry, search just the +If ALIST contains no 'reusable-frames' entry, search just the selected frame if `display-buffer-reuse-frames' and `pop-up-frames' are both nil; search all frames on the current terminal if either of those variables is non-nil. -If ALIST has a non-nil `inhibit-switch-frame' entry, then in the +If ALIST has a non-nil 'inhibit-switch-frame' entry, then in the event that a window on another frame is chosen, avoid raising that frame." (let* ((alist-entry (assq 'reusable-frames alist)) @@ -7198,9 +7366,21 @@ that frame." (window (if (and (eq buffer (window-buffer)) (not (cdr (assq 'inhibit-same-window alist)))) (selected-window) - (car (delq (selected-window) - (get-buffer-window-list buffer 'nomini - frames)))))) + ;; Preferably use a window on the selected frame, + ;; if such a window exists (Bug#36680). + (let* ((windows (delq (selected-window) + (get-buffer-window-list + buffer 'nomini frames))) + (first (car windows)) + (this-frame (selected-frame))) + (cond + ((eq (window-frame first) this-frame) + first) + ((catch 'found + (dolist (next (cdr windows)) + (when (eq (window-frame next) this-frame) + (throw 'found next))))) + (t first)))))) (when (window-live-p window) (prog1 (window--display-buffer buffer window 'reuse alist) (unless (cdr (assq 'inhibit-switch-frame alist)) @@ -7306,8 +7486,7 @@ new frame." (with-current-buffer buffer (setq frame (funcall fun))) (setq window (frame-selected-window frame))) - (prog1 (window--display-buffer - buffer window 'frame alist display-buffer-mark-dedicated) + (prog1 (window--display-buffer buffer window 'frame alist) (unless (cdr (assq 'inhibit-switch-frame alist)) (window--maybe-raise-frame frame)))))) @@ -7336,8 +7515,7 @@ raising the frame." (window--try-to-split-window (get-lru-window frame t) alist)))) - (prog1 (window--display-buffer - buffer window 'window alist display-buffer-mark-dedicated) + (prog1 (window--display-buffer buffer window 'window alist) (unless (cdr (assq 'inhibit-switch-frame alist)) (window--maybe-raise-frame (window-frame window))))))) @@ -7348,12 +7526,23 @@ text-only terminal), try with `display-buffer-pop-up-frame'. If that cannot be done, and `pop-up-windows' is non-nil, try again with `display-buffer-pop-up-window'." - (or (and (if (eq pop-up-frames 'graphic-only) - (display-graphic-p) - pop-up-frames) - (display-buffer-pop-up-frame buffer alist)) - (and pop-up-windows - (display-buffer-pop-up-window buffer alist)))) + (or (display-buffer--maybe-pop-up-frame buffer alist) + (display-buffer--maybe-pop-up-window buffer alist))) + +(defun display-buffer--maybe-pop-up-frame (buffer alist) + "Try displaying BUFFER based on `pop-up-frames'. +If `pop-up-frames' is non-nil (and not `graphic-only' on a +text-only terminal), try with `display-buffer-pop-up-frame'." + (and (if (eq pop-up-frames 'graphic-only) + (display-graphic-p) + pop-up-frames) + (display-buffer-pop-up-frame buffer alist))) + +(defun display-buffer--maybe-pop-up-window (buffer alist) + "Try displaying BUFFER based on `pop-up-windows'. +If `pop-up-windows' is non-nil, try with `display-buffer-pop-up-window'." + (and pop-up-windows + (display-buffer-pop-up-window buffer alist))) (defun display-buffer-in-child-frame (buffer alist) "Display BUFFER in a child frame. @@ -7374,7 +7563,7 @@ be added to ALIST." (parent (or (assq 'parent-frame parameters) (selected-frame))) (share (assq 'share-child-frame parameters)) - share1 frame window) + share1 frame window type) (with-current-buffer buffer (when (frame-live-p parent) (catch 'frame @@ -7387,38 +7576,220 @@ be added to ALIST." (throw 'frame t)))))) (if frame - (setq window (frame-selected-window frame)) + (progn + (setq window (frame-selected-window frame)) + (setq type 'reuse)) (setq frame (make-frame parameters)) - (setq window (frame-selected-window frame)))) + (setq window (frame-selected-window frame)) + (setq type 'frame))) - (prog1 (window--display-buffer - buffer window 'frame alist display-buffer-mark-dedicated) + (prog1 (window--display-buffer buffer window type alist) (unless (cdr (assq 'inhibit-switch-frame alist)) (window--maybe-raise-frame frame))))) +(defun windows-sharing-edge (&optional window edge within) + "Return list of live windows sharing the same edge with WINDOW. +WINDOW must be a valid window and defaults to the selected one. +EDGE stands for the edge to share and must be either 'left', +'above', 'right' or 'below'. Omitted or nil, EDGE defaults to +'left'. + +WITHIN nil means to find a live window that shares the opposite +EDGE with WINDOW. For example, if EDGE equals 'left', WINDOW has +to share (part of) the right edge of any window returned. WITHIN +non-nil means to find all live windows that share the same EDGE +with WINDOW (Window must be internal in this case). So if EDGE +equals 'left', WINDOW's left edge has to fully encompass the left +edge of any window returned." + (setq window (window-normalize-window window)) + (setq edge (or edge 'left)) + (when (and within (window-live-p window)) + (error "Cannot share edge from within live window %s" window)) + (let ((window-edges (window-edges window nil nil t)) + (horizontal (memq edge '(left right))) + (n (pcase edge + ('left 0) ('above 1) ('right 2) ('below 3)))) + (unless (numberp n) + (error "Invalid EDGE %s" edge)) + (let ((o (mod (+ 2 n) 4)) + (p (if horizontal 1 0)) + (q (if horizontal 3 2)) + windows) + (walk-window-tree + (lambda (other) + (let ((other-edges (window-edges other nil nil t))) + (when (and (not (eq window other)) + (= (nth n window-edges) + (nth (if within n o) other-edges)) + (cond + ((= (nth p window-edges) (nth p other-edges))) + ((< (nth p window-edges) (nth p other-edges)) + (< (nth p other-edges) (nth q window-edges))) + (t + (< (nth p window-edges) (nth q other-edges))))) + (setq windows (cons other windows))))) + (window-frame window) nil 'nomini) + (reverse windows)))) + +(defun window--try-to-split-window-in-direction (window direction alist) + "Try to split WINDOW in DIRECTION. +DIRECTION is passed as SIDE argument to `split-window-no-error'. +ALIST is a buffer display alist." + (and (not (frame-parameter (window-frame window) 'unsplittable)) + (let* ((window-combination-limit + ;; When `window-combination-limit' equals + ;; `display-buffer' or equals `resize-window' and a + ;; `window-height' or `window-width' alist entry are + ;; present, bind it to t so resizing steals space + ;; preferably from the window that was split. + (if (or (eq window-combination-limit 'display-buffer) + (and (eq window-combination-limit 'window-size) + (or (cdr (assq 'window-height alist)) + (cdr (assq 'window-width alist))))) + t + window-combination-limit)) + (new-window (split-window-no-error window nil direction))) + (and (window-live-p new-window) new-window)))) + +(defun display-buffer-in-direction (buffer alist) + "Try to display BUFFER in a direction specified by ALIST. +ALIST has to contain a 'direction' entry whose value should be +one of 'left', 'above' (or 'up'), 'right', and 'below' (or +'down'). Other values are usually interpreted as 'below'. + +If ALIST also contains a 'window' entry, its value specifies a +reference window. That value can be a special symbol like +'main' (which stands for the selected frame's main window) or +'root' (standings for the selected frame's root window) or an +arbitrary valid window. Any other value (or omitting the +'window' entry) means to use the selected window as reference +window. + +This function tries to reuse or split a window such that the +window produced this way is on the side of the reference window +specified by the 'direction' entry. + +Four special values for 'direction' entries allow to implicitly +specify the selected frame's main window as reference window: +'leftmost', 'top', 'rightmost' and 'bottom'. Hence, instead of +'(direction . left) (window . main)' one can simply write +'(direction . leftmost)'." + (let ((direction (cdr (assq 'direction alist)))) + (when direction + (let ((window (cdr (assq 'window alist))) + within windows other-window-shows-buffer other-window) + ;; Sanitize WINDOW. + (cond + ((or (eq window 'main) + (memq direction '(top bottom leftmost rightmost))) + (setq window (window-main-window))) + ((eq window 'root) + (setq window (frame-root-window))) + ((window-valid-p window)) + (t + (setq window (selected-window)))) + (setq within (not (window-live-p window))) + ;; Sanitize DIRECTION + (cond + ((memq direction '(left above right below))) + ((eq direction 'leftmost) + (setq direction 'left)) + ((memq direction '(top up)) + (setq direction 'above)) + ((eq direction 'rightmost) + (setq direction 'right)) + ((memq direction '(bottom down)) + (setq direction 'below)) + (t + (setq direction 'below))) + + (setq alist + (append alist + `(,(if temp-buffer-resize-mode + '(window-height . resize-temp-buffer-window) + '(window-height . fit-window-to-buffer)) + ,(when temp-buffer-resize-mode + '(preserve-size . (nil . t)))))) + + (setq windows (windows-sharing-edge window direction within)) + (dolist (other windows) + (cond + ((and (not other-window-shows-buffer) + (eq buffer (window-buffer other))) + (setq other-window-shows-buffer t) + (setq other-window other)) + ((not other-window) + (setq other-window other)))) + (or (and other-window-shows-buffer + (window--display-buffer buffer other-window 'reuse alist)) + (and (setq other-window + (window--try-to-split-window-in-direction + window direction alist)) + (window--display-buffer buffer other-window 'window alist)) + (and (setq window other-window) + (not (window-dedicated-p other-window)) + (not (window-minibuffer-p other-window)) + (window--display-buffer buffer other-window 'reuse alist))))))) + +;; This should be rewritten as +;; (display-buffer-in-direction buffer (cons '(direction . below) alist)) (defun display-buffer-below-selected (buffer alist) "Try displaying BUFFER in a window below the selected window. If there is a window below the selected one and that window already displays BUFFER, use that window. Otherwise, try to create a new window below the selected one and show BUFFER there. If that attempt fails as well and there is a non-dedicated window -below the selected one, use that window." - (let (window) +below the selected one, use that window. + +If ALIST contains a 'window-min-height' entry, this function +ensures that the window used is or can become at least as high as +specified by that entry's value. Note that such an entry alone +will not resize the window per se. In order to do that, ALIST +must also contain a 'window-height' entry with the same value." + (let ((min-height (cdr (assq 'window-min-height alist))) + window) (or (and (setq window (window-in-direction 'below)) - (eq buffer (window-buffer window)) + (eq buffer (window-buffer window)) + (or (not (numberp min-height)) + (>= (window-height window) min-height) + ;; 'window--display-buffer' can resize this window if + ;; and only if it has a 'quit-restore' parameter + ;; certifying that it always showed BUFFER before. + (let ((height (window-height window)) + (quit-restore (window-parameter window 'quit-restore))) + (and quit-restore + (eq (nth 1 quit-restore) 'window) + (window-resizable-p window (- min-height height))))) (window--display-buffer buffer window 'reuse alist)) (and (not (frame-parameter nil 'unsplittable)) - (let ((split-height-threshold 0) + (or (not (numberp min-height)) + (window-sizable-p nil (- min-height))) + (let ((split-height-threshold 0) split-width-threshold) - (setq window (window--try-to-split-window + (setq window (window--try-to-split-window (selected-window) alist))) - (window--display-buffer - buffer window 'window alist display-buffer-mark-dedicated)) + (window--display-buffer buffer window 'window alist)) (and (setq window (window-in-direction 'below)) - (not (window-dedicated-p window)) - (window--display-buffer - buffer window 'reuse alist display-buffer-mark-dedicated))))) - + (not (window-dedicated-p window)) + (or (not (numberp min-height)) + ;; A window that showed another buffer before cannot + ;; be resized. + (>= (window-height window) min-height)) + (window--display-buffer buffer window 'reuse alist))))) + +(defun display-buffer--maybe-at-bottom (buffer alist) + (let ((alist (append alist `(,(if temp-buffer-resize-mode + '(window-height . resize-temp-buffer-window) + '(window-height . fit-window-to-buffer)) + ,(when temp-buffer-resize-mode + '(preserve-size . (nil . t))))))) + (or (display-buffer--maybe-same-window buffer alist) + (display-buffer-reuse-window buffer alist) + (display-buffer--maybe-pop-up-frame buffer alist) + (display-buffer-at-bottom buffer alist)))) + +;; This should be rewritten as +;; (display-buffer-in-direction buffer (cons '(direction . bottom) alist)) (defun display-buffer-at-bottom (buffer alist) "Try displaying BUFFER in a window at the bottom of the selected frame. This either reuses such a window provided it shows BUFFER @@ -7435,24 +7806,16 @@ selected frame." (setq bottom-window-shows-buffer t) (setq bottom-window window)) ((not bottom-window) - (setq bottom-window window))) - nil nil 'nomini)) + (setq bottom-window window)))) + nil nil 'nomini) (or (and bottom-window-shows-buffer - (window--display-buffer - buffer bottom-window 'reuse alist display-buffer-mark-dedicated)) - (and (not (frame-parameter nil 'unsplittable)) - (let (split-width-threshold) - (setq window (window--try-to-split-window bottom-window alist))) - (window--display-buffer - buffer window 'window alist display-buffer-mark-dedicated)) + (window--display-buffer buffer bottom-window 'reuse alist)) (and (not (frame-parameter nil 'unsplittable)) (setq window (split-window-no-error (window-main-window))) - (window--display-buffer - buffer window 'window alist display-buffer-mark-dedicated)) + (window--display-buffer buffer window 'window alist)) (and (setq window bottom-window) (not (window-dedicated-p window)) - (window--display-buffer - buffer window 'reuse alist display-buffer-mark-dedicated))))) + (window--display-buffer buffer window 'reuse alist))))) (defun display-buffer-in-previous-window (buffer alist) "Display BUFFER in a window previously showing it. @@ -7512,7 +7875,8 @@ apply the following order of preference: ;; anything we found so far. (when (and (setq window (cdr (assq 'previous-window alist))) (window-live-p window) - (not (window-dedicated-p window))) + (or (eq buffer (window-buffer window)) + (not (window-dedicated-p window)))) (if (eq window (selected-window)) (unless inhibit-same-window (setq second-best-window window)) @@ -7682,7 +8046,9 @@ position in the selected window. This variable is ignored if the buffer is already displayed in the selected window or never appeared in it before, or if -`switch-to-buffer' calls `pop-to-buffer' to display the buffer." +`switch-to-buffer' calls `pop-to-buffer' to display the buffer, +or non-nil `switch-to-buffer-obey-display-actions' displays it +in another window." :type '(choice (const :tag "Never" nil) (const :tag "If already displayed elsewhere" already-displayed) @@ -7717,6 +8083,16 @@ FORCE-SAME-WINDOW is non-nil." :group 'windows :version "25.1") +(defcustom switch-to-buffer-obey-display-actions nil + "If non-nil, `switch-to-buffer' runs `pop-to-buffer-same-window' instead. +This means that when switching the buffer it respects display actions +specified by `display-buffer-overriding-action', `display-buffer-alist' +and other display related variables. So `switch-to-buffer' will display +the buffer in the window specified by the rules from these variables." + :type 'boolean + :group 'windows + :version "27.1") + (defun switch-to-buffer (buffer-or-name &optional norecord force-same-window) "Display buffer BUFFER-OR-NAME in the selected window. @@ -7749,59 +8125,83 @@ displaying it the most recently selected one. If optional argument FORCE-SAME-WINDOW is non-nil, the buffer must be displayed in the selected window when called non-interactively; if that is impossible, signal an error rather -than calling `pop-to-buffer'. +than calling `pop-to-buffer'. It has no effect when the option +`switch-to-buffer-obey-display-actions' is non-nil. The option `switch-to-buffer-preserve-window-point' can be used to make the buffer appear at its last position in the selected window. +If the option `switch-to-buffer-obey-display-actions' is non-nil, +run the function `pop-to-buffer-same-window' instead. +This may display the buffer in another window as specified by +`display-buffer-overriding-action', `display-buffer-alist' and +other display related variables. If this results in displaying +the buffer in the selected window, window start and point are adjusted +as prescribed by the option `switch-to-buffer-preserve-window-point'. +Otherwise, these are left alone. + Return the buffer switched to." (interactive (let ((force-same-window - (cond - ((window-minibuffer-p) nil) - ((not (eq (window-dedicated-p) t)) 'force-same-window) - ((pcase switch-to-buffer-in-dedicated-window - (`nil (user-error - "Cannot switch buffers in a dedicated window")) - (`prompt - (if (y-or-n-p - (format "Window is dedicated to %s; undedicate it" - (window-buffer))) - (progn - (set-window-dedicated-p nil nil) - 'force-same-window) - (user-error - "Cannot switch buffers in a dedicated window"))) - (`pop nil) - (_ (set-window-dedicated-p nil nil) 'force-same-window)))))) + (unless switch-to-buffer-obey-display-actions + (cond + ((window-minibuffer-p) nil) + ((not (eq (window-dedicated-p) t)) 'force-same-window) + ((pcase switch-to-buffer-in-dedicated-window + ('nil (user-error + "Cannot switch buffers in a dedicated window")) + ('prompt + (if (y-or-n-p + (format "Window is dedicated to %s; undedicate it" + (window-buffer))) + (progn + (set-window-dedicated-p nil nil) + 'force-same-window) + (user-error + "Cannot switch buffers in a dedicated window"))) + ('pop nil) + (_ (set-window-dedicated-p nil nil) 'force-same-window))))))) (list (read-buffer-to-switch "Switch to buffer: ") nil force-same-window))) - (let ((buffer (window-normalize-buffer-to-switch-to buffer-or-name))) + (let ((buffer (window-normalize-buffer-to-switch-to buffer-or-name)) + (set-window-start-and-point (not switch-to-buffer-obey-display-actions))) (cond ;; Don't call set-window-buffer if it's not needed since it ;; might signal an error (e.g. if the window is dedicated). - ((eq buffer (window-buffer))) - ((window-minibuffer-p) + ((and (eq buffer (window-buffer)) + ;; pop-to-buffer-same-window might decide to display + ;; the same buffer in another window + (not switch-to-buffer-obey-display-actions))) + ((and (window-minibuffer-p) + (not switch-to-buffer-obey-display-actions)) (if force-same-window (user-error "Cannot switch buffers in minibuffer window") (pop-to-buffer buffer norecord))) - ((eq (window-dedicated-p) t) + ((and (eq (window-dedicated-p) t) + (not switch-to-buffer-obey-display-actions)) (if force-same-window (user-error "Cannot switch buffers in a dedicated window") (pop-to-buffer buffer norecord))) (t - (let* ((entry (assq buffer (window-prev-buffers))) - (displayed (and (eq switch-to-buffer-preserve-window-point - 'already-displayed) - (get-buffer-window buffer 0)))) - (set-window-buffer nil buffer) - (when (and entry - (or (eq switch-to-buffer-preserve-window-point t) - displayed)) - ;; Try to restore start and point of buffer in the selected - ;; window (Bug#4041). - (set-window-start (selected-window) (nth 1 entry) t) - (set-window-point nil (nth 2 entry)))))) + (when switch-to-buffer-obey-display-actions + (let ((selected-window (selected-window))) + (pop-to-buffer-same-window buffer norecord) + (when (eq (selected-window) selected-window) + (setq set-window-start-and-point t)))) + + (when set-window-start-and-point + (let* ((entry (assq buffer (window-prev-buffers))) + (displayed (and (eq switch-to-buffer-preserve-window-point + 'already-displayed) + (get-buffer-window buffer 0)))) + (set-window-buffer nil buffer) + (when (and entry + (or (eq switch-to-buffer-preserve-window-point t) + displayed)) + ;; Try to restore start and point of buffer in the selected + ;; window (Bug#4041). + (set-window-start (selected-window) (nth 1 entry) t) + (set-window-point nil (nth 2 entry))))))) (unless norecord (select-window (selected-window))) @@ -8098,7 +8498,7 @@ parameters of FRAME." (if parent (frame-native-height parent) (- (nth 3 geometry) (nth 1 geometry)))) - ;; FRAME'S parent or workarea sizes. Used when no margins + ;; FRAME's parent or workarea sizes. Used when no margins ;; are specified. (parent-or-workarea (if parent @@ -8822,7 +9222,7 @@ A prefix argument is handled like `recenter': With plain `C-u', move current line to window center." (interactive "P") (cond - (arg (recenter arg)) ; Always respect ARG. + (arg (recenter arg t)) ; Always respect ARG. (t (setq recenter-last-op (if (eq this-command last-command) @@ -8833,15 +9233,15 @@ A prefix argument is handled like `recenter': (min (max 0 scroll-margin) (truncate (/ (window-body-height) 4.0))))) (cond ((eq recenter-last-op 'middle) - (recenter)) + (recenter nil t)) ((eq recenter-last-op 'top) - (recenter this-scroll-margin)) + (recenter this-scroll-margin t)) ((eq recenter-last-op 'bottom) - (recenter (- -1 this-scroll-margin))) + (recenter (- -1 this-scroll-margin) t)) ((integerp recenter-last-op) - (recenter recenter-last-op)) + (recenter recenter-last-op t)) ((floatp recenter-last-op) - (recenter (round (* recenter-last-op (window-height)))))))))) + (recenter (round (* recenter-last-op (window-height))) t))))))) (define-key global-map [?\C-l] 'recenter-top-bottom) @@ -8979,35 +9379,17 @@ This is different from `scroll-down-command' that scrolls a full screen." (put 'scroll-down-line 'scroll-command t) -(defun scroll-other-window-down (&optional lines) - "Scroll the \"other window\" down. -For more details, see the documentation for `scroll-other-window'." - (interactive "P") - (scroll-other-window - ;; Just invert the argument's meaning. - ;; We can do that without knowing which window it will be. - (if (eq lines '-) nil - (if (null lines) '- - (- (prefix-numeric-value lines)))))) - (defun beginning-of-buffer-other-window (arg) "Move point to the beginning of the buffer in the other window. Leave mark at previous position. With arg N, put point N/10 of the way from the true beginning." (interactive "P") - (let ((orig-window (selected-window)) - (window (other-window-for-scrolling))) - ;; We use unwind-protect rather than save-window-excursion - ;; because the latter would preserve the things we want to change. - (unwind-protect - (progn - (select-window window) - ;; Set point and mark in that window's buffer. - (with-no-warnings - (beginning-of-buffer arg)) - ;; Set point accordingly. - (recenter '(t))) - (select-window orig-window)))) + (with-selected-window (other-window-for-scrolling) + ;; Set point and mark in that window's buffer. + (with-no-warnings + (beginning-of-buffer arg)) + ;; Set point accordingly. + (recenter '(t)))) (defun end-of-buffer-other-window (arg) "Move point to the end of the buffer in the other window. @@ -9015,15 +9397,10 @@ Leave mark at previous position. With arg N, put point N/10 of the way from the true end." (interactive "P") ;; See beginning-of-buffer-other-window for comments. - (let ((orig-window (selected-window)) - (window (other-window-for-scrolling))) - (unwind-protect - (progn - (select-window window) - (with-no-warnings - (end-of-buffer arg)) - (recenter '(t))) - (select-window orig-window)))) + (with-selected-window (other-window-for-scrolling) + (with-no-warnings + (end-of-buffer arg)) + (recenter '(t)))) (defvar mouse-autoselect-window-timer nil "Timer used by delayed window autoselection.") @@ -9149,6 +9526,8 @@ is active. This function is run by `mouse-autoselect-window-timer'." ;; autoselection. (mouse-autoselect-window-start mouse-position window))))) +(declare-function display-multi-frame-p "frame" (&optional display)) + (defun handle-select-window (event) "Handle select-window events." (interactive "^e") @@ -9186,7 +9565,7 @@ is active. This function is run by `mouse-autoselect-window-timer'." ;; we might get two windows with an active cursor. (select-window window) (cond - ((or (not (memq (window-system frame) '(x w32 ns))) + ((or (not (display-multi-frame-p)) (not focus-follows-mouse) ;; Focus FRAME if it's either a child frame or an ancestor ;; of the frame switched from. @@ -9258,10 +9637,12 @@ a two-argument function used to combine the widths and heights of the given windows." (when windows (let ((width (window-max-chars-per-line (car windows))) - (height (window-body-height (car windows)))) + (height (with-selected-window (car windows) + (floor (window-screen-lines))))) (dolist (window (cdr windows)) (setf width (funcall reducer width (window-max-chars-per-line window))) - (setf height (funcall reducer height (window-body-height window)))) + (setf height (funcall reducer height (with-selected-window window + (floor (window-screen-lines)))))) (cons width height)))) (defun window-adjust-process-window-size-smallest (_process windows) @@ -9317,15 +9698,7 @@ displaying that processes's buffer." (when size (set-process-window-size process (cdr size) (car size)))))))))) -;; Remove the following call in Emacs 27, running -;; 'window-size-change-functions' should suffice. (add-hook 'window-configuration-change-hook 'window--adjust-process-windows) - -;; Catch any size changes not handled by -;; 'window-configuration-change-hook' (Bug#32720, "another issue" in -;; Bug#33230). -(add-hook 'window-size-change-functions (lambda (_frame) - (window--adjust-process-windows))) ;; Some of these are in tutorial--default-keys, so update that if you ;; change these. diff --git a/lisp/winner.el b/lisp/winner.el index 1070e26df51..ec3b296489c 100644 --- a/lisp/winner.el +++ b/lisp/winner.el @@ -57,21 +57,22 @@ (defcustom winner-dont-bind-my-keys nil "Non-nil means do not bind keys in Winner mode." - :type 'boolean - :group 'winner) + :type 'boolean) (defcustom winner-ring-size 200 "Maximum number of stored window configurations per frame." - :type 'integer - :group 'winner) + :type 'integer) (defcustom winner-boring-buffers '("*Completions*") "List of buffer names whose windows `winner-undo' will not restore. You may want to include buffer names such as *Help*, *Apropos*, *Buffer List*, *info* and *Compile-Log*." - :type '(repeat string) - :group 'winner) + :type '(repeat string)) +(defcustom winner-boring-buffers-regexp nil + "`winner-undo' will not restore windows with buffers matching this regexp." + :type 'string + :version "27.1") ;;;; Saving old configurations (internal variables and subroutines) @@ -273,8 +274,9 @@ You may want to include buffer names such as *Help*, *Apropos*, ;; Make sure point does not end up in the minibuffer and delete ;; windows displaying dead or boring buffers -;; (c.f. `winner-boring-buffers'). Return nil if all the windows -;; should be deleted. Preserve correct points and marks. +;; (c.f. `winner-boring-buffers') and `winner-boring-buffers-regexp'. +;; Return nil if all the windows should be deleted. Preserve correct +;; points and marks. (defun winner-set (conf) ;; For the format of `conf', see `winner-conf'. (let* ((buffers nil) @@ -291,10 +293,23 @@ You may want to include buffer names such as *Help*, *Apropos*, ;; Restore points (dolist (win (winner-sorted-window-list)) (unless (and (pop alive) - (setf (window-point win) - (winner-get-point (window-buffer win) win)) - (not (member (buffer-name (window-buffer win)) - winner-boring-buffers))) + (let* ((buf (window-buffer win)) + (pos (winner-get-point (window-buffer win) win)) + (entry (assq buf (window-prev-buffers win)))) + ;; Try to restore point of buffer in the selected + ;; window (Bug#23621). + (let ((marker (nth 2 entry))) + (when (and switch-to-buffer-preserve-window-point + marker + (not (= marker pos))) + (setq pos marker)) + (setf (window-point win) pos))) + (not (or (member (buffer-name (window-buffer win)) + winner-boring-buffers) + (and winner-boring-buffers-regexp + (string-match + winner-boring-buffers-regexp + (buffer-name (window-buffer win))))))) (push win xwins))) ; delete this window ;; Restore marks @@ -311,10 +326,10 @@ You may want to include buffer names such as *Help*, *Apropos*, ;; Return t if this is still a possible configuration. (or (null xwins) (progn - (mapc 'delete-window (cdr xwins)) ; delete all but one - (unless (one-window-p t) - (delete-window (car xwins)) - t)))))) + (mapc 'delete-window (cdr xwins)) ; delete all but one + (unless (one-window-p t) + (delete-window (car xwins)) + t)))))) @@ -345,9 +360,6 @@ You may want to include buffer names such as *Help*, *Apropos*, ;;;###autoload (define-minor-mode winner-mode "Toggle Winner mode on or off. -With a prefix argument ARG, enable Winner mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'. Winner mode is a global minor mode that records the changes in the window configuration (i.e. how the frames are partitioned diff --git a/lisp/woman.el b/lisp/woman.el index 8a206338f7f..39d9b806d27 100644 --- a/lisp/woman.el +++ b/lisp/woman.el @@ -1619,7 +1619,7 @@ decompress the file if appropriate. See the documentation for the (setq woman-buffer-alist (cons (cons file-name bufname) woman-buffer-alist) woman-buffer-number 0))))) - (Man-build-section-alist) + (Man-build-section-list) (Man-build-references-alist) (goto-char (point-min))) @@ -1714,14 +1714,14 @@ Do not call directly!" ;; Interpret overprinting to indicate bold face: (goto-char (point-min)) - (while (re-search-forward "\\(.\\)\\(\\(+\\1\\)+\\)" nil t) + (while (re-search-forward "\\(.\\)\\(\\(\^H+\\1\\)+\\)" nil t) (woman-delete-match 2) (woman-set-face (1- (point)) (point) 'woman-bold)) ;; Interpret underlining to indicate italic face: ;; (Must be AFTER emboldening to interpret bold _ correctly!) (goto-char (point-min)) - (while (search-forward "_" nil t) + (while (search-forward "_\^H" nil t) (delete-char -2) (woman-set-face (point) (1+ (point)) 'woman-italic)) @@ -2010,10 +2010,8 @@ Optional argument REDRAW, if non-nil, forces mode line to be updated." ;; (after Man-bgproc-sentinel-advice activate) ;; ;; Terminates man processing ;; "Report formatting time." -;; (let* ((time (current-time)) -;; (time (+ (* (- (car time) (car WoMan-Man-start-time)) 65536) -;; (- (cadr time) (cadr WoMan-Man-start-time))))) -;; (message "Man formatting done in %d seconds" time))) +;; (message "Man formatting done in %s seconds" +;; (float-time (time-since WoMan-Man-start-time)))) ;;; Buffer handling: @@ -2071,14 +2069,14 @@ alist in `woman-buffer-alist' and return nil." ;;; Syntax and display tables: -(defconst woman-escaped-escape-char ? +(defconst woman-escaped-escape-char ?\^\\ ;; An arbitrary unused control character "Internal character representation of escaped escape characters.") (defconst woman-escaped-escape-string (char-to-string woman-escaped-escape-char) "Internal string representation of escaped escape characters.") -(defconst woman-unpadded-space-char ? +(defconst woman-unpadded-space-char ?\^\] ;; An arbitrary unused control character "Internal character representation of unpadded space characters.") (defconst woman-unpadded-space-string @@ -2626,7 +2624,7 @@ If DELETE is non-nil then delete from point." (t ; Ignore -- leave in buffer ;; This does not work too well, but it's only for debugging! (skip-chars-forward "^ \t") - (if (looking-at "[ \t]*\\{") (search-forward "\\}")) + (if (looking-at "[ \t]*{") (search-forward "}")) (forward-line 1)))) ;; request is not used dynamically by any callees. @@ -2638,7 +2636,7 @@ If DELETE is non-nil then delete from point." ;; Ignore -- leave in buffer ;; This does not work too well, but it's only for debugging! (skip-chars-forward "^ \t") - (if (looking-at "[ \t]*\\{") (search-forward "\\}")) + (if (looking-at "[ \t]*{") (search-forward "}")) (forward-line 1))) (defun woman0-so () @@ -3270,7 +3268,7 @@ If optional arg CONCAT is non-nil then join arguments." (while ;; Find font requests, paragraph macros and font escapes: (re-search-forward - "^[.'][ \t]*\\(\\(\\ft\\)\\|\\(.P\\)\\)\\|\\(\\\\f\\)" nil 1) + "^[.'][ \t]*\\(\\(ft\\)\\|\\(.P\\)\\)\\|\\(\\\\f\\)" nil 1) (let (font beg notfont fescape) ;; Match font indicator and leave point at end of sequence: (cond ((match-beginning 2) @@ -3513,7 +3511,7 @@ The expression may be an argument in quotes." (let ((value (if (looking-at "[+-]") 0 (woman-parse-numeric-value))) op) (while (cond - ((looking-at "[+-/*%]") ; arithmetic operators + ((looking-at "[+/*%-]") ; arithmetic operators (forward-char) (setq op (intern-soft (match-string 0))) (setq value (funcall op value (woman-parse-numeric-value)))) @@ -3663,46 +3661,46 @@ expression in parentheses. Leaves point after the value." (fset 'insert-and-inherit (symbol-function 'insert)) (fset 'set-text-properties 'ignore) (unwind-protect - (while - ;; Find next control line: - (re-search-forward woman-request-regexp nil t) - (cond - ;; Construct woman function to call: - ((setq fn (intern-soft - (concat "woman2-" - (setq woman-request (match-string 1))))) - ;; Delete request or macro name: - (woman-delete-match 0)) - ;; Unrecognized request: - ((prog1 nil - ;; (WoMan-warn ".%s request ignored!" woman-request) - (WoMan-warn-ignored woman-request "ignored!") - ;; (setq fn 'woman2-LP) + (progn + (while + ;; Find next control line: + (re-search-forward woman-request-regexp nil t) + (cond + ;; Construct woman function to call: + ((setq fn (intern-soft + (concat "woman2-" + (setq woman-request (match-string 1))))) + ;; Delete request or macro name: + (woman-delete-match 0)) + ;; Unrecognized request: + ((prog1 nil + ;; (WoMan-warn ".%s request ignored!" woman-request) + (WoMan-warn-ignored woman-request "ignored!") + ;; (setq fn 'woman2-LP) + ;; AVOID LEAVING A BLANK LINE! + ;; (setq fn 'woman2-format-paragraphs) + )) + ;; .LP assumes it is at eol and leaves a (blank) line, + ;; so leave point at end of line before paragraph: + ((or (looking-at "[ \t]*$") ; no argument + woman-ignore) ; ignore all + ;; (beginning-of-line) (kill-line) ;; AVOID LEAVING A BLANK LINE! - ;; (setq fn 'woman2-format-paragraphs) - )) - ;; .LP assumes it is at eol and leaves a (blank) line, - ;; so leave point at end of line before paragraph: - ((or (looking-at "[ \t]*$") ; no argument - woman-ignore) ; ignore all - ;; (beginning-of-line) (kill-line) - ;; AVOID LEAVING A BLANK LINE! - (beginning-of-line) (woman-delete-line 1)) - (t (end-of-line) (insert ?\n)) - ) - (if (not (or fn - (and (not (memq (following-char) '(?. ?'))) - (setq fn 'woman2-format-paragraphs)))) - () - ;; Find next control line: - (if (equal woman-request "TS") - (set-marker to (woman-find-next-control-line "TE")) - (set-marker to (woman-find-next-control-line))) - ;; Call the appropriate function: - (funcall fn to))) - (if (not (eobp)) ; This should not happen, but ... - (woman2-format-paragraphs (copy-marker (point-max) t) - woman-left-margin)) + (beginning-of-line) (woman-delete-line 1)) + (t (end-of-line) (insert ?\n))) + (if (not (or fn + (and (not (memq (following-char) '(?. ?'))) + (setq fn 'woman2-format-paragraphs)))) + () + ;; Find next control line: + (if (equal woman-request "TS") + (set-marker to (woman-find-next-control-line "TE")) + (set-marker to (woman-find-next-control-line))) + ;; Call the appropriate function: + (funcall fn to))) + (if (not (eobp)) ; This should not happen, but ... + (woman2-format-paragraphs (copy-marker (point-max) t) + woman-left-margin))) (fset 'canonically-space-region canonically-space-region) (fset 'set-text-properties set-text-properties) (fset 'insert-and-inherit insert-and-inherit) diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index 8f12b0be25b..e4e2dec3b82 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -264,9 +264,8 @@ STRING is the uri-list as a string. The URIs are separated by \\r\\n." WINDOW is the window where the drop happened. STRING is the file names as a string, separated by nulls." (let ((uri-list (split-string string "[\0\r\n]" t)) - (coding (and (default-value 'enable-multibyte-characters) - (or file-name-coding-system - default-file-name-coding-system))) + (coding (or file-name-coding-system + default-file-name-coding-system)) retval) (dolist (bf uri-list) ;; If one URL is handled, treat as if the whole drop succeeded. @@ -557,18 +556,18 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." (defun x-dnd-motif-value-to-list (value size byteorder) (let ((bytes (cond ((eq size 2) - (list (logand (lsh value -8) ?\xff) + (list (logand (ash value -8) ?\xff) (logand value ?\xff))) ((eq size 4) (if (consp value) - (list (logand (lsh (car value) -8) ?\xff) + (list (logand (ash (car value) -8) ?\xff) (logand (car value) ?\xff) - (logand (lsh (cdr value) -8) ?\xff) + (logand (ash (cdr value) -8) ?\xff) (logand (cdr value) ?\xff)) - (list (logand (lsh value -24) ?\xff) - (logand (lsh value -16) ?\xff) - (logand (lsh value -8) ?\xff) + (list (logand (ash value -24) ?\xff) + (logand (ash value -16) ?\xff) + (logand (ash value -8) ?\xff) (logand value ?\xff))))))) (if (eq byteorder ?l) (reverse bytes) diff --git a/lisp/xdg.el b/lisp/xdg.el index 3a7420d6a41..e5a3de48289 100644 --- a/lisp/xdg.el +++ b/lisp/xdg.el @@ -34,6 +34,7 @@ ;;; Code: (eval-when-compile + (require 'cl-lib) (require 'subr-x)) @@ -116,7 +117,7 @@ file:///foo/bar.jpg" (defun xdg--substitute-home-env (str) (if (file-name-absolute-p str) str (save-match-data - (and (string-match "^$HOME/" str) + (and (string-match "^\\$HOME/" str) (replace-match "~/" t nil str 0))))) (defun xdg--user-dirs-parse-line () @@ -212,6 +213,110 @@ Optional argument GROUP defaults to the string \"Desktop Entry\"." (when (null (string-match-p "[^[:blank:]]" (car res))) (pop res)) (nreverse res))) + +;; MIME apps specification +;; https://standards.freedesktop.org/mime-apps-spec/mime-apps-spec-1.0.1.html + +(defvar xdg-mime-table nil + "Table of MIME type to desktop file associations. +The table is an alist with keys being MIME major types (\"application\", +\"audio\", etc.), and values being hash tables. Each hash table has +MIME subtypes as keys and lists of desktop file absolute filenames.") + +(defun xdg-mime-apps-files () + "Return a list of files containing MIME/Desktop associations. +The list is in order of descending priority: user config, then +admin config, and finally system cached associations." + (let ((xdg-data-dirs (xdg-data-dirs)) + (desktop (getenv "XDG_CURRENT_DESKTOP")) + res) + (when desktop + (setq desktop (format "%s-mimeapps.list" desktop))) + (dolist (name (cons "mimeapps.list" desktop)) + (push (expand-file-name name (xdg-config-home)) res) + (push (expand-file-name (format "applications/%s" name) (xdg-data-home)) + res) + (dolist (dir (xdg-config-dirs)) + (push (expand-file-name name dir) res)) + (dolist (dir xdg-data-dirs) + (push (expand-file-name (format "applications/%s" name) dir) res))) + (dolist (dir xdg-data-dirs) + (push (expand-file-name "applications/mimeinfo.cache" dir) res)) + (nreverse res))) + +(defun xdg-mime-collect-associations (mime files) + "Return a list of desktop file names associated with MIME. +The associations are searched in the list of file names FILES, +which is expected to be ordered by priority as in +`xdg-mime-apps-files'." + (let ((regexp (concat (regexp-quote mime) "=\\([^[:cntrl:]]*\\)$")) + res sec defaults added removed cached) + (with-temp-buffer + (dolist (f (reverse files)) + (when (file-readable-p f) + (insert-file-contents-literally f nil nil nil t) + (goto-char (point-min)) + (let (end) + (while (not (or (eobp) end)) + (if (= (following-char) ?\[) + (progn (setq sec (char-after (1+ (point)))) + (forward-line)) + (if (not (looking-at regexp)) + (forward-line) + (dolist (str (xdg-desktop-strings (match-string 1))) + (cl-pushnew str + (cond ((eq sec ?D) defaults) + ((eq sec ?A) added) + ((eq sec ?R) removed) + ((eq sec ?M) cached)) + :test #'equal)) + (while (and (zerop (forward-line)) + (/= (following-char) ?\[))))))) + ;; Accumulate results into res + (dolist (f cached) + (when (not (member f removed)) (cl-pushnew f res :test #'equal))) + (dolist (f added) + (when (not (member f removed)) (push f res))) + (dolist (f removed) + (setq res (delete f res))) + (dolist (f defaults) + (push f res)) + (setq defaults nil added nil removed nil cached nil)))) + (delete-dups res))) + +(defun xdg-mime-apps (mime) + "Return list of desktop files associated with MIME, otherwise nil. +The list is in order of descending priority, and each element is +an absolute file name of a readable file. +Results are cached in `xdg-mime-table'." + (pcase-let ((`(,type ,subtype) (split-string mime "/")) + (xdg-data-dirs (xdg-data-dirs)) + (caches (xdg-mime-apps-files)) + (files ())) + (let ((mtim1 (get 'xdg-mime-table 'mtime)) + (mtim2 (cl-loop for f in caches when (file-readable-p f) + maximize (float-time + (file-attribute-modification-time + (file-attributes f)))))) + ;; If one of the MIME/Desktop cache files has been modified: + (when (or (null mtim1) (time-less-p mtim1 mtim2)) + (setq xdg-mime-table nil))) + (when (null (assoc type xdg-mime-table)) + (push (cons type (make-hash-table :test #'equal)) xdg-mime-table)) + (if (let ((def (make-symbol "def")) + (table (cdr (assoc type xdg-mime-table)))) + (not (eq (setq files (gethash subtype table def)) def))) + files + (and files (setq files nil)) + (let ((dirs (mapcar (lambda (dir) (expand-file-name "applications" dir)) + (cons (xdg-data-home) xdg-data-dirs)))) + ;; Not being particular about desktop IDs + (dolist (f (nreverse (xdg-mime-collect-associations mime caches))) + (push (locate-file f dirs) files)) + (when files + (put 'xdg-mime-table 'mtime (current-time))) + (puthash subtype (delq nil files) (cdr (assoc type xdg-mime-table))))))) + (provide 'xdg) ;;; xdg.el ends here diff --git a/lisp/xml.el b/lisp/xml.el index cec1f8a4e16..833eb8aced2 100644 --- a/lisp/xml.el +++ b/lisp/xml.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2000-2019 Free Software Foundation, Inc. -;; Author: Emmanuel Briot <briot@gnat.com> +;; Author: Emmanuel Briot <briot@gnat.com> ;; Maintainer: Mark A. Hershberger <mah@everybody.org> ;; Keywords: xml, data @@ -176,11 +176,11 @@ See also `xml-get-attribute-or-nil'." ;; [4] NameStartChar ;; See the definition of word syntax in `xml-syntax-table'. -(defconst xml-name-start-char-re (concat "[[:word:]:_]")) +(defconst xml-name-start-char-re "[[:word:]:_]") ;; [4a] NameChar ::= NameStartChar | "-" | "." | [0-9] | #xB7 ;; | [#x0300-#x036F] | [#x203F-#x2040] -(defconst xml-name-char-re (concat "[-0-9.[:word:]:_·̀-ͯ‿-⁀]")) +(defconst xml-name-char-re "[[:word:]:_.0-9\u00B7\u0300-\u036F\u203F\u2040-]") ;; [5] Name ::= NameStartChar (NameChar)* (defconst xml-name-re (concat xml-name-start-char-re xml-name-char-re "*")) @@ -194,13 +194,13 @@ See also `xml-get-attribute-or-nil'." ;; [8] Nmtokens ::= Nmtoken (#x20 Nmtoken)* (defconst xml-nmtokens-re (concat xml-nmtoken-re "\\(?: " xml-name-re "\\)*")) -;; [66] CharRef ::= '&#' [0-9]+ ';' | '&#x' [0-9a-fA-F]+ ';' -(defconst xml-char-ref-re "\\(?:&#[0-9]+;\\|&#x[0-9a-fA-F]+;\\)") +;; [66] CharRef ::= '&#' [0-9]+ ';' | '&#x' [[:xdigit:]]+ ';' +(defconst xml-char-ref-re "\\(?:&#[0-9]+;\\|&#x[[:xdigit:]]+;\\)") ;; [68] EntityRef ::= '&' Name ';' (defconst xml-entity-ref (concat "&" xml-name-re ";")) -(defconst xml-entity-or-char-ref-re (concat "&\\(?:#\\(x\\)?\\([0-9a-fA-F]+\\)\\|\\(" +(defconst xml-entity-or-char-ref-re (concat "&\\(?:#\\(x\\)?\\([[:xdigit:]]+\\)\\|\\(" xml-name-re "\\)\\);")) ;; [69] PEReference ::= '%' Name ';' @@ -245,7 +245,6 @@ See also `xml-get-attribute-or-nil'." ;; [54] AttType ::= StringType | TokenizedType | EnumeratedType ;; [55] StringType ::= 'CDATA' (defconst xml-att-type-re (concat "\\(?:CDATA\\|" xml-tokenized-type-re - "\\|" xml-notation-type-re "\\|" xml-enumerated-type-re "\\)")) ;; [60] DefaultDecl ::= '#REQUIRED' | '#IMPLIED' | (('#FIXED' S)? AttValue) @@ -718,10 +717,10 @@ This follows the rule [28] in the XML specifications." (cond ((looking-at "PUBLIC\\s-+") (goto-char (match-end 0)) (unless (or (re-search-forward - "\\=\"\\([[:space:][:alnum:]-'()+,./:=?;!*#@$_%]*\\)\"" + "\\=\"\\([[:space:][:alnum:]'()+,./:=?;!*#@$_%-]*\\)\"" nil t) (re-search-forward - "\\='\\([[:space:][:alnum:]-()+,./:=?;!*#@$_%]*\\)'" + "\\='\\([[:space:][:alnum:]()+,./:=?;!*#@$_%-]*\\)'" nil t)) (error "XML: Missing Public ID")) (let ((pubid (match-string-no-properties 1))) @@ -890,7 +889,7 @@ This follows the rule [28] in the XML specifications." The replacement text is obtained by replacing character references and parameter-entity references." (let ((ref-re (eval-when-compile - (concat "\\(?:&#\\([0-9]+\\)\\|&#x\\([0-9a-fA-F]+\\)\\|%\\(" + (concat "\\(?:&#\\([0-9]+\\)\\|&#x\\([[:xdigit:]]+\\)\\|%\\(" xml-name-re "\\)\\);"))) children) (while (string-match ref-re string) @@ -1073,6 +1072,19 @@ The first line is indented with INDENT-STRING." (insert ?\n indent-string)) (insert ?< ?/ (symbol-name (xml-node-name xml)) ?>)))) +;;;###autoload +(defun xml-remove-comments (beg end) + "Remove XML/HTML comments in the region between BEG and END. +All text between the <!-- ... --> markers will be removed." + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char beg) + (while (search-forward "<!--" nil t) + (let ((start (match-beginning 0))) + (when (search-forward "-->" nil t) + (delete-region start (point)))))))) + (provide 'xml) ;;; xml.el ends here diff --git a/lisp/xt-mouse.el b/lisp/xt-mouse.el index cfa9c36ea0e..5ff718292d3 100644 --- a/lisp/xt-mouse.el +++ b/lisp/xt-mouse.el @@ -123,20 +123,7 @@ http://invisible-island.net/xterm/ctlseqs/ctlseqs.html)." (terminal-parameter nil 'xterm-mouse-y)))) pos) -(defun xterm-mouse-truncate-wrap (f) - "Truncate with wrap-around." - (condition-case nil - ;; First try the built-in truncate, in case there's no overflow. - (truncate f) - ;; In case of overflow, do wraparound by hand. - (range-error - ;; In our case, we wrap around every 3 days or so, so if we assume - ;; a maximum of 65536 wraparounds, we're safe for a couple years. - ;; Using a power of 2 makes rounding errors less likely. - (let* ((maxwrap (* 65536 2048)) - (dbig (truncate (/ f maxwrap))) - (fdiff (- f (* 1.0 maxwrap dbig)))) - (+ (truncate fdiff) (* maxwrap dbig)))))) +(define-obsolete-function-alias 'xterm-mouse-truncate-wrap 'truncate "27.1") (defcustom xterm-mouse-utf-8 nil "Non-nil if UTF-8 coordinates should be used to read mouse coordinates. @@ -256,18 +243,17 @@ which is the \"1006\" extension implemented in Xterm >= 277." (y (nth 2 click)) ;; Emulate timestamp information. This is accurate enough ;; for default value of mouse-1-click-follows-link (450msec). - (timestamp (xterm-mouse-truncate-wrap - (* 1000 - (- (float-time) - (or xt-mouse-epoch - (setq xt-mouse-epoch (float-time))))))) + (timestamp (if (not xt-mouse-epoch) + (progn (setq xt-mouse-epoch (float-time)) 0) + (car (encode-time (time-since xt-mouse-epoch) + 1000)))) (w (window-at x y)) (ltrb (window-edges w)) (left (nth 0 ltrb)) (top (nth 1 ltrb)) (posn (if w - (posn-at-x-y (- x left) (- y top) w t) - (append (list nil 'menu-bar) + (posn-at-x-y (- x left) (- y top) w t) + (append (list nil 'menu-bar) (nthcdr 2 (posn-at-x-y x y))))) (event (list type posn))) (setcar (nthcdr 3 posn) timestamp) @@ -312,9 +298,6 @@ which is the \"1006\" extension implemented in Xterm >= 277." ;;;###autoload (define-minor-mode xterm-mouse-mode "Toggle XTerm mouse mode. -With a prefix argument ARG, enable XTerm mouse mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. 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 |